utility.bas

AD9954源码

Attribute VB_Name = "Utility"
Option Explicit
'Win API functions
'Used to lock a window
Public Declare Function LockWindowUpdate Lib "user32" (ByVal hwndLock As Long) As Long

'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

'Finds the executable associated with a file
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 GetForegroundWindow Lib "user32" () 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

Public Declare Function SetCapture Lib "user32" (ByVal hWnd As Long) As Long
Public Declare Function ReleaseCapture Lib "user32" () As Long

Private Declare Sub ExitWindowsDialog Lib "shell32.dll" Alias "#60" (ByVal hWnd As Long)

'
' Constant used with GetWindow() to obta
'     in handle
' to MDIForm's client space
'
Public Const GW_CHILD = 5
Public Declare Function GetWindow Lib "user32" (ByVal hWnd As Long, ByVal wCmd As Long) As Long
Public Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
Public Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long) As Long
Public Declare Function GetClientRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long
Public Type RECT
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
End Type

Public Declare Function BitBlt Lib "gdi32" ( _
   ByVal hdcDest As Long, ByVal XDest As Long, _
   ByVal YDest As Long, ByVal nWidth As Long, _
   ByVal nHeight As Long, ByVal hDCSrc As Long, _
   ByVal XSrc As Long, ByVal YSrc As Long, ByVal dwRop As Long) _
   As Long

Public Const NOTSRCCOPY = &H330008 ' dest = (NOT source)
Public Const NOTSRCERASE = &H1100A6 ' dest = (NOT src) AND (NOT dest)
Public Const BLACKNESS = &H42 ' dest = BLACK
Public Const DSTINVERT = &H550009 ' dest = (NOT dest)
Public Const MERGECOPY = &HC000CA ' dest = (source AND pattern)
Public Const MERGEPAINT = &HBB0226 ' dest = (NOT source) OR dest
Public Const PATCOPY = &HF00021 ' dest = pattern
Public Const PATINVERT = &H5A0049 ' dest = pattern XOR dest
Public Const PATPAINT = &HFB0A09 ' dest = DPSnoo
Public Const SRCAND = &H8800C6 ' dest = source AND dest
Public Const SRCCOPY = &HCC0020 ' dest = source
Public Const SRCERASE = &H440328 ' dest = source AND (NOT dest )
Public Const SRCINVERT = &H660046 ' dest = source XOR dest
Public Const SRCPAINT = &HEE0086 ' dest = source OR dest
Public Const WHITENESS = &HFF0062  ' dest = WHITE

'Used to make modeless forms
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public Const WS_OVERLAPPED = &H0&

'**********************************************************
'Windows API/Global Declarations for :Win95DirectoryPrompt
'**********************************************************
Public Type BROWSEINFOTYPE
    hOwner As Long
    pidlRoot As Long
    pszDisplayName As String
    lpszTitle As String
    ulFlags As Long
    lpfn As Long
    lParam As Long
    iImage As Long
End Type
Public Const BIF_RETURNONLYFSDIRS = 1
'Public Const MAX_PATH = 260

Public Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long)

Public Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" _
    (ByVal lpString1 As String, ByVal lpString2 As String) As Long

Public Declare Function SHBrowseForFolder Lib "shell32" _
    (lpbi As BROWSEINFOTYPE) As Long

Public Declare Function SHGetPathFromIDList Lib "shell32" _
    (ByVal pidList As Long, ByVal lpBuffer As String) As Long

Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal dwLength As Long)

Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long

Public Const WM_USER = &H400

Public Const BFFM_SETSELECTIONA As Long = (WM_USER + 102)
Public Const BFFM_SETSELECTIONW As Long = (WM_USER + 103)
Public Declare Function LocalAlloc Lib "kernel32" (ByVal uFlags As Long, ByVal uBytes As Long) As Long
Public Declare Function LocalFree Lib "kernel32" (ByVal hMem As Long) As Long
Public Const LPTR = (&H0 Or &H40)

'Used by DisableMinButton
Public Const MF_BYPOSITION = &H400&
Public Declare Function GetSystemMenu Lib "user32" (ByVal hWnd As Long, ByVal bRevert As Long) As Long
Public Declare Function RemoveMenu Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long

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

'**************************************
'Windows API/Global Declarations for :Ch
'     anging priority
'**************************************
Private Const NORMAL_PRIORITY_CLASS = &H20
Private Const IDLE_PRIORITY_CLASS = &H40
Private Const HIGH_PRIORITY_CLASS = &H80
Private Const REALTIME_PRIORITY_CLASS = &H100
Private Const PROCESS_DUP_HANDLE = &H40


Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, _
    ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long


Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long


Private Declare Function GetCurrentProcessId Lib "kernel32" () As Long


Private Declare Function SetPriorityClass& Lib "kernel32" (ByVal hProcess As Long, _
    ByVal dwPriorityClass As Long)


'Used by IsWinNT
Public Type OSVERSIONINFO
        dwOSVersionInfoSize As Long 'Set to 148
        dwMajorVersion As Long
        dwMinorVersion As Long
        dwBuildNumber As Long
        dwPlatformId As Long
        szCSDVersion As String * 128      '  Maintenance string for PSS usage
End Type

Public Const VER_PLATFORM_WIN32_NT = 2
Public Const VER_PLATFORM_WIN32_WINDOWS = 1
Public Const VER_PLATFORM_WIN32s = 0
'End Used by IsWinNT

'Call this for
'XP THEMED FORMS
Public Type INITCOMMONCONTROLSEX_TYPE
    dwSize As Long
    dwICC As Long
End Type

Public Declare Function InitCommonControlsEx Lib "comctl32.dll" (lpInitCtrls As _
    INITCOMMONCONTROLSEX_TYPE) As Long
Public Const ICC_INTERNET_CLASSES = &H800
'XP Themeing

'Used for ChangePriority()
Public Const WM_SETREDRAW = &HB

'Adds support for xp themes
Public Sub EnableXPThemes()
        
    On Error GoTo ErrorHandler:
    
    Dim comctls As INITCOMMONCONTROLSEX_TYPE  ' identifies the control to register
    Dim retval As Long                        ' generic return value
    With comctls
        .dwSize = Len(comctls)
        .dwICC = ICC_INTERNET_CLASSES
    End With
    retval = InitCommonControlsEx(comctls)
    
    'Exit the function
    Exit Sub
    
ErrorHandler:
    'Avoid a crash by doing nothing
    
End Sub

'Gets the Proccess ID for your program
Public Function GetPID() As Long
    GetPID = GetCurrentProcessId()
End Function


Public Function IsWinNT() As Boolean
    Dim myOS As OSVERSIONINFO

    myOS.dwOSVersionInfoSize = Len(myOS)
    GetVersionEx myOS
    IsWinNT = (myOS.dwPlatformId = VER_PLATFORM_WIN32_NT)
End Function


'Allows the user to browse for a folder and returns the path
'Public Function BrowseForFolder(hWndOwner As Long, sPrompt As String) As String
'    Dim iNull As Integer
'    Dim lpIDList As Long
'    Dim lResult As Long
'    Dim sPath As String
'    Dim udtBI As BrowseInfo
'
'
'    With udtBI
'        .hWndOwner = hWndOwner
'        .lpszTitle = lstrcat(sPrompt, "")
'        .ulFlags = BIF_RETURNONLYFSDIRS
'    End With
'    lpIDList = SHBrowseForFolder(udtBI)
'
'
'    If lpIDList Then
'        sPath = String$(MAX_PATH, 0)
'        lResult = SHGetPathFromIDList(lpIDList, sPath)
'        Call CoTaskMemFree(lpIDList)
'        iNull = InStr(sPath, vbNullChar)
'
'
'        If iNull Then
'            sPath = Left$(sPath, iNull - 1)
'        End If
'    End If
'    BrowseForFolder = sPath
'End Function
Public Function BrowseForFolder(hWndOwner As Long, sPrompt As String, selectedPath As String) As String
    Dim Browse_for_folder As BROWSEINFOTYPE
    Dim itemID As Long
    Dim selectedPathPointer As Long
    Dim tmpPath As String * 256
    With Browse_for_folder
        .hOwner = hWndOwner ' Window Handle
        .lpszTitle = sPrompt 'lstrcat(sPrompt, "") ' Dialog Title
        .lpfn = FunctionPointer(AddressOf BrowseCallbackProcStr) ' Dialog callback function that preselectes the folder specified
        selectedPathPointer = LocalAlloc(LPTR, Len(selectedPath) + 1) ' Allocate a string
        CopyMemory ByVal selectedPathPointer, ByVal selectedPath, Len(selectedPath) + 1 ' Copy the path to the string
        .lParam = selectedPathPointer ' The folder to preselect
    End With
    itemID = SHBrowseForFolder(Browse_for_folder) ' Execute the BrowseForFolder API
    If itemID Then
        If SHGetPathFromIDList(itemID, tmpPath) Then ' Get the path for the selected folder in the dialog
            BrowseForFolder = Left$(tmpPath, InStr(tmpPath, vbNullChar) - 1) ' Take only the path without the nulls
        End If
        Call CoTaskMemFree(itemID) ' Free the itemID
    End If
    Call LocalFree(selectedPathPointer) ' Free the string from the memory
End Function
'Needed for "BrowseForFolder" function to work properly
Public Function BrowseCallbackProcStr(ByVal hWnd As Long, ByVal uMsg As Long, ByVal lParam As Long, ByVal lpData As Long) As Long