utility.bas

Some mathematical functions

Attribute VB_Name = "Utility"
'Win API functions
Public Declare Function OpenProcess Lib "kernel32" _
       (ByVal dwDesiredAccess As Long, _
       ByVal bInheritHandle As Long, _
       ByVal dwProcessId As Long) As Long

Public Declare Function WinHelp Lib "user32" Alias "WinHelpA" (ByVal hwnd As Long, ByVal lpHelpFile As String, ByVal wCommand As Long, ByVal dwData As Long) As Long
Public Const HELP_COMMAND = &H102&
Public Const HELP_CONTENTS = &H3&
Public Const HELP_CONTEXT = &H1
Public Const HELP_CONTEXTPOPUP = &H8&
Public Const HELP_FORCEFILE = &H9&
Public Const HELP_HELPONHELP = &H4
Public Const HELP_INDEX = &H3
Public Const HELP_KEY = &H101
Public Const HELP_MULTIKEY = &H201&
Public Const HELP_PARTIALKEY = &H105&
Public Const HELP_QUIT = &H2
Public Const HELP_SETCONTENTS = &H5&
Public Const HELP_SETINDEX = &H5
Public Const HELP_SETWINPOS = &H203&
Public Const HELPMSGSTRING = "commdlg_help"
Public Const HELP_TAB = &HF&

Public Declare Function GetExitCodeProcess Lib "kernel32" _
       (ByVal hProcess As Long, lpExitCode As Long) As Long

Const PROCESS_QUERY_INFORMATION = &H400

Public Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long

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
Public Const SW_HIDE = 0
Public Const SW_SHOWMAXIMIZED = 3
Public Const SW_SHOWMINIMIZED = 2
Public Const SW_SHOWNORMAL = 1
Public Const SW_SHOWNA = 8
Public Const SW_SHOWMINNOACTIVE = 7


Public Declare Function FindExecutable Lib "shell32.dll" Alias "FindExecutableA" (ByVal lpFile As String, ByVal lpDirectory As String, ByVal lpResult As String) As Long
Public Const ERROR_FILE_NOT_FOUND = 2&
Public Const ERROR_PATH_NOT_FOUND = 3&
Public Const ERROR_BAD_FORMAT = 11&

'Maximum path length
Public Const MAX_PATH = 260

'Gets windows directory
Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long

Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Public Declare Function OpenIcon Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function SetForegroundWindow Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function IsIconic Lib "user32" (ByVal hwnd As Long) As Long

Public Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Public Const HWND_NOTOPMOST = -2
Public Const HWND_TOP = 0
Public Const HWND_TOPMOST = -1
Public Const HWND_BOTTOM = 1
Public Const SWP_NOMOVE = &H2
Public Const SWP_NOSIZE = &H1
Public Const SWP_SHOWWINDOW = &H40
Public Const SWP_NOACTIVATE = &H10

'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 the 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(frmMain.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