acaglbl.bas

将使用的DLL文件预先装入内存已提高VB程序执行速度的程序

Option Explicit
' =========================================================================================
' Standard Global String Variables
' =========================================================================================
Global gsCRLF As String         ' Carriage-Return Line-Feed character
Global gsTAB As String          ' Standard TAB character

' ===============================================================
' Declaration of Application Title
' ===============================================================
Global TITLE As String ' Setup at start of application as several apps share code can't be Global Constant

' ========================================================================================
' Global Constant Values
' ========================================================================================
Global Const INI_ERROR = "ERROR"

Function AddAmpersand (msg As Variant) As String
    
On Error GoTo AddAmpersand_Err

    Dim iPos As Integer
    Dim strStart As String, strEnd As String
    
    iPos = InStr(msg, "&")

    If iPos <> 0 Then
        strStart = Left$(msg, iPos)
        strEnd = Right$(msg, Len(msg) - iPos)
        AddAmpersand = strStart & "&" & strEnd
    Else
        AddAmpersand = msg
    End If
    
    Exit Function

AddAmpersand_Err:
    AddAmpersand = ""
    Exit Function

End Function

' Centres form in argument on the screen
Sub CentreMe (frmLoadingForm As Form)
' mh 951012 - added checking for MDI child window

        frmLoadingForm.Move (screen.Width - frmLoadingForm.Width) / 2, (screen.Height - frmLoadingForm.Height) / 2
    
End Sub

Function CheckField (vFieldIn) As Variant

    If Not IsNull(vFieldIn) Then CheckField = vFieldIn

End Function

' Validates a date as a string dd/mm/yy and returns true/false
Function DateValid (sTestDate As String)

    Dim RetDate

On Error GoTo InvalidDate

    ' The DateValue function returns an error if the date is not valid
    ' It tests for silly numbers - eg. "101010" passed in as a string
    ' It tests for close numbers - eg. "32/03/95" or "15/13/95"
    ' It also tests for leap years

    RetDate = DateValue(sTestDate)

    DateValid = True
    Exit Function

InvalidDate:
    DateValid = False
    Exit Function

End Function

Function dMax (dA As Double, dB As Double) As Double
' rdm 950722
' return the Max value

    If dA > dB Then
        dMax = dA
    Else
        dMax = dB
    End If

End Function

Function dMin (dA As Double, dB As Double) As Double
' rdm 950722
' return the Min value

    If dA < dB Then
        dMin = dA
    Else
        dMin = dB
    End If

End Function

' Subroutine used to display error messages in VB code
Sub ErrorHandler (iErr As Integer, lErrLine As Long, sModule As String, sFunction As String)
' Displays Error Message Box

    MsgBox "Error " & iErr & ": " & Error & "." & gsCRLF & "In Line " & lErrLine & gsCRLF + gsCRLF + "Module : " + sModule + gsCRLF + gsCRLF + " Function : " + sFunction, 64, TITLE
' Format of error handling :

' sub FunctionName()

    ' On Error Goto FunctionNameError     ' Use function name with error written after it
    '
    '
    ' ..... Body of function
    '
    '
    ' Exit Sub
    
' FunctionNameError:
    ' Call ErrorHandler(Err, Erl, ModuleName, FunctionName)
    ' Exit Sub

    ' End Sub

    '
    '
    ' The ModuleName above is the name of the VB module the error occured
    ' i.e. "GLOBALS.BAS"
    ' The FunctionName is the name of the VB function that the error occured in i.e. "ErrorHandler"
    
End Sub

Function FindAndReplace (sFind As String, sReplace As String, sCurrentString As String) As String
On Error GoTo FindAndReplaceError

    Dim sNewString As String
    Dim sTempString As String
    Dim iPos As Integer

    ' look for a SPACE
    iPos = InStr(sCurrentString, sFind)

    ' loop While there are SPACES in CurrentString
    Do While iPos
    sTempString = Left$(sCurrentString, iPos)
    sNewString = sNewString & Left$(sTempString, iPos - 1) & sReplace
    sCurrentString = Right$(sCurrentString, Len(sCurrentString) - iPos)
    iPos = InStr(sCurrentString, sFind)
    Loop

    ' capitalise the last word n current string
    If Len(sCurrentString) Then
    sNewString = sNewString & sCurrentString
    End If

    FindAndReplace = sNewString
    Exit Function

FindAndReplaceError:
    'Call ErrorHandler(Err, Erl, "WBLIST", "FindAndReplace")
    Exit Function

End Function

' Overload of the ReadFileInI function that allows you to specify the INI file name
Function GetINIStringValue (sSection$, sKeyName$, sDefaultValue$, sFileName$) As String

    Dim iStrLen As Integer
    Dim sString As String * 150
    
    iStrLen = GetPrivateProfileString(sSection, sKeyName, sDefaultValue$, sString, Len(sString), sFileName$)
    GetINIStringValue = Left(sString, iStrLen)
    
End Function

Function iMin (a As Integer, b As Integer) As Integer

    If a < b Then
        iMin = a
    Else
        iMin = b
    End If

End Function

Sub SetINIStringValue (sSection As String, sEntry As String, sNewValue As String, sINIFile As String)
    Dim iRetValue As Integer
    
    '// write appropriate information to ini file
    iRetValue = WritePrivateProfileString(sSection, sEntry, sNewValue, sINIFile)
    
End Sub

' Sets up any global variables for this program
Sub SetupGlobalVariables ()
    
    gsCRLF = Chr$(13) + Chr$(10)    ' Used to store the carriage return string
    gsTAB = Chr$(9)
    
End Sub

Function SLDate (sDate As String) As String
' rdm 950524

' take date in  medium format convert to YYYYMMDD
On Error GoTo SLDate_Err
    
    SLDate = (Format$(DateValue(sDate), "YYYY") + Format$(DateValue(sDate), "MM") + Format$(DateValue(sDate), "DD"))
    Exit Function

SLDate_Err:
    'SLDate = "00000000" - previously in ACAGLBL.BAS
    SLDate = ""
    Exit Function

End Function

Function sMax (a As Single, b As Single) As Single

    If a > b Then
        sMax = a
    Else
        sMax = b
    End If

End Function

Function sZeroSpaces (sString As String) As String

Dim sOut As String
Dim iCount As Integer
Dim iLength As Integer

On Error GoTo BadZeroSpaces
    
    sOut = sString

    iLength = Len(sOut)

    For iCount = 1 To iLength

        If Not IsNumeric(Mid(sOut, iCount, 1)) Then Mid(sOut, iCount, 1) = "0"

    Next iCount

    sZeroSpaces = sOut
    Exit Function

BadZeroSpaces:

    sZeroSpaces = sString
    Exit Function

End Function