Attribute VB_Name = "modSocket"
Option Explicit
Private Const WM_APP As Long = 32768 '0x8000
Public Const RESOLVE_MESSAGE As Long = WM_APP
Public Const SOCKET_MESSAGE As Long = WM_APP + 1
Private Const PATCH_09 As Long = 119
Private Const PATCH_0C As Long = 150
Private Const MEM_RELEASE As Long = &H8000& 'Release allocated memory flag
Private Const MEM_COMMIT As Long = &H1000& 'Commit allocated memory
Private Const PAGE_RWX As Long = &H40& 'Allocate executable memory
Public Const SOCKET_ERROR As Long = -1
Private Const OFFSET_2 = 65536
Private Const MAXINT_2 = 32767
Private Const GWL_WNDPROC As Long = (-4)
Private Const TIMER_TIMEOUT As Long = 200 'control timer time out, in milliseconds
Private lMsgCntA As Long 'TableA entry count
Private lMsgCntB As Long 'TableB entry count
Private lTableA1() As Long 'TableA1: list of async handles
Private lTableA2() As Long 'TableA2: list of async handles owners
Private lTableB1() As Long 'TableB1: list of sockets
Private lTableB2() As Long 'TableB2: list of sockets owners
Private hWndSub As Long 'window handle subclassed
Private nAddrSubclass As Long 'address of our WndProc
Private nAddrOriginal As Long 'address of original WndProc
Private hTimer As Long 'control timer handle
Public DbgFlg As Boolean 'Determines if debug messages are recorded
'==============================================================================
'MEMBER VARIABLES
'==============================================================================
Private m_bInit As Boolean 'SubClass initialized
Private m_lSocksQuantity As Long 'number of instances created
Private m_colSocketsInst As Collection 'sockets list and instance owner
Private m_colAcceptList As Collection 'sockets in queue that need to be accepted
Private m_hWindow As Long 'message window handle
'WINSOCK CONTROL ERROR CODES
Public Const sckOutOfMemory = 7
' To initialize Winsock.
Private Type WSADATA
wVersion As Integer
wHighVersion As Integer
szDescription(256 + 1) As Byte
szSystemstatus(128 + 1) As Byte
iMaxSockets As Integer
iMaxUpdDg As Integer
lpVendorInfo As Long
End Type
' Messages send with WSAAsyncSelect().
Public Const FD_READ As Long = &H1
Public Const FD_WRITE As Long = &H2
Public Const FD_OOB As Long = &H4
Public Const FD_ACCEPT As Long = &H8
Public Const FD_CONNECT As Long = &H10
Public Const FD_CLOSE As Long = &H20
'==============================================================================
'SUBCLASSING DECLARATIONS
'by Paul Caton
'==============================================================================
Private Declare Function API_IsWindow Lib "user32" Alias "IsWindow" (ByVal hWnd As Long) As Long
Private Declare Function API_GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare Function API_SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function API_GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
Private Declare Function API_GetProcAddress Lib "kernel32" Alias "GetProcAddress" (ByVal hModule As Long, ByVal lpProcName As String) As Long
Private Declare Function API_DestroyWindow Lib "user32" Alias "DestroyWindow" (ByVal hWnd As Long) As Long
' DLL handling functions.
Public Declare Function WSAStartup Lib "ws2_32.dll" (ByVal wVersionRequested As Integer, ByRef lpWSAData As WSADATA) As Long
Public Declare Function WSACleanup Lib "ws2_32.dll" () As Long
Private Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Any) As Long
Private Declare Function WSAAsyncSelect Lib "ws2_32.dll" (ByVal s As Long, ByVal hWnd As Long, ByVal wMsg As Long, ByVal lEvent As Long) As Long
' Winsock error constants.
Private Const WSABASEERR As Long = 10000
Private Const WSAEINTR As Long = WSABASEERR + 4
Private Const WSAEBADF As Long = WSABASEERR + 9
Private Const WSAEACCES As Long = WSABASEERR + 13
Private Const WSAEFAULT As Long = WSABASEERR + 14
Private Const WSAEINVAL As Long = WSABASEERR + 22
Private Const WSAEMFILE As Long = WSABASEERR + 24
Public Const WSAEWOULDBLOCK As Long = WSABASEERR + 35
Private Const WSAEINPROGRESS As Long = WSABASEERR + 36
Private Const WSAEALREADY As Long = WSABASEERR + 37
Private Const WSAENOTSOCK As Long = WSABASEERR + 38
Private Const WSAEDESTADDRREQ As Long = WSABASEERR + 39
Public Const WSAEMSGSIZE As Long = WSABASEERR + 40
Private Const WSAEPROTOTYPE As Long = WSABASEERR + 41
Private Const WSAENOPROTOOPT As Long = WSABASEERR + 42
Private Const WSAEPROTONOSUPPORT As Long = WSABASEERR + 43
Private Const WSAESOCKTNOSUPPORT As Long = WSABASEERR + 44
Private Const WSAEOPNOTSUPP As Long = WSABASEERR + 45
Private Const WSAEPFNOSUPPORT As Long = WSABASEERR + 46
Private Const WSAEAFNOSUPPORT As Long = WSABASEERR + 47
Private Const WSAEADDRINUSE As Long = WSABASEERR + 48
Public Const WSAEADDRNOTAVAIL As Long = WSABASEERR + 49
Private Const WSAENETDOWN As Long = WSABASEERR + 50
Private Const WSAENETUNREACH As Long = WSABASEERR + 51
Private Const WSAENETRESET As Long = WSABASEERR + 52
Private Const WSAECONNABORTED As Long = WSABASEERR + 53
Private Const WSAECONNRESET As Long = WSABASEERR + 54
Private Const WSAENOBUFS As Long = WSABASEERR + 55
Private Const WSAEISCONN As Long = WSABASEERR + 56
Private Const WSAENOTCONN As Long = WSABASEERR + 57
Private Const WSAESHUTDOWN As Long = WSABASEERR + 58
Private Const WSAETOOMANYREFS As Long = WSABASEERR + 59
Private Const WSAETIMEDOUT As Long = WSABASEERR + 60
Private Const WSAECONNREFUSED As Long = WSABASEERR + 61
Private Const WSAELOOP As Long = WSABASEERR + 62
Private Const WSAENAMETOOLONG As Long = WSABASEERR + 63
Private Const WSAEHOSTDOWN As Long = WSABASEERR + 64
Private Const WSAEHOSTUNREACH As Long = WSABASEERR + 65
Private Const WSAENOTEMPTY As Long = WSABASEERR + 66
Private Const WSAEPROCLIM As Long = WSABASEERR + 67
Private Const WSAEUSERS As Long = WSABASEERR + 68
Private Const WSAEDQUOT As Long = WSABASEERR + 69
Private Const WSAESTALE As Long = WSABASEERR + 70
Private Const WSAEREMOTE As Long = WSABASEERR + 71
Private Const WSASYSNOTREADY As Long = WSABASEERR + 91
Private Const WSAVERNOTSUPPORTED As Long = WSABASEERR + 92
Private Const WSANOTINITIALISED As Long = WSABASEERR + 93
Private Const WSAHOST_NOT_FOUND As Long = WSABASEERR + 1001
Private Const WSATRY_AGAIN As Long = WSABASEERR + 1002
Private Const WSANO_RECOVERY As Long = WSABASEERR + 1003
Private Const WSANO_DATA As Long = WSABASEERR + 1004
' Other general Win32 APIs.
Public Declare Function VirtualAlloc Lib "kernel32" (ByVal lpAddress As Long, ByVal dwSize As Long, ByVal flAllocationType As Long, ByVal flProtect As Long) As Long
Public Declare Function VirtualFree Lib "kernel32" (ByVal lpAddress As Long, ByVal dwSize As Long, ByVal dwFreeType As Long) As Long
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Public Declare Sub ZeroMemory Lib "kernel32" Alias "RtlZeroMemory" (pDestination As Any, ByVal lByteCount As Long)
Private Declare Function API_LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
Private Declare Function API_SetTimer Lib "user32" Alias "SetTimer" (ByVal hWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Function API_KillTimer Lib "user32" Alias "KillTimer" (ByVal hWnd As Long, ByVal nIDEvent As Long) As Long
Public Declare Function lstrlenA Lib "kernel32" (ByVal lpString As Long) As Long
Private Declare Function lstrcpyA Lib "kernel32" (ByVal lpString1 As String, ByVal lpString2 As Long) As Long
Public Function AddByte(bArray1() As Byte, bArray2() As Byte, Optional lLen As Long) As Boolean
Dim lLen1 As Long
Dim lLen2 As Long
lLen1 = GetbSize(bArray1)
lLen2 = GetbSize(bArray2)
If lLen2 = 0 Then GoTo Done
If lLen > 0 Then
If lLen2 > lLen Then
lLen2 = lLen
End If
End If
ReDim Preserve bArray1(lLen1 + lLen2 - 1)
CopyMemory bArray1(lLen1), bArray2(0), lLen2
Done:
AddByte = True
End Function
Public Function ByteToStr(bArray() As Byte) As String
Dim lPntr As Long
Dim bTmp() As Byte
On Error GoTo ByteErr
ReDim bTmp(UBound(bArray) * 2 + 1)
For lPntr = 0 To UBound(bArray)
bTmp(lPntr * 2) = bArray(lPntr)
Next lPntr
Let ByteToStr = bTmp
Exit Function
ByteErr:
ByteToStr = ""
End Function
Public Function ByteToUni(bArray() As Byte) As String
ByteToUni = bArray
End Function
Private Function CreateWinsockMessageWindow() As Long
'Create a window that is used to capture sockets messages.
'Returns 0 if it has success.
m_hWindow = CreateWindowEx(0&, "STATIC", "SOCKET_WINDOW", 0&, 0&, 0&, 0&, 0&, 0&, 0&, App.hInstance, ByVal 0&)
If m_hWindow = 0 Then
CreateWinsockMessageWindow = sckOutOfMemory
Exit Function
Else
CreateWinsockMessageWindow = 0
Call PrintDebug("OK Created winsock message window " & CStr(m_hWindow))
End If
End Function
Public Function DeleteByte(bArray1() As Byte, ByVal lLen As Long) As Boolean
Dim lLen1 As Long
Dim bTmp() As Byte
lLen1 = GetbSize(bArray1)
If lLen1 > lLen Then
ReDim bTmp(lLen1 - lLen - 1)
CopyMemory bTmp(0), bArray1(lLen), lLen1 - lLen
End If
bArray1 = bTmp
End Function
Private Function DestroyWinsockMessageWindow() As Long
'Destroy the window that is used to capture sockets messages.
'Returns 0 if it has success.
Dim lRet As Long
DestroyWinsockMessageWindow = 0
If m_hWindow = 0 Then
Call PrintDebug("WARNING hWindow is ZERO")
Exit Function
End If
lRet = API_DestroyWindow(m_hWindow)
If lRet = 0 Then
DestroyWinsockMessageWindow = sckOutOfMemory
Err.Raise sckOutOfMemory, "modSimple.DestroyWinsockMessageWindow", "Out of memory"
Else
Call PrintDebug("OK Destroyed winsock message window " & CStr(m_hWindow))
m_hWindow = 0
End If
End Function
Private Function FileErrors(errVal As Integer) As Integer
'Return Value 0=Resume, 1=Resume Next,
' 2=Unrecoverable Error, 3=Unrecognized Error
Dim msgType%
Dim Msg$
Dim Response%
msgType% = 48
Select Case errVal
Case 68
Msg$ = "That device appears Unavailable."
msgType% = msgType% + 4
Case 71
Msg$ = "Insert a Disk in the Drive"
Case 53
Msg$ = "Cannot Find File"
msgType% = msgType% + 5
Case 57
Msg$ = "Internal Disk Error."
msgType% = msgType% + 4
Case 61
Msg$ = "Disk is Full. Continue?"
msgType% = 35
Case 64, 52
Msg$ = "That Filename is Illegal!"
msgType% = msgType% + 5
Case 70
Msg$ = "File in use by another user!"
msgType% = msgType% + 5
Case 76
Msg$ = "Path does not Exist!"
msgType% = msgType% + 2
Case 54
Msg$ = "Bad File Mode!"
Case 55
Msg$ = "File is Already Open."
Case 62
Msg$ = "Read Attempt Past End of File."
Case Else
FileErrors = 3
Exit Function
End Select
'Response% = MsgBox(Msg$, msgType%, "Disk Error")
Response% = 2
Select Case Response%
Case 1, 4
FileErrors = 0
Case 5
FileErrors = 1
Case 2, 3
FileErrors = 2
Case Else
FileErrors = 3
End Select
End Function
Public Function Finalize() As Boolean
'Once we are done with the class instance we call this
'function to discount it and finish winsock service if
'it was the last one.
m_lSocksQuantity = m_lSocksQuantity - 1
'if the service was initiated and there's no more instances
'of the class then we finish the service
If m_bInit And m_lSocksQuantity = 0 Then
Call WSACleanup
Debug.Print "OK Winsock Service Terminated!"
Subclass_Terminate
Debug.Print "OK SubClass Finalized!"
m_bInit = False
End If
End Function
Public Function GetbSize(bArray() As Byte) As Long
On Error GoTo GetSizeErr
GetbSize = UBound(bArray) + 1
Exit Function
GetSizeErr:
GetbSize = 0
End Function
Public Function GetErrorDescription(ByVal lErrorCode As Long) As String
'This function receives a number that represents an error
'and returns the corresponding description string.
Select Case lErrorCode
Case WSAEACCES
GetErrorDescription = "Permission denied."
Case WSAEADDRINUSE
GetErrorDescription = "Address already in use."
Case WSAEADDRNOTAVAIL
GetErrorDescription = "Cannot assign requested address."
Case WSAEAFNOSUPPORT
GetErrorDescription = "Address family not supported by protocol family."
Case WSAEALREADY
GetErrorDescription = "Operation already in progress."
Case WSAECONNABORTED
GetErrorDescription = "Software caused connection abort."
Case WSAECONNREFUSED
GetErrorDescription = "Connection refused."
Case WSAECONNRESET
GetErrorDescription = "Connection reset by peer."
Case WSAEDESTADDRREQ
GetErrorDescription = "Destination address required."
Case WSAEFAULT
GetErrorDescription = "Bad address."
Case WSAEHOSTUNREACH
GetErrorDescription = "No route to host."
Case WSAEINPROGRESS
GetErrorDescription = "Operation now in progress."
Case WSAEINTR
GetErrorDescription = "Interrupted function call."
Case WSAEINVAL
GetErrorDescription = "Invalid argument."
Case WSAEISCONN
GetErrorDescription = "Socket is already connected."
Case WSAEMFILE
GetErrorDescription = "Too many open files."
Case WSAEMSGSIZE
GetErrorDescription = "Message too long."
Case WSAENETDOWN
GetErrorDescription = "Network is down."
Case WSAENETRESET
GetErrorDescription = "Network dropped connection on reset."
Case WSAENETUNREACH
GetErrorDescription = "Network is unreachable."
Case WSAENOBUFS
GetErrorDescription = "No buffer space available."
Case WSAENOPROTOOPT
GetErrorDescription = "Bad protocol option."
Case WSAENOTCONN
GetErrorDescription = "Socket is not connected."
Case WSAENOTSOCK
GetErrorDescription = "Socket operation on nonsocket."
Case WSAEOPNOTSUPP
GetErrorDescription = "Operation not supported."
Case WSAEPFNOSUPPORT
GetErrorDescription = "Protocol family not supported."
Case WSAEPROCLIM
GetErrorDescription = "Too many processes."
Case WSAEPROTONOSUPPORT
GetErrorDescription = "Protocol not supported."
Case WSAEPROTOTYPE
GetErrorDescription = "Protocol wrong type for socket."
Case WSAESHUTDOWN
GetErrorDescription = "Cannot send after socket shutdown."
Case WSAESOCKTNOSUPPORT
GetErrorDescription = "Socket type not supported."
Case WSAETIMEDOUT
GetErrorDescription = "Connection timed out."
Case WSAEWOULDBLOCK
GetErrorDescription = "Resource temporarily unavailable."
Case WSAHOST_NOT_FOUND
GetErrorDescription = "Host not found."
Case WSANOTINITIALISED
GetErrorDescription = "Successful WSAStartup not yet performed."
Case WSANO_DATA
GetErrorDescription = "Valid name, no data record of requested type."
Case WSANO_RECOVERY
GetErrorDescription = "This is a nonrecoverable error."
Case WSASYSNOTREADY
GetErrorDescription = "Network subsystem is unavailable."
Case WSATRY_AGAIN
GetErrorDescription = "Nonauthoritative host not found."
Case WSAVERNOTSUPPORTED
GetErrorDescription = "Winsock.dll version out of range."
Case Else
GetErrorDescription = "Unknown error."
End Select
End Function
Public Function GetSocketCount() As Long
GetSocketCount = m_colSocketsInst.Count
End Function
Public Function HexToByte(HexStr As String, bHex() As Byte) As Boolean
Dim lLen As Long
Dim lPntr As Long
If Len(HexStr) > 1 Then
lLen = Len(HexStr) / 2
ReDim bHex(lLen - 1)
For lPntr = 0 To UBound(bHex)
bHex(lPntr) = Val("&H" & Mid$(HexStr, lPntr * 2 + 1, 2))
Next lPntr
HexToByte = True
End If
End Function
Public Function Initialize() As Boolean
Dim udtWSAData As WSADATA
Dim lRet As Long
m_lSocksQuantity = m_lSocksQuantity + 1
'if the service wasn't initiated yet we do it now
Initialize = True
If Not m_bInit Then
If Subclass_Initialize Then
'Start the winsock service
lRet = WSAStartup(&H202, udtWSAData)
If lRet > 0 Then
Err.Raise lRet, "modSimple.Initialize", GetErrorDescription(lRet)
Else
m_bInit = True
Debug.Print ("OK SubClass Initialized!")
End If
Else
Initialize = False
End If
End If
End Function
Public Function IntegerToUnsigned(Value As Integer) As Long
'The function takes a Long containing a value in the range
'of an unsigned Integer and returns an Integer that you
'can pass to an API that requires an unsigned Integer
If Value < 0 Then
IntegerToUnsigned = Value + OFFSET_2
Else
IntegerToUnsigned = Value
End If
End Function
Public Function IsSocketRegistered(ByVal lSocket As Long) As Boolean
'Returns TRUE si the socket that is passed is registered
'in the colSocketsInst collection.
On Error GoTo Error_Handler
Call m_colSocketsInst.Item("S" & lSocket)
IsSocketRegistered = True
Exit Function
Error_Handler:
IsSocketRegistered = False
End Function
Public Sub LogError(Log$)
Dim LogFile%
LogFile% = OpenFile(App.Path + "\Socket.Log", 3, 0, 80)
If LogFile% = 0 Then
'MsgBox "File Error with LogFile", 16, "ABORT PROCEDURE"
Exit Sub
End If
Print #LogFile%, CStr(Now) + ": " + Log$
Close LogFile%
End Sub
Public Function OpenFile(FileName$, Mode%, RLock%, RecordLen%) As Integer
Const REPLACEFILE = 1, READAFILE = 2, ADDTOFILE = 3
Const RANDOMFILE = 4, BINARYFILE = 5
Const NOLOCK = 0, RDLOCK = 1, WRLOCK = 2, RWLOCK = 3
Dim FileNum%
Dim Action%
FileNum% = FreeFile
On Error GoTo OpenErrors
Select Case Mode
Case REPLACEFILE
Select Case RLock%
Case NOLOCK
Open FileName For Output Shared As FileNum%
Case RDLOCK
Open FileName For Output Lock Read As FileNum%
Case WRLOCK
Open FileName For Output Lock Write As FileNum%
Case RWLOCK
Open FileName For Output Lock Read Write As FileNum%
End Select
Case READAFILE
Select Case RLock%
Case NOLOCK
Open FileName For Input Shared As FileNum%
Case RDLOCK
Open FileName For Input Lock Read As FileNum%
Case WRLOCK
Open FileName For Input Lock Write As FileNum%
Case RWLOCK
Open FileName For Input Lock Read Write As FileNum%
End Select
Case ADDTOFILE
Select Case RLock%
Case NOLOCK
Open FileName For Append Shared As FileNum%
Case RDLOCK
Open FileName For Append Lock Read As FileNum%
Case WRLOCK
Open FileName For Append Lock Write As FileNum%
Case RWLOCK
Open FileName For Append Lock Read Write As FileNum%
End Select
Case RANDOMFILE
Select Case RLock%
Case NOLOCK
Open FileName For Random Shared As FileNum% Len = RecordLen%
Case RDLOCK
Open FileName For Random Lock Read As FileNum% Len = RecordLen%
Case WRLOCK
Open FileName For Random Lock Write As FileNum% Len = RecordLen%
Case RWLOCK
Open FileName For Random Lock Read Write As FileNum% Len = RecordLen%
End Select
Case BINARYFILE
Select Case RLock%
Case NOLOCK
Open FileName For Binary Shared As FileNum%
Case RDLOCK
Open FileName For Binary Lock Read As FileNum%
Case WRLOCK
Open FileName For Binary Lock Write As FileNum%
Case RWLOCK
Open FileName For Binary Lock Read Write As FileNum%
End Select
Case Else
Exit Function
End Select
OpenFile = FileNum%
Exit Function
OpenErrors:
Action% = FileErrors(Err)
Select Case Action%
Case 0
Resume 'Resumes at line where ERROR occured
Case 1
Resume Next 'Resumes at line after ERROR
Case 2
OpenFile = 0 'Unrecoverable ERROR-reports error, exits function with error code
Exit Function
Case Else
'MsgBox Error$(Err) + vbCrLf + "After line " + CStr(Erl) + vbCrLf + "Program will TERMINATE!"
'Unrecognized ERROR-reports error and terminates.
'End
End Select
End Function
Public Function PeekB(ByVal lpdwData As Long) As Byte
CopyMemory PeekB, ByVal lpdwData, 1
End Function
Public Sub PrintDebug(Msg As String)
Debug.Print Msg
If DbgFlg Then Call LogError(Msg)
End Sub
Public Function RegisterSocket(ByVal lSocket As Long, ByVal lObjectPointer As Long, ByVal blnEvents As Boolean) As Boolean
'Adds the socket to the m_colSocketsInst collection, and
'registers that socket with WSAAsyncSelect Winsock API
'function to receive network events for the socket.
'If this socket is the first one to be registered, the
'window and collection will be created in this function as well.
Dim lEvents As Long
Dim lRet As Long
Dim lErrorCode As Long
If m_colSocketsInst Is Nothing Then
Set m_colSocketsInst = New Collection
Call PrintDebug("OK Created socket collection")
If CreateWinsockMessageWindow <> 0 Then
Err.Raise sckOutOfMemory, "modSimple.RegisterSocket", "Out of memory"
End If
Subclass_Subclass (m_hWindow)
End If
Subclass_AddSocketMessage lSocket, lObjectPointer
'Do we need to register socket events?
If blnEvents Then
lEvents = FD_READ Or FD_WRITE Or FD_ACCEPT Or FD_CONNECT Or FD_CLOSE
lRet = WSAAsyncSelect(lSocket, m_hWindow, SOCKET_MESSAGE, lEvents)
If lRet = SOCKET_ERROR Then
Call PrintDebug("ERROR trying to register events from socket " & CStr(lSocket))
lErrorCode = Err.LastDllError
Err.Raise lErrorCode, "modSimple.RegisterSocket", GetErrorDescription(lErrorCode)
Else
Call PrintDebug("OK Registered events from socket " & CStr(lSocket))
End If
End If
Call m_colSocketsInst.Add(lObjectPointer, "S" & lSocket)
RegisterSocket = True
End Function
Public Function StringFromPointer(ByVal lPointer As Long) As String
'Receives a string pointer and it turns it into a regular string.
Dim sTemp As String
Dim lRetVal As Long
sTemp = String$(lstrlenA(ByVal lPointer), 0)
lRetVal = lstrcpyA(ByVal sTemp, ByVal lPointer)
If lRetVal Then StringFromPointer = sTemp
End Function
Public Function StrToByte(strInput As String) As Byte()
Dim lPntr As Long
Dim bTmp() As Byte
Dim bArray() As Byte
If Len(strInput) = 0 Then Exit Function
ReDim bTmp(LenB(strInput) - 1) 'Memory length
ReDim bArray(Len(strInput) - 1) 'String length
CopyMemory bTmp(0), ByVal StrPtr(strInput), LenB(strInput)
'Examine every second byte
For lPntr = 0 To UBound(bArray)
If bTmp(lPntr * 2 + 1) > 0 Then
'bArray(lPntr) = Asc(Mid$(strInput, lPntr + 1, 1))
StrToByte = bTmp
Exit Function
Else
bArray(lPntr) = bTmp(lPntr * 2)
End If
Next lPntr
StrToByte = bArray
End Function
Private Function Subclass_AddrFunc(ByVal sDLL As String, ByVal sProc As String) As Long
'Return the address of the passed function in the passed dll
Subclass_AddrFunc = API_GetProcAddress(API_GetModuleHandle(sDLL), sProc)
End Function
Private Function Subclass_AddrMsgTbl(ByRef aMsgTbl() As Long) As Long
'Return the address of the low bound of the passed table array
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
Private Sub Subclass_AddSocketMessage(ByVal lSocket As Long, ByVal lObjPntr As Long)
Dim Count As Long
For Count = 1 To lMsgCntB
Select Case lTableB1(Count)
Case -1
lTableB1(Count) = lSocket
lTableB2(Count) = lObjPntr
Exit Sub
Case lSocket
Call PrintDebug("WARNING: Socket already registered!")
Exit Sub
End Select
Next Count
lMsgCntB = lMsgCntB + 1
ReDim Preserve lTableB1(1 To lMsgCntB)
ReDim Preserve lTableB2(1 To lMsgCntB)
lTableB1(lMsgCntB) = lSocket
lTableB2(lMsgCntB) = lObjPntr
Subclass_PatchTableB
End Sub
Private Sub Subclass_DelSocketMessage(ByVal lSocket As Long)
Dim Count As Long
For Count = 1 To lMsgCntB
If lTableB1(Count) = lSocket Then
lTableB1(Count) = -1
lTableB2(Count) = -1
Exit Sub
End If
Next Count
End Sub
Private Function Subclass_Initialize() As Boolean
Const PATCH_01 As Long = 16 'Code buffer offset to the location of the relative address to EbMode
Const PATCH_03 As Long = 72 'Relative address of SetWindowsLong
Const PATCH_04 As Long = 77 'Relative address of WSACleanup
Const PATCH_06 As Long = 89 'Relative address of KillTimer
Const PATCH_08 As Long = 113 '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 FUNC_WCU As String = "WSACleanup" 'closesocket is called when the program is closed to release the sockets
Const FUNC_KTM As String = "KillTimer" 'KillTimer destroys the control timer
' 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
Const MOD_WS As String = "ws2_32" 'Location of the closesocket function
Dim lPntr As Long 'Loop index
Dim nLen As Long 'String lengths
Dim sHex As String 'Hex code string
Dim bHex() As Byte 'Binary code string
'Store the hex pair machine code representation in sHex
sHex = "5850505589E55753515231C0FCEB09E8xxxxx01x85C074258B45103D0080000074543D01800000746CE8310000005A595B5FC9C21400E824000000EBF168xxxxx02x6AFCFF750CE8xxxxx03xE8xxxxx04x68xxxxx05x6A00E8xxxxx06xEBCFFF7518FF7514FF7510FF750C68xxxxx07xE8xxxxx08xC3BBxxxxx09x8B4514BFxxxxx0Ax89D9F2AF75A529CB4B8B1C9Dxxxxx0BxEB1DBBxxxxx0Cx8B4514BFxxxxx0Dx89D9F2AF758629CB4B8B1C9Dxxxxx0Ex895D088B1B8B5B1C89D85A595B5FC9FFE0"
If HexToByte(sHex, bHex) Then
nLen = UBound(bHex) + 1
nAddrSubclass = VirtualAlloc(0, nLen, MEM_COMMIT, PAGE_RWX) 'Allocate executable memory
'Copy the code to allocated memory
Call CopyMemory(ByVal nAddrSubclass, ByVal VarPtr(bHex(0)), nLen)
If Subclass_InIDE Then
'Patch the jmp (EB0E) with two nop's (90) enabling the IDE breakpoint/stop checking code
Call CopyMemory(ByVal nAddrSubclass + 13, &H9090, 2)
lPntr = Subclass_AddrFunc(MOD_VBA6, FUNC_EBM) 'Get the address of EbMode in vba6.dll
Debug.Assert lPntr 'Ensure the EbMode function was found
Call Subclass_PatchRel(PATCH_01, lPntr) 'Patch the relative address to the EbMode api function
End If
Call API_LoadLibrary(MOD_WS) 'Ensure ws2_32.dll is loaded before getting WSACleanup address
Call Subclass_PatchRel(PATCH_03, Subclass_AddrFunc(MOD_USER, FUNC_SWL)) 'Address of the SetWindowLong api function
Call Subclass_PatchRel(PATCH_04, Subclass_AddrFunc(MOD_WS, FUNC_WCU)) 'Address of the WSACleanup api function
Call Subclass_PatchRel(PATCH_06, Subclass_AddrFunc(MOD_USER, FUNC_KTM)) 'Address of the KillTimer api function
Call Subclass_PatchRel(PATCH_08, Subclass_AddrFunc(MOD_USER, FUNC_CWP)) 'Address of the CallWindowProc api function
Subclass_Initialize = True
End If
End Function
Private Sub Subclass_PatchRel(ByVal nOffset As Long, ByVal nTargetAddr As Long)
'Patch the machine code buffer offset with the relative address to the target address
Call CopyMemory(ByVal (nAddrSubclass + nOffset), nTargetAddr - nAddrSubclass - nOffset - 4, 4)
End Sub
Private Sub Subclass_PatchTableB()
Const PATCH_0D As Long = 158
Const PATCH_0E As Long = 174
Call Subclass_PatchVal(PATCH_0C, lMsgCntB)
Call Subclass_PatchVal(PATCH_0D, Subclass_AddrMsgTbl(lTableB1))
Call Subclass_PatchVal(PATCH_0E, Subclass_AddrMsgTbl(lTableB2))
End Sub
Private Sub Subclass_PatchVal(ByVal nOffset As Long, ByVal nValue As Long)
'Patch the machine code buffer offset with the passed value
Call CopyMemory(ByVal (nAddrSubclass + nOffset), nValue, 4)
End Sub
Private Function Subclass_SetTrue(bValue As Boolean) As Boolean
'Worker function for InIDE - will only be called whilst running in the IDE
Subclass_SetTrue = True
bValue = True
End Function
Private Function Subclass_Subclass(ByVal hWnd As Long) As Boolean
'Set the window subclass
Const PATCH_02 As Long = 62 'Address of the previous WndProc
Const PATCH_05 As Long = 82 'Control timer handle
Const PATCH_07 As Long = 108 '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_07, 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
Subclass_Subclass = True 'Success
End If
End If
If Subclass_InIDE Then
hTimer = API_SetTimer(0, 0, TIMER_TIMEOUT, nAddrSubclass) 'Create the control timer
Call Subclass_PatchVal(PATCH_05, hTimer) 'Patch the control timer handle
End If
Debug.Assert Subclass_Subclass
End Function
Private Sub Subclass_Terminate()
'UnSubclass and release the allocated memory
Call Subclass_UnSubclass 'UnSubclass if the Subclass thunk is active
Call VirtualFree(nAddrSubclass, 0, MEM_RELEASE) 'Release the allocated memory
Call PrintDebug("OK Freed subclass memory at: " & Hex$(nAddrSubclass))
nAddrSubclass = 0
ReDim lTableA1(1 To 1)
ReDim lTableA2(1 To 1)
ReDim lTableB1(1 To 1)
ReDim lTableB2(1 To 1)
End Sub
Private Function Subclass_UnSubclass() As Boolean
'Stop subclassing the window
If hWndSub <> 0 Then
lMsgCntA = 0
lMsgCntB = 0
Call Subclass_PatchVal(PATCH_09, lMsgCntA) 'Patch the TableA entry count to ensure no further Proc callbacks
Call Subclass_PatchVal(PATCH_0C, lMsgCntB) 'Patch the TableB entry count to ensure no further Proc callbacks
'Restore the original WndProc
Call API_SetWindowLong(hWndSub, GWL_WNDPROC, nAddrOriginal)
If hTimer <> 0 Then
Call API_KillTimer(0&, hTimer) 'Destroy control timer
hTimer = 0
End If
hWndSub = 0 'Indicate the subclasser is inactive
Subclass_UnSubclass = True 'Success
End If
End Function
Public Function UniToByte(strInput As String) As Byte()
UniToByte = strInput
End Function
Public Sub UnregisterSocket(ByVal lSocket As Long)
'Removes the socket from the m_colSocketsInst collection
'If it is the last socket in that collection, the window
'and colection will be destroyed as well.
Subclass_DelSocketMessage lSocket
On Error Resume Next
Call m_colSocketsInst.Remove("S" & lSocket)
If m_colSocketsInst.Count = 0 Then
Set m_colSocketsInst = Nothing
Subclass_UnSubclass
DestroyWinsockMessageWindow
Call PrintDebug("OK Destroyed socket collection")
End If
End Sub
Private Function Subclass_InIDE() As Boolean
'Return whether we're running in the IDE. Public for general utility purposes
Debug.Assert Subclass_SetTrue(Subclass_InIDE)
End Function