isbutton.ctl

iso文件制作与制作光盘 iso文件制作与制作光盘

  'hWnd, uMsg, wParam and lParam parameters in a 'before' callback so that different
  'values get passed to the default handler.. and optionaly, the 'after' callback
  On Error GoTo zSubclass_Proc_Error

  Select Case uMsg
    Case WM_MOUSEMOVE

      If Not bInCtrl Then
        bInCtrl = True
        Call TrackMouseLeave(lng_hWnd)
        m_iState = stateHot
        Refresh
        RaiseEvent MouseEnter
        CreateToolTip
      End If

    Case WM_MOUSELEAVE
      bInCtrl = False
      m_iState = statenormal
      RemoveToolTip
      Refresh
      RaiseEvent MouseLeave
    Case WM_SYSCOLORCHANGE
      Refresh
    Case WM_THEMECHANGED
      Refresh
  End Select

  Exit Sub

zSubclass_Proc_Error:
End Sub

'======================================================================================================
'Subclass code - The programmer may call any of the following Subclass_??? routines
'Add a message to the table of those that will invoke a callback. You should Subclass_Start first and then add the messages
Private Sub Subclass_AddMsg(ByVal lng_hWnd As Long, _
                            ByVal uMsg As Long, _
                            Optional ByVal When As eMsgWhen = MSG_AFTER)
  On Error GoTo Subclass_AddMsg_Error

  'Parameters:
  'lng_hWnd  - The handle of the window for which the uMsg is to be added to the callback table
  'uMsg      - The message number that will invoke a callback. NB Can also be ALL_MESSAGES, ie all messages will callback
  'When      - Whether the msg is to callback before, after or both with respect to the the default (previous) handler
  With sc_aSubData(zIdx(lng_hWnd))

    If When And eMsgWhen.MSG_BEFORE Then
      Call zAddMsg(uMsg, .aMsgTblB, .nMsgCntB, eMsgWhen.MSG_BEFORE, .nAddrSub)
    End If

    If When And eMsgWhen.MSG_AFTER Then
      Call zAddMsg(uMsg, .aMsgTblA, .nMsgCntA, eMsgWhen.MSG_AFTER, .nAddrSub)
    End If

  End With

  Exit Sub

Subclass_AddMsg_Error:
End Sub

''Delete a message from the table of those that will invoke a callback.
'Private Sub Subclass_DelMsg(ByVal lng_hWnd As Long, _
'                            ByVal uMsg As Long, _
'                            Optional ByVal When As eMsgWhen = MSG_AFTER)
'  On Error GoTo Subclass_DelMsg_Error
'
'  'Parameters:
'  'lng_hWnd  - The handle of the window for which the uMsg is to be removed from the callback table
'  'uMsg      - The message number that will be removed from the callback table. NB Can also be ALL_MESSAGES, ie all messages will callback
'  'When      - Whether the msg is to be removed from the before, after or both callback tables
'  With sc_aSubData(zIdx(lng_hWnd))
'
'    If When And eMsgWhen.MSG_BEFORE Then
'      Call zDelMsg(uMsg, .aMsgTblB, .nMsgCntB, eMsgWhen.MSG_BEFORE, .nAddrSub)
'    End If
'
'    If When And eMsgWhen.MSG_AFTER Then
'      Call zDelMsg(uMsg, .aMsgTblA, .nMsgCntA, eMsgWhen.MSG_AFTER, .nAddrSub)
'    End If
'
'  End With
'
'  Exit Sub
'
'Subclass_DelMsg_Error:
'End Sub

'Return whether we're running in the IDE.
Private Function Subclass_InIDE() As Boolean
  On Error GoTo Subclass_InIDE_Error

  Debug.Assert zSetTrue(Subclass_InIDE)
  Exit Function

Subclass_InIDE_Error:
End Function

'Start subclassing the passed window handle
Private Function Subclass_Start(ByVal lng_hWnd As Long) As Long
  'Parameters:
  'lng_hWnd  - The handle of the window to be subclassed
  'Returns;
  'The sc_aSubData() index
  On Error GoTo Subclass_Start_Error

  Const CODE_LEN              As Long = 200                 'Length of the machine code in bytes
  Const FUNC_CWP              As String = "CallWindowProcA" 'We use CallWindowProc to call the original WndProc
  Const FUNC_EBM              As String = "EbMode"          'VBA's EbMode function allows the machine code thunk to know if the IDE has stopped or is on a breakpoint
  Const FUNC_SWL              As String = "SetWindowLongA"  'SetWindowLongA allows the cSubclasser machine code thunk to unsubclass the subclasser itself if it detects via the EbMode function that the IDE has stopped
  Const MOD_USER              As String = "user32"          'Location of the SetWindowLongA & CallWindowProc functions
  Const MOD_VBA5              As String = "vba5"            'Location of the EbMode function if running VB5
  Const MOD_VBA6              As String = "vba6"            'Location of the EbMode function if running VB6
  Const PATCH_01              As Long = 18                  'Code buffer offset to the location of the relative address to EbMode
  Const PATCH_02              As Long = 68                  'Address of the previous WndProc
  Const PATCH_03              As Long = 78                  'Relative address of SetWindowsLong
  Const PATCH_06              As Long = 116                 'Address of the previous WndProc
  Const PATCH_07              As Long = 121          'Relative address of CallWindowProc
  Const PATCH_0A              As Long = 186          'Address of the owner object
  Static aBuf(1 To CODE_LEN)  As Byte          'Static code buffer byte array
  Static pCWP                 As Long           'Address of the CallWindowsProc
  Static pEbMode              As Long          'Address of the EbMode IDE break/stop/running function
  Static pSWL                 As Long          'Address of the SetWindowsLong function
  Dim i                       As Long          'Loop index
  Dim j                       As Long          'Loop index
  Dim nSubIdx                 As Long          'Subclass data index
  Dim sHex                    As String          'Hex code string

  'If it's the first time through here..
  If aBuf(1) = 0 Then
    'The hex pair machine code representation.
    sHex = "5589E583C4F85731C08945FC8945F8EB0EE80000000083F802742185C07424E830000000837DF800750AE838000000E84D00" & "00005F8B45FCC9C21000E826000000EBF168000000006AFCFF7508E800000000EBE031D24ABF00000000B900000000E82D00" & "0000C3FF7514FF7510FF750CFF75086800000000E8000000008945FCC331D2BF00000000B900000000E801000000C3E33209" & "C978078B450CF2AF75278D4514508D4510508D450C508D4508508D45FC508D45F85052B800000000508B00FF90A4070000C3"
    'Convert the string from hex pairs to bytes and store in the static machine code buffer
    i = 1

    Do While j < CODE_LEN
      j = j + 1
      aBuf(j) = Val("&H" & Mid$(sHex, i, 2)) 'Convert a pair of hex characters to an eight-bit value and store in the static code buffer array
      i = i + 2
    Loop 'Next 'pair of hex characters

    'Get API function addresses
    If Subclass_InIDE Then 'If we're running in the VB IDE
      aBuf(16) = &H90 'Patch the code buffer to enable the IDE state code
      aBuf(17) = &H90 'Patch the code buffer to enable the IDE state code
      pEbMode = zAddrFunc(MOD_VBA6, FUNC_EBM) 'Get the address of EbMode in vba6.dll

      If pEbMode = 0 Then 'Found?
        pEbMode = zAddrFunc(MOD_VBA5, FUNC_EBM) 'VB5 perhaps
      End If
    End If

    pCWP = zAddrFunc(MOD_USER, FUNC_CWP) 'Get the address of the CallWindowsProc function
    pSWL = zAddrFunc(MOD_USER, FUNC_SWL) 'Get the address of the SetWindowLongA function
    ReDim sc_aSubData(0 To 0) As tSubData 'Create the first sc_aSubData element
  Else
    nSubIdx = zIdx(lng_hWnd, True)

    If nSubIdx = -1 Then                                   'If an sc_aSubData element isn't being re-cycled
      nSubIdx = UBound(sc_aSubData()) + 1                  'Calculate the Next 'element
      ReDim Preserve sc_aSubData(0 To nSubIdx) As tSubData 'Create a new sc_aSubData element
    End If

    Subclass_Start = nSubIdx
  End If

  With sc_aSubData(nSubIdx)
    .hWnd = lng_hWnd                                           'Store the hWnd
    .nAddrSub = GlobalAlloc(GMEM_FIXED, CODE_LEN)              'Allocate memory for the machine code WndProc
    .nAddrOrig = SetWindowLongA(.hWnd, GWL_WNDPROC, .nAddrSub) 'Set our WndProc in place
    Call RtlMoveMemory(ByVal .nAddrSub, aBuf(1), CODE_LEN)     'Copy the machine code from the static byte array to the code array in sc_aSubData
    Call zPatchRel(.nAddrSub, PATCH_01, pEbMode)               'Patch the relative address to the VBA EbMode api function, whether we need to not.. hardly worth testing
    Call zPatchVal(.nAddrSub, PATCH_02, .nAddrOrig)            'Original WndProc address for CallWindowProc, call the original WndProc
    Call zPatchRel(.nAddrSub, PATCH_03, pSWL)                  'Patch the relative address of the SetWindowLongA api function
    Call zPatchVal(.nAddrSub, PATCH_06, .nAddrOrig)            'Original WndProc address for SetWindowLongA, unsubclass on IDE stop
    Call zPatchRel(.nAddrSub, PATCH_07, pCWP)                  'Patch the relative address of the CallWindowProc api function
    Call zPatchVal(.nAddrSub, PATCH_0A, ObjPtr(Me))            'Patch the address of this object instance into the static machine code buffer
  End With

  Exit Function

Subclass_Start_Error:
End Function

'Stop all subclassing
Private Sub Subclass_StopAll()
  On Error GoTo Subclass_StopAll_Error

  Dim i As Long
  i = UBound(sc_aSubData()) 'Get the upper bound of the subclass data array

  Do While i >= 0           'Iterate through each element

    With sc_aSubData(i)

      If .hWnd <> 0 Then               'If not previously Subclass_Stop'd
        Call Subclass_Stop(.hWnd)      'Subclass_Stop
      End If

    End With

    i = i - 1           'Next 'element
  Loop

  Exit Sub

Subclass_StopAll_Error:
End Sub

'Stop subclassing the passed window handle
Private Sub Subclass_Stop(ByVal lng_hWnd As Long)
  On Error GoTo Subclass_Stop_Error

  'Parameters:
  'lng_hWnd  - The handle of the window to stop being subclassed
  With sc_aSubData(zIdx(lng_hWnd))
    Call SetWindowLongA(.hWnd, GWL_WNDPROC, .nAddrOrig)  'Restore the original WndProc
    Call zPatchVal(.nAddrSub, PATCH_05, 0)               'Patch the Table B entry count to ensure no further 'before' callbacks
    Call zPatchVal(.nAddrSub, PATCH_09, 0)               'Patch the Table A entry count to ensure no further 'after' callbacks
    Call GlobalFree(.nAddrSub)                           'Release the machine code memory
    .hWnd = 0                 'Mark the sc_aSubData element as available for re-use
    .nMsgCntB = 0             'Clear the before table
    .nMsgCntA = 0             'Clear the after table
    Erase .aMsgTblB           'Erase the before table
    Erase .aMsgTblA           'Erase the after table
  End With

  Exit Sub

Subclass_Stop_Error:
End Sub

'======================================================================================================
'These z??? routines are exclusively called by the Subclass_??? routines.
'Worker sub for Subclass_AddMsg
Private Sub zAddMsg(ByVal uMsg As Long, _
                    ByRef aMsgTbl() As Long, _
                    ByRef nMsgCnt As Long, _
                    ByVal When As eMsgWhen, _
                    ByVal nAddr As Long)
  On Error GoTo zAddMsg_Error

  Dim nEntry  As Long 'Message table entry index
  Dim nOff1   As Long 'Machine code buffer offset 1
  Dim nOff2   As Long 'Machine code buffer offset 2

  If uMsg = ALL_MESSAGES Then 'If all messages
    nMsgCnt = ALL_MESSAGES 'Indicates that all messages will callback
  Else 'Else a specific message number

    Do While nEntry < nMsgCnt 'For each existing entry. NB will skip if nMsgCnt = 0
      nEntry = nEntry + 1

      If aMsgTbl(nEntry) = 0 Then 'This msg table slot is a deleted entry
        aMsgTbl(nEntry) = uMsg 'Re-use this entry
        Exit Sub 'Bail

      ElseIf aMsgTbl(nEntry) = uMsg Then 'The msg is already in the table!
        Exit Sub 'Bail

      End If

    Loop 'Next 'entry

    nMsgCnt = nMsgCnt + 1 'New slot required, bump the table entry count
    ReDim Preserve aMsgTbl(1 To nMsgCnt) As Long 'Bump the size of the table.
    aMsgTbl(nMsgCnt) = uMsg 'Store the message number in the table
  End If

  If When = eMsgWhen.MSG_BEFORE Then 'If before
    nOff1 = PATCH_04 'Offset to the Before table
    nOff2 = PATCH_05 'Offset to the Before table entry count
  Else 'Else after
    nOff1 = PATCH_08 'Offset to the After table
    nOff2 = PATCH_09 'Offset to the After table entry count
  End If

  If uMsg <> ALL_MESSAGES Then
    Call zPatchVal(nAddr, nOff1, VarPtr(aMsgTbl(1))) 'Address of the msg table, has to be re-patched because Redim Preserve will move it in memory.
  End If

  Call zPatchVal(nAddr, nOff2, nMsgCnt) 'Patch the appropriate table entry count
  Exit Sub

zAddMsg_Error:
End Sub

'Return the memory address of the passed function in the passed dll
Private Function zAddrFunc(ByVal sDLL As String, _
                           ByVal sProc As String) As Long
  On Error GoTo zAddrFunc_Error

  zAddrFunc = GetProcAddress(GetModuleHandleA(sDLL), sProc)
  '  Debug.Assert zAddrFunc                                                                'You may wish to comment out this line if you're using vb5 else the EbMode GetProcAddress will stop h