AuroNet/modSocketMaster.bas

   1 Attribute VB_Name = "modSocketMaster"
   2 '**************************************************************************************
   3 '
   4 'modSocketMaster module 1.2
   5 'Copyright (c) 2004 by Emiliano Scavuzzo <anshoku@yahoo.com>
   6 '
   7 'Rosario, Argentina
   8 '
   9 '**************************************************************************************
  10 'This module contains API declarations and helper functions for the CSocketMaster class
  11 '**************************************************************************************
  12 Option Explicit
  13 '==============================================================================
  14 'API FUNCTIONS
  15 '==============================================================================
  16 'Public Declare Function api_WSAGetLastError Lib "ws2_32.dll" Alias "WSAGetLastError" () As Long
  17 Public Declare Sub api_CopyMemory _
  18                Lib "kernel32" _
  19                Alias "RtlMoveMemory" (Destination As Any, _
  20                                       Source As Any, _
  21                                       ByVal Length As Long)
  22 Public Declare Function api_GlobalAlloc _
  23                Lib "kernel32" _
  24                Alias "GlobalAlloc" (ByVal wFlags As Long, _
  25                                     ByVal dwBytes As Long) As Long
  26 Public Declare Function api_GlobalFree _
  27                Lib "kernel32" _
  28                Alias "GlobalFree" (ByVal hMem As Long) As Long
  29 Private Declare Function api_WSAStartup _
  30                 Lib "ws2_32.dll" _
  31                 Alias "WSAStartup" (ByVal wVersionRequired As Long, _
  32                                     lpWSADATA As WSAData) As Long
  33 Private Declare Function api_WSACleanup _
  34                 Lib "ws2_32.dll" _
  35                 Alias "WSACleanup" () As Long
  36 Private Declare Function api_WSAAsyncGetHostByName _
  37                 Lib "ws2_32.dll" _
  38                 Alias "WSAAsyncGetHostByName" (ByVal hWnd As Long, _
  39                                                ByVal wMsg As Long, _
  40                                                ByVal strHostName As String, _
  41                                                buf As Any, _
  42                                                ByVal buflen As Long) As Long
  43 Private Declare Function api_WSAAsyncSelect _
  44                 Lib "ws2_32.dll" _
  45                 Alias "WSAAsyncSelect" (ByVal s As Long, _
  46                                         ByVal hWnd As Long, _
  47                                         ByVal wMsg As Long, _
  48                                         ByVal lEvent As Long) As Long
  49 Private Declare Function api_CreateWindowEx _
  50                 Lib "user32" _
  51                 Alias "CreateWindowExA" (ByVal dwExStyle As Long, _
  52                                          ByVal lpClassName As String, _
  53                                          ByVal lpWindowName As String, _
  54                                          ByVal dwStyle As Long, _
  55                                          ByVal x As Long, _
  56                                          ByVal y As Long, _
  57                                          ByVal nWidth As Long, _
  58                                          ByVal nHeight As Long, _
  59                                          ByVal hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Any) As Long
  60 Private Declare Function api_DestroyWindow _
  61                 Lib "user32" _
  62                 Alias "DestroyWindow" (ByVal hWnd As Long) As Long
  63 Private Declare Function api_lstrlen _
  64                 Lib "kernel32" _
  65                 Alias "lstrlenA" (ByVal lpString As Any) As Long
  66 Private Declare Function api_lstrcpy _
  67                 Lib "kernel32" _
  68                 Alias "lstrcpyA" (ByVal lpString1 As String, _
  69                                   ByVal lpString2 As Long) As Long
  70 '==============================================================================
  71 'CONSTANTS
  72 '==============================================================================
  73 Public Const SOCKET_ERROR   As Integer = -1
  74 Public Const INVALID_SOCKET As Integer = -1
  75 Public Const INADDR_NONE As Long = &HFFFF
  76 Private Const WSADESCRIPTION_LEN As Integer = 257
  77 Private Const WSASYS_STATUS_LEN  As Integer = 129
  78 Private Enum WinsockVersion
  79     SOCKET_VERSION_11 = &H101
  80     SOCKET_VERSION_22 = &H202
  81 End Enum
  82 Public Const MAXGETHOSTSTRUCT As Long = 1024
  83 Public Const AF_INET        As Long = 2
  84 Public Const SOCK_STREAM    As Long = 1
  85 Public Const SOCK_DGRAM     As Long = 2
  86 Public Const IPPROTO_TCP    As Long = 6
  87 Public Const IPPROTO_UDP    As Long = 17
  88 Public Const FD_READ    As Integer = &H1&
  89 Public Const FD_WRITE   As Integer = &H2&
  90 Public Const FD_ACCEPT  As Integer = &H8&
  91 Public Const FD_CONNECT As Integer = &H10&
  92 Public Const FD_CLOSE   As Integer = &H20&
  93 Private Const OFFSET_2 As Long = 65536
  94 Private Const MAXINT_2 As Long = 32767
  95 Public Const GMEM_FIXED As Integer = &H0
  96 Public Const LOCAL_HOST_BUFF As Integer = 256
  97 Public Const SOL_SOCKET         As Long = 65535
  98 Public Const SO_SNDBUF          As Long = &H1001&
  99 Public Const SO_RCVBUF          As Long = &H1002&
 100 Public Const SO_MAX_MSG_SIZE    As Long = &H2003
 101 Public Const SO_BROADCAST       As Long = &H20
 102 Public Const FIONREAD           As Long = &H4004667F
 103 '==============================================================================
 104 'ERROR CODES
 105 '==============================================================================
 106 Public Const WSABASEERR         As Long = 10000
 107 Public Const WSAEINTR           As Long = (WSABASEERR + 4)
 108 Public Const WSAEACCES          As Long = (WSABASEERR + 13)
 109 Public Const WSAEFAULT          As Long = (WSABASEERR + 14)
 110 Public Const WSAEINVAL          As Long = (WSABASEERR + 22)
 111 Public Const WSAEMFILE          As Long = (WSABASEERR + 24)
 112 Public Const WSAEWOULDBLOCK     As Long = (WSABASEERR + 35)
 113 Public Const WSAEINPROGRESS     As Long = (WSABASEERR + 36)
 114 Public Const WSAEALREADY        As Long = (WSABASEERR + 37)
 115 Public Const WSAENOTSOCK        As Long = (WSABASEERR + 38)
 116 Public Const WSAEDESTADDRREQ    As Long = (WSABASEERR + 39)
 117 Public Const WSAEMSGSIZE        As Long = (WSABASEERR + 40)
 118 Public Const WSAEPROTOTYPE      As Long = (WSABASEERR + 41)
 119 Public Const WSAENOPROTOOPT     As Long = (WSABASEERR + 42)
 120 Public Const WSAEPROTONOSUPPORT As Long = (WSABASEERR + 43)
 121 Public Const WSAESOCKTNOSUPPORT As Long = (WSABASEERR + 44)
 122 Public Const WSAEOPNOTSUPP      As Long = (WSABASEERR + 45)
 123 Public Const WSAEPFNOSUPPORT    As Long = (WSABASEERR + 46)
 124 Public Const WSAEAFNOSUPPORT    As Long = (WSABASEERR + 47)
 125 Public Const WSAEADDRINUSE      As Long = (WSABASEERR + 48)
 126 Public Const WSAEADDRNOTAVAIL   As Long = (WSABASEERR + 49)
 127 Public Const WSAENETDOWN        As Long = (WSABASEERR + 50)
 128 Public Const WSAENETUNREACH     As Long = (WSABASEERR + 51)
 129 Public Const WSAENETRESET       As Long = (WSABASEERR + 52)
 130 Public Const WSAECONNABORTED    As Long = (WSABASEERR + 53)
 131 Public Const WSAECONNRESET      As Long = (WSABASEERR + 54)
 132 Public Const WSAENOBUFS         As Long = (WSABASEERR + 55)
 133 Public Const WSAEISCONN         As Long = (WSABASEERR + 56)
 134 Public Const WSAENOTCONN        As Long = (WSABASEERR + 57)
 135 Public Const WSAESHUTDOWN       As Long = (WSABASEERR + 58)
 136 Public Const WSAETIMEDOUT       As Long = (WSABASEERR + 60)
 137 Public Const WSAEHOSTUNREACH    As Long = (WSABASEERR + 65)
 138 Public Const WSAECONNREFUSED    As Long = (WSABASEERR + 61)
 139 Public Const WSAEPROCLIM        As Long = (WSABASEERR + 67)
 140 Public Const WSASYSNOTREADY     As Long = (WSABASEERR + 91)
 141 Public Const WSAVERNOTSUPPORTED As Long = (WSABASEERR + 92)
 142 Public Const WSANOTINITIALISED  As Long = (WSABASEERR + 93)
 143 Public Const WSAHOST_NOT_FOUND  As Long = (WSABASEERR + 1001)
 144 Public Const WSATRY_AGAIN       As Long = (WSABASEERR + 1002)
 145 Public Const WSANO_RECOVERY     As Long = (WSABASEERR + 1003)
 146 Public Const WSANO_DATA         As Long = (WSABASEERR + 1004)
 147 '==============================================================================
 148 'WINSOCK CONTROL ERROR CODES
 149 '==============================================================================
 150 Public Const sckOutOfMemory As Long = 7
 151 Public Const sckBadState    As Long = 40006
 152 Public Const sckInvalidArg  As Long = 40014
 153 Public Const sckUnsupported As Long = 40018
 154 Public Const sckInvalidOp   As Long = 40020
 155 '==============================================================================
 156 'STRUCTURES
 157 '==============================================================================
 158 Private Type WSAData
 159     wVersion       As Integer
 160     wHighVersion   As Integer
 161     szDescription  As String * WSADESCRIPTION_LEN
 162     szSystemStatus As String * WSASYS_STATUS_LEN
 163     iMaxSockets    As Integer
 164     iMaxUdpDg      As Integer
 165     lpVendorInfo   As Long
 166 End Type
 167 Public Type HOSTENT
 168     hName     As Long
 169     hAliases  As Long
 170     hAddrType As Integer
 171     hLength   As Integer
 172     hAddrList As Long
 173 End Type
 174 Public Type sockaddr_in
 175     sin_family       As Integer
 176     sin_port         As Integer
 177     sin_addr         As Long
 178     sin_zero(1 To 8) As Byte
 179 End Type
 180 '==============================================================================
 181 'MEMBER VARIABLES
 182 '==============================================================================
 183 Private m_blnInitiated          As Boolean      'specify if winsock service was initiated
 184 Private m_lngSocksQuantity      As Long         'number of instances created
 185 Private m_colSocketsInst        As Collection   'sockets list and instance owner
 186 Private m_colAcceptList         As Collection   'sockets in queue that need to be accepted
 187 Private m_lngWindowHandle       As Long         'message window handle
 188 '==============================================================================
 189 'SUBCLASSING DECLARATIONS
 190 'by Paul Caton
 191 '==============================================================================
 192 Private Declare Function api_IsWindow _
 193                 Lib "user32" _
 194                 Alias "IsWindow" (ByVal hWnd As Long) As Long
 195 Private Declare Function api_GetWindowLong _
 196                 Lib "user32" _
 197                 Alias "GetWindowLongA" (ByVal hWnd As Long, _
 198                                         ByVal nIndex As Long) As Long
 199 Private Declare Function api_SetWindowLong _
 200                 Lib "user32" _
 201                 Alias "SetWindowLongA" (ByVal hWnd As Long, _
 202                                         ByVal nIndex As Long, _
 203                                         ByVal dwNewLong As Long) As Long
 204 Private Declare Function api_GetModuleHandle _
 205                 Lib "kernel32" _
 206                 Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
 207 Private Declare Function api_GetProcAddress _
 208                 Lib "kernel32" _
 209                 Alias "GetProcAddress" (ByVal hModule As Long, _
 210                                         ByVal lpProcName As String) As Long
 211 Private Const PATCH_06 As Long = 106
 212 Private Const PATCH_09 As Long = 137
 213 Private Const GWL_WNDPROC As Long = (-4)
 214 Private Const WM_APP As Long = 32768 '0x8000
 215 Public Const RESOLVE_MESSAGE As Long = WM_APP
 216 Public Const SOCKET_MESSAGE  As Long = WM_APP + 1
 217 Private lngMsgCntA      As Long     'TableA entry count
 218 Private lngMsgCntB      As Long     'TableB entry count
 219 Private lngTableA1()    As Long     'TableA1: list of async handles
 220 Private lngTableA2()    As Long     'TableA2: list of async handles owners
 221 Private lngTableB1()    As Long     'TableB1: list of sockets
 222 Private lngTableB2()    As Long     'TableB2: list of sockets owners
 223 Private hWndSub         As Long     'window handle subclassed
 224 Private nAddrSubclass   As Long     'address of our WndProc
 225 Private nAddrOriginal   As Long     'address of original WndProc
 226
 227 'Once we are done with the class instance we call this
 228 'function to discount it and finish winsock service if
 229 'it was the last one.
 230 'Returns 0 if it has success.
 231 Public Function FinalizeProcesses() As Long
 232         '<EhHeader>
 233         On Error GoTo FinalizeProcesses_Err
 234         '</EhHeader>
 235 100     FinalizeProcesses = 0
 236 101     m_lngSocksQuantity = m_lngSocksQuantity - 1
 237
 238         'if the service was initiated and there's no more instances
 239         'of the class then we finish the service
 240 102     If m_blnInitiated And m_lngSocksQuantity = 0 Then
 241 103         If FinalizeService = SOCKET_ERROR Then
 242                 Dim lngErrorCode As Long
 243 104             lngErrorCode = Err.LastDllError
 244 105             FinalizeProcesses = lngErrorCode
 245 106             Err.Raise lngErrorCode, "modSocketMaster.FinalizeProcesses", GetErrorDescription(lngErrorCode)
 246             Else
 247                 '114             Debug.Print "OK Winsock service finalized"
 248             End If
 249
 250 107         Subclass_Terminate
 251 108         m_blnInitiated = False
 252         End If
 253
 254         '<EhFooter>
 255         Exit Function
 256 FinalizeProcesses_Err:
 257         Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.FinalizeProcesses.Ref 12/2/2008 : 09:38:31"
 258         Resume Next
 259         '</EhFooter>
 260 End Function
 261
 262 'Return the accept instance class from a socket.
 263 Public Function GetAcceptClass(ByVal lngSocket As Long) As CSocketMaster
 264         '<EhHeader>
 265         On Error GoTo GetAcceptClass_Err
 266         '</EhHeader>
 267 100     Set GetAcceptClass = m_colAcceptList("S" & lngSocket)
 268         '<EhFooter>
 269         Exit Function
 270 GetAcceptClass_Err:
 271         Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.GetAcceptClass.Ref 12/2/2008 : 09:38:31"
 272         Resume Next
 273         '</EhFooter>
 274 End Function
 275
 276 'This function receives a number that represents an error
 277 'and returns the corresponding description string.
 278 Public Function GetErrorDescription(ByVal lngErrorCode As Long) As String
 279         '<EhHeader>
 280         On Error GoTo GetErrorDescription_Err
 281
 282         '</EhHeader>
 283 100     Select Case lngErrorCode
 284
 285             Case WSAEACCES
 286 101             GetErrorDescription = "Permission denied."
 287
 288 102         Case WSAEADDRINUSE
 289 103             GetErrorDescription = "Address already in use."
 290
 291 104         Case WSAEADDRNOTAVAIL
 292 105             GetErrorDescription = "Cannot assign requested address."
 293
 294 106         Case WSAEAFNOSUPPORT
 295 107             GetErrorDescription = "Address family not supported by protocol family."
 296
 297 108         Case WSAEALREADY
 298 109             GetErrorDescription = "Operation already in progress."
 299
 300 110         Case WSAECONNABORTED
 301 111             GetErrorDescription = "Software caused connection abort."
 302
 303 112         Case WSAECONNREFUSED
 304 113             GetErrorDescription = "Connection refused."
 305
 306 114         Case WSAECONNRESET
 307 115             GetErrorDescription = "Connection reset by peer."
 308
 309 116         Case WSAEDESTADDRREQ
 310 117             GetErrorDescription = "Destination address required."
 311
 312 118         Case WSAEFAULT
 313 119             GetErrorDescription = "Bad address."
 314
 315 120         Case WSAEHOSTUNREACH
 316 121             GetErrorDescription = "No route to host."
 317
 318 122         Case WSAEINPROGRESS
 319 123             GetErrorDescription = "Operation now in progress."
 320
 321 124         Case WSAEINTR
 322 125             GetErrorDescription = "Interrupted function call."
 323
 324 126         Case WSAEINVAL
 325 127             GetErrorDescription = "Invalid argument."
 326
 327 128         Case WSAEISCONN
 328 129             GetErrorDescription = "Socket is already connected."
 329
 330 130         Case WSAEMFILE
 331 131             GetErrorDescription = "Too many open files."
 332
 333 132         Case WSAEMSGSIZE
 334 133             GetErrorDescription = "Message too long."
 335
 336 134         Case WSAENETDOWN
 337 135             GetErrorDescription = "Network is down."
 338
 339 136         Case WSAENETRESET
 340 137             GetErrorDescription = "Network dropped connection on reset."
 341
 342 138         Case WSAENETUNREACH
 343 139             GetErrorDescription = "Network is unreachable."
 344
 345 140         Case WSAENOBUFS
 346 141             GetErrorDescription = "No buffer space available."
 347
 348 142         Case WSAENOPROTOOPT
 349 143             GetErrorDescription = "Bad protocol option."
 350
 351 144         Case WSAENOTCONN
 352 145             GetErrorDescription = "Socket is not connected."
 353
 354 146         Case WSAENOTSOCK
 355 147             GetErrorDescription = "Socket operation on nonsocket."
 356
 357 148         Case WSAEOPNOTSUPP
 358 149             GetErrorDescription = "Operation not supported."
 359
 360 150         Case WSAEPFNOSUPPORT
 361 151             GetErrorDescription = "Protocol family not supported."
 362
 363 152         Case WSAEPROCLIM
 364 153             GetErrorDescription = "Too many processes."
 365
 366 154         Case WSAEPROTONOSUPPORT
 367 155             GetErrorDescription = "Protocol not supported."
 368
 369 156         Case WSAEPROTOTYPE
 370 157             GetErrorDescription = "Protocol wrong type for socket."
 371
 372 158         Case WSAESHUTDOWN
 373 159             GetErrorDescription = "Cannot send after socket shutdown."
 374
 375 160         Case WSAESOCKTNOSUPPORT
 376 161             GetErrorDescription = "Socket type not supported."
 377
 378 162         Case WSAETIMEDOUT
 379 163             GetErrorDescription = "Connection timed out."
 380
 381 164         Case WSAEWOULDBLOCK
 382 165             GetErrorDescription = "Resource temporarily unavailable."
 383
 384 166         Case WSAHOST_NOT_FOUND
 385 167             GetErrorDescription = "Host not found."
 386
 387 168         Case WSANOTINITIALISED
 388 169             GetErrorDescription = "Successful WSAStartup not yet performed."
 389
 390 170         Case WSANO_DATA
 391 171             GetErrorDescription = "Valid name, no data record of requested type."
 392
 393 172         Case WSANO_RECOVERY
 394 173             GetErrorDescription = "This is a nonrecoverable error."
 395
 396 174         Case WSASYSNOTREADY
 397 175             GetErrorDescription = "Network subsystem is unavailable."
 398
 399 176         Case WSATRY_AGAIN
 400 177             GetErrorDescription = "Non authoritative host not found."
 401
 402 178         Case WSAVERNOTSUPPORTED
 403 179             GetErrorDescription = "Winsock.dll version out of range."
 404
 405 180         Case Else
 406 181             GetErrorDescription = "Unknown error."
 407         End Select
 408
 409         '<EhFooter>
 410         Exit Function
 411 GetErrorDescription_Err:
 412         Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.GetErrorDescription.Ref 12/2/2008 : 09:38:31"
 413         Resume Next
 414         '</EhFooter>
 415 End Function
 416
 417 'Returns the hi word from a double word.
 418 Public Function HiWord(lngValue As Long) As Long
 419         '<EhHeader>
 420         On Error GoTo HiWord_Err
 421
 422         '</EhHeader>
 423 100     If (lngValue And &H80000000) = &H80000000 Then
 424 101         HiWord = ((lngValue And &H7FFF0000) \ &H10000) Or &H8000&
 425         Else
 426 102         HiWord = (lngValue And &HFFFF0000) \ &H10000
 427         End If
 428
 429         '<EhFooter>
 430         Exit Function
 431 HiWord_Err:
 432         Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.HiWord.Ref 12/2/2008 : 09:38:31"
 433         Resume Next
 434         '</EhFooter>
 435 End Function
 436
 437 'This function initiates the processes needed to keep
 438 'control of sockets. Returns 0 if it has success.
 439 Public Function InitiateProcesses() As Long
 440         '<EhHeader>
 441         On Error GoTo InitiateProcesses_Err
 442         '</EhHeader>
 443 100     InitiateProcesses = 0
 444 101     m_lngSocksQuantity = m_lngSocksQuantity + 1
 445
 446         'if the service wasn't initiated yet we do it now
 447 102     If Not m_blnInitiated Then
 448 103         Subclass_Initialize
 449 104         m_blnInitiated = True
 450             Dim lngResult As Long
 451 105         lngResult = InitiateService
 452
 453 106         If lngResult = 0 Then
 454                 'Debug.Print "OK Winsock service initiated"
 455             Else
 456 107             Debug.Print "ERROR trying to initiate winsock service"
 457 108             Err.Raise lngResult, "modSocketMaster.InitiateProcesses", GetErrorDescription(lngResult)
 458 109             InitiateProcesses = lngResult
 459             End If
 460         End If
 461
 462         '<EhFooter>
 463         Exit Function
 464 InitiateProcesses_Err:
 465         Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.InitiateProcesses.Ref 12/2/2008 : 09:38:31"
 466         Resume Next
 467         '</EhFooter>
 468 End Function
 469
 470 'The function takes a Long containing a value in the range
 471 'of an unsigned Integer and returns an Integer that you
 472 'can pass to an API that requires an unsigned Integer
 473 Public Function IntegerToUnsigned(Value As Integer) As Long
 474         '<EhHeader>
 475         On Error GoTo IntegerToUnsigned_Err
 476
 477         '</EhHeader>
 478 100     If Value < 0 Then
 479 101         IntegerToUnsigned = Value + OFFSET_2
 480         Else
 481 102         IntegerToUnsigned = Value
 482         End If
 483
 484         '<EhFooter>
 485         Exit Function
 486 IntegerToUnsigned_Err:
 487         Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.IntegerToUnsigned.Ref 12/2/2008 : 09:38:31"
 488         Resume Next
 489         '</EhFooter>
 490 End Function
 491
 492 'Returns True is lngSocket is registered on the
 493 'accept list.
 494 Public Function IsAcceptRegistered(ByVal lngSocket As Long) As Boolean
 495         '<EhHeader>
 496         On Error GoTo IsAcceptRegistered_Err
 497         '</EhHeader>
 498         On Error GoTo Error_Handler
 499 100     m_colAcceptList.Item ("S" & lngSocket)
 500 101     IsAcceptRegistered = True
 501         Exit Function
 502 Error_Handler:
 503 102     IsAcceptRegistered = False
 504         '<EhFooter>
 505         Exit Function
 506 IsAcceptRegistered_Err:
 507         Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.IsAcceptRegistered.Ref 12/2/2008 : 09:38:31"
 508         Resume Next
 509         '</EhFooter>
 510 End Function
 511
 512 'Returns TRUE si the socket that is passed is registered
 513 'in the colSocketsInst collection.
 514 Public Function IsSocketRegistered(ByVal lngSocket As Long) As Boolean
 515         '<EhHeader>
 516         On Error GoTo IsSocketRegistered_Err
 517         '</EhHeader>
 518         On Error GoTo Error_Handler
 519 100     m_colSocketsInst.Item ("S" & lngSocket)
 520 101     IsSocketRegistered = True
 521         Exit Function
 522 Error_Handler:
 523 102     IsSocketRegistered = False
 524         '<EhFooter>
 525         Exit Function
 526 IsSocketRegistered_Err:
 527         Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.IsSocketRegistered.Ref 12/2/2008 : 09:38:31"
 528         Resume Next
 529         '</EhFooter>
 530 End Function
 531
 532 'Returns the low word from a double word.
 533 Public Function LoWord(lngValue As Long) As Long
 534         '<EhHeader>
 535         On Error GoTo LoWord_Err
 536         '</EhHeader>
 537 100     LoWord = (lngValue And &HFFFF&)
 538         '<EhFooter>
 539         Exit Function
 540 LoWord_Err:
 541         Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.LoWord.Ref 12/2/2008 : 09:38:31"
 542         Resume Next
 543         '</EhFooter>
 544 End Function
 545
 546 'Assing a temporal instance of CSocketMaster to a
 547 'socket and register this socket to the accept list.
 548 Public Sub RegisterAccept(ByVal lngSocket As Long)
 549         '<EhHeader>
 550         On Error GoTo RegisterAccept_Err
 551
 552         '</EhHeader>
 553 100     If m_colAcceptList Is Nothing Then
 554 101         Set m_colAcceptList = New Collection
 555         End If
 556
 557         Dim Socket As CSocketMaster
 558 102     Set Socket = New CSocketMaster
 559 103     Socket.Accept lngSocket
 560 104     m_colAcceptList.Add Socket, "S" & lngSocket
 561         '<EhFooter>
 562         Exit Sub
 563 RegisterAccept_Err:
 564         Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.RegisterAccept.Ref 12/2/2008 : 09:38:31"
 565         Resume Next
 566         '</EhFooter>
 567 End Sub
 568
 569 'Adds the socket to the m_colSocketsInst collection, and
 570 'registers that socket with WSAAsyncSelect Winsock API
 571 'function to receive network events for the socket.
 572 'If this socket is the first one to be registered, the
 573 'window and collection will be created in this function as well.
 574 Public Function RegisterSocket(ByVal lngSocket As Long, _
 575                                ByVal lngObjectPointer As Long, _
 576                                ByVal blnEvents As Boolean) As Boolean
 577         '<EhHeader>
 578         On Error GoTo RegisterSocket_Err
 579
 580         '</EhHeader>
 581 100     If m_colSocketsInst Is Nothing Then
 582 101         Set m_colSocketsInst = New Collection
 583
 584 102         If CreateWinsockMessageWindow <> 0 Then
 585 103             Err.Raise sckOutOfMemory, "modSocketMaster.RegisterSocket", "Out of memory"
 586             End If
 587
 588 104         Subclass_Subclass (m_lngWindowHandle)
 589         End If
 590
 591 105     Subclass_AddSocketMessage lngSocket, lngObjectPointer
 592
 593         'Do we need to register socket events?
 594 106     If blnEvents Then
 595             Dim lngEvents As Long
 596             Dim lngResult As Long
 597             Dim lngErrorCode As Long
 598 107         lngEvents = FD_READ Or FD_WRITE Or FD_ACCEPT Or FD_CONNECT Or FD_CLOSE
 599 108         lngResult = api_WSAAsyncSelect(lngSocket, m_lngWindowHandle, SOCKET_MESSAGE, lngEvents)
 600
 601 109         If lngResult = SOCKET_ERROR Then
 602 110             Debug.Print "ERROR trying to register events from socket " & lngSocket
 603 111             lngErrorCode = Err.LastDllError
 604 112             Err.Raise lngErrorCode, "modSocketMaster.RegisterSocket", GetErrorDescription(lngErrorCode)
 605             End If
 606         End If
 607
 608 113     m_colSocketsInst.Add lngObjectPointer, "S" & lngSocket
 609 114     RegisterSocket = True
 610         '<EhFooter>
 611         Exit Function
 612 RegisterSocket_Err:
 613         Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.RegisterSocket.Ref 12/2/2008 : 09:38:31"
 614         Resume Next
 615         '</EhFooter>
 616 End Function
 617
 618 'When a socket needs to resolve a hostname in asynchronous way
 619 'it calls this function. If it has success it returns a nonzero
 620 'number that represents the async task handle and register this
 621 'number in the TableA list.
 622 'Returns 0 if it fails.
 623 Public Function ResolveHost(ByVal strHost As String, _
 624                             ByVal lngHOSTENBuf As Long, _
 625                             ByVal lngObjectPointer As Long) As Long
 626         '<EhHeader>
 627         On Error GoTo ResolveHost_Err
 628         '</EhHeader>
 629         Dim lngAsynHandle As Long
 630 100     lngAsynHandle = api_WSAAsyncGetHostByName(m_lngWindowHandle, RESOLVE_MESSAGE, strHost, ByVal lngHOSTENBuf, MAXGETHOSTSTRUCT)
 631
 632 101     If lngAsynHandle <> 0 Then Subclass_AddResolveMessage lngAsynHandle, lngObjectPointer
 633 102     ResolveHost = lngAsynHandle
 634         '<EhFooter>
 635         Exit Function
 636 ResolveHost_Err:
 637         Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.ResolveHost.Ref 12/2/2008 : 09:38:31"
 638         Resume Next
 639         '</EhFooter>
 640 End Function
 641
 642 'Receives a string pointer and it turns it into a regular string.
 643 Public Function StringFromPointer(ByVal lPointer As Long) As String
 644         '<EhHeader>
 645         On Error GoTo StringFromPointer_Err
 646         '</EhHeader>
 647         Dim strTemp As String
 648         Dim lRetVal As Long
 649 100     strTemp = String$(api_lstrlen(ByVal lPointer), 0)
 650 101     lRetVal = api_lstrcpy(ByVal strTemp, ByVal lPointer)
 651
 652 102     If lRetVal Then StringFromPointer = strTemp
 653         '<EhFooter>
 654         Exit Function
 655 StringFromPointer_Err:
 656         Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.StringFromPointer.Ref 12/2/2008 : 09:38:31"
 657         Resume Next
 658         '</EhFooter>
 659 End Function
 660
 661 'Unregister lngSocket from the accept list.
 662 Public Sub UnregisterAccept(ByVal lngSocket As Long)
 663         '<EhHeader>
 664         On Error GoTo UnregisterAccept_Err
 665         '</EhHeader>
 666 100     m_colAcceptList.Remove "S" & lngSocket
 667
 668 101     If m_colAcceptList.Count = 0 Then
 669 102         Set m_colAcceptList = Nothing
 670         End If
 671
 672         '<EhFooter>
 673         Exit Sub
 674 UnregisterAccept_Err:
 675         Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.UnregisterAccept.Ref 12/2/2008 : 09:38:31"
 676         Resume Next
 677         '</EhFooter>
 678 End Sub
 679
 680 'When ResolveHost is called an async task handle is added
 681 'to TableA list. Use this function to remove that record.
 682 Public Sub UnregisterResolution(ByVal lngAsynHandle As Long)
 683         '<EhHeader>
 684         On Error GoTo UnregisterResolution_Err
 685         '</EhHeader>
 686 100     Subclass_DelResolveMessage lngAsynHandle
 687         '<EhFooter>
 688         Exit Sub
 689 UnregisterResolution_Err:
 690         Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.UnregisterResolution.Ref 12/2/2008 : 09:38:31"
 691         Resume Next
 692         '</EhFooter>
 693 End Sub
 694
 695 'Removes the socket from the m_colSocketsInst collection
 696 'If it is the last socket in that collection, the window
 697 'and colection will be destroyed as well.
 698 Public Sub UnregisterSocket(ByVal lngSocket As Long)
 699         '<EhHeader>
 700         On Error GoTo UnregisterSocket_Err
 701         '</EhHeader>
 702 100     Subclass_DelSocketMessage lngSocket
 703         On Error Resume Next
 704 101     m_colSocketsInst.Remove "S" & lngSocket
 705
 706 102     If m_colSocketsInst.Count = 0 Then
 707 103         Set m_colSocketsInst = Nothing
 708 104         Subclass_UnSubclass
 709 105         DestroyWinsockMessageWindow
 710         End If
 711
 712         '<EhFooter>
 713         Exit Sub
 714 UnregisterSocket_Err:
 715         Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.UnregisterSocket.Ref 12/2/2008 : 09:38:31"
 716         Resume Next
 717         '</EhFooter>
 718 End Sub
 719
 720 'The function takes an unsigned Integer from and API and
 721 'converts it to a Long for display or arithmetic purposes
 722 Public Function UnsignedToInteger(Value As Long) As Integer
 723         '<EhHeader>
 724         On Error GoTo UnsignedToInteger_Err
 725
 726         '</EhHeader>
 727 100     If Value < 0 Or Value >= OFFSET_2 Then Error 6 ' Overflow
 728 101     If Value <= MAXINT_2 Then
 729 102         UnsignedToInteger = Value
 730         Else
 731 103         UnsignedToInteger = Value - OFFSET_2
 732         End If
 733
 734         '<EhFooter>
 735         Exit Function
 736 UnsignedToInteger_Err:
 737         Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.UnsignedToInteger.Ref 12/2/2008 : 09:38:31"
 738         Resume Next
 739         '</EhFooter>
 740 End Function
 741
 742 'Create a window that is used to capture sockets messages.
 743 'Returns 0 if it has success.
 744 Private Function CreateWinsockMessageWindow() As Long
 745         '<EhHeader>
 746         On Error GoTo CreateWinsockMessageWindow_Err
 747         '</EhHeader>
 748 100     m_lngWindowHandle = api_CreateWindowEx(0&, "STATIC", "SOCKET_WINDOW", 0&, 0&, 0&, 0&, 0&, 0&, 0&, App.hInstance, ByVal 0&)
 749
 750 101     If m_lngWindowHandle = 0 Then
 751 102         CreateWinsockMessageWindow = sckOutOfMemory
 752             Exit Function
 753         Else
 754 103         CreateWinsockMessageWindow = 0
 755         End If
 756
 757         '<EhFooter>
 758         Exit Function
 759 CreateWinsockMessageWindow_Err:
 760         Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.CreateWinsockMessageWindow.Ref 12/2/2008 : 09:38:31"
 761         Resume Next
 762         '</EhFooter>
 763 End Function
 764
 765 'Destroy the window that is used to capture sockets messages.
 766 'Returns 0 if it has success.
 767 Private Function DestroyWinsockMessageWindow() As Long
 768         '<EhHeader>
 769         On Error GoTo DestroyWinsockMessageWindow_Err
 770         '</EhHeader>
 771 100     DestroyWinsockMessageWindow = 0
 772
 773 101     If m_lngWindowHandle = 0 Then
 774             Exit Function
 775         End If
 776
 777         Dim lngResult As Long
 778 102     lngResult = api_DestroyWindow(m_lngWindowHandle)
 779
 780 103     If lngResult = 0 Then
 781 104         DestroyWinsockMessageWindow = sckOutOfMemory
 782 105         Err.Raise sckOutOfMemory, "modSocketMaster.DestroyWinsockMessageWindow", "Out of memory"
 783         Else
 784             '112         Debug.Print "OK Destroyed winsock message window " & m_lngWindowHandle
 785 106         m_lngWindowHandle = 0
 786         End If
 787
 788         '<EhFooter>
 789         Exit Function
 790 DestroyWinsockMessageWindow_Err:
 791         Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.DestroyWinsockMessageWindow.Ref 12/2/2008 : 09:38:31"
 792         Resume Next
 793         '</EhFooter>
 794 End Function
 795
 796 'Finish winsock service calling the function
 797 'api_WSACleanup and returns the result.
 798 Private Function FinalizeService() As Long
 799         '<EhHeader>
 800         On Error GoTo FinalizeService_Err
 801         '</EhHeader>
 802         Dim lngResultado As Long
 803 100     lngResultado = api_WSACleanup
 804 101     FinalizeService = lngResultado
 805         '<EhFooter>
 806         Exit Function
 807 FinalizeService_Err:
 808         Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.FinalizeService.Ref 12/2/2008 : 09:38:31"
 809         Resume Next
 810         '</EhFooter>
 811 End Function
 812
 813 'This function initiate the winsock service calling
 814 'the api_WSAStartup funtion and returns resulting value.
 815 Private Function InitiateService() As Long
 816         '<EhHeader>
 817         On Error GoTo InitiateService_Err
 818         '</EhHeader>
 819         Dim udtWSAData As WSAData
 820         Dim lngResult As Long
 821 100     lngResult = api_WSAStartup(SOCKET_VERSION_11, udtWSAData)
 822 101     InitiateService = lngResult
 823         '<EhFooter>
 824         Exit Function
 825 InitiateService_Err:
 826         Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.InitiateService.Ref 12/2/2008 : 09:38:31"
 827         Resume Next
 828         '</EhFooter>
 829 End Function
 830
 831 Public Sub Subclass_ChangeOwner(ByVal lngSocket As Long, _
 832                                 ByVal lngObjectPointer As Long)
 833         '<EhHeader>
 834         On Error GoTo Subclass_ChangeOwner_Err
 835         '</EhHeader>
 836         Dim Count As Long
 837
 838 100     For Count = 1 To lngMsgCntB
 839
 840 101         If lngTableB1(Count) = lngSocket Then
 841 102             lngTableB2(Count) = lngObjectPointer
 842                 Exit Sub
 843             End If
 844
 845         Next
 846
 847         '<EhFooter>
 848         Exit Sub
 849 Subclass_ChangeOwner_Err:
 850         Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.Subclass_ChangeOwner.Ref 12/2/2008 : 09:38:31"
 851         Resume Next
 852         '</EhFooter>
 853 End Sub
 854
 855 Private Sub Subclass_AddResolveMessage(ByVal lngAsync As Long, _
 856                                        ByVal lngObjectPointer As Long)
 857         '<EhHeader>
 858         On Error GoTo Subclass_AddResolveMessage_Err
 859         '</EhHeader>
 860         Dim Count As Long
 861
 862 100     For Count = 1 To lngMsgCntA
 863
 864 101         Select Case lngTableA1(Count)
 865
 866                 Case -1
 867 102                 lngTableA1(Count) = lngAsync
 868 103                 lngTableA2(Count) = lngObjectPointer
 869                     Exit Sub
 870
 871 104             Case lngAsync
 872                     Exit Sub
 873             End Select
 874
 875         Next
 876
 877 105     lngMsgCntA = lngMsgCntA + 1
 878 106     ReDim Preserve lngTableA1(1 To lngMsgCntA)
 879 107     ReDim Preserve lngTableA2(1 To lngMsgCntA)
 880 108     lngTableA1(lngMsgCntA) = lngAsync
 881 109     lngTableA2(lngMsgCntA) = lngObjectPointer
 882 110     Subclass_PatchTableA
 883         '<EhFooter>
 884         Exit Sub
 885 Subclass_AddResolveMessage_Err:
 886         Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.Subclass_AddResolveMessage.Ref 12/2/2008 : 09:38:31"
 887         Resume Next
 888         '</EhFooter>
 889 End Sub
 890
 891 'Return the address of the passed function in the passed dll
 892 Private Function Subclass_AddrFunc(ByVal sDLL As String, _
 893                                    ByVal sProc As String) As Long
 894         '<EhHeader>
 895         On Error GoTo Subclass_AddrFunc_Err
 896         '</EhHeader>
 897 100     Subclass_AddrFunc = api_GetProcAddress(api_GetModuleHandle(sDLL), sProc)
 898         '<EhFooter>
 899         Exit Function
 900 Subclass_AddrFunc_Err:
 901         Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.Subclass_AddrFunc.Ref 12/2/2008 : 09:38:31"
 902         Resume Next
 903         '</EhFooter>
 904 End Function
 905
 906 'Return the address of the low bound of the passed table array
 907 Private Function Subclass_AddrMsgTbl(ByRef aMsgTbl() As Long) As Long
 908         '<EhHeader>
 909         On Error GoTo Subclass_AddrMsgTbl_Err
 910         '</EhHeader>
 911         On Error Resume Next                                    'The table may not be dimensioned yet so we need protection
 912 100     Subclass_AddrMsgTbl = VarPtr(aMsgTbl(1))              'Get the address of the first element of the passed message table
 913         On Error GoTo Subclass_AddrMsgTbl_Err                                         'Switch off error protection
 914         '<EhFooter>
 915         Exit Function
 916 Subclass_AddrMsgTbl_Err:
 917         Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.Subclass_AddrMsgTbl.Ref 12/2/2008 : 09:38:31"
 918         Resume Next
 919         '</EhFooter>
 920 End Function
 921
 922 Private Sub Subclass_AddSocketMessage(ByVal lngSocket As Long, _
 923                                       ByVal lngObjectPointer As Long)
 924         '<EhHeader>
 925         On Error GoTo Subclass_AddSocketMessage_Err
 926         '</EhHeader>
 927         Dim Count As Long
 928
 929 100     For Count = 1 To lngMsgCntB
 930
 931 101         Select Case lngTableB1(Count)
 932
 933                 Case -1
 934 102                 lngTableB1(Count) = lngSocket
 935 103                 lngTableB2(Count) = lngObjectPointer
 936                     Exit Sub
 937
 938 104             Case lngSocket
 939                     Exit Sub
 940             End Select
 941
 942         Next
 943
 944 105     lngMsgCntB = lngMsgCntB + 1
 945 106     ReDim Preserve lngTableB1(1 To lngMsgCntB)
 946 107     ReDim Preserve lngTableB2(1 To lngMsgCntB)
 947 108     lngTableB1(lngMsgCntB) = lngSocket
 948 109     lngTableB2(lngMsgCntB) = lngObjectPointer
 949 110     Subclass_PatchTableB
 950         '<EhFooter>
 951         Exit Sub
 952 Subclass_AddSocketMessage_Err:
 953         Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.Subclass_AddSocketMessage.Ref 12/2/2008 : 09:38:31"
 954         Resume Next
 955         '</EhFooter>
 956 End Sub
 957
 958 Private Sub Subclass_DelResolveMessage(ByVal lngAsync As Long)
 959         '<EhHeader>
 960         On Error GoTo Subclass_DelResolveMessage_Err
 961         '</EhHeader>
 962         Dim Count As Long
 963
 964 100     For Count = 1 To lngMsgCntA
 965
 966 101         If lngTableA1(Count) = lngAsync Then
 967 102             lngTableA1(Count) = -1
 968 103             lngTableA2(Count) = -1
 969                 Exit Sub
 970             End If
 971
 972         Next
 973
 974         '<EhFooter>
 975         Exit Sub
 976 Subclass_DelResolveMessage_Err:
 977         Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.Subclass_DelResolveMessage.Ref 12/2/2008 : 09:38:31"
 978         Resume Next
 979         '</EhFooter>
 980 End Sub
 981
 982 Private Sub Subclass_DelSocketMessage(ByVal lngSocket As Long)
 983         '<EhHeader>
 984         On Error GoTo Subclass_DelSocketMessage_Err
 985         '</EhHeader>
 986         Dim Count As Long
 987
 988 100     For Count = 1 To lngMsgCntB
 989
 990 101         If lngTableB1(Count) = lngSocket Then
 991 102             lngTableB1(Count) = -1
 992 103             lngTableB2(Count) = -1
 993                 Exit Sub
 994             End If
 995
 996         Next
 997
 998         '<EhFooter>
 999         Exit Sub
1000 Subclass_DelSocketMessage_Err:
1001         Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.Subclass_DelSocketMessage.Ref 12/2/2008 : 09:38:31"
1002         Resume Next
1003         '</EhFooter>
1004 End Sub
1005
1006 'Return whether we're running in the IDE. Public for general utility purposes
1007 Private Function Subclass_InIDE() As Boolean
1008         '<EhHeader>
1009         On Error GoTo Subclass_InIDE_Err
1010         '</EhHeader>
1011 100     Debug.Assert Subclass_SetTrue(Subclass_InIDE)
1012         '<EhFooter>
1013         Exit Function
1014 Subclass_InIDE_Err:
1015         Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.Subclass_InIDE.Ref 12/2/2008 : 09:38:31"
1016         Resume Next
1017         '</EhFooter>
1018 End Function
1019
1020 '==============================================================================
1021 'SUBCLASSING CODE
1022 'based on code by Paul Caton
1023 '==============================================================================
1024 Private Sub Subclass_Initialize()
1025         '<EhHeader>
1026         On Error GoTo Subclass_Initialize_Err
1027         '</EhHeader>
1028         Const PATCH_01 As Long = 15                                 'Code buffer offset to the location of the relative address to EbMode
1029         Const PATCH_03 As Long = 76                                 'Relative address of SetWindowsLong
1030         Const PATCH_05 As Long = 100                                 'Relative address of CallWindowProc
1031         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
1032         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
1033         Const FUNC_CWP As String = "CallWindowProcA"                'We use CallWindowProc to call the original WndProc
1034         Const MOD_VBA5 As String = "vba5"                           'Location of the EbMode function if running VB5
1035         Const MOD_VBA6 As String = "vba6"                           'Location of the EbMode function if running VB6
1036         Const MOD_USER As String = "user32"                         'Location of the SetWindowLong & CallWindowProc functions
1037         Dim i        As Long                                      'Loop index
1038         Dim nLen     As Long                                      'String lengths
1039         Dim sHex     As String                                    'Hex code string
1040         Dim sCode    As String                                    'Binary code string
1041         'Store the hex pair machine code representation in sHex
1042 100     sHex = "5850505589E55753515231C0EB0EE8xxxxx01x83F802742285C074258B45103D0080000074433D01800000745BE8200000005A595B5FC9C21400E813000000EBF168xxxxx02x6AFCFF750CE8xxxxx03xEBE0FF7518FF7514FF7510FF750C68xxxxx04xE8xxxxx05xC3BBxxxxx06x8B4514BFxxxxx07x89D9F2AF75B629CB4B8B1C9Dxxxxx08xEB1DBBxxxxx09x8B4514BFxxxxx0Ax89D9F2AF759729CB4B8B1C9Dxxxxx0Bx895D088B1B8B5B1C89D85A595B5FC9FFE0"
1043 101     nLen = Len(sHex)                                          'Length of hex pair string
1044
1045         'Convert the string from hex pairs to bytes and store in the ASCII string opcode buffer
1046 102     For i = 1 To nLen Step 2                                  'For each pair of hex characters
1047 103         sCode = sCode & ChrB$(Val("&H" & Mid$(sHex, i, 2)))     'Convert a pair of hex characters to a byte and append to the ASCII string
1048         Next                                                     'Next pair
1049
1050 104     nLen = LenB(sCode)                                        'Get the machine code length
1051 105     nAddrSubclass = api_GlobalAlloc(0, nLen)                  'Allocate fixed memory for machine code buffer
1052         'Copy the code to allocated memory
1053 106     Call api_CopyMemory(ByVal nAddrSubclass, ByVal StrPtr(sCode), nLen)
1054
1055 107     If Subclass_InIDE Then
1056             'Patch the jmp (EB0E) with two nop's (90) enabling the IDE breakpoint/stop checking code
1057 108         Call api_CopyMemory(ByVal nAddrSubclass + 12, &H9090, 2)
1058 109         i = Subclass_AddrFunc(MOD_VBA6, FUNC_EBM)               'Get the address of EbMode in vba6.dll
1059
1060 110         If i = 0 Then                                           'Found?
1061 111             i = Subclass_AddrFunc(MOD_VBA5, FUNC_EBM)             'VB5 perhaps, try vba5.dll
1062             End If
1063
1064 112         Debug.Assert i                                          'Ensure the EbMode function was found
1065 113         Call Subclass_PatchRel(PATCH_01, i)                     'Patch the relative address to the EbMode api function
1066         End If
1067
1068 114     Call Subclass_PatchRel(PATCH_03, Subclass_AddrFunc(MOD_USER, FUNC_SWL))     'Address of the SetWindowLong api function
1069 115     Call Subclass_PatchRel(PATCH_05, Subclass_AddrFunc(MOD_USER, FUNC_CWP))     'Address of the CallWindowProc api function
1070         '<EhFooter>
1071         Exit Sub
1072 Subclass_Initialize_Err:
1073         Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.Subclass_Initialize.Ref 12/2/2008 : 09:38:30"
1074         Resume Next
1075         '</EhFooter>
1076 End Sub
1077
1078 'Patch the machine code buffer offset with the relative address to the target address
1079 Private Sub Subclass_PatchRel(ByVal nOffset As Long, _
1080                               ByVal nTargetAddr As Long)
1081         '<EhHeader>
1082         On Error GoTo Subclass_PatchRel_Err
1083         '</EhHeader>
1084 100     Call api_CopyMemory(ByVal (nAddrSubclass + nOffset), nTargetAddr - nAddrSubclass - nOffset - 4, 4)
1085         '<EhFooter>
1086         Exit Sub
1087 Subclass_PatchRel_Err:
1088         Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.Subclass_PatchRel.Ref 12/2/2008 : 09:38:30"
1089         Resume Next
1090         '</EhFooter>
1091 End Sub
1092
1093 Private Sub Subclass_PatchTableA()
1094         '<EhHeader>
1095         On Error GoTo Subclass_PatchTableA_Err
1096         '</EhHeader>
1097         Const PATCH_07 As Long = 114
1098         Const PATCH_08 As Long = 130
1099 100     Call Subclass_PatchVal(PATCH_06, lngMsgCntA)
1100 101     Call Subclass_PatchVal(PATCH_07, Subclass_AddrMsgTbl(lngTableA1))
1101 102     Call Subclass_PatchVal(PATCH_08, Subclass_AddrMsgTbl(lngTableA2))
1102         '<EhFooter>
1103         Exit Sub
1104 Subclass_PatchTableA_Err:
1105         Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.Subclass_PatchTableA.Ref 12/2/2008 : 09:38:30"
1106         Resume Next
1107         '</EhFooter>
1108 End Sub
1109
1110 Private Sub Subclass_PatchTableB()
1111         '<EhHeader>
1112         On Error GoTo Subclass_PatchTableB_Err
1113         '</EhHeader>
1114         Const PATCH_0A As Long = 145
1115         Const PATCH_0B As Long = 161
1116 100     Call Subclass_PatchVal(PATCH_09, lngMsgCntB)
1117 101     Call Subclass_PatchVal(PATCH_0A, Subclass_AddrMsgTbl(lngTableB1))
1118 102     Call Subclass_PatchVal(PATCH_0B, Subclass_AddrMsgTbl(lngTableB2))
1119         '<EhFooter>
1120         Exit Sub
1121 Subclass_PatchTableB_Err:
1122         Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.Subclass_PatchTableB.Ref 12/2/2008 : 09:38:30"
1123         Resume Next
1124         '</EhFooter>
1125 End Sub
1126
1127 'Patch the machine code buffer offset with the passed value
1128 Private Sub Subclass_PatchVal(ByVal nOffset As Long, _
1129                               ByVal nValue As Long)
1130         '<EhHeader>
1131         On Error GoTo Subclass_PatchVal_Err
1132         '</EhHeader>
1133 100     Call api_CopyMemory(ByVal (nAddrSubclass + nOffset), nValue, 4)
1134         '<EhFooter>
1135         Exit Sub
1136 Subclass_PatchVal_Err:
1137         Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.Subclass_PatchVal.Ref 12/2/2008 : 09:38:30"
1138         Resume Next
1139         '</EhFooter>
1140 End Sub
1141
1142 'Worker function for InIDE - will only be called whilst running in the IDE
1143 Private Function Subclass_SetTrue(bValue As Boolean) As Boolean
1144         '<EhHeader>
1145         On Error GoTo Subclass_SetTrue_Err
1146         '</EhHeader>
1147 100     Subclass_SetTrue = True
1148 101     bValue = True
1149         '<EhFooter>
1150         Exit Function
1151 Subclass_SetTrue_Err:
1152         Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.Subclass_SetTrue.Ref 12/2/2008 : 09:38:30"
1153         Resume Next
1154         '</EhFooter>
1155 End Function
1156
1157 'Set the window subclass
1158 Private Function Subclass_Subclass(ByVal hWnd As Long) As Boolean
1159         '<EhHeader>
1160         On Error GoTo Subclass_Subclass_Err
1161         '</EhHeader>
1162         Const PATCH_02 As Long = 66                                'Address of the previous WndProc
1163         Const PATCH_04 As Long = 95                                'Address of the previous WndProc
1164
1165 100     If hWndSub = 0 Then
1166 101         Debug.Assert api_IsWindow(hWnd)                         'Invalid window handle
1167 102         hWndSub = hWnd                                          'Store the window handle
1168             'Get the original window proc
1169 103         nAddrOriginal = api_GetWindowLong(hWnd, GWL_WNDPROC)
1170 104         Call Subclass_PatchVal(PATCH_02, nAddrOriginal)                  'Original WndProc address for CallWindowProc, call the original WndProc
1171 105         Call Subclass_PatchVal(PATCH_04, nAddrOriginal)                  'Original WndProc address for SetWindowLong, unsubclass on IDE stop
1172             'Set our WndProc in place of the original
1173 106         nAddrOriginal = api_SetWindowLong(hWnd, GWL_WNDPROC, nAddrSubclass)
1174
1175 107         If nAddrOriginal <> 0 Then
1176 108             nAddrOriginal = 0
1177 109             Subclass_Subclass = True                                       'Success
1178             End If
1179         End If
1180
1181 110     Debug.Assert Subclass_Subclass
1182         '<EhFooter>
1183         Exit Function
1184 Subclass_Subclass_Err:
1185         Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.Subclass_Subclass.Ref 12/2/2008 : 09:38:30"
1186         Resume Next
1187         '</EhFooter>
1188 End Function
1189
1190 'UnSubclass and release the allocated memory
1191 Private Sub Subclass_Terminate()
1192         '<EhHeader>
1193         On Error GoTo Subclass_Terminate_Err
1194         '</EhHeader>
1195 100     Call Subclass_UnSubclass                                      'UnSubclass if the Subclass thunk is active
1196 101     Call api_GlobalFree(nAddrSubclass)                            'Release the allocated memory
1197 102     nAddrSubclass = 0
1198 103     ReDim lngTableA1(1 To 1)
1199 104     ReDim lngTableA2(1 To 1)
1200 105     ReDim lngTableB1(1 To 1)
1201 106     ReDim lngTableB2(1 To 1)
1202         '<EhFooter>
1203         Exit Sub
1204 Subclass_Terminate_Err:
1205         Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.Subclass_Terminate.Ref 12/2/2008 : 09:38:30"
1206         Resume Next
1207         '</EhFooter>
1208 End Sub
1209
1210 'Stop subclassing the window
1211 Private Function Subclass_UnSubclass() As Boolean
1212         '<EhHeader>
1213         On Error GoTo Subclass_UnSubclass_Err
1214
1215         '</EhHeader>
1216 100     If hWndSub <> 0 Then
1217 101         lngMsgCntA = 0
1218 102         lngMsgCntB = 0
1219 103         Call Subclass_PatchVal(PATCH_06, lngMsgCntA)                              'Patch the TableA entry count to ensure no further Proc callbacks
1220 104         Call Subclass_PatchVal(PATCH_09, lngMsgCntB)                              'Patch the TableB entry count to ensure no further Proc callbacks
1221             'Restore the original WndProc
1222 105         Call api_SetWindowLong(hWndSub, GWL_WNDPROC, nAddrOriginal)
1223 106         hWndSub = 0                                             'Indicate the subclasser is inactive
1224 107         Subclass_UnSubclass = True                              'Success
1225         End If
1226
1227         '<EhFooter>
1228         Exit Function
1229 Subclass_UnSubclass_Err:
1230         Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.Subclass_UnSubclass.Ref 12/2/2008 : 09:38:30"
1231         Resume Next
1232         '</EhFooter>
1233 End Function