Planet Source Code Jumbo …e CD Visual Basic 1 to 7/3_2004-2005.ISO/Data/Zips/BAS_Module18049510142004.psc/ModuleMania/Common.bas

BASIC Source File | 2004-10-14 | 12.2 KB | 313 lines

Attribute VB_Name = "Common"
Option Explicit

' Note - Use error handlers in procedures that call these functions

Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
          (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)

Public Declare Function AllocStrB Lib "oleaut32" Alias "SysAllocStringByteLen" _
          (ByVal lpszStr As Long, ByVal lLenB As Long) As Long

Public Declare Function OSWinHelp Lib "user32" Alias "WinHelpA" _
          (ByVal hWnd As Long, ByVal lpHelpFile As String, _
           ByVal wCommand As Long, ByVal dwData As Long) As Long

Public Const ZERO As Long = 0
Public Const ONE As Long = 1
Public Const TWO As Long = 2
Public Const THREE As Long = 3
Public Const FOUR As Long = 4
Public Const FIVE As Long = 5

Private Const INVALID_ARG As Long = FIVE

Public Enum HelpTypeFlags
    HelpContents = THREE
    HowToUseHelp = FOUR
    SearchForHelpOn = 261
End Enum

' The return value is the sum of the attribute values
Public Declare Function GetAttributes Lib "kernel32" Alias "GetFileAttributesA" _
    (ByVal lpSpec As String) As Long

' Sets the Attributes argument whose sum specifies file attributes
' An error occurs if you try to set the attributes of an open file
Public Declare Function SetAttributes Lib "kernel32" Alias "SetFileAttributesA" _
    (ByVal lpSpec As String, ByVal dwAttributes As Long) As Long

Private Const INVALID_FILE_ATTRIBUTES As Long = &HFFFFFFFF ' -1

Public Enum vbFileAttributes
    vbInvalidFile = -1   ' Returned INVALID_FILE_ATTRIBUTES
    vbNormal = 0         ' Normal (default for SetAttributes)
    vbReadOnly = 1       ' Read-only
    vbHidden = 2         ' Hidden
    vbSystem = 4         ' System file
    vbVolume = 8         ' Volume label
    vbDirectory = 16     ' Directory or folder
    vbArchive = 32       ' File has changed since last backup
    vbTemporary = &H100  ' 256
    vbCompressed = &H800 ' 2048
End Enum

Private Declare Function GetLongPathName Lib "kernel32" Alias "GetLongPathNameA" _
    (ByVal lpszShortPath As String, ByVal lpszLongPath As String, _
     ByVal cchBuffer As Long) As Long

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_FROM_SYSTEM = &H1000&
Private Const sEMPTY_STR = "Empty string passed."

' Maximum allowed path length including path, filename,
' and command line arguments for NT (Intel) and Win95
Public Const MAX_PATH As Long = 260
Public Const DIR_SEP As String = "\"

' PI is: 3.1415926535897932384626433832795028841971694
Public Const PI As Double = 3.14159265358979 'PI = 4 * Atn(1)

Public Function RandomColor() As Long 'Returns a random RBG color
    Dim lRed As Long ' ⌐Jay
    Dim lGreen As Long
    Dim lBlue As Long

    Call Randomize(Timer)
    lRed = Random(ONE, 255)
    lGreen = Random(ONE, 255)
    lBlue = Random(ONE, 255)
    RandomColor = RGB(lRed, lGreen, lBlue)
End Function

' Bounced off Paul Catons InIDE
Public Function InTheIDE() As Boolean
    Debug.Assert True Xor DebugOnly(InTheIDE)
End Function

Private Function DebugOnly(fInIDE As Boolean) As Boolean
    fInIDE = True
End Function

Public Function GetAttrib(sFileSpec As String, ByVal Attrib As vbFileAttributes) As Boolean
    ' Returns True if the specified attribute(s) is currently set.
    If LenB(sFileSpec) = ZERO Then Err.Raise INVALID_ARG, , sEMPTY_STR
    GetAttrib = (GetAttributes(sFileSpec) And Attrib) = Attrib
End Function

Public Sub SetAttrib(sFileSpec As String, ByVal Attrib As vbFileAttributes, Optional fTurnOff As Boolean)
    ' Sets/clears the specified attribute(s) without affecting other attributes. You
    ' do not need to know the current state of an attribute to set it to on or off.
    If LenB(sFileSpec) = ZERO Then Err.Raise INVALID_ARG, , sEMPTY_STR
    Dim Attribs As Long: Attribs = GetAttributes(sFileSpec)
    If fTurnOff Then
        SetAttributes sFileSpec, Attribs And (Not Attrib)
    Else
        SetAttributes sFileSpec, Attribs Or Attrib
    End If
End Sub

Public Function Exists(sFileSpec As String, Optional fIsDir As Boolean, Optional fCreateIfNot As Boolean) As Boolean
    If LenB(sFileSpec) = ZERO Then Err.Raise INVALID_ARG, , sEMPTY_STR
    If fIsDir Then
        Exists = DirExists(sFileSpec, fCreateIfNot)
    Else
        Exists = FileExists(sFileSpec, fCreateIfNot)
    End If
End Function

Public Function FileExists(sFileSpec As String, Optional fCreateIfNot As Boolean) As Boolean
    If LenB(sFileSpec) = ZERO Then Err.Raise INVALID_ARG, , sEMPTY_STR
    Dim Attribs As Long: Attribs = GetAttributes(sFileSpec)
    If (Attribs <> INVALID_FILE_ATTRIBUTES) Then
        FileExists = ((Attribs And vbDirectory) <> vbDirectory)
    End If
    If (FileExists = False) Then
        If fCreateIfNot Then FileExists = CreateFile(sFileSpec)
    End If
End Function

Public Function DirExists(sPath As String, Optional fCreateIfNot As Boolean) As Boolean
    If LenB(sPath) = ZERO Then Err.Raise INVALID_ARG, , sEMPTY_STR
    Dim Attribs As Long: Attribs = GetAttributes(sPath)
    If (Attribs <> INVALID_FILE_ATTRIBUTES) Then
        DirExists = ((Attribs And vbDirectory) = vbDirectory)
    End If
    If (DirExists = False) Then
        If fCreateIfNot Then DirExists = CreatePath(sPath)
    End If
End Function

'-----------------------------------------------------------
' Creates the specified file sFileSpec.
' Returns: 2 if created, 1 if existed, 0 if error.
'-----------------------------------------------------------
Public Function CreateFile(sFileSpec As String) As Long
    If LenB(sFileSpec) = ZERO Then Err.Raise INVALID_ARG, , sEMPTY_STR
    Dim iFile As Integer, Idx As Integer, sFile As String

    On Error GoTo FailedCreateFile
    If FileExists(sFileSpec) Then
        CreateFile = ONE
    Else
        sFile = LongPathName(sFileSpec)
        Idx = InStrR(sFile, DIR_SEP)
        If (Idx > ZERO) And (Idx < Len(sFile)) Then
            If CreatePath(Left$(sFile, Idx)) Then
                iFile = FreeFile
                Open sFile For Output As #iFile
                Close #iFile
                CreateFile = TWO
    End If: End If: End If
FailedCreateFile:
End Function

'-----------------------------------------------------------
' Creates the specified directory sPath.
' Returns: 2 if created, 1 if existed, 0 if error.
'-----------------------------------------------------------
Public Function CreatePath(sPath As String) As Long
    If LenB(sPath) = ZERO Then Err.Raise INVALID_ARG, , sEMPTY_STR
    Dim sDir As String, sTemp As String, Idx As Integer

    On Error GoTo FailedCreatePath
    If (DirExists(sPath)) Then
        CreatePath = ONE
    Else
        ' Add trailing backslash if missing
        sDir = AddBackslash(LongPathName(sPath))

        ' Set Idx to the first backslash
        Idx = InStr(ONE, sDir, DIR_SEP)

        Do ' Loop and make each subdir of the path separately
            Idx = InStr(Idx + ONE, sDir, DIR_SEP)
            If (Idx <> ZERO) Then
                sTemp = Left$(sDir, Idx - ONE)
                ' Determine if this directory already exists
                If (DirExists(sTemp) = False) Then
                    ' We must create this directory
                    MkDir sTemp
                    CreatePath = TWO
                End If
            End If
        Loop Until Idx = ZERO
    End If
FailedCreatePath:
End Function

Public Function LongPathName(sPathName As String) As String
    If LenB(sPathName) = 0 Then Exit Function
    LongPathName = sPathName ' Default to the passed name
    On Error GoTo GetFailed
    Dim sPath As String, lResult As Long
    sPath = String$(MAX_PATH, vbNullChar)
    lResult = GetLongPathName(sPathName, sPath, MAX_PATH)
    If (lResult) Then LongPathName = TrimZ(sPath)
GetFailed:
End Function

Public Function TrimZ(sNullTerminated As String) As String
    If (LenB(sNullTerminated) = ZERO) Then Err.Raise INVALID_ARG, , sEMPTY_STR
    Dim Idx As Integer: Idx = InStr(sNullTerminated, vbNullChar)
    If (Idx <> ZERO) Then
        TrimZ = Left$(sNullTerminated, Idx - ONE)
    Else
        TrimZ = Trim$(sNullTerminated)
    End If
End Function

Public Function InStrR(sSrc As String, sTerm As String, _
                       Optional ByVal lLeftBound As Long = ONE, _
                       Optional ByVal lRightBound As Long, _
                       Optional CaseSensative As Boolean) As Long
    If (LenB(sSrc) = ZERO) Or (LenB(sTerm) = ZERO) Then Err.Raise INVALID_ARG
    Dim lPos As Long, lTerm As Long
    If lRightBound = ZERO Then lRightBound = Len(sSrc)
    lTerm = Len(sTerm)
    lRightBound = (lRightBound - lTerm) + ONE
    If CaseSensative Then
        lLeftBound = InStr(sSrc, sTerm)
        If lLeftBound = ZERO Then Exit Function
        For lPos = lRightBound To lLeftBound Step -ONE
            If (Mid$(sSrc, lPos, lTerm) = sTerm) Then
                InStrR = lPos
                Exit Function
            End If
        Next lPos
    Else
        Dim sText As String, sFind As String
        sText = LCase$(sSrc): sFind = LCase$(sTerm)
        lLeftBound = InStr(sText, sFind)
        If lLeftBound = ZERO Then Exit Function
        For lPos = lRightBound To lLeftBound Step -ONE
            If (Mid$(sText, lPos, lTerm) = sFind) Then
                InStrR = lPos
                Exit Function
            End If
        Next lPos
    End If
End Function

'-BuildStr-----------------------------------------------
'  This function can replace vb's string & concatenation.
'  The speed is exactly the same for simple appends:
'     sResult = sResult & "text"
'     sResult = BuildStr(sResult, "text")
'  But for more substrings this function is much faster
'  because vb's multiple appending is very slow:
'     sResult = sResult & "some" & "more" & "text"
'     sResult = BuildStr(sResult, "some", "more", "text")
'  Notice you can safely pass as an argument the variable
'  that the function is assigning back to (compiler safe).
'  You can also specify the delimiter character(s) to
'  insert between the appended substrings, and will work
'  correctly if an argument is omitted or passed empty:
'     sMsg = BuildStr("s1", , "s2", "s3", vbCrLf)
'     MsgBox BuildStr("", sMsg, , "s4", vbCrLf)
'--------------------------------------------------------
Public Function BuildStr(Str1 As String, Optional Str2 As String, Optional Str3 As String, Optional Str4 As String, Optional Delim As String) As String
    Dim LenWrk As Long, LenAll As Long
    Dim LenDlm As Long, CntDlm As Long
    Dim Len1 As Long, Len2 As Long
    Dim Len3 As Long, Len4 As Long
    Dim lpStr As Long
    Len1 = LenB(Str1): Len2 = LenB(Str2)
    Len3 = LenB(Str3): Len4 = LenB(Str4)
    LenDlm = LenB(Delim)
    If (LenDlm <> ZERO) Then
        CntDlm = -LenDlm
        If (Len1 <> ZERO) Then CntDlm = ZERO
        If (Len2 <> ZERO) Then CntDlm = CntDlm + LenDlm
        If (Len3 <> ZERO) Then CntDlm = CntDlm + LenDlm
        If (Len4 <> ZERO) Then CntDlm = CntDlm + LenDlm
    End If
    LenAll = Len1 + Len2 + Len3 + Len4 + CntDlm
    If (LenAll > ZERO) Then
        lpStr = AllocStrB(0&, LenAll)

        ' Preserve Unicode by passing StrPtr and byte count
        If (Len1 <> ZERO) Then
            CopyMemory ByVal lpStr, ByVal StrPtr(Str1), Len1
            LenWrk = Len1
        End If

        If (Len2 <> ZERO) Then
            If (LenDlm <> ZERO) Then If (LenWrk <> ZERO) Then GoSub InsDelim
            CopyMemory ByVal lpStr + LenWrk, ByVal StrPtr(Str2), Len2
            LenWrk = LenWrk + Len2
        End If

        If (Len3 <> ZERO) Then
            If (LenDlm <> ZERO) Then If (LenWrk <> ZERO) Then GoSub InsDelim
            CopyMemory ByVal lpStr + LenWrk, ByVal StrPtr(Str3), Len3
            LenWrk = LenWrk + Len3
        End If

        If (Len4 <> ZERO) Then
            If (LenDlm <> ZERO) Then If (LenWrk <> ZERO) Then GoSub InsDelim
            CopyMemory ByVal lpStr + LenWrk, ByVal StrPtr(Str4     EstnRaise INVALID_ARG
    i As L4