vbAccelerator - Contents of code file: mUtility.bas

Attribute VB_Name = "mUtility"
Option Explicit

Public g_cFileTypes As New cVBFileTypes

Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA"
 (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA"
 (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Const GWL_EXSTYLE = (-20)
Private Const WS_EX_WINDOWEDGE = &H100
Private Const WS_EX_CLIENTEDGE = &H200
Private Const WS_EX_STATICEDGE = &H20000
Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal
 hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long,
 ByVal cy As Long, ByVal wFlags As Long) As Long
Private Enum ESetWindowPosStyles
    SWP_SHOWWINDOW = &H40
    SWP_HIDEWINDOW = &H80
    SWP_FRAMECHANGED = &H20 ' The frame changed: send WM_NCCALCSIZE
    SWP_NOACTIVATE = &H10
    SWP_NOCOPYBITS = &H100
    SWP_NOMOVE = &H2
    SWP_NOOWNERZORDER = &H200 ' Don't do owner Z ordering
    SWP_NOREDRAW = &H8
    SWP_NOREPOSITION = SWP_NOOWNERZORDER
    SWP_NOSIZE = &H1
    SWP_NOZORDER = &H4
    SWP_DRAWFRAME = SWP_FRAMECHANGED
    HWND_NOTOPMOST = -2
End Enum
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA"
 (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String,
 ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As
 Long) As Long
Private Declare Function ShellExecuteForExplore Lib "shell32.dll" Alias
 "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile
 As String, lpParameters As Any, lpDirectory As Any, ByVal nShowCmd As Long) As
 Long
Public Enum EShellShowConstants
    essSW_HIDE = 0
    essSW_MAXIMIZE = 3
    essSW_MINIMIZE = 6
    essSW_SHOWMAXIMIZED = 3
    essSW_SHOWMINIMIZED = 2
    essSW_SHOWNORMAL = 1
    essSW_SHOWNOACTIVATE = 4
    essSW_SHOWNA = 8
    essSW_SHOWMINNOACTIVE = 7
    essSW_SHOWDEFAULT = 10
    essSW_RESTORE = 9
    essSW_SHOW = 5
End Enum
Private Const ERROR_FILE_NOT_FOUND = 2&
Private Const ERROR_PATH_NOT_FOUND = 3&
Private Const ERROR_BAD_FORMAT = 11&
Private Const SE_ERR_ACCESSDENIED = 5        ' access denied
Private Const SE_ERR_ASSOCINCOMPLETE = 27
Private Const SE_ERR_DDEBUSY = 30
Private Const SE_ERR_DDEFAIL = 29
Private Const SE_ERR_DDETIMEOUT = 28
Private Const SE_ERR_DLLNOTFOUND = 32
Private Const SE_ERR_FNF = 2                ' file not found
Private Const SE_ERR_NOASSOC = 31
Private Const SE_ERR_PNF = 3                ' path not found
Private Const SE_ERR_OOM = 8                ' out of memory
Private Const SE_ERR_SHARE = 26

Private Const MAX_PATH = 260
Private Declare Function GetShortPathName Lib "kernel32" Alias
 "GetShortPathNameA" (ByVal lpszLongPath As String, ByVal lpszShortPath As
 String, ByVal cchBuffer As Long) As Long
Private Type FILETIME
   dwLowDateTime As Long
   dwHighDateTime As Long
End Type
Private Type WIN32_FIND_DATA
   dwFileAttributes As Long
   ftCreationTime As FILETIME
   ftLastAccessTime As FILETIME
   ftLastWriteTime As FILETIME
   nFileSizeHigh As Long
   nFileSizeLow As Long
   dwReserved0 As Long
   dwReserved1 As Long
   cFileName As String * MAX_PATH
   cAlternate As String * 14
End Type
Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA"
 (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As
 Long
Private Declare Function lopen Lib "kernel32" Alias "_lopen" (ByVal lpPathName
 As String, ByVal iReadWrite As Long) As Long
Private Declare Function lclose Lib "kernel32" Alias "_lclose" (ByVal hFile As
 Long) As Long
Private Declare Function SetFileTime Lib "kernel32" (ByVal hFile As Long,
 lpCreationTime As FILETIME, lpLastAccessTime As FILETIME, lpLastWriteTime As
 FILETIME) As Long
Private Declare Function SetFileAttributes Lib "kernel32" Alias
 "SetFileAttributesA" (ByVal lpFileName As String, ByVal dwFileAttributes As
 Long) As Long
Private Const OF_WRITE = &H1
Private Const OF_SHARE_DENY_WRITE = &H20
Private Const GENERIC_WRITE = &H40000000
Private Const GENERIC_READ = &H80000000
Private Const FILE_SHARE_WRITE = &H2
Private Const CREATE_ALWAYS = 2
Private Const FILE_BEGIN = 0
Private Const SECTION_MAP_WRITE = &H2


Public Sub ThinBorder(ByVal hwnd As Long, ByVal bState As Boolean)
Dim lStyle As Long
   ' Thin border:
   lStyle = GetWindowLong(hwnd, GWL_EXSTYLE)
   If bState Then
      lStyle = lStyle And Not WS_EX_CLIENTEDGE Or WS_EX_STATICEDGE
   Else
      lStyle = lStyle Or WS_EX_CLIENTEDGE And Not WS_EX_STATICEDGE
   End If
   SetWindowLong hwnd, GWL_EXSTYLE, lStyle
   ' Make the style 'take':
   SetWindowPos hwnd, 0, 0, 0, 0, 0, SWP_NOACTIVATE Or SWP_NOZORDER Or
    SWP_FRAMECHANGED Or SWP_NOSIZE Or SWP_NOMOVE

End Sub

Public Function ReadFileText( _
      ByVal sCmd As String, _
      ByRef sText As String _
   ) As Boolean
Dim iFile As Integer
On Error GoTo ErrorHandler
   If FileExists(sCmd) Then
      iFile = FreeFile
      Open sCmd For Binary Access Read Lock Write As #iFile
      sText = String$(LOF(iFile), 0)
      Get #iFile, , sText
      Close #iFile
      ReadFileText = True
   Else
      Error 53
   End If
   Exit Function

ErrorHandler:
   MsgBox "Error reading file: " & Err.Description, vbInformation
   Exit Function
   
   Resume 0
End Function
Public Function WriteFileText( _
      ByVal sCmd As String, _
      ByRef sText As String _
   ) As Boolean
Dim iFile As Integer
On Error GoTo ErrorHandler
   iFile = FreeFile
   Open sCmd For Binary Access Write Lock Read As #iFile
   Put #iFile, , sText
   Close #iFile
   WriteFileText = True
   Exit Function

ErrorHandler:
   MsgBox "Error reading file: " & Err.Description, vbInformation
   Exit Function
   
   Resume 0
End Function
Public Function ReplaceFileText( _
      ByVal sFile As String, _
      ByRef sText As String _
   ) As Boolean
Dim tFnd As WIN32_FIND_DATA
Dim bFileExisted As Boolean
Dim hFile As Long
Dim hSearch As Long

   hSearch = FindFirstFile(sFile, tFnd)
   If Not (hSearch = -1) Then
      FindClose hSearch
      Kill sFile
   End If
   ReplaceFileText = WriteFileText(sFile, sText)
   ' Now if we are replacing an existing file, then we want to
   ' put the file creation and archive information back again:
   If bFileExisted Then
      
      hFile = lopen(sFile, OF_WRITE Or OF_SHARE_DENY_WRITE)
      If hFile = 0 Then
         ' problem
      Else
         SetFileTime hFile, tFnd.ftCreationTime, tFnd.ftLastAccessTime,
          tFnd.ftLastWriteTime
         lclose hFile
         SetFileAttributes sFile, tFnd.dwFileAttributes
      End If
      
   End If
   
End Function

Public Function FileExists( _
      ByVal sFile As String _
   ) As Boolean
Dim tFnd As WIN32_FIND_DATA
Dim hSearch As Long

   hSearch = FindFirstFile(sFile, tFnd)
   If Not (hSearch = -1) Then
      FindClose hSearch
      FileExists = True
   End If
End Function

Public Sub KillFileIfExists( _
      ByVal sFile As String _
   )
   On Error Resume Next
   Kill sFile
End Sub

Public Function InstrRev(ByVal sThis As String, ByVal sToFind As String) As Long
Dim lLen As Long
Dim iPos As Long
   iPos = Len(sThis)
   lLen = Len(sToFind)
   If iPos > 0 Then
      Do
         If StrComp(Mid$(sThis, iPos, lLen), sToFind) = 0 Then
            InstrRev = iPos
            Exit Function
         Else
            iPos = iPos - 1
         End If
      Loop While iPos > 0
   End If
End Function

Public Function NormalizePath(ByVal sPath As String) As String
   If Len(sPath) > 0 Then
      If Right$(sPath, 1) <> "\" Then
         sPath = sPath & "\"
      End If
   End If
   NormalizePath = sPath
End Function

Public Function AddFileToPath(ByVal sPath As String, ByVal sFile As String) As
 String
Dim iPos As Long
Dim sPart As String
   
   If Len(sPath) > 0 Then
      If Right$(sPath, 1) = "\" Then
         sPath = Left$(sPath, Len(sPath) - 1)
      End If
   End If
   
   Dim cS As New cSplitString
   cS.TheString = sFile
   cS.Splitter = "\"
   Do
      sPart = cS.NextItem
      If sPart = "." Then
         ' ignore:
      ElseIf sPart = ".." Then
         ' loose a directory from the path:
         iPos = InstrRev(sPath, "\")
         If iPos > 0 Then
            sPath = Left$(sPath, iPos - 1)
         End If
      ElseIf sPart = "" Then
         ' implies the first part of the directory is a \, i.e. the
         ' root:
         iPos = InStr(sPath, "\")
         If iPos > 0 Then
            sPath = Left$(sPath, iPos - 1)
         End If
      Else
         ' append a directory to the path:
         sPath = NormalizePath(sPath) & sPart
      End If
   Loop While cS.More
   AddFileToPath = sPath
End Function

Public Function ReplaceSection( _
        ByVal sToModify As String, _
        ByVal sToReplace As String, _
        ByVal sReplaceWith As String _
    ) As String
' ==================================================================
' Replaces all occurrences of sToReplace with
' sReplaceWidth in sToModify.
' ==================================================================
Dim iLastPos As Long
Dim iNextPos As Long
Dim iReplaceLen As Long
Dim sOut As String
    iReplaceLen = Len(sToReplace)
    iLastPos = 1
    iNextPos = InStr(iLastPos, sToModify, sToReplace)
    sOut = ""
    Do While (iNextPos > 0)
        If (iNextPos > 1) Then
            sOut = sOut & Mid$(sToModify, iLastPos, (iNextPos - iLastPos))
        End If
        sOut = sOut & sReplaceWith
        iLastPos = iNextPos + iReplaceLen
        iNextPos = InStr(iLastPos, sToModify, sToReplace)
    Loop
    If (iLastPos <= Len(sToModify)) Then
        sOut = sOut & Mid$(sToModify, (iLastPos))
    End If
    ReplaceSection = sOut
End Function


Public Function ShellEx( _
        ByVal sFile As String, _
        Optional ByVal eShowCmd As EShellShowConstants = essSW_SHOWDEFAULT, _
        Optional ByVal sParameters As String = "", _
        Optional ByVal sDefaultDir As String = "", _
        Optional sOperation As String = "open", _
        Optional Owner As Long = 0 _
    ) As Boolean
Dim lR As Long
Dim lErr As Long, sErr As Long
    If (InStr(UCase$(sFile), ".EXE") <> 0) Then
        eShowCmd = 0
    End If
    On Error Resume Next
    If (sParameters = "") And (sDefaultDir = "") Then
        lR = ShellExecuteForExplore(Owner, sOperation, sFile, 0, 0,
         essSW_SHOWNORMAL)
    Else
        lR = ShellExecute(Owner, sOperation, sFile, sParameters, sDefaultDir,
         eShowCmd)
    End If
    If (lR < 0) Or (lR > 32) Then
        ShellEx = True
    Else
        ' raise an appropriate error:
        lErr = vbObjectError + 1048 + lR
        Select Case lR
        Case 0
            lErr = 7: sErr = "Out of memory"
        Case ERROR_FILE_NOT_FOUND
            lErr = 53: sErr = "File not found"
        Case ERROR_PATH_NOT_FOUND
            lErr = 76: sErr = "Path not found"
        Case ERROR_BAD_FORMAT
            sErr = "The executable file is invalid or corrupt"
        Case SE_ERR_ACCESSDENIED
            lErr = 75: sErr = "Path/file access error"
        Case SE_ERR_ASSOCINCOMPLETE
            sErr = "This file type does not have a valid file association."
        Case SE_ERR_DDEBUSY
            lErr = 285: sErr = "The file could not be opened because the target
             application is busy. Please try again in a moment."
        Case SE_ERR_DDEFAIL
            lErr = 285: sErr = "The file could not be opened because the DDE
             transaction failed. Please try again in a moment."
        Case SE_ERR_DDETIMEOUT
            lErr = 286: sErr = "The file could not be opened due to time out.
             Please try again in a moment."
        Case SE_ERR_DLLNOTFOUND
            lErr = 48: sErr = "The specified dynamic-link library was not
             found."
        Case SE_ERR_FNF
            lErr = 53: sErr = "File not found"
        Case SE_ERR_NOASSOC
            sErr = "No application is associated with this file type."
        Case SE_ERR_OOM
            lErr = 7: sErr = "Out of memory"
        Case SE_ERR_PNF
            lErr = 76: sErr = "Path not found"
        Case SE_ERR_SHARE
            lErr = 75: sErr = "A sharing violation occurred."
        Case Else
            sErr = "An error occurred occurred whilst trying to open or print
             the selected file."
        End Select
                
        Err.Raise lErr, , App.EXEName & ".GShell", sErr
        ShellEx = False
    End If

End Function


Public Function GetShortPath(ByVal sPath As String) As String
Dim sShortPath As String
Dim lR As Long
Dim iPos As Long
   sShortPath = String$(MAX_PATH + 1, 0)
   lR = GetShortPathName(sPath, sShortPath, MAX_PATH)
   If lR = 0 Then
       Error 53 ' File not found
   Else
      iPos = InStr(sShortPath, vbNullChar)
      If iPos > 1 Then
         GetShortPath = Left$(sShortPath, iPos - 1)
      Else
         GetShortPath = sShortPath
      End If
   End If
End Function
Public Function GetLongPath(ByVal sPath As String) As String
Dim sLongPath As String
Dim lR As Long
Dim tFR As WIN32_FIND_DATA
Dim hSearch As Long
Dim iPos As Long
Dim iLastPos As Long
Dim sBit As String

   sLongPath = ""
   sBit = ""
   iLastPos = 1
   iPos = InStr(sPath, "\")
   Do
      If (iPos > 0) Then
         sBit = NormalizePath(sBit) & Mid$(sPath, iLastPos, iPos - iLastPos)
      Else
         sBit = NormalizePath(sBit) & Mid$(sPath, iLastPos)
      End If
      If iPos > 4 Or iLastPos > 4 Then
         hSearch = FindFirstFile(sBit, tFR)
         If Not (hSearch = 0 Or hSearch = -1) Then
            FindClose hSearch
            lR = InStr(tFR.cFileName, vbNullChar)
            sLongPath = NormalizePath(sLongPath)
            If lR > 1 Then
               sLongPath = sLongPath & Left$(tFR.cFileName, lR - 1)
            Else
               sLongPath = sLongPath & tFR.cFileName
            End If
         Else
            Error 53
            Exit Function
         End If
      Else
         sLongPath = NormalizePath(sLongPath) & sBit
      End If
      If iPos > 0 Then
         iLastPos = iPos + 1
         iPos = InStr(iLastPos, sPath, "\")
      Else
         iLastPos = 0
      End If
   Loop While (iLastPos > 0)
   GetLongPath = sLongPath
   
End Function

Public Function RelativePath( _
      ByVal sTo As String, _
      ByVal sFile As String _
   ) As String
Dim sToBit As String
Dim sFileBit As String
Dim sFilePart As String
Dim sRel As String
Dim bMatch As Boolean
Dim iPos As Long

   bMatch = True
   sRel = ""
   sTo = GetLongPath(sTo)
   iPos = InstrRev(sFile, "\")
   sFilePart = Mid$(sFile, iPos + 1)
   sFile = GetLongPath(Left$(sFile, iPos - 1))
   Dim cSTo As New cSplitString
   Dim cSFile As New cSplitString
   cSTo.Splitter = "\"
   cSFile.Splitter = "\"
   cSTo.TheString = sTo
   cSFile.TheString = sFile
   Do
      sToBit = cSTo.NextItem
      sFileBit = cSFile.NextItem
      
      'Debug.Print sToBit, sFileBit
      If bMatch Then
         If UCase$(sToBit) = UCase$(sFileBit) Then
            ' cool
         Else
            bMatch = False
         End If
      End If
      
      If Not bMatch Then
         If sToBit <> "" Then
            If sFileBit = "" Then
               sRel = "..\" & NormalizePath(sRel)
            Else
               sRel = "..\" & NormalizePath(sRel) & sFileBit
            End If
         Else
            sRel = NormalizePath(sRel) & sFileBit
         End If
      End If
      
   Loop While (cSFile.More Or cSTo.More)
   
   'Debug.Print
   RelativePath = NormalizePath(sRel) & sFilePart
   
End Function

Public Function ExtractTag(ByVal sString, ByVal sStartTag As String, ByVal
 sEndTag As String, ByRef sTag As String) As Boolean
Dim iPos As Long
Dim iNextPos As Long
   iPos = InStr(sString, sStartTag)
   If iPos > 0 Then
      iPos = iPos + Len(sStartTag)
      iNextPos = InStr(iPos, sString, sEndTag)
      If iNextPos > 0 Then
         sTag = Mid$(sString, iPos, iNextPos - iPos)
         ExtractTag = True
      End If
   End If
End Function