apicallbackprocs.bas

几个不错的VB例子

Attribute VB_Name = "APICallbackProcs"
'\\ --[APICallbackProcs]---------------------------------------------------------------
'\\ Series of visual basic functions whose addresses can be passed as lpfnProcAddress
'\\ parameter of windows API callback functions using the AddressOf operator.
'\\ NOTE:
'\\ When creating a new callback proc, don't forget to declare the parameters ByVal,
'\\ or VB's type conversion will fail with GPF consequences
'\\ -----------------------------------------------------------------------------------

'typedef BOOL (CALLBACK* GRAYSTRINGPROC)(HDC, LPARAM, int);
'typedef VOID (CALLBACK* SENDASYNCPROC)(HWND, UINT, DWORD, LRESULT);
'typedef BOOL (CALLBACK* PROPENUMPROCA)(HWND, LPCSTR, HANDLE);
'typedef BOOL (CALLBACK* PROPENUMPROCEXA)(HWND, LPSTR, HANDLE, DWORD);
'typedef int (CALLBACK* EDITWORDBREAKPROCA)(LPSTR lpch, int ichCurrent, int cch, int code);
'typedef BOOL (CALLBACK* NAMEENUMPROCA)(LPSTR, LPARAM);
'typedef BOOL (CALLBACK* ENUMRESTYPEPROC)(HMODULE hModule, LPTSTR lpType, LONG lParam);
'typedef BOOL (CALLBACK* ENUMRESNAMEPROC)(HMODULE hModule, LPCTSTR lpType, LPTSTR lpName, LONG lParam);
'typedef BOOL (CALLBACK* ENUMRESLANGPROC)(HMODULE hModule, LPCTSTR lpType, LPCTSTR lpName, WORD  wLanguage, LONG lParam);

Option Explicit

'\\ Application global variables....
Public Eventhandler As EnumHandler
Public APIDispenser As APIFunctions
Public AllSubclassedWindows As colSubclassedWindows
Public AllTopLevelWindows As Collection
Public AllInstalledLocales As Collection

'\\ Windows hooks...
Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal ncode As Long, ByVal wParam As Long, lParam As Any) As Long

'\\ Enumerating windows....
Private Declare Function EnumWindows Lib "user32" (ByVal lpEnumFunc As Long, ByVal lParam As Long) As Long
Private Declare Function IsWindowApi Lib "user32" Alias "IsWindow" (ByVal hwnd As Long) As Long

'\\ Enumerating system locales
Private Enum SystemLocaleEnumerationTypes
     LCID_INSTALLED = &H1        ' ##  installed locale ids
     LCID_SUPPORTED = &H2        ' ##  supported locale ids
     LCID_ALTERNATE_SORTS = &H4        ' ##  alternate sort locale ids
End Enum
Private Declare Function EnumSystemLocales Lib "kernel32" Alias "EnumSystemLocalesA" (ByVal lpLocaleEnumProc As Long, ByVal dwFlags As Long) As Long

'\\ Speeding up error reporting
'\\ API Error decoding
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

Public Function GetLastSystemError() As String

Const FORMAT_MESSAGE_FROM_SYSTEM = &H1000
Dim sError As String * 500 '\\ Preinitilise a string buffer to put any error message into
Dim lErrNum As Long
Dim lErrMsg As Long

lErrNum = Err.LastDllError

lErrMsg = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, ByVal 0&, lErrNum, 0, sError, Len(sError), 0)

GetLastSystemError = Trim(sError)

End Function


Public Sub Main()

Set APIDispenser = New APIFunctions

End Sub


Public Sub RefreshInstalledLocales()

Dim lret As Long

Set AllInstalledLocales = New Collection

lret = EnumSystemLocales(AddressOf VB_ENUMLOCALESPROC, LCID_INSTALLED)


End Sub

Public Sub RefreshTopLevelWindows()

Dim lret As Long

Set AllTopLevelWindows = New Collection

lret = EnumWindows(AddressOf TopLevelWndEnumProc, 0)
If Err.LastDllError <> 0 Then
    ReportError Err.LastDllError, "System:TopLevelWindows", GetLastSystemError
End If

End Sub

Public Sub ReportError(ByVal Number As Long, ByVal Source As String, ByVal Description As String)

If APIDispenser Is Nothing Then
    Err.Raise Number, Source, Description
Else
    APIDispenser.RaiseError Number, Source, Description
End If

Err.Clear

End Sub
'\\ --[VB_DLGPROC]----------------------------------------------------------------------------
'\\ typedef BOOL (CALLBACK* DLGPROC)(HWND, UINT, WPARAM, LPARAM)
'\\ ----------------------------------------------------------------------------------------
'\\ (c) 2001 - Merrion Computing.  All rights  to use, reproduce or publish this code reserved
'\\ Please check http://www.merrioncomputing.com for updates.
'\\ ----------------------------------------------------------------------------------------
Public Function VB_DLGPROC(ByVal hwnd As Long, ByVal uint As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

Dim Params() As Variant

ReDim Params(1 To 5) As Variant
Params(1) = hwnd
Params(2) = uint
Params(3) = wParam
Params(4) = lParam
Params(5) = 0

If Not Eventhandler Is Nothing Then
    Eventhandler.TriggerEvent DLGPROC, Params()
End If

VB_DLGPROC = Params(5)

End Function

'\\ --[VB_EDITWORDBREAKPROCA]------------------------------------------------------------
'\\ 'typedef int (CALLBACK* EDITWORDBREAKPROCA)(LPSTR lpch, int ichCurrent, int cch, int code);
'\\ This gets called by an edit control when a line of text has filled up the available
'\\ space.
'\\ By default, a text edit box breaks on spaces.
'\\ (This version prevents numbers being broken up if the digit grouping sepeartor is a space.)
'\\ ----------------------------------------------------------------------------------------
'\\ (c) 2001 - Merrion Computing.  All rights  to use, reproduce or publish this code reserved
'\\ Please check http://www.merrioncomputing.com for updates.
'\\ ----------------------------------------------------------------------------------------
Public Function VB_EDITWORDBREAKPROCA(ByVal lpch As Long, _
                                      ByVal ichCurrent As Long, _
                                      ByVal cch As Long, _
                                      ByVal Code As Long) As Long
                                      
On Local Error Resume Next

Dim sCharacters As String

Dim lCharPos As Long

sCharacters = StringFromPointer(lpch, 1024)

Select Case Code
Case WB_ISDELIMITER
    '\\ Edit control is asking if this character is a wordbreak char...
    '\\ Reply FALSE is it is not a space, or if the characters either side of it
    '\\ are numbers....
    If Mid$(sCharacters, ichCurrent, 1) = " " Then
        VB_EDITWORDBREAKPROCA = 1
        If (ichCurrent > 0) And (ichCurrent < Len(sCharacters)) Then
            If IsNumeric(Mid$(sCharacters, ichCurrent - 1, 1)) And IsNumeric(Mid$(sCharacters, ichCurrent + 1, 1)) Then
                VB_EDITWORDBREAKPROCA = 0
            End If
        End If
    Else
        VB_EDITWORDBREAKPROCA = 0
    End If

Case WB_LEFT
  '\\ Find the begining of a word to the left of this position....
  For lCharPos = ichCurrent To 1 Step -1
    If Mid$(sCharacters, lCharPos, 1) = " " Then
        If Not (IsNumeric(Mid$(sCharacters, lCharPos - 1, 1)) And IsNumeric(Mid$(sCharacters, lCharPos + 1, 1))) Then
            VB_EDITWORDBREAKPROCA = lCharPos
            Exit For
        End If
    End If
  Next lCharPos
  
Case WB_RIGHT
'\\ Find the begining of a word to the right of this position....
  For lCharPos = ichCurrent To Len(sCharacters)
    If Mid$(sCharacters, lCharPos, 1) = " " Then
        If Not (IsNumeric(Mid$(sCharacters, lCharPos - 1, 1)) And IsNumeric(Mid$(sCharacters, lCharPos + 1, 1))) Then
            VB_EDITWORDBREAKPROCA = lCharPos
            Exit For
        End If
    End If
  Next lCharPos
End Select

End Function


'\\ ----------------------------------------------------------------------------------------
'\\ (c) 2001 - Merrion Computing.  All rights  to use, reproduce or publish this code reserved
'\\ Please check http://www.merrioncomputing.com for updates.
'\\ ----------------------------------------------------------------------------------------
Public Function VB_EnumDesktops(ByVal lpstrName As String, ByVal lParam As Long) As Long

Dim Params() As Variant

ReDim Params(1 To 2) As Variant
Params(1) = lpstrName
Params(2) = lParam

If Not Eventhandler Is Nothing Then
    Eventhandler.TriggerEvent DESKTOPENUMPROC, Params()
End If

VB_EnumDesktops = 1

End Function

'\\ --[VB_ENUMLOCALESPROC]-----------------------------------------------------------
'\\ BOOL CALLBACK EnumLocalesProc(
'\\   LPTSTR lpLocaleString   // locale identifier string
'\\   };
'\\ ---------------------------------------------------------------------------------
'\\ (c) 2001 - Merrion Computing Ltd.  All rights reserved
'\\ ---------------------------------------------------------------------------------
Public Function VB_ENUMLOCALESPROC(ByVal lpLocales As Long) As Long

Dim sLocale As String
Dim LCid As Long

Dim lcThis As New ApiLocale

sLocale = StringFromPointer(lpLocales, 9)

LCid = Val("&H" & sLocale)
lcThis.LocaleId = LCid
AllInstalledLocales.Add lcThis, "&H" & sLocale

VB_ENUMLOCALESPROC = 1

End Function

'\\ ----------------------------------------------------------------------------------------
'\\ (c) 2001 - Merrion Computing.  All rights  to use, reproduce or publish this code reserved
'\\ Please check http://www.merrioncomputing.com for updates.
'\\ ----------------------------------------------------------------------------------------
Public Function VB_ENUMPROC(ByVal hwnd As Long, ByVal lpStrPropName As String, ByVal hHandle As Long) As Long

Dim Params() As Variant

ReDim Params(1 To 3) As Variant
Params(1) = hwnd
Params(2) = lpStrPropName
Params(3) = hHandle
If Not Eventhandler Is Nothing Then
    Eventhandler.TriggerEvent PROPENUMPROC, Params()
End If

VB_ENUMPROC = 1

End Function

'\\ ----------------------------------------------------------------------------------------
'\\ (c) 2001 - Merrion Computing.  All rights  to use, reproduce or publish this code reserved
'\\ Please check http://www.merrioncomputing.com for updates.
'\\ ----------------------------------------------------------------------------------------
Public Function VB_ENUMPROCEX(ByVal hwnd As Long, ByVal lpStr As String, ByVal hHandle As Long, ByVal dWord As Long) As Long

Dim Params() As Variant

ReDim Params(1 To 3) As Variant
Params(1) = hwnd
Params(2) = lpStr
Params(3) = hHandle
Params(4) = dWord
If Not Eventhandler Is Nothing Then
    Eventhandler.TriggerEvent PROPENUMPROC, Params()
End If

VB_ENUMPROCEX = 1

End Function

'\\ --[VB_ENUMRESLANGPROC]---------------------------------------------
'\\ Decl:
'\\ ----------------------------------------------------------------------------------------
'\\ (c) 2001 - Merrion Computing.  All rights  to use, reproduce or publish this code reserved
'\\ Please check http://www.merrioncomputing.com for updates.
'\\ ----------------------------------------------------------------------------------------
Public Function VB_ENUMRESLANGPROC(ByVal hModule As Long, ByVal lpType As String, ByVal lpName As String, ByVal wLanguage As Long, ByVal lParam As Long) As Long

Dim Params() As Variant

ReDim Params(1 To 5) As Variant
Params(1) = hModule
Params(2) = lpType
Params(3) = lpName
Params(4) = wLanguage
Params(5) = lParam
If Not Eventhandler Is Nothing Then
    Eventhandler.TriggerEvent ENUMRESLANGPROC, Params()
End If

End Function

'\\ --[VB_ENUMRESNAMEPROC]------------------------------------------------------------
'\\ Decl:
'\\
'\\ ----------------------------------------------------------------------------------------
'\\ (c) 2001 - Merrion Computing.  All rights  to use, reproduce or publish this code reserved
'\\ Please check http://www.merrioncomputing.com for updates.
'\\ ----------------------------------------------------------------------------------------
Public Function VB_ENUMRESNAMEPROC(ByVal hModule As Long, ByVal lpType As String, _
                                    ByVal lpName As String, ByVal lParam As Long) As Long

Dim Params() As Variant

ReDim Params(1 To 4) As Variant
Params(1) = hModule
Params(2) = lpType
Params(3) = lpName
Params(4) = lParam
If Not Eventhandler Is Nothing Then
    Eventhandler.TriggerEvent ENUMRESNAMEPROC, Params()
End If