Utils.bas #1

Attribute VB_Name = "Utils"
Option Explicit

' Main functions which we don't want to put in classes

Const ModuleName = "Utils"

Const LoginReqd = "Perforce password (P4PASSWD) invalid or unset."
Const SessionExpired = "Your session has expired, please login again."
Const PasswordMustBeSet = "Password must be set before access can be granted."

' Note this version requires use of StrPtr to pass in string due to Unicode requirements
' http://vb.mvps.org/hardcore/html/unicodeapifunctions.htm
Declare Function SetCurrentDirectory Lib "kernel32" Alias "SetCurrentDirectoryW" ( _
   ByVal CurrentDir As Long) As Long

Private Type OSVERSIONINFO
    dwOSVersionInfoSize As Long
    dwMajorVersion As Long
    dwMinorVersion As Long
    dwBuildNumber As Long
    dwPlatformId As Long
    szCSDVersion As String * 128
End Type

Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (lpVersionInformation As OSVERSIONINFO) As Long

' Declarations for Memory debugging
Private Type PROCESS_MEMORY_COUNTERS
    cb                          As Long
    PageFaultCount              As Long
    PeakWorkingSetSize          As Long
    WorkingSetSize              As Long
    QuotaPeakPagedPoolUsage     As Long
    QuotaPagedPoolUsage         As Long
    QuotaPeakNonPagedPoolUsage  As Long
    QuotaNonPagedPoolUsage      As Long
    PagefileUsage               As Long
    PeakPagefileUsage           As Long
End Type

Private Declare Function GetCurrentProcess Lib "kernel32" () As Long
Private Declare Function GetProcessMemoryInfo Lib "psapi.dll" (ByVal lHandle As Long, _
        ByVal lpStructure As Long, ByVal lSize As Long) As Integer

Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
   (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Long) As Long

Private Const GWL_HWNDPARENT As Long = -8

Public Declare Function FindWindowA Lib "user32" _
    (ByVal lpClassName As String, ByVal lpWindowName As String) As Long

Private Declare Function SetWindowLongA Lib "user32" _
    (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long


'-- Win32 API Declarations - needed for GetDLLVersion
Private Declare Function LoadLibrary Lib "kernel32" _
        Alias "LoadLibraryA" _
        (ByVal lpLibFileName As String) As Long
Private Declare Function FindResource Lib "kernel32" _
        Alias "FindResourceA" (ByVal hInstance As Long, _
        ByVal lpName As String, ByVal lpType As String) As Long
Private Declare Function FindResourceI Lib "kernel32" _
        Alias "FindResourceA" (ByVal hInstance As Long, _
        ByVal lpName As Long, ByVal lpType As Long) As Long
Private Declare Function LoadResource Lib "kernel32" _
        (ByVal hInstance As Long, ByVal hResInfo As Long) _
        As Long
Private Declare Function LockResource Lib "kernel32" _
        (ByVal hResData As Long) As Long
Private Declare Function GetModuleFileName Lib "kernel32" _
        Alias "GetModuleFileNameA" (ByVal hModule As Long, _
        ByVal lpFileName As String, ByVal nSize As Long) As Long
Private Declare Function FreeLibrary Lib "kernel32" _
        (ByVal hLibModule As Long) As Long
'-- VB type casting!
Public Declare Sub CopyMemoryFromPointer Lib "kernel32" _
        Alias "RtlMoveMemory" (Destination As Any, _
        ByVal Source As Long, ByVal Length As Long)

Type VS_VERSIONINFO
    wLength As Integer
    wValueLength As Integer
    wType As Integer
    szKey(29) As Byte '-- contains the UNICODE String
                      '-- "VS_VERSION_INFO" and in VB that's (29)!
    '-- Padding1(?) As Byte '-- this is the dynamic element
End Type

'-- This UDT is defined in <windows.h>, and here
'-- is the VB translation
Type VS_FIXEDFILEINFO
    dwSignature As Long
    dwStrucVersion As Long
    dwFileVersionMS As Long
    dwFileVersionLS As Long
    dwProductVersionMS As Long
    dwProductVersionLS As Long
    dwFileFlagsMask As Long
    dwFileFlags As Long
    dwFileOS As Long
    dwFileType As Long
    dwFileSubtype As Long
    dwFileDateMS As Long
    dwFileDateLS As Long
End Type

Public Const SW_SHOW = 1
Public Const SW_SHOWMAXIMIZED = 3

Public 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 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

' Global variable we can save results to
Global g_p4interface As p4interface

' Show test form - for debug purposes
Public Sub Testform()
    Dim T As Tracker: Set T = GStackTrace.Enter(ModuleName, "Testform")
    ShowForm p4vbTestForm
End Sub

' Create appropriate new filename e.g. xyz.doc -> xyz-v23.doc
Public Function VersionFilename(ByVal Fname As String, ver As String) As String
    Dim i As Integer
    Dim NewName As String
    
    i = Len(Fname)
    While i > 0 And Mid$(Fname, i, 1) <> "."
        i = i - 1
    Wend
    NewName = Left$(Fname, i - 1) & "-v" & ver & Mid$(Fname, i)
    VersionFilename = NewName
End Function

Public Sub DeleteFile(FileName As String)
    Dim fso As FileSystemObject
    
    Set fso = New FileSystemObject
    fso.DeleteFile FileName

End Sub

Public Function FileExists(FileName As String) As Boolean
    On Error GoTo ErrorHandler
    ' get the attributes and ensure that it isn't a directory
    FileExists = (GetAttr(FileName) And vbDirectory) = 0
ErrorHandler:
    ' if an error occurs, this function returns False
End Function

' Technique from MS KB article Q141026
Sub SetListboxWidth(f As MSForms.UserForm, lb As MSForms.ListBox)
    Dim AvgCharWidth As Single
    Dim MaxSoFar As Integer
    Dim ind As Integer
    Dim ratio As Single
    Dim alphabet As String
    Const LB_SETHORIZONTALEXTENT As Long = &H194
    Dim ColWidth As Long
    ' A fudge factor found by trail and error which gives reasonable results!
    Const FudgeFactor = 4#
    
    
    Dim T As Tracker: Set T = GStackTrace.Enter(ModuleName, "SetListboxWidth")
    
    alphabet = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
    AvgCharWidth = (f.TextWidth(alphabet) / Screen.TwipsPerPixelX) / 52
    
    MaxSoFar = 0
    ind = 0
    While ind < lb.ListCount
        If Len(lb.list(ind)) > MaxSoFar Then
            MaxSoFar = Len(lb.list(ind))
        End If
        ind = ind + 1
    Wend

    ColWidth = MaxSoFar * AvgCharWidth
    SendMessage lb.hwnd, LB_SETHORIZONTALEXTENT, ColWidth, 0

End Sub

' Run a Perforce command
Public Function p4runcmd(ByVal p4cmd As String, InfoArr() As String, ErrorArr() As String, _
        FileName As String, Optional Myp4 As P4COM.p4) As Long
    On Error GoTo Error_Block
    Dim Result As Long
    Dim Warnings() As String
    Dim p4 As P4COM.p4
    Dim Msg As String
    
    Dim T As Tracker: Set T = GStackTrace.Enter(ModuleName, "p4runcmd")
        
    If GStacker.Tracing Then
        Msg = "p4 cmd: " & p4cmd
        GStacker.TraceMsg Msg
    End If
    
    Result = 0
    
    If IsMissing(Myp4) Or Myp4 Is Nothing Then
        Set p4 = NewP4
        p4.ExceptionLevel = 0
    Else
        Set p4 = Myp4
    End If
    p4.Connect
    InitP4 p4
    If GStacker.Tracing Then
        GStacker.TraceMsg "p4.port: " & p4.port
    End If
    InfoArr = p4.Run(p4cmd)
    Warnings = p4.Warnings
    ' Note serverversion
    g_p4interface.ServerVersionStore p4
    ' Concatenate Warnings onto end of info
    If Not IsEmptyArray(Warnings) Then
        If IsEmptyArray(InfoArr) Then
            InfoArr = Warnings
        Else
            Dim i As Integer
            Dim j As Integer
            ReDim Preserve InfoArr(UBound(InfoArr) + UBound(Warnings))
            i = UBound(InfoArr) + 1
            For j = LBound(Warnings) To UBound(Warnings)
                InfoArr(i) = Warnings(j)
                i = i + 1
            Next
        End If
    End If
    ErrorArr = p4.Errors
    FileName = p4.TempFilename
    If GStacker.Tracing Then
        Msg = "p4 result: " & Join(InfoArr, "|")
        GStacker.TraceMsg Msg
    End If

Exit_Block:
    p4.Disconnect
    p4runcmd = Result
    Exit Function
    
Error_Block:
    Result = 1
    Resume Exit_Block
    
End Function

Public Function ConvertSlashes(ByVal path As String) As String
    ' Ensure slashes in path names are using standard DOS char
    Dim i As Integer
    ' For some reason Instr doesn't work here if mixed \ and / appeard in string - so we do it the slow way!
    For i = 1 To Len(path)
        If Mid$(path, i, 1) = "/" Then
            ConvertSlashes = Replace(path, "/", "\")
            Exit Function
        End If
    Next
    ConvertSlashes = path
End Function

Public Function RenameFile(ByVal OldName As String, ByVal NewName As String) As String
    ' Renames a file assuming the first one has a directory path component, and the
    ' second parameter is just a file name (no path).
    Dim i As Integer
    
    Dim T As Tracker: Set T = GStackTrace.Enter(ModuleName, "RenameFile")
    
    OldName = ConvertSlashes(OldName)
    If InStr(1, OldName, "\") <> 0 Then
        i = Len(OldName)
        While Mid$(OldName, i, 1) <> "\" And i > 0
            i = i - 1
        Wend
        If i > 0 Then
            NewName = Left$(OldName, i) & NewName
        End If
    End If
    RenameFile = NewName
    
    Dim fso As FileSystemObject
    
    Set fso = New FileSystemObject
    If fso.FileExists(NewName) Then
        fso.DeleteFile NewName, force:=True
    End If
    fso.MoveFile OldName, NewName
End Function

Public Function GetDir(ByVal FilePath As String) As String
    ' Return directory component of file path (if it exists)
    Dim i As Integer
    
    GetDir = vbNullString
    FilePath = ConvertSlashes(FilePath)
    If InStr(1, FilePath, "\") <> 0 Then
        i = Len(FilePath)
        While Mid$(FilePath, i, 1) <> "\" And i > 0
            i = i - 1
        Wend
        If i > 0 Then
            GetDir = Left$(FilePath, i - 1)
        End If
    End If
    
End Function

Public Function StripPath(ByVal FileName As String) As String
    ' Removes any path component from the front of the string
    Dim i As Integer
    
    Dim T As Tracker: Set T = GStackTrace.Enter(ModuleName, "StripPath")
    
    FileName = ConvertSlashes(FileName)
    StripPath = FileName
    i = Len(FileName)
    While Mid$(FileName, i, 1) <> "\" And i > 0
        i = i - 1
    Wend
    
    If i > 0 Then
        StripPath = Mid$(FileName, i + 1)
    End If
    
End Function

Private Sub CheckError(ReturnVal As Long, Msg As String, lb As ListBox)
    Dim T As Tracker: Set T = GStackTrace.Enter(ModuleName, "CheckError")

    If ReturnVal = 0 Then
        Msg = Msg & " - Success"
    Else
        Msg = Msg & " - Error '" & ReturnVal & "'"
    End If
    Msg = Msg
    Debug.Print Msg
    lb.AddItem Msg
    
End Sub

Public Function WindowsString(str As String) As String
    ' Convert LF to CR LF
    
    WindowsString = Replace(str, vbLf, vbCr & vbLf)
    
End Function

Public Function UnixString(str As String) As String
    ' Convert CR LF to just LF
    
    UnixString = Replace(str, vbCr & vbLf, vbLf)
    
End Function

Public Function IsEmptyArray(arr() As String) As Boolean
    On Error Resume Next
    Dim i As Integer
    i = UBound(arr)
    If err.Number <> 0 Or i < 0 Then
        IsEmptyArray = True
        err.Clear
    Else
        IsEmptyArray = False
    End If
End Function

' Just output the text to a text box (superseded)
Private Sub DisplayText(arr() As String, tb As TextBox)
    Dim i As Integer
    Dim s As String
    
    On Error Resume Next
    
    s = tb.Text
    
    For i = LBound(arr) To UBound(arr)
        If Len(s) = 0 Then
            s = arr(i)
        Else
            s = s & vbCr & arr(i)
        End If
    Next
    
    tb.Text = s
    err.Clear
    
End Sub

' Displays an array of strings in a listbox
Public Sub DisplayArray(arr() As String, ByRef f As MSForms.UserForm, ByRef lb As MSForms.ListBox)
    Dim i As Integer
    
    On Error GoTo Exit_Block
    
    For i = LBound(arr) To UBound(arr)
        AddItems f, lb, arr(i)
    Next

Exit_Block:
    err.Clear
    
End Sub

' Parse string for LFs and split them
Private Sub AddItems(ByRef f As MSForms.UserForm, ByRef lb As MSForms.ListBox, s As String)
    Dim start As Integer
    Dim ind As Integer
    Dim line As String
    
    Dim T As Tracker: Set T = GStackTrace.Enter(ModuleName, "AddItems")

    start = 1
    While start <= Len(s)
        ind = InStr(start, s, vbLf)
        If ind > 0 Then
            line = Mid$(s, start, ind - start)
            AddToListBox f, lb, line
            start = ind + 1
        Else
            AddToListBox f, lb, Mid$(s, start)
            start = Len(s) + 1
        End If
    Wend
    
End Sub

' Add to the listbox and make sure columnwidth is correct
Public Sub AddToListBox(ByRef f As MSForms.UserForm, ByRef lb As MSForms.ListBox, s As String)
    Dim T As Tracker: Set T = GStackTrace.Enter(ModuleName, "AddToListBox")
    
    lb.AddItem s

End Sub

' function which detects if we are running within the VB IDE or not
Public Function InIDE() As Boolean
    Debug.Assert Not TestIDE(InIDE)
End Function

Private Function TestIDE(Test As Boolean) As Boolean
    Test = True
End Function


Public Sub UpdateFstatDatetime(InfoArr() As String)
    Dim i As Integer
    
    Dim T As Tracker: Set T = GStackTrace.Enter(ModuleName, "UpdateFstatDatetime")
    If Not IsEmptyArray(InfoArr) Then
        For i = LBound(InfoArr) To UBound(InfoArr)
            If (InStr(1, InfoArr(i), "headTime") <> 0) Then
                Dim d As Date
                Dim l As Long
                
                l = CLng(Mid(InfoArr(i), Len("headTime") + 1))
                d = UnixLongToDate(l)
                InfoArr(i) = "headTime " & d
            End If
        Next
    End If
    
End Sub

Public Function UnixLongToDate(l As Long) As String
    Dim Days As Long
    Dim SecondsInDay As Long
    Dim Seconds As Long
    Dim tz As Long
    Dim Result As Date
    Dim UTCTime As Date
    
    Dim T As Tracker: Set T = GStackTrace.Enter(ModuleName, "UnixLongToDate")
    Dim p4 As P4COM.p4
    
    Set p4 = NewP4
    UnixLongToDate = p4.FormatDateTime(l)
    
End Function

Public Sub ShowForm(f As Form, Optional Modal As Boolean = False)
    Dim T As Tracker: Set T = GStackTrace.Enter(ModuleName, "ShowForm")

    SetParent f, g_p4interface.App.Caption
    f.Show vbModal

End Sub

' Alternative version which takes MSForms2 type forms
Public Sub ShowForm2(f As MSForms.UserForm, Optional Modal As Boolean = False)
    Dim T As Tracker: Set T = GStackTrace.Enter(ModuleName, "ShowForm")

    SetParent2 f, g_p4interface.App.Caption
    f.Show vbModal

End Sub

Public Function p4cmdstring(cmd As String, FileName As String) As String
    ' construct p4 command type string
    p4cmdstring = cmd & " " & Chr(34) & FileName & Chr(34)
End Function

Sub SetParent(f As Form, ByVal Caption As String)
    ' Change parent of this form
    Dim hw As Long

    ' Get the Application window handle
    hw = FindWindowA(vbNullString, Caption)

    ' Parent your form's window handle to the application window
    SetWindowLongA f.hwnd, GWL_HWNDPARENT, hw

End Sub

Sub SetParent2(f As MSForms.UserForm, ByVal Caption As String)
    ' Change parent of this form
    Dim hwndApp As Long
    Dim hwndForm As Long

    ' Get the Application window handle
    hwndApp = FindWindowA(vbNullString, Caption)
    hwndForm = FindWindowA("ThunderDframe", f.Caption)
    ' Note for VB versions may use "ThunderXframe"

    ' Parent your form's window handle to the application window
    SetWindowLongA hwndForm, GWL_HWNDPARENT, hwndApp

End Sub

Public Function GetFullPathName(ByVal path As String) As String
    ' Make sure we get unshortened version no "c:\progra~1\" instead of "c:\program files\"
    ' Used to use GetFullPathNameA in module "kernel32" but not present on Win95 or NT4.
    Dim T As Tracker: Set T = GStackTrace.Enter(ModuleName, "GetFullPathName")
    Dim FullPathName As String
    Dim Parts() As String
    Dim i As Integer
    Dim nPath As String
    Dim nTestPath As String
    
    path = ConvertSlashes(path)
    If Left$(path, 2) = "\\" Then
        GetFullPathName = path
    Else
        Parts = Split(path, "\")
        If UBound(Parts) > 0 Then
            If Len(Parts(1)) Then
                FullPathName = Parts(0)
                nTestPath = FullPathName
                For i = 1 To UBound(Parts)
                    nTestPath = nTestPath & "\" & Parts(i)
                    nPath = dir$(nTestPath, vbDirectory Or vbHidden _
                         Or vbReadOnly Or vbSystem)
                    If Len(nPath) Then
                        FullPathName = FullPathName & "\" & nPath
                    Else
                        GoTo Exit_Block
                    End If
                Next
                GetFullPathName = FullPathName
            Else
                GetFullPathName = path
            End If
        End If
    End If
    
Exit_Block:
    If GStacker.Tracing Then
        Dim Msg As String
        Msg = "fullpath: " & path & "/" & GetFullPathName
        GStacker.TraceMsg Msg
    End If
End Function

Public Function DLLVersion() As String
    DLLVersion = CStr(VB.App.Major) & "." & CStr(VB.App.Minor) & "." & CStr(VB.App.Revision) & _
                 "/" & g_BuildVersion
End Function

Public Function COMDLLVersion() As String
    Dim maj As Long, min As Long, rev As Long, bld As Long
    Dim myFilename As String
    Dim myLoadpath As String
    
    myFilename = "p4com.dll"
    COMDLLVersion = "unknown"
    If (GetDllVersion(myFilename, myLoadpath, maj, min, rev, bld)) Then
        COMDLLVersion = CStr(maj) & "." & CStr(min) & "." & CStr(rev) & "." & CStr(bld)
    End If
    
End Function

' Types and declares used to retrieve current workingset

Public Function SysResourcesGetWorkingSet() As String
    SysResourcesGetWorkingSet = vbNullString
#If False Then      ' For use in debugging memory usage (only works on nt4/2k/xp - not win98 etc)
    Dim lReturn As Long
    Dim uMemory As PROCESS_MEMORY_COUNTERS
    
    lReturn = GetProcessMemoryInfo(GetCurrentProcess(), VarPtr(uMemory), Len(uMemory))
    SysResourcesGetWorkingSet = "(" & CStr(uMemory.WorkingSetSize) & ")"
#End If

End Function

' Function taken from Windows Developer Magazine article:
' http://www.windevnet.com/documents/s=7625/wdj0105c/0105c_l2.htm
Public Function GetDllVersion(ByVal supFile As String, _
                       ByRef loadpath As String, _
                       ByRef maj As Long, _
                       ByRef min As Long, _
                       ByRef rev As Long, _
                       ByRef build As Long) As Boolean
'---------------------------------------------------------------
'   This function uses the supFile parameter to do a dynamic
'   load of the dll name.  Once loaded, the version resource
'   is queried for the file version number.  The version info
'   as well as the full load path are returned to the caller.
'
'   parameters:
'       supFile     [in] String         Dll file name
'       loadpath    [out] String        full path of file
'       maj         [out] integer       File version info
'       min         [out] integer       File version info
'       rev         [out] integer       File version info
'       build       [out] integer       File version info
'---------------------------------------------------------------
Dim hDll As Long
Dim RetVal As Long

maj = -1: min = -1: rev = -1: build = -1

GetDllVersion = False           '-- pessimistic view
hDll = LoadLibrary(supFile)     '-- try to load the file
If (hDll) Then
    '-- get the load path
    Dim tmpPath As String
    tmpPath = String(512, 0)    '-- buffer for API call
    RetVal = GetModuleFileName(hDll, tmpPath, 511)
    If (RetVal) Then
        '-- make sure there is a null(0)
        If (InStr(tmpPath, Chr$(0)) > 0) Then
            '-- trim the returned string
            loadpath = Left$(tmpPath, InStr(tmpPath, Chr$(0)) - 1)
        End If
    End If
    '-- find the version resource
    Dim hRes As Long
    hRes = FindResourceI(hDll, 1, 16)
    If (hRes) Then
        Dim hGbl As Long
        hGbl = LoadResource(hDll, hRes)
        If (hGbl) Then
            Dim lpRes As Long
            lpRes = LockResource(hGbl)
            If (lpRes) Then
                '-- lpRes is a memory pointer to file's
                '-- version resource!
                Dim verinfo As VS_VERSIONINFO   '-- make space
                '-- copy what we know of the verinfo UDT
                CopyMemoryFromPointer verinfo, lpRes, Len(verinfo)
                '-- test if we have a VS_FIXEDFILEINFO struct
                If (verinfo.wValueLength > 0) Then
                    '-- lpRes is the pointer to the locked
                    '-- resource and we need to position just
                    '-- past the known data elements...

                    '-- set the pointer to Padding1(0)
                    lpRes = lpRes + Len(verinfo)

                    '-- Since the actual Padding1 element is
                    '-- unknown in size we must loop and
                    '-- increment the memory pointer until it
                    '-- it is on a 32bit (DWORD) boundry.
                    While ((lpRes And &H4) <> 0)
                        lpRes = lpRes + 1
                    Wend

                    '-- create a variable to hold the fixed
                    '-- version info
                    Dim fInfo As VS_FIXEDFILEINFO
                    
                    '-- copy the fixed file info now
                    CopyMemoryFromPointer fInfo, lpRes, Len(fInfo)
                    
                    '-- extract the version data, and we're done!
                    maj = fInfo.dwFileVersionMS / 65535
                    min = fInfo.dwFileVersionMS And &H7FFF
                    rev = fInfo.dwFileVersionLS / 65535
                    build = fInfo.dwFileVersionLS And &H7FFF
                    GetDllVersion = True    '-- SUCCESS!!!
                End If
            End If
        End If
    End If
    '-- unload the library instance count...
    FreeLibrary (hDll)
End If
End Function

Public Sub TestGetDLLVersion()
    Dim myFilename As String
    Dim myLoadpath As String
    Dim maj As Long, min As Long, rev As Long, bld As Long
    
    myFilename = "p4com.dll"
    
    If (GetDllVersion(myFilename, myLoadpath, maj, min, rev, bld)) Then
        MsgBox "File " & myFilename & "-" & myLoadpath & " is version " & CStr(maj) & _
               "." & CStr(min) & "." & CStr(rev) & "." & CStr(bld), _
               vbInformation, "VerRes"
    Else
        MsgBox "Couldn't get the version of " & myFilename, vbExclamation, _
               "VerRes"
    End If

End Sub

'Returns Version of Windows as a String.
'NOTE: Win95 returns "4.00", WIn98 returns "4.10"
Public Function WindowsVersion() As String
    Dim osInfo As OSVERSIONINFO
    Dim Msg As String
    Dim build As String, ver_major As String, ver_minor As String
    
    osInfo.dwOSVersionInfoSize = Len(osInfo)
    GetVersionEx osInfo

    Select Case osInfo.dwPlatformId
        Case 0
            Msg = Msg & "Windows 32s "
        Case 1
            Msg = Msg & "Windows 95/98 "
        Case 2
            Msg = Msg & "Windows NT "
    End Select

    ver_major = osInfo.dwMajorVersion
    ver_minor = osInfo.dwMinorVersion
    build = osInfo.dwBuildNumber
    Msg = Msg & ver_major & "." & ver_minor
    Msg = Msg & " (Build " & build & ")"
    WindowsVersion = Msg
             
End Function

Public Function WindowsNTorGreater() As Boolean
    Dim osInfo As OSVERSIONINFO
    
    osInfo.dwOSVersionInfoSize = Len(osInfo)
    GetVersionEx osInfo

    WindowsNTorGreater = False
    If osInfo.dwPlatformId = 2 Then
        WindowsNTorGreater = True
    End If
             
End Function

Public Function StringPresent(arr() As String, SearchString As String) As Boolean

    StringPresent = False
    If Not IsEmptyArray(arr) Then
        Dim i As Integer
        For i = LBound(arr) To UBound(arr)
            If (InStr(1, arr(i), SearchString) <> 0) Then
                StringPresent = True
                Exit Function
            End If
        Next
    End If

End Function

Public Function CommandSuccessful(cmd As String, p4 As P4COM.p4, SuccessString As String) As Boolean
    Dim T As Tracker: Set T = GStackTrace.Enter(ModuleName, "CommandSuccessful")
    Dim i As Integer
    Dim Result As Long
    Dim InfoArr() As String
    Dim Msg As String
    
    CommandSuccessful = False
    If GStacker.Tracing Then
        Msg = "p4 cmd: " & cmd
        GStacker.TraceMsg Msg
    End If
    p4.Connect
    InitP4 p4
    InfoArr = p4.Run(cmd)
    If GStacker.Tracing Then
        Msg = "p4 result: " & Join(InfoArr, "|")
        GStacker.TraceMsg Msg
    End If
    If StringPresent(InfoArr, SuccessString) Then
        CommandSuccessful = True
    End If
    p4.Disconnect
    
End Function

Public Function LoginRequired(p4 As P4COM.p4) As Boolean
    Dim T As Tracker: Set T = GStackTrace.Enter(ModuleName, "LoginRequired")
    Dim ErrorArr() As String
    
    ' Search for success string - if found then don't display results
    LoginRequired = False
    ErrorArr = p4.Errors
    If StringPresent(ErrorArr, PasswordMustBeSet) Or _
       StringPresent(ErrorArr, LoginReqd) Or _
       StringPresent(ErrorArr, SessionExpired) Then
        LoginRequired = True
    End If

End Function

Public Function LoggedIn(p4 As P4COM.p4) As Boolean
    Dim T As Tracker: Set T = GStackTrace.Enter(ModuleName, "LoginIfRequired")
    Const LoginReqd = "Perforce password (P4PASSWD) invalid or unset."
    Const PasswordMustBeSet = "Password must be set before access can be granted."
    Dim ErrorArr() As String
    Dim Answer As VbMsgBoxResult
    
    ' Search for success string - if found then don't display results
    LoggedIn = False
    ErrorArr = p4.Errors
    If StringPresent(ErrorArr, PasswordMustBeSet) Then
        If ChangePasswordForm.Answer(p4) = vbOK Then
            LoggedIn = True
        End If
    ElseIf StringPresent(ErrorArr, LoginReqd) Or _
           StringPresent(ErrorArr, SessionExpired) Then
        If EnterPasswordForm.Answer(p4) = vbOK Then
            LoggedIn = True
        End If
    End If

End Function

Public Function IsUnicode(s As String) As Boolean
    If Len(s) = LenB(s) Then
       IsUnicode = False
    Else
       IsUnicode = True
    End If
End Function

Public Sub ChDir(path As String)
    ' Handles Unicode pathnames
    Dim bResult As Boolean
    
    If Not IsUnicode(path) Then
        VBA.ChDir path
    Else
        bResult = SetCurrentDirectory(StrPtr(path))
    End If
End Sub

Public Function ShellEx( _
        ByVal Operation As String, _
        ByVal File As String, _
        ByVal Parameters As String, _
        ByVal Directory As String, _
        ByVal ShowCmd As Long, _
        ErrMsg As String) As Boolean
    Dim lR As Long
    Dim lErr As Long
    On Error Resume Next
    lR = ShellExecute(0, Operation, File, Parameters, Directory, ShowCmd)
    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: ErrMsg = "Out of memory"
        Case ERROR_FILE_NOT_FOUND
            lErr = 53: ErrMsg = "File not found"
        Case ERROR_PATH_NOT_FOUND
            lErr = 76: ErrMsg = "Path not found"
        Case ERROR_BAD_FORMAT
            ErrMsg = "The executable file is invalid or corrupt"
        Case SE_ERR_ACCESSDENIED
            lErr = 75: ErrMsg = "Path/file access error"
        Case SE_ERR_ASSOCINCOMPLETE
            ErrMsg = "This file type does not have a valid file association."
        Case SE_ERR_DDEBUSY
            lErr = 285: ErrMsg = "The file could not be opened because the target application is busy. Please try again in a moment."
        Case SE_ERR_DDEFAIL
            lErr = 285: ErrMsg = "The file could not be opened because the DDE transaction failed. Please try again in a moment."
        Case SE_ERR_DDETIMEOUT
            lErr = 286: ErrMsg = "The file could not be opened due to time out. Please try again in a moment."
        Case SE_ERR_DLLNOTFOUND
            lErr = 48: ErrMsg = "The specified dynamic-link library was not found."
        Case SE_ERR_FNF
            lErr = 53: ErrMsg = "File not found"
        Case SE_ERR_NOASSOC
            ErrMsg = "No application is associated with this file type."
        Case SE_ERR_OOM
            lErr = 7: ErrMsg = "Out of memory"
        Case SE_ERR_PNF
            lErr = 76: ErrMsg = "Path not found"
        Case SE_ERR_SHARE
            lErr = 75: ErrMsg = "A sharing violation occurred."
        Case Else
            ErrMsg = "An error occurred occurred whilst trying to open or print the selected file."
        End Select
               
        ShellEx = False
    End If

End Function

Public Function NewP4() As P4COM.p4
    Dim T As Tracker: Set T = GStackTrace.Enter(ModuleName, "NewP4")
    Dim op4 As P4COM.p4
    
    Set op4 = New P4COM.p4
    op4.SetProtocol "api", "57"       ' Special value to stick to 2005.2 api levels
    op4.SetProtocol "enableStreams", "yes"
    If GStacker.Tracing Then
        Dim Msg As String
        Msg = "p4 charset: " & op4.Charset
        GStacker.TraceMsg Msg
    End If
    If LCase(op4.Charset) = "none" Then
        op4.Charset = ""
    End If
    Set NewP4 = op4
    
End Function

Public Sub InitP4(p4 As P4COM.p4)
    p4.SetProg "P4OFC"
    p4.SetVersion DLLVersion()
End Sub