utility.bas

AD9954源码

If uMsg = 1 Then
    Call SendMessage(hWnd, BFFM_SETSELECTIONA, True, ByVal lpData)
End If
End Function
'Needed for "BrowseForFolder" function to work properly
Public Function FunctionPointer(FunctionAddress As Long) As Long
FunctionPointer = FunctionAddress
End Function

'Put this code in MouseMove event. In this example, I put a CommandButton on a
'form with the name Command1

'Private Sub Command1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
'Static CtrMov As Boolean
'With Command1 'Change this 'Command1' to your control name
'    If (X < 0) Or (Y < 0) Or (X > .Width) Or (Y > .Height) Then
'        ReleaseCapture
'        CtrMov = False
'
'        'Put here your code to LostMouseFocus
'        'For example:
'        Me.Print "LostMouseFocus"
'
'    Else
'        SetCapture .hwnd
'        If CtrMov = False Then
'            CtrMov = True
'
'            'Put here your code to GetMouseFocus
'            'For example:
'            Me.Print "GetMouseFocus"
'
'        End If
'    End If
'End With
'End Sub

'Gets a profile string from the specified ini file
Public Function GetPPString(ByVal AppName As String, ByVal KeyName As String, ByVal DefaultVal As String, ByVal iniFileName As String) As String
    Dim ReturnString As String
    Dim PPString As String * 200
    Dim PPStringLen As Long
    
    'Get the private profile string
    PPStringLen = GetPrivateProfileString(AppName, KeyName, DefaultVal, PPString, 199, iniFileName)

    'Trim off the trailing 0's and null character
    ReturnString = Left(PPString, PPStringLen)
    
    'Return the corrected string
    GetPPString = ReturnString
End Function

'This function will return True if the file exists and False if it doesn't
Public Function FileExists(File As String) As Boolean
    If Dir(File) = "" Then
        FileExists = False
    Else
        FileExists = True
    End If
End Function

'Runs a program and waits for it to end
Public Function RunShell(CmdLine$, Optional WinVisible As Variant) As Long
    Dim hProcess As Long
    Dim ProcessId As Long
    Dim exitCode As Long
    Dim WinType As Long
    
    If WinVisible = True Then
        WinType = vbNormalFocus
    Else
        WinType = vbHide
    End If
    
    ProcessId& = Shell(CmdLine$, WinType)
    
    hProcess& = OpenProcess(PROCESS_QUERY_INFORMATION, False, ProcessId&)

    Do
        Call GetExitCodeProcess(hProcess&, exitCode&)

        DoEvents
    Loop While exitCode& > 0

    RunShell = exitCode
End Function

'This function will dither a blue background on the
'form passed to it.
Public Sub DitherForm(vForm As Form)
    Dim oldScaleHeight As Long
    Dim oldScaleMode As Long
    
    Dim intLoop As Integer
    
    'Store the old form value
    oldScaleHeight = vForm.ScaleHeight
    oldScaleMode = vForm.ScaleMode
    
    vForm.DrawStyle = vbInsideSolid
    vForm.DrawMode = vbCopyPen
    vForm.ScaleMode = vbPixels
    vForm.DrawWidth = 2
    vForm.ScaleHeight = 256
    For intLoop = 0 To 255
        vForm.Line (0, intLoop)-(Screen.Width, intLoop - 1), RGB(0, 0, 255 - intLoop), B
    Next intLoop
    
    'Restore the old form values
    vForm.ScaleMode = oldScaleMode
    vForm.ScaleHeight = oldScaleHeight
    
End Sub

'Returns the drive that the application is running on
'If error occurs then returns "Not Found"
'Ex: "C:"
Public Function GetAppDrive() As String
    Dim endstr As Integer
    'Get the position of the ":" in the app path
    endstr = InStr(1, App.path, ":")
    
    'If a colin was found in the app path then truncate there
    If endstr <> 0 Then
        GetAppDrive = Left(App.path, endstr)
    Else
        GetAppDrive = "Not Found"
    End If
End Function

Public Function AddBackSlash2Path(ByVal path As String) As String
    'If there is no "\" character in the path then add it
    If Right(path, 1) <> "\" Then
        AddBackSlash2Path = path & "\"
    Else 'Nothing needs to be done
        AddBackSlash2Path = path
    End If
End Function

'This function uses the API function ShellExecute to run a program or document
Public Function ShellOpenEx(ByVal FilePath As String, ByVal DirPath As String, ByVal Parms As String, ByVal ShowType As Long) As Boolean
    Dim RetValue As Long
    Dim ShowValues(0 To 6) As Long
    ShowValues(0) = SW_HIDE
    ShowValues(1) = SW_SHOWNORMAL
    ShowValues(2) = SW_SHOWMINIMIZED
    ShowValues(3) = SW_SHOWMAXIMIZED
    ShowValues(4) = SW_SHOWNA
    ShowValues(5) = SW_SHOWNA
    ShowValues(6) = SW_SHOWMINNOACTIVE
    
    If ShowType < 0 Or ShowType > 6 Then
        MsgBox "ShellOpen: Bad Argument", vbCritical + vbApplicationModal
        Exit Function
    End If
    
    If ShowType = 5 Then
        MsgBox "ShellOpenEx(): Bad Argument", vbCritical + vbApplicationModal
        Exit Function
    End If
    
    'Shell the application
    RetValue = ShellExecute(mdiMain.hWnd, "Open", FilePath, Parms, DirPath, ShowValues(ShowType))
    
    If RetValue > 32 Then
        ShellOpenEx = True
    Else
        ShellOpenEx = False
    End If
End Function

'Gets the associated program with a file
'Returns Executable file associated with the file passed or vbNullstring
'if the function fails
Public Function GetExecutable(ByVal FileStr As String, ByVal DirStr As String) As String
    Dim ResultStr As String * MAX_PATH
    Dim retval As Long
    
    'Use the api to get the associated program
    retval = FindExecutable(FileStr, DirStr, ResultStr)
    
    If retval < 32 Then
        GetExecutable = vbNullString
    Else
        'Trim the string at the first null char and return it
        GetExecutable = Left(ResultStr, InStr(1, ResultStr, vbNullChar) - 1)
    End If
End Function

Public Function GetAssociatedEXE(ByVal FileExt As String) As String
    Dim ResultStr As String * MAX_PATH
    Dim retval As Long
    Dim FileNum As Integer
    Dim TestFile As String
    
    'Define a temp file
    TestFile = "~TF23872." & FileExt
    
    'Create a dummy file
    FileNum = FreeFile
    
    'Open the file
    Open "C:\" & TestFile For Output As #FileNum
    'Write something in it
    Print #FileNum, "TestFile"
    'Close the file
    Close #FileNum
    
    'Use the api to get the associated program
    retval = FindExecutable(TestFile, "C:\", ResultStr)
    
    If retval < 32 Then
        'Return a NullString
        GetAssociatedEXE = vbNullString
    Else
        'Trim the string at the first null char and return it
        GetAssociatedEXE = Left(ResultStr, InStr(1, ResultStr, vbNullChar) - 1)
    End If
    
    'Delete the test file
    Kill "C:\" & TestFile
End Function

'This function will get the current directory where windows is installed
Public Function GetWindowsDir() As String
    Dim WinDir As String * MAX_PATH
    Dim RetWinDir As String
    Dim TrimAmount As Long
    
    'Get the windows directory
    TrimAmount = GetWindowsDirectory(WinDir, MAX_PATH)
    
    'Trim off all unneeded trailling characters
    RetWinDir = Left(WinDir, TrimAmount)
    
    'Return the directory
    GetWindowsDir = RetWinDir
End Function


'Makes a window topmost or normal
Sub MakeTopMost(ByVal fForm As Form, ByVal Topmost As Boolean)
    Dim flags As Long
    Dim zPos As Long
    
    'Setup the default flags value
    flags = SWP_NOMOVE Or SWP_NOSIZE
    
    'Set the zPos value
    If Topmost Then
        zPos = HWND_TOPMOST
    Else
        zPos = hWnd_NOTOPMOST
    End If
    
    Call SetWindowPos(fForm.hWnd, zPos, 0, 0, 0, 0, flags)
End Sub
'Formats a number in engineering format
Function EngFormat(ByVal num As Variant) As String
    Dim dStr As String
    Dim ePow As Integer
    Dim numTmp As Variant

    numTmp = num
    
    If num >= 1 Then
        Do
            numTmp = numTmp / 10
            ePow = ePow + 1
        Loop Until numTmp < 1
        
        ePow = ePow - 1
        numTmp = numTmp * 10
    Else
    End If
End Function

'This function makes a form modeless
Function MakeFormModeless(ByVal myForm As Form, ByVal PrntHwnd As Long) As Long
    MakeFormModeless = SetWindowLong(myForm.hWnd, -8, PrntHwnd)
End Function

'Draws a 3D border around a control
'BorderType = 1  -  Border is sunken
'BorderType = 0  -  Border is raised
Public Sub vbDrawSimpleBorder(ByVal MyCtrl As Control, ByVal ParentCtrl As Object, ByVal BorderType As Long)
    Dim PX1 As Long 'One pixel on the x axis
    Dim PY1 As Long 'One pixel on the y axis
    
    PX1 = Screen.TwipsPerPixelX
    PY1 = Screen.TwipsPerPixelY
    
    With MyCtrl
        'Draw a raised or sunken border
        If BorderType Then
            ParentCtrl.ForeColor = vb3DHighlight
        Else
            ParentCtrl.ForeColor = vb3DShadow
        End If
        'Draw the line along the top of the control
        ParentCtrl.Line (.Left - PX1, .Top - PY1)-(.Left + .Width + 2 * PX1, .Top - PY1)
        'Draw the line along the left of the control
        ParentCtrl.Line (.Left - PX1, .Top - PY1)-(.Left - PX1, .Top + .Height + PY1)
        'Draw a raised or sunken border
        If BorderType Then
            ParentCtrl.ForeColor = vb3DShadow
        Else
            ParentCtrl.ForeColor = vb3DHighlight
        End If
        'Draw the line along the bottom of the control
        ParentCtrl.Line (.Left, .Top + .Height)-(.Left + .Width + 2 * PX1, .Top + .Height)