home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 3_2004-2005.ISO / Data / Zips / DHTML_Edit18343612292004.psc / Functions.bas < prev    next >
BASIC Source File  |  2005-09-05  |  7KB  |  243 lines
  1. Attribute VB_Name = "Generic_Functions"
  2. Option Explicit
  3.  
  4. 'required for isDirty work-around!
  5. Public g_IsDirty As Boolean
  6.  
  7. 'Init CpmCtl32.dll ver 6 for WinXP styles
  8. Public Declare Function InitCommonControls Lib "comctl32.dll" () As Long
  9.  
  10. Public Sub ColorizeCode(rtfHTML As RichTextBox)
  11.  
  12.  
  13. Dim needle1, needle2, colorvar As Variant
  14. Dim holder, difference1, difference2, start, startpos, endpos, between, check, goo As Long
  15.  
  16.  
  17. holder = rtfHTML.SelStart   'Remember Where Cursor Is
  18. rtfHTML.SelStart = 0        ' Make everything black
  19. rtfHTML.SelLength = 90000   '
  20. rtfHTML.SelColor = vbBlack  '
  21. redo:
  22.         Select Case goo
  23.         
  24.         Case Is = 0
  25.             needle1 = "<"     ''1st Search String                               \
  26.             needle2 = ">"     ''2nd Search String                               |
  27.             colorvar = vbBlue ''Color To HighLight With                         |Color Tags
  28.             difference1 = 1   ''# of spaces to add to the end of selection set  |
  29.             difference2 = 0   ''Skip this many spaces from initial find         /
  30.             
  31.         Case Is = 1
  32.             needle1 = Chr(61) & Chr(34)  ''\<--61 is a = and 34 is a "
  33.             needle2 = Chr(34)            ''|
  34.             colorvar = RGB(100, 100, 100)           ''|Color Variables
  35.             difference1 = 0              ''|
  36.             difference2 = 1              ''/
  37.         
  38.         Case Is = 2
  39.             needle1 = "<!--"             ''\
  40.             needle2 = "-->"              ''|
  41.             colorvar = RGB(60, 114, 0)   ''|Color Comments
  42.             difference1 = 3              ''|
  43.             difference2 = 0              ''/
  44.         
  45.         Case Is = 3
  46.             needle1 = "<SCRIPT"          ''\
  47.             needle2 = "</SCRIPT>"        ''|
  48.             colorvar = RGB(255, 140, 10) ''|Color Scripting
  49.             difference1 = 9              ''|
  50.             difference2 = 0              ''/
  51.             
  52.         Case Is = 4
  53.             GoTo final                  ''Skip Coloring Process
  54.     End Select
  55.         
  56.  
  57.         Do Until 1 = 2
  58.             If check = 0 Then        ''\
  59.                 start = 0            ''|
  60.                 check = 1            ''|Ensure the search starts from the beginning
  61.                 Else                 ''|
  62.                 start = startpos + 1 ''|
  63.             End If                   ''/
  64.                 
  65.             startpos = rtfHTML.Find(needle1, start) ''Find Begin Tag
  66.                 
  67.             If startpos = -1 Then  ''\
  68.             GoTo ender             ''|Check to see if it wasn't found
  69.             End If                 ''/
  70.             
  71.             endpos = rtfHTML.Find(needle2, (startpos + 2)) '' Find End Tag
  72.             
  73.             between = endpos - startpos          ''Find space between needles
  74.             
  75.             rtfHTML.SelStart = (startpos + difference2)     ''\
  76.             rtfHTML.SelLength = (between + difference1)     ''|Select and color the code
  77.             rtfHTML.SelColor = colorvar                     ''/
  78.             
  79.         Loop
  80.         
  81. ender:
  82.         goo = goo + 1 ''Advance to next coloring step
  83.         GoTo redo:    ''Restart Coloring Process
  84.  
  85. final:
  86. rtfHTML.SelStart = holder ''Return to where the cursor was before color code
  87.  
  88.  
  89. End Sub
  90. Public Sub LogErrors(ByVal ErrNumber As Long, ErrDescription As String, ErrSource As String)
  91. Dim ff As Integer, sErrorInfo As String
  92.  
  93. ff = FreeFile
  94.  
  95.  
  96. sErrorInfo = "TIME = " & Format(Now, "dd/mm/yyyy - hh:mm") & vbCrLf
  97. sErrorInfo = sErrorInfo & "ERROR NUMBER = " & ErrNumber & vbCrLf
  98. sErrorInfo = sErrorInfo & "ERROR DESCRIPTION = " & ErrDescription & vbCrLf
  99. sErrorInfo = sErrorInfo & "ERROR SOURCE = " & ErrSource & vbCrLf
  100.  
  101. Open App.Path & "\error.log" For Output As #ff
  102.     Print #ff, sErrorInfo
  103.     Print #ff, "---------------------------------------------------------------------------------"
  104. Close #ff
  105.  
  106.  
  107. End Sub
  108. Function RemoveSlash(ByVal sPath As String) As String
  109.  
  110. sPath = Trim$(sPath)
  111.  
  112. If Right$(sPath, 1) = "\" Then
  113.     RemoveSlash = Left(sPath, Len(sPath) - 1)
  114. Else
  115.     RemoveSlash = sPath
  116. End If
  117.  
  118.  
  119. End Function
  120.  
  121.  
  122. Function ChangeFileExtension(ByVal FileName As String, ByVal NewExtension As String) As String
  123. Dim sOldExt As String, sDot As String
  124.  
  125. sOldExt = ExtractFileExtension(FileName)
  126. If sOldExt = "" Then
  127.     sDot = "."
  128. Else
  129.     sDot = ""
  130. End If
  131.  
  132. ChangeFileExtension = Left$(FileName, Len(FileName) - Len(sOldExt)) & sDot & NewExtension
  133.  
  134. End Function
  135. Function ExtractFileExtension(ByVal FileName As String) As String
  136.  
  137. Dim ThePos As Integer
  138.  
  139. 'In case the path contains a dot
  140. FileName = ExtractFileName(FileName)
  141.  
  142. ThePos = InStrRev(FileName, ".")
  143. If ThePos = 0 Then
  144.     ExtractFileExtension = ""
  145. Else
  146.     ExtractFileExtension = Right$(FileName, Len(FileName) - ThePos)
  147. End If
  148.  
  149.  
  150. End Function
  151. Public Function ExtractFileName(ByVal FilePath As String) As String
  152.  
  153. ' Extract the File name from a full file path
  154.  
  155. Dim iLastSlash As Integer
  156.  
  157. iLastSlash = InStrRev(FilePath, "\")
  158.  
  159. If iLastSlash = 0 Then
  160.         ExtractFileName = FilePath
  161. Else
  162.     ExtractFileName = Right(FilePath, Len(FilePath) - iLastSlash)
  163. End If
  164.  
  165.  
  166. End Function
  167. Public Function GetLinkHref(ByVal LinkHtml As String) As String
  168. Dim iPos  As Integer
  169. Dim sTemp As String
  170.  
  171.  
  172.  
  173. iPos = InStr(1, LinkHtml, "href", vbTextCompare)
  174.  
  175. If iPos > 0 Then
  176.     
  177.     sTemp = Right(LinkHtml, Len(LinkHtml) - iPos - 4)
  178.     iPos = InStr(2, sTemp, """")
  179.     If iPos <> 0 Then sTemp = Left(sTemp, iPos)
  180.     GetLinkHref = Replace(sTemp, """", "")
  181.  
  182. Else
  183.     'no href, could be an Anchor
  184.     GetLinkHref = ""
  185.  
  186. End If
  187.  
  188.  
  189.  
  190.  
  191. End Function
  192. Public Function UnFormatRGBString(ByVal Color As String) As Long
  193. Dim lColor As Long
  194. Dim r As String
  195. Dim g As String
  196. Dim b As String
  197.     
  198.     
  199.  Color = Right(Color, 6)
  200.  
  201.  r = Left(Color, 2)
  202.  g = Mid(Color, 3, 2)
  203.  b = Right(Color, 2)
  204.  
  205.  Color = "&h" & b & g & r
  206.  
  207.  UnFormatRGBString = CLng(Color)
  208.  
  209. End Function
  210. Public Function FormatRGBString(val As Long) As String
  211.     Dim Color As String
  212.     Dim pad As Long
  213.     Dim r As String
  214.     Dim g As String
  215.     Dim b As String
  216.     
  217.     ' This function formats a long consisting of rgb values
  218.     ' taken from the CommonDialog color dialog
  219.     ' to a string in the form of "#RRGGBB" where RRGGBB are
  220.     ' hex values
  221.     
  222.     ' convert to hex
  223.     Color = Hex(val)
  224.     'determine how many zeros to pad in front of converted value
  225.     pad = 6 - Len(Color)
  226.     
  227.     If pad Then
  228.         Color = String(pad, "0") & Color
  229.     End If
  230.         
  231.     'Extract the rgb components
  232.     r = Right(Color, 2)
  233.     g = Mid(Color, 3, 2)
  234.     b = Left(Color, 2)
  235.     
  236.     ' Swab r and b position, color dialog returns
  237.     ' bgr instead of rgb
  238.     Color = "#" & r & g & b
  239.     
  240.     FormatRGBString = Color
  241.  
  242. End Function
  243.