modsocketmaster.bas

一个使用GPRS连接的WAP服务程序

m_colAcceptList.Add Socket, "S" & lngSocket
End Sub

'Returns True is lngSocket is registered on the
'accept list.
Public Function IsAcceptRegistered(ByVal lngSocket As Long) As Boolean
On Error GoTo Error_Handler

m_colAcceptList.Item ("S" & lngSocket)
IsAcceptRegistered = True

Exit Function

Error_Handler:
    IsAcceptRegistered = False
End Function

'Unregister lngSocket from the accept list.
Public Sub UnregisterAccept(ByVal lngSocket As Long)
m_colAcceptList.Remove "S" & lngSocket

If m_colAcceptList.Count = 0 Then
    Set m_colAcceptList = Nothing
    Debug.Print "OK Destroyed accept collection"
End If
End Sub

'Return the accept instance class from a socket.
Public Function GetAcceptClass(ByVal lngSocket As Long) As CSocketMaster
Set GetAcceptClass = m_colAcceptList("S" & lngSocket)
End Function


'==============================================================================
'SUBCLASSING CODE
'based on code by Paul Caton
'==============================================================================

Private Sub Subclass_Initialize()
Const PATCH_01 As Long = 15                                 'Code buffer offset to the location of the relative address to EbMode
Const PATCH_03 As Long = 76                                 'Relative address of SetWindowsLong
Const PATCH_05 As Long = 100                                 'Relative address of CallWindowProc
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"                 'SetWindowLong allows the cSubclasser machine code thunk to unsubclass the subclasser itself if it detects via the EbMode function that the IDE has stopped
Const FUNC_CWP As String = "CallWindowProcA"                'We use CallWindowProc to call the original WndProc
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 MOD_USER As String = "user32"                         'Location of the SetWindowLong & CallWindowProc functions
  Dim i        As Long                                      'Loop index
  Dim nLen     As Long                                      'String lengths
  Dim sHex     As String                                    'Hex code string
  Dim sCode    As String                                    'Binary code string
  
  'Store the hex pair machine code representation in sHex
  sHex = "5850505589E55753515231C0EB0EE8xxxxx01x83F802742285C074258B45103D0008000074433D01080000745BE8200000005A595B5FC9C21400E813000000EBF168xxxxx02x6AFCFF750CE8xxxxx03xEBE0FF7518FF7514FF7510FF750C68xxxxx04xE8xxxxx05xC3BBxxxxx06x8B4514BFxxxxx07x89D9F2AF75B629CB4B8B1C9Dxxxxx08xEB1DBBxxxxx09x8B4514BFxxxxx0Ax89D9F2AF759729CB4B8B1C9Dxxxxx0Bx895D088B1B8B5B1C89D85A595B5FC9FFE0"
  nLen = Len(sHex)                                          'Length of hex pair string
  
  'Convert the string from hex pairs to bytes and store in the ASCII string opcode buffer
  For i = 1 To nLen Step 2                                  'For each pair of hex characters
    sCode = sCode & ChrB$(Val("&H" & Mid$(sHex, i, 2)))     'Convert a pair of hex characters to a byte and append to the ASCII string
  Next i                                                    'Next pair
  
  nLen = LenB(sCode)                                        'Get the machine code length
  nAddrSubclass = api_GlobalAlloc(0, nLen)                  'Allocate fixed memory for machine code buffer
  Debug.Print "OK Subclass memory allocated at: " & nAddrSubclass

  'Copy the code to allocated memory
  Call api_CopyMemory(ByVal nAddrSubclass, ByVal StrPtr(sCode), nLen)

  If Subclass_InIDE Then
    'Patch the jmp (EB0E) with two nop's (90) enabling the IDE breakpoint/stop checking code
    Call api_CopyMemory(ByVal nAddrSubclass + 12, &H9090, 2)
    
    i = Subclass_AddrFunc(MOD_VBA6, FUNC_EBM)               'Get the address of EbMode in vba6.dll
    If i = 0 Then                                           'Found?
      i = Subclass_AddrFunc(MOD_VBA5, FUNC_EBM)             'VB5 perhaps, try vba5.dll
    End If

    Debug.Assert i                                          'Ensure the EbMode function was found
    Call Subclass_PatchRel(PATCH_01, i)                     'Patch the relative address to the EbMode api function
  End If
  
  Call Subclass_PatchRel(PATCH_03, Subclass_AddrFunc(MOD_USER, FUNC_SWL))     'Address of the SetWindowLong api function
  Call Subclass_PatchRel(PATCH_05, Subclass_AddrFunc(MOD_USER, FUNC_CWP))     'Address of the CallWindowProc api function
End Sub

'UnSubclass and release the allocated memory
Private Sub Subclass_Terminate()
  Call Subclass_UnSubclass                                      'UnSubclass if the Subclass thunk is active
  Call api_GlobalFree(nAddrSubclass)                            'Release the allocated memory
  Debug.Print "OK Freed subclass memory at: " & nAddrSubclass
  nAddrSubclass = 0
  ReDim lngTableA1(1 To 1)
  ReDim lngTableA2(1 To 1)
  ReDim lngTableB1(1 To 1)
  ReDim lngTableB2(1 To 1)
End Sub

'Return whether we're running in the IDE. Public for general utility purposes
Private Function Subclass_InIDE() As Boolean
  Debug.Assert Subclass_SetTrue(Subclass_InIDE)
End Function

'Set the window subclass
Private Function Subclass_Subclass(ByVal hwnd As Long) As Boolean
Const PATCH_02 As Long = 66                                'Address of the previous WndProc
Const PATCH_04 As Long = 95                                'Address of the previous WndProc
  
  If hWndSub = 0 Then
    Debug.Assert api_IsWindow(hwnd)                         'Invalid window handle
    hWndSub = hwnd                                          'Store the window handle
    
    'Get the original window proc
    nAddrOriginal = api_GetWindowLong(hwnd, GWL_WNDPROC)
    Call Subclass_PatchVal(PATCH_02, nAddrOriginal)                  'Original WndProc address for CallWindowProc, call the original WndProc
    Call Subclass_PatchVal(PATCH_04, nAddrOriginal)                  'Original WndProc address for SetWindowLong, unsubclass on IDE stop
    
    'Set our WndProc in place of the original
    nAddrOriginal = api_SetWindowLong(hwnd, GWL_WNDPROC, nAddrSubclass)
    If nAddrOriginal <> 0 Then
      nAddrOriginal = 0
      Subclass_Subclass = True                                       'Success
    End If
  End If
  
  Debug.Assert Subclass_Subclass
End Function

'Stop subclassing the window
Private Function Subclass_UnSubclass() As Boolean
  If hWndSub <> 0 Then
    lngMsgCntA = 0
    lngMsgCntB = 0
    Call Subclass_PatchVal(PATCH_06, lngMsgCntA)                              'Patch the TableA entry count to ensure no further Proc callbacks
    Call Subclass_PatchVal(PATCH_09, lngMsgCntB)                              'Patch the TableB entry count to ensure no further Proc callbacks
    
    'Restore the original WndProc
    Call api_SetWindowLong(hWndSub, GWL_WNDPROC, nAddrOriginal)
    
    hWndSub = 0                                             'Indicate the subclasser is inactive

    Subclass_UnSubclass = True                              'Success
  End If
  
End Function

'Return the address of the passed function in the passed dll
Private Function Subclass_AddrFunc(ByVal sDLL As String, _
                          ByVal sProc As String) As Long
  Subclass_AddrFunc = api_GetProcAddress(api_GetModuleHandle(sDLL), sProc)
  
End Function

'Return the address of the low bound of the passed table array
Private Function Subclass_AddrMsgTbl(ByRef aMsgTbl() As Long) As Long
  On Error Resume Next                                    'The table may not be dimensioned yet so we need protection
    Subclass_AddrMsgTbl = VarPtr(aMsgTbl(1))              'Get the address of the first element of the passed message table
  On Error GoTo 0                                         'Switch off error protection
End Function

'Patch the machine code buffer offset with the relative address to the target address
Private Sub Subclass_PatchRel(ByVal nOffset As Long, _
                     ByVal nTargetAddr As Long)
  Call api_CopyMemory(ByVal (nAddrSubclass + nOffset), nTargetAddr - nAddrSubclass - nOffset - 4, 4)
End Sub

'Patch the machine code buffer offset with the passed value
Private Sub Subclass_PatchVal(ByVal nOffset As Long, _
                     ByVal nValue As Long)
  Call api_CopyMemory(ByVal (nAddrSubclass + nOffset), nValue, 4)
End Sub

'Worker function for InIDE - will only be called whilst running in the IDE
Private Function Subclass_SetTrue(bValue As Boolean) As Boolean
  Subclass_SetTrue = True
  bValue = True
End Function

Private Sub Subclass_AddResolveMessage(ByVal lngAsync As Long, ByVal lngObjectPointer As Long)
Dim Count As Long
For Count = 1 To lngMsgCntA
    Select Case lngTableA1(Count)
    
    Case -1
        lngTableA1(Count) = lngAsync
        lngTableA2(Count) = lngObjectPointer
        Exit Sub
    Case lngAsync
        Debug.Print "WARNING: Async already registered!"
        Exit Sub
    End Select
Next Count

lngMsgCntA = lngMsgCntA + 1
ReDim Preserve lngTableA1(1 To lngMsgCntA)
ReDim Preserve lngTableA2(1 To lngMsgCntA)
 
lngTableA1(lngMsgCntA) = lngAsync
lngTableA2(lngMsgCntA) = lngObjectPointer
Subclass_PatchTableA

End Sub

Private Sub Subclass_AddSocketMessage(ByVal lngSocket As Long, ByVal lngObjectPointer As Long)
Dim Count As Long
For Count = 1 To lngMsgCntB
    Select Case lngTableB1(Count)
    
    Case -1
        lngTableB1(Count) = lngSocket
        lngTableB2(Count) = lngObjectPointer
        Exit Sub
    Case lngSocket
        Debug.Print "WARNING: Socket already registered!"
        Exit Sub
    End Select
Next Count

lngMsgCntB = lngMsgCntB + 1
ReDim Preserve lngTableB1(1 To lngMsgCntB)
ReDim Preserve lngTableB2(1 To lngMsgCntB)
 
lngTableB1(lngMsgCntB) = lngSocket
lngTableB2(lngMsgCntB) = lngObjectPointer
Subclass_PatchTableB

End Sub

Private Sub Subclass_DelResolveMessage(ByVal lngAsync As Long)
Dim Count As Long
For Count = 1 To lngMsgCntA
    If lngTableA1(Count) = lngAsync Then
        lngTableA1(Count) = -1
        lngTableA2(Count) = -1
        Exit Sub
    End If
Next Count
End Sub

Private Sub Subclass_DelSocketMessage(ByVal lngSocket As Long)
Dim Count As Long
For Count = 1 To lngMsgCntB
    If lngTableB1(Count) = lngSocket Then
        lngTableB1(Count) = -1
        lngTableB2(Count) = -1
        Exit Sub
    End If
Next Count
End Sub

Private Sub Subclass_PatchTableA()
Const PATCH_07 As Long = 114
Const PATCH_08 As Long = 130

Call Subclass_PatchVal(PATCH_06, lngMsgCntA)
Call Subclass_PatchVal(PATCH_07, Subclass_AddrMsgTbl(lngTableA1))
Call Subclass_PatchVal(PATCH_08, Subclass_AddrMsgTbl(lngTableA2))
End Sub

Private Sub Subclass_PatchTableB()
Const PATCH_0A As Long = 145
Const PATCH_0B As Long = 161

Call Subclass_PatchVal(PATCH_09, lngMsgCntB)
Call Subclass_PatchVal(PATCH_0A, Subclass_AddrMsgTbl(lngTableB1))
Call Subclass_PatchVal(PATCH_0B, Subclass_AddrMsgTbl(lngTableB2))
End Sub

Public Sub Subclass_ChangeOwner(ByVal lngSocket As Long, ByVal lngObjectPointer As Long)
Dim Count As Long
For Count = 1 To lngMsgCntB
    If lngTableB1(Count) = lngSocket Then
        lngTableB2(Count) = lngObjectPointer
        Exit Sub
    End If
Next Count
End Sub