vbAccelerator - Contents of code file: mUtility.bas

Attribute VB_Name = "mUtility"
Option Explicit


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
Public 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
' OS Version:
Private Declare Function GetVersion Lib "kernel32" () As Long

' Win32 API Error Reporting:
Private Declare Function FormatMessage Lib "kernel32" Alias "FormatMessageA"
 (ByVal dwFlags As Long, lpSource As Any, ByVal dwMessageId As Long, ByVal
 dwLanguageId As Long, ByVal lpBuffer As String, ByVal nSize As Long, Arguments
 As Long) As Long
Private Const FORMAT_MESSAGE_ALLOCATE_BUFFER = &H100
Private Const FORMAT_MESSAGE_ARGUMENT_ARRAY = &H2000
Private Const FORMAT_MESSAGE_FROM_HMODULE = &H800
Private Const FORMAT_MESSAGE_FROM_STRING = &H400
Private Const FORMAT_MESSAGE_FROM_SYSTEM = &H1000
Private Const FORMAT_MESSAGE_IGNORE_INSERTS = &H200
Private Const FORMAT_MESSAGE_MAX_WIDTH_MASK = &HFF


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 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 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 WinApiError(ByVal e As Long) As String
   Dim s As String
   Dim c As Long
   s = String(256, 0)
   c = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM Or _
                      FORMAT_MESSAGE_IGNORE_INSERTS, _
                      0&, e, 0&, s, Len(s), ByVal 0&)
   If (c > 0) Then
      WinApiError = Left$(s, c)
   End If
End Function


Public Function IsNt() As Boolean
Dim lVer As Long
   lVer = GetVersion()
   IsNt = ((lVer And &H80000000) = 0)
End Function