Skip to content
Permalink
Branch: master
Find file Copy path
Find file Copy path
Fetching contributors…
Cannot retrieve contributors at this time
1826 lines (1672 sloc) 67.3 KB
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
Persistable = 0 'NotPersistable
DataBindingBehavior = 0 'vbNone
DataSourceBehavior = 0 'vbNone
MTSTransactionMode = 0 'NotAnMTSObject
END
Attribute VB_Name = "cAsyncSocket"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'=========================================================================
'
' VbAsyncSocket Project (c) 2018-2019 by wqweto@gmail.com
'
' Simple and thin WinSock API wrappers for VB6
'
' This project is licensed under the terms of the MIT license
' See the LICENSE file in the project root for more information
'
'=========================================================================
Option Explicit
DefObj A-Z
Private Const MODULE_NAME As String = "cAsyncSocket"
#Const ImplUseShared = (ASYNCSOCKET_USE_SHARED <> 0)
#Const ImplSync = Not (ASYNCSOCKET_NO_SYNC <> 0)
#Const ImplNoIdeProtection = (MST_NO_IDE_PROTECTION <> 0)
'=========================================================================
' Public events
'=========================================================================
Event OnResolve(IpAddress As String)
Event OnAccept()
Event OnClose()
Event OnConnect()
Event OnReceive()
Event OnSend()
Event OnError(ByVal ErrorCode As Long, ByVal EventMask As UcsAsyncSocketEventMaskEnum)
Event OnMessagePending(Handled As Boolean)
'=========================================================================
' Public enums
'=========================================================================
Public Enum UcsAsyncSocketTypeEnum
ucsSckStream = 1
ucsSckDatagram = 2
End Enum
Public Enum UcsAsyncSocketEventMaskEnum
ucsSfdRead = 2 ^ 0
ucsSfdWrite = 2 ^ 1
ucsSfdOob = 2 ^ 2
ucsSfdAccept = 2 ^ 3
ucsSfdConnect = 2 ^ 4
ucsSfdClose = 2 ^ 5
ucsSfdAll = 2 ^ 6 - 1
[_ucsSfdResolve] = 2 ^ 15
[_ucsSfdForceRead] = 2 ^ 14
End Enum
Public Enum UcsAsyncSocketOptionLevelEnum
ucsSolSocket = &HFFFF& ' SOL_SOCKET
End Enum
Public Enum UcsAsyncSocketOptionNameEnum
ucsSsoDebug = &H1 ' Debugging is enabled.
ucsSsoAcceptConnection = &H2 ' Socket is listening.
ucsSsoReuseAddress = &H4 ' The socket can be bound to an address which is already in use. Not applicable for ATM sockets.
ucsSsoKeepAlive = &H8 ' Keep-alives are being sent. Not supported on ATM sockets.
ucsSsoDontRoute = &H10 ' Routing is disabled. Not supported on ATM sockets.
ucsSsoBroadcast = &H20 ' Socket is configured for the transmission of broadcast messages.
ucsSsoUseLoopback = &H40 ' Bypass hardware when possible.
ucsSsoLinger = &H80 ' Linger on close if unsent data is present.
ucsSsoOutOfBandInline = &H100 ' Receives out-of-band data in the normal data stream.
ucsSsoDontLinger = Not ucsSsoLinger ' Close socket gracefully without lingering.
ucsSsoExclusiveAddressUse = Not ucsSsoReuseAddress ' Enables a socket to be bound for exclusive access.
ucsSsoSendBuffer = &H1001 ' Buffer size for sends.
ucsSsoReceiveBuffer = &H1002 ' Buffer size for receives.
ucsSsoSendLowWater = &H1003 ' Specifies the total per-socket buffer space reserved for receives.
ucsSsoReceiveLowWater = &H1004 ' Receive low water mark.
ucsSsoSendTimeout = &H1005 ' Sends time-out (available in Microsoft implementation of Windows Sockets 2).
ucsSsoReceiveTimeout = &H1006 ' Receives time-out (available in Microsoft implementation of Windows Sockets 2).
ucsSsoError = &H1007 ' Get error status and clear.
ucsSsoType = &H1008 ' Get socket type.
' ucsSsoGroupId = &H2001 ' Reserved.
' ucsSsoGroupPriority = &H2002 ' Reserved.
ucsSsoMaxMsgSize = &H2003 ' Maximum size of a message for message-oriented socket types (for example, SOCK_DGRAM). Has no meaning for stream oriented sockets.
ucsSsoProtocolInfo = &H2004 ' Description of protocol information for protocol that is bound to this socket.
ucsSsoReuseUnicastPort = &H3007 ' Defer ephemeral port allocation for outbound connections
ucsSsoMaxConnections = &H7FFFFFFF ' Maximum queue length specifiable by listen.
End Enum
Public Enum UcsAsyncSocketCodePageEnum
ucsScpAcp = 0
ucsScpOem = 1
ucsScpUtf8 = 65001
ucsScpUnicode = -1 '--- handled internally -> no conversion, keep text wide-char
ucsScpNone = ucsScpUnicode '--- and some more aliases
ucsScpWideChar = ucsScpUnicode
End Enum
'=========================================================================
' API
'=========================================================================
Private Const SOCKET_ERROR As Long = -1
Private Const INVALID_SOCKET As Long = -1
Private Const AF_INET As Long = 2
Private Const ERR_TIMEOUT As Long = &H800705B4
'--- for ioctlsocket
Private Const FIONREAD As Long = &H4004667F
'--- for WSAGetLastError
Private Const WSABASEERR As Long = 10000
Private Const WSAEINTR As Long = (WSABASEERR + 4)
Private Const WSAEINVAL As Long = (WSABASEERR + 22)
Private Const WSAEMFILE As Long = (WSABASEERR + 24)
Private Const WSAEWOULDBLOCK As Long = (WSABASEERR + 35)
Private Const WSAEALREADY As Long = (WSABASEERR + 37)
Private Const WSAENOTCONN As Long = (WSABASEERR + 57)
Private Const WSANOTINITIALISED As Long = (WSABASEERR + 93)
'--- for WSAAsyncGetHostByName
Private Const MAXGETHOSTSTRUCT As Long = 1024
Private Const INADDR_ANY As Long = 0
Private Const INADDR_NONE As Long = -1
'--- Windows Messages
Private Const WM_PAINT As Long = &HF
Private Const WM_TIMER As Long = &H113
Private Const WM_USER As Long = &H400
Private Const WM_SOCKET_RESOLVE As Long = WM_USER + 1
Private Const WM_SOCKET_NOTIFY As Long = WM_USER + 2
'--- for Get/SetWindowLong
Private Const GWL_USERDATA As Long = (-21)
Private Const HWND_MESSAGE As Long = -3
'--- for PeekMessage
Private Const PM_NOREMOVE As Long = 0
Private Const PM_REMOVE As Long = 1
'--- for FormatMessage
Private Const FORMAT_MESSAGE_FROM_SYSTEM As Long = &H1000
Private Const FORMAT_MESSAGE_IGNORE_INSERTS As Long = &H200
'--- for Modern Subclassing Thunk (MST)
Private Const MEM_COMMIT As Long = &H1000
Private Const PAGE_EXECUTE_READWRITE As Long = &H40
Private Const CRYPT_STRING_BASE64 As Long = 1
Private Const SIGN_BIT As Long = &H80000000
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function ArrPtr Lib "msvbvm60" Alias "VarPtr" (Ptr() As Any) As Long
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As Long) As Long
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWndParent As Long, ByVal hWndChildAfter As Long, ByVal lpszClass As String, ByVal lpszWindow As String) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare Function FormatMessage Lib "kernel32" Alias "FormatMessageA" (ByVal dwFlags As Long, lpSource As Long, ByVal dwMessageId As Long, ByVal dwLanguageId As Long, ByVal lpBuffer As String, ByVal nSize As Long, Args As Any) As Long
Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function WideCharToMultiByte Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long, lpMultiByteStr As Any, ByVal cchMultiByte As Long, ByVal lpDefaultChar As Long, ByVal lpUsedDefaultChar As Long) As Long
Private Declare Function MultiByteToWideChar Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, lpMultiByteStr As Any, ByVal cchMultiByte As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long) 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 lX As Long, ByVal lY 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 SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function vbaObjSetAddref Lib "msvbvm60" Alias "__vbaObjSetAddref" (oDest As Any, ByVal lSrcPtr As Long) As Long
Private Declare Function GetCurrentProcessId Lib "kernel32" () As Long
Private Declare Function WSAStartup Lib "ws2_32" (ByVal wVersionRequired As Long, lpWSAData As Any) As Long
Private Declare Function WSACleanup Lib "ws2_32" () As Long
Private Declare Function WSAAsyncGetHostByName Lib "ws2_32" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal strHostName As String, buf As Any, ByVal BufLen As Long) As Long
Private Declare Function WSAAsyncSelect Lib "ws2_32" (ByVal s As Long, ByVal hWnd As Long, ByVal wMsg As Long, ByVal lEvent As Long) As Long
Private Declare Function WSACancelAsyncRequest Lib "ws2_32" (ByVal hAsyncTaskHandle As Long) As Long
Private Declare Function ws_connect Lib "ws2_32" Alias "connect" (ByVal s As Long, ByRef Name As SOCKADDR_IN, ByVal namelen As Long) As Long
Private Declare Function ws_socket Lib "ws2_32" Alias "socket" (ByVal af As Long, ByVal s_type As Long, ByVal Protocol As Long) As Long
Private Declare Function ws_bind Lib "ws2_32" Alias "bind" (ByVal s As Long, ByRef Name As SOCKADDR_IN, ByRef namelen As Long) As Long
Private Declare Function ws_htonl Lib "ws2_32" Alias "htonl" (ByVal hostlong As Long) As Long
Private Declare Function ws_htons Lib "ws2_32" Alias "htons" (ByVal hostshort As Long) As Integer
Private Declare Function ws_ntohs Lib "ws2_32" Alias "ntohs" (ByVal netshort As Long) As Integer
Private Declare Function ws_inet_ntoa Lib "ws2_32" Alias "inet_ntoa" (ByVal inn As Long) As Long
Private Declare Function ws_recv Lib "ws2_32" Alias "recv" (ByVal s As Long, ByRef buf As Any, ByVal BufLen As Long, ByVal Flags As Long) As Long
Private Declare Function ws_recvfrom Lib "ws2_32" Alias "recvfrom" (ByVal s As Long, ByRef buf As Any, ByVal BufLen As Long, ByVal Flags As Long, ByRef from As SOCKADDR_IN, ByRef fromlen As Long) As Long
Private Declare Function ws_send Lib "ws2_32" Alias "send" (ByVal s As Long, ByRef buf As Any, ByVal BufLen As Long, ByVal Flags As Long) As Long
Private Declare Function ws_sendto Lib "ws2_32" Alias "sendto" (ByVal s As Long, ByRef buf As Any, ByVal BufLen As Long, ByVal Flags As Long, ByRef toaddr As SOCKADDR_IN, ByVal tolen As Long) As Long
Private Declare Function ws_getpeername Lib "ws2_32" Alias "getpeername" (ByVal s As Long, ByRef Name As SOCKADDR_IN, ByRef namelen As Long) As Long
Private Declare Function ws_getsockname Lib "ws2_32" Alias "getsockname" (ByVal s As Long, ByRef Name As SOCKADDR_IN, ByRef namelen As Long) As Long
Private Declare Function ws_shutdown Lib "ws2_32" Alias "shutdown" (ByVal s As Long, ByVal How As Long) As Long
Private Declare Function ws_listen Lib "ws2_32" Alias "listen" (ByVal s As Long, ByVal backlog As Long) As Long
Private Declare Function ws_accept Lib "ws2_32" Alias "accept" (ByVal s As Long, Addr As Any, addrlen As Any) As Long
Private Declare Function ws_ioctlsocket Lib "ws2_32" Alias "ioctlsocket" (ByVal s As Long, ByVal cmd As Long, argp As Long) As Long
Private Declare Function ws_getsockopt Lib "ws2_32" Alias "getsockopt" (ByVal s As Long, ByVal Level As Long, ByVal optname As Long, optval As Any, optlen As Long) As Long
Private Declare Function ws_setsockopt Lib "ws2_32" Alias "setsockopt" (ByVal s As Long, ByVal Level As Long, ByVal optname As Long, optval As Any, ByVal optlen As Long) As Long
Private Declare Function ws_inet_addr Lib "ws2_32" Alias "inet_addr" (ByVal cp As String) As Long
Private Declare Function ws_gethostbyname Lib "ws2_32" Alias "gethostbyname" (ByVal host_name As String) As Long
Private Declare Function ws_gethostname Lib "ws2_32" Alias "gethostname" (ByVal host_name As String, ByVal namelen As Long) As Long
#If ImplSync Then
Private Declare Function PeekMessage Lib "user32" Alias "PeekMessageA" (lpMsg As APIMSG, ByVal hWnd As Long, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long, ByVal wRemoveMsg As Long) As Long
Private Declare Function DispatchMessage Lib "user32" Alias "DispatchMessageA" (lpMsg As APIMSG) As Long
Private Declare Function SetTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long) As Long
Private Declare Function WaitMessage Lib "user32" () As Long
#End If
#If Not ImplUseShared Then
Private Declare Function QueryPerformanceCounter Lib "kernel32" (lpPerformanceCount As Currency) As Long
Private Declare Function QueryPerformanceFrequency Lib "kernel32" (lpFrequency As Currency) As Long
'--- for Modern Subclassing Thunk (MST)
Private Declare Function VirtualAlloc Lib "kernel32" (ByVal lpAddress As Long, ByVal dwSize As Long, ByVal flAllocationType As Long, ByVal flProtect As Long) As Long
Private Declare Function CryptStringToBinary Lib "crypt32" Alias "CryptStringToBinaryA" (ByVal pszString As String, ByVal cchString As Long, ByVal dwFlags As Long, ByVal pbBinary As Long, pcbBinary As Long, Optional ByVal pdwSkip As Long, Optional ByVal pdwFlags As Long) As Long
Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
Private Declare Function GetProcAddressByOrdinal Lib "kernel32" Alias "GetProcAddress" (ByVal hModule As Long, ByVal lpProcOrdinal As Long) As Long
Private Declare Function DefSubclassProc Lib "comctl32" Alias "#413" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hWnd As Long, lpdwProcessId As Long) As Long
Private Declare Function GetEnvironmentVariable Lib "kernel32" Alias "GetEnvironmentVariableA" (ByVal lpName As String, ByVal lpBuffer As String, ByVal nSize As Long) As Long
Private Declare Function SetEnvironmentVariable Lib "kernel32" Alias "SetEnvironmentVariableA" (ByVal lpName As String, ByVal lpValue As String) As Long
'--- end MST
#End If
Private Type SOCKADDR_IN
sin_family As Integer
sin_port As Integer
sin_addr As Long
sin_zero(1 To 8) As Byte
End Type
Private Type APIPOINT
X As Long
Y As Long
End Type
Private Type APIMSG
hWnd As Long
lMessage As Long
wParam As Long
lParam As Long
lTime As Long
pt As APIPOINT
End Type
'=========================================================================
' Constants and member variables
'=========================================================================
Private Const STR_HELPER_CLASS As String = "STATIC"
Private Const STR_HELPER_NAME As String = "AsyncSocket Helper Window"
Private Const STR_CHR1 As String = "" '--- CHAR(1)
Private Const DEF_TIMEOUT As Long = 5000
'--- helper window
Private Const MAX_SOCKETS As Long = &HC000 - WM_SOCKET_NOTIFY
Private m_hSocket As Long
Private m_pCleanup As IUnknown
Private m_oHelperWindow As cAsyncSocket
Private m_lIndex As Long
Private m_lLastError As Long
Private m_uGetHostByName() As UcsAsyncGetHostByNameType
Private m_uWindowState() As UcsHelperWindowStateType
#If ImplSync Then
Private m_cMsgQueue As Collection
Private m_bBlocking As Boolean
#End If
Private Type UcsAsyncGetHostByNameType
Handle As Long
Port As Long
Buffer(0 To MAXGETHOSTSTRUCT) As Byte
End Type
Private Type UcsHelperWindowStateType
hWnd As Long
Subclass As IUnknown
Cleanup As IUnknown
SocketPtr() As Long
Pos As Long
Count As Long
End Type
'=========================================================================
' Error handling
'=========================================================================
Private Sub PrintError(sFunction As String)
Debug.Print "Critical error: " & Err.Description & " [" & MODULE_NAME & "." & sFunction & "]"
End Sub
'=========================================================================
' Properties
'=========================================================================
Property Get SocketHandle() As Long
SocketHandle = m_hSocket
End Property
Property Get LastError() As Long
LastError = m_lLastError
End Property
Property Get SockOpt(ByVal OptionName As UcsAsyncSocketOptionNameEnum, Optional ByVal Level As UcsAsyncSocketOptionLevelEnum = ucsSolSocket) As Long
Call ws_getsockopt(m_hSocket, Level, OptionName, SockOpt, 4)
m_lLastError = Err.LastDllError
End Property
Property Let SockOpt(ByVal OptionName As UcsAsyncSocketOptionNameEnum, Optional ByVal Level As UcsAsyncSocketOptionLevelEnum = ucsSolSocket, ByVal Value As Long)
Call ws_setsockopt(m_hSocket, Level, OptionName, Value, 4)
m_lLastError = Err.LastDllError
End Property
Property Get AvailableBytes() As Long
If Not IOCtl(FIONREAD, AvailableBytes) Then
AvailableBytes = SOCKET_ERROR
End If
End Property
Property Get HasPendingEvent() As Boolean
HasPendingEvent = (m_lLastError = WSAEWOULDBLOCK)
End Property
Property Get HasPendingResolve() As Boolean
HasPendingResolve = pvResolveHandle <> 0
End Property
'= helper window =========================================================
Friend Property Get frMessageHWnd() As Long
If Peek(ArrPtr(m_uWindowState)) <> 0 Then
frMessageHWnd = m_uWindowState(0).hWnd
End If
End Property
'= private ===============================================================
Private Property Get pvResolveHandle() As Long
If Peek(ArrPtr(m_uGetHostByName)) <> 0 Then
pvResolveHandle = m_uGetHostByName(0).Handle
End If
End Property
'=========================================================================
' Methods
'=========================================================================
Public Function Create( _
Optional ByVal SocketPort As Long, _
Optional ByVal SocketType As UcsAsyncSocketTypeEnum = ucsSckStream, _
Optional ByVal EventMask As UcsAsyncSocketEventMaskEnum = ucsSfdAll, _
Optional SocketAddress As String) As Boolean
Const FUNC_NAME As String = "Create"
On Error GoTo EH
If m_hSocket <> INVALID_SOCKET Then
m_lLastError = WSAEALREADY
GoTo QH
End If
If m_oHelperWindow.frMessageHWnd = 0 Then
m_lLastError = WSANOTINITIALISED
GoTo QH
End If
m_hSocket = ws_socket(AF_INET, SocketType, 0)
If m_hSocket = INVALID_SOCKET Then
m_lLastError = Err.LastDllError
GoTo QH
End If
Set m_pCleanup = InitCleanupThunk(m_hSocket, "ws2_32", "closesocket")
If Not m_oHelperWindow.frAddSocket(Me, m_lIndex) Then
m_lLastError = WSAEMFILE
pvClose
GoTo QH
End If
If Not AsyncSelect(EventMask) Then
pvClose
GoTo QH
End If
If SocketPort <> 0 Then
If Not Bind(SocketAddress, SocketPort) Then
pvClose
GoTo QH
End If
End If
'--- success
m_lLastError = 0
Create = True
QH:
Exit Function
EH:
PrintError FUNC_NAME
End Function
Public Function Attach( _
ByVal SocketHandle As Long, _
Optional ByVal EventMask As UcsAsyncSocketEventMaskEnum = ucsSfdAll) As Boolean
Const FUNC_NAME As String = "Attach"
On Error GoTo EH
If m_hSocket <> INVALID_SOCKET Then
m_lLastError = WSAEALREADY
GoTo QH
End If
m_hSocket = SocketHandle
If Not m_oHelperWindow.frAddSocket(Me, m_lIndex) Then
m_hSocket = INVALID_SOCKET
m_lLastError = WSAEMFILE
GoTo QH
End If
Set m_pCleanup = InitCleanupThunk(m_hSocket, "ws2_32", "closesocket")
If Not AsyncSelect(EventMask) Then
GoTo QH
End If
'--- success
m_lLastError = 0
Attach = True
QH:
Exit Function
EH:
PrintError FUNC_NAME
End Function
Public Function Detach() As Long
Const FUNC_NAME As String = "Detach"
On Error GoTo EH
m_lLastError = 0
Detach = m_hSocket
'--- note: prevent closesocket(m_hSocket) being called
ThunkPrivateData(m_pCleanup) = INVALID_SOCKET
m_oHelperWindow.frRemoveSocket Me, m_lIndex
m_hSocket = INVALID_SOCKET
Set m_pCleanup = Nothing
Exit Function
EH:
PrintError FUNC_NAME
End Function
Public Function GetPeerName(PeerAddress As String, PeerPort As Long) As Boolean
Const FUNC_NAME As String = "GetPeerName"
Dim uAddr As SOCKADDR_IN
On Error GoTo EH
If ws_getpeername(m_hSocket, uAddr, LenB(uAddr)) = SOCKET_ERROR Then
m_lLastError = Err.LastDllError
GoTo QH
End If
pvFromSockAddr uAddr, PeerAddress, PeerPort
'--- success
m_lLastError = 0
GetPeerName = True
QH:
Exit Function
EH:
PrintError FUNC_NAME
End Function
Public Function GetSockName(SocketAddress As String, SocketPort As Long) As Boolean
Const FUNC_NAME As String = "GetSockName"
Dim uAddr As SOCKADDR_IN
On Error GoTo EH
If ws_getsockname(m_hSocket, uAddr, LenB(uAddr)) = SOCKET_ERROR Then
m_lLastError = Err.LastDllError
GoTo QH
End If
pvFromSockAddr uAddr, SocketAddress, SocketPort
'--- success
m_lLastError = 0
GetSockName = True
QH:
Exit Function
EH:
PrintError FUNC_NAME
End Function
Public Function GetLocalHost(HostName As String, HostAddress As String) As Boolean
Const FUNC_NAME As String = "GetLocalHost"
Dim sBuffer As String
Dim uAddr As SOCKADDR_IN
On Error GoTo EH
sBuffer = String$(256, 0)
If ws_gethostname(sBuffer, Len(sBuffer) - 1) = SOCKET_ERROR Then
m_lLastError = Err.LastDllError
GoTo QH
End If
HostName = Left$(sBuffer, InStr(sBuffer, Chr$(0)) - 1)
pvToSockAddr HostName, 0, uAddr
pvFromSockAddr uAddr, HostAddress, 0
'--- success
m_lLastError = 0
GetLocalHost = True
QH:
Exit Function
EH:
PrintError FUNC_NAME
End Function
Public Function Accept(ConnectedSocket As cAsyncSocket, Optional SocketAddress As String, Optional SocketPort As Long) As Boolean
Const FUNC_NAME As String = "Accept"
Dim hTemp As Long
Dim uAddr As SOCKADDR_IN
On Error GoTo EH
If SocketPort = 0 Then
hTemp = ws_accept(m_hSocket, ByVal 0, ByVal 0)
Else
pvToSockAddr SocketAddress, SocketPort, uAddr
hTemp = ws_accept(m_hSocket, uAddr, LenB(uAddr))
End If
If hTemp = INVALID_SOCKET Then
m_lLastError = Err.LastDllError
GoTo QH
End If
If Not ConnectedSocket.Attach(hTemp) Then
m_lLastError = ConnectedSocket.LastError
GoTo QH
End If
'--- success
m_lLastError = 0
Accept = True
QH:
Exit Function
EH:
PrintError FUNC_NAME
End Function
Public Function AsyncSelect(Optional ByVal EventMask As UcsAsyncSocketEventMaskEnum = ucsSfdAll) As Boolean
Const FUNC_NAME As String = "AsyncSelect"
On Error GoTo EH
If WSAAsyncSelect(m_hSocket, m_oHelperWindow.frMessageHWnd, WM_SOCKET_NOTIFY + m_lIndex, EventMask) = SOCKET_ERROR Then
m_lLastError = Err.LastDllError
GoTo QH
End If
'--- success
m_lLastError = 0
AsyncSelect = True
QH:
Exit Function
EH:
PrintError FUNC_NAME
End Function
Public Function Bind(Optional SocketAddress As String, Optional ByVal SocketPort As Long) As Boolean
Const FUNC_NAME As String = "Bind"
Dim uAddr As SOCKADDR_IN
On Error GoTo EH
If Not pvToSockAddr(SocketAddress, SocketPort, uAddr) Then
GoTo QH
End If
If ws_bind(m_hSocket, uAddr, LenB(uAddr)) = SOCKET_ERROR Then
m_lLastError = Err.LastDllError
GoTo QH
End If
'--- success
m_lLastError = 0
Bind = True
QH:
Exit Function
EH:
PrintError FUNC_NAME
End Function
Public Sub Close_()
Const FUNC_NAME As String = "Close_"
On Error GoTo EH
If pvResolveHandle <> 0 Then
Call WSACancelAsyncRequest(m_uGetHostByName(0).Handle)
Erase m_uGetHostByName
End If
If m_hSocket <> INVALID_SOCKET Then
Call ws_shutdown(m_hSocket, 1)
pvClose
End If
Exit Sub
EH:
PrintError FUNC_NAME
End Sub
Public Function Connect(HostAddress As String, ByVal HostPort As Long) As Boolean
Const FUNC_NAME As String = "Connect"
Dim uAddr As SOCKADDR_IN
On Error GoTo EH
If m_hSocket = INVALID_SOCKET Then
Create
End If
If Not pvToSockAddr(HostAddress, HostPort, uAddr, Resolve:=False) Then
ReDim m_uGetHostByName(0 To 0) As UcsAsyncGetHostByNameType
m_uGetHostByName(0).Port = HostPort
'--- note: concat "" to prevent passing NULL for HostAddress
m_uGetHostByName(0).Handle = WSAAsyncGetHostByName(m_oHelperWindow.frMessageHWnd, WM_SOCKET_RESOLVE, HostAddress & "", m_uGetHostByName(0).Buffer(0), MAXGETHOSTSTRUCT)
If m_uGetHostByName(0).Handle = 0 Then
m_lLastError = Err.LastDllError
Erase m_uGetHostByName
GoTo QH
End If
m_lLastError = WSAEWOULDBLOCK
Else
If SockOpt(ucsSsoType) = ucsSckStream Then
If ws_connect(m_hSocket, uAddr, LenB(uAddr)) = SOCKET_ERROR Then
m_lLastError = Err.LastDllError
If m_lLastError <> WSAEWOULDBLOCK Then
GoTo QH
End If
Else
PostEvent ucsSfdConnect
End If
Else
PostEvent ucsSfdConnect
End If
End If
'--- success
m_lLastError = 0
Connect = True
QH:
Exit Function
EH:
PrintError FUNC_NAME
End Function
Public Function IOCtl(ByVal Command As Long, Argument As Long) As Boolean
Const FUNC_NAME As String = "IOCtl"
On Error GoTo EH
If ws_ioctlsocket(m_hSocket, Command, Argument) = SOCKET_ERROR Then
m_lLastError = Err.LastDllError
GoTo QH
End If
'--- success
m_lLastError = 0
IOCtl = True
QH:
Exit Function
EH:
PrintError FUNC_NAME
End Function
Public Function Listen(Optional ByVal ConnectionBacklog As Long = 5) As Boolean
Const FUNC_NAME As String = "Listen"
On Error GoTo EH
If ws_listen(m_hSocket, ConnectionBacklog) = SOCKET_ERROR Then
m_lLastError = Err.LastDllError
GoTo QH
End If
'--- success
m_lLastError = 0
Listen = True
QH:
Exit Function
EH:
PrintError FUNC_NAME
End Function
Public Function ReceiveText( _
Optional HostAddress As String = STR_CHR1, _
Optional HostPort As Long, _
Optional ByVal CodePage As UcsAsyncSocketCodePageEnum = ucsScpUtf8) As String
Const FUNC_NAME As String = "ReceiveText"
Dim baBuffer() As Byte
On Error GoTo EH
If ReceiveArray(baBuffer, HostAddress, HostPort) Then
ReceiveText = FromTextArray(baBuffer, CodePage)
End If
Exit Function
EH:
PrintError FUNC_NAME
End Function
Public Function ReceiveArray( _
Buffer() As Byte, _
Optional HostAddress As String = STR_CHR1, _
Optional HostPort As Long, _
Optional ByVal Flags As Long = 0) As Boolean
Const FUNC_NAME As String = "ReceiveArray"
Dim uAddr As SOCKADDR_IN
Dim lBytes As Long
On Error GoTo EH
lBytes = AvailableBytes
If lBytes <= 0 Then
Buffer = vbNullString
Else
ReDim Buffer(0 To lBytes - 1) As Byte
If HostAddress <> STR_CHR1 Then
lBytes = ws_recvfrom(m_hSocket, Buffer(0), lBytes, Flags, uAddr, LenB(uAddr))
Else
lBytes = ws_recv(m_hSocket, Buffer(0), lBytes, Flags)
End If
If lBytes = SOCKET_ERROR Then
m_lLastError = Err.LastDllError
GoTo QH
End If
If uAddr.sin_family <> 0 Then
pvFromSockAddr uAddr, HostAddress, HostPort
End If
End If
'--- success
m_lLastError = 0
ReceiveArray = True
QH:
Exit Function
EH:
PrintError FUNC_NAME
End Function
Public Function Receive( _
ByVal BufPtr As Long, _
ByVal BufLen As Long, _
Optional HostAddress As String = STR_CHR1, _
Optional HostPort As Long, _
Optional ByVal Flags As Long = 0) As Long
Const FUNC_NAME As String = "Receive"
Dim uAddr As SOCKADDR_IN
On Error GoTo EH
If HostAddress <> STR_CHR1 Then
Receive = ws_recvfrom(m_hSocket, ByVal BufPtr, BufLen, Flags, uAddr, LenB(uAddr))
Else
Receive = ws_recv(m_hSocket, ByVal BufPtr, BufLen, Flags)
End If
If Receive = SOCKET_ERROR Then
m_lLastError = Err.LastDllError
GoTo QH
End If
If uAddr.sin_family <> 0 Then
pvFromSockAddr uAddr, HostAddress, HostPort
End If
'--- success
m_lLastError = 0
QH:
Exit Function
EH:
PrintError FUNC_NAME
End Function
Public Function SendText( _
Text As String, _
Optional HostAddress As String, _
Optional ByVal HostPort As Long, _
Optional ByVal CodePage As UcsAsyncSocketCodePageEnum = ucsScpUtf8) As Boolean
Const FUNC_NAME As String = "SendText"
On Error GoTo EH
SendText = SendArray(ToTextArray(Text, CodePage), HostAddress, HostPort)
Exit Function
EH:
PrintError FUNC_NAME
End Function
Public Function SendArray( _
Buffer() As Byte, _
Optional HostAddress As String, _
Optional ByVal HostPort As Long, _
Optional ByVal Flags As Long = 0) As Boolean
Const FUNC_NAME As String = "SendArray"
Dim uAddr As SOCKADDR_IN
Dim lBytes As Long
Dim lResult As Long
On Error GoTo EH
If LenB(HostAddress) <> 0 Then
If Not pvToSockAddr(HostAddress, HostPort, uAddr) Then
GoTo QH
End If
End If
Do
If uAddr.sin_family <> 0 Then
lResult = ws_sendto(m_hSocket, Buffer(lBytes), UBound(Buffer) + 1 - lBytes, Flags, uAddr, LenB(uAddr))
Else
lResult = ws_send(m_hSocket, Buffer(lBytes), UBound(Buffer) + 1 - lBytes, Flags)
End If
If lResult < 0 Then
m_lLastError = Err.LastDllError
GoTo QH
End If
lBytes = lBytes + lResult
Loop While lBytes <= UBound(Buffer)
'--- success
m_lLastError = 0
SendArray = True
QH:
Exit Function
EH:
PrintError FUNC_NAME
End Function
Public Function Send( _
ByVal BufPtr As Long, _
ByVal BufLen As Long, _
Optional HostAddress As String, _
Optional ByVal HostPort As Long, _
Optional ByVal Flags As Long = 0) As Long
Const FUNC_NAME As String = "Send"
Dim uAddr As SOCKADDR_IN
On Error GoTo EH
If LenB(HostAddress) <> 0 Then
If Not pvToSockAddr(HostAddress, HostPort, uAddr) Then
Send = SOCKET_ERROR
GoTo QH
End If
End If
If uAddr.sin_family <> 0 Then
Send = ws_sendto(m_hSocket, ByVal BufPtr, BufLen, Flags, uAddr, LenB(uAddr))
Else
Send = ws_send(m_hSocket, ByVal BufPtr, BufLen, Flags)
End If
If Send = SOCKET_ERROR Then
m_lLastError = Err.LastDllError
GoTo QH
End If
'--- success
m_lLastError = 0
QH:
Exit Function
EH:
PrintError FUNC_NAME
End Function
Public Function ShutDown(Optional ByVal How As Long = 1) As Boolean
Const FUNC_NAME As String = "ShutDown"
On Error GoTo EH
If ws_shutdown(m_hSocket, How) = SOCKET_ERROR Then
m_lLastError = Err.LastDllError
GoTo QH
End If
'--- success
m_lLastError = 0
ShutDown = True
QH:
Exit Function
EH:
PrintError FUNC_NAME
End Function
Public Function GetErrorDescription(ByVal ErrorCode As Long) As String
Const FUNC_NAME As String = "GetErrorDescription"
Dim lSize As Long
On Error GoTo EH
GetErrorDescription = Space$(2000)
lSize = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM Or FORMAT_MESSAGE_IGNORE_INSERTS, 0&, ErrorCode, 0, GetErrorDescription, Len(GetErrorDescription) + 1, 0)
If lSize > 2 Then
If Mid$(GetErrorDescription, lSize - 1, 2) = vbCrLf Then
lSize = lSize - 2
End If
End If
GetErrorDescription = Left$(GetErrorDescription, lSize)
Exit Function
EH:
PrintError FUNC_NAME
End Function
Public Sub PostEvent(ByVal EventMask As UcsAsyncSocketEventMaskEnum)
Const FUNC_NAME As String = "PostEvent"
On Error GoTo EH
Call PostMessage(m_oHelperWindow.frMessageHWnd, WM_SOCKET_NOTIFY + m_lIndex, m_hSocket, EventMask)
Exit Sub
EH:
PrintError FUNC_NAME
End Sub
'= static helpers ========================================================
Public Function FromTextArray(baText() As Byte, Optional ByVal CodePage As UcsAsyncSocketCodePageEnum = ucsScpUtf8) As String
Const FUNC_NAME As String = "FromTextArray"
Dim lSize As Long
On Error GoTo EH
If CodePage = ucsScpUnicode Then
FromTextArray = baText
ElseIf UBound(baText) >= 0 Then
FromTextArray = String$(2 * (UBound(baText) + 1), 0)
lSize = MultiByteToWideChar(CodePage, 0, baText(0), UBound(baText) + 1, StrPtr(FromTextArray), Len(FromTextArray) + 1)
If lSize <> Len(FromTextArray) Then
FromTextArray = Left$(FromTextArray, lSize)
End If
End If
Exit Function
EH:
PrintError FUNC_NAME
End Function
Public Function ToTextArray(sText As String, Optional ByVal CodePage As UcsAsyncSocketCodePageEnum = ucsScpUtf8) As Byte()
Const FUNC_NAME As String = "ToTextArray"
Dim baRetVal() As Byte
Dim lSize As Long
On Error GoTo EH
If CodePage = ucsScpUnicode Then
baRetVal = sText
ElseIf LenB(sText) <> 0 Then
ReDim baRetVal(0 To 2 * Len(sText)) As Byte
lSize = WideCharToMultiByte(CodePage, 0, StrPtr(sText), Len(sText), baRetVal(0), UBound(baRetVal) + 1, 0, 0)
If lSize > 0 Then
ReDim Preserve baRetVal(0 To lSize - 1) As Byte
Else
baRetVal = vbNullString
End If
Else
baRetVal = vbNullString
End If
ToTextArray = baRetVal
Exit Function
EH:
PrintError FUNC_NAME
End Function
'= friend ================================================================
Friend Function frNotifyEvent(ByVal wParam As Long, ByVal lParam As Long) As Boolean
If m_hSocket = wParam Then
#If ImplSync Then
SyncProcessMsgQueue
#End If
pvDoNotify wParam, lParam
'--- handled
frNotifyEvent = True
End If
End Function
Friend Function frNotifyGetHostByName(ByVal wParam As Long, ByVal lParam As Long) As Boolean
If pvResolveHandle = wParam Then
#If ImplSync Then
SyncProcessMsgQueue
#End If
pvDoResolve wParam, lParam
'--- handled
frNotifyGetHostByName = True
End If
End Function
Private Sub pvDoNotify(ByVal wParam As Long, ByVal lParam As Long)
Dim eEvent As UcsAsyncSocketEventMaskEnum
Dim lErrorCode As Long
Dim lBytes As Long
If m_hSocket = wParam Then
eEvent = lParam And &HFFFF&
lErrorCode = lParam \ &H10000
If lErrorCode <> 0 Then
m_lLastError = lErrorCode
RaiseEvent OnError(lErrorCode, eEvent)
Else
Select Case eEvent
Case ucsSfdRead
If Not IOCtl(FIONREAD, lBytes) Then
RaiseEvent OnError(m_lLastError, eEvent)
If m_hSocket = INVALID_SOCKET Then
GoTo QH
End If
End If
If lBytes <> 0 Then
m_lLastError = 0
RaiseEvent OnReceive
End If
Case [_ucsSfdForceRead]
m_lLastError = 0
RaiseEvent OnReceive
Case ucsSfdWrite
m_lLastError = 0
RaiseEvent OnSend
Case ucsSfdConnect
m_lLastError = 0
RaiseEvent OnConnect
Case ucsSfdAccept
m_lLastError = 0
RaiseEvent OnAccept
Case ucsSfdClose
m_lLastError = 0
RaiseEvent OnClose
End Select
End If
End If
QH:
End Sub
Private Sub pvDoResolve(ByVal wParam As Long, ByVal lParam As Long)
Dim lErrorCode As Long
Dim uAddr As SOCKADDR_IN
Dim lPtr As Long
If pvResolveHandle = wParam Then
lErrorCode = lParam \ &H10000
If lErrorCode <> 0 Then
Erase m_uGetHostByName
m_lLastError = lErrorCode
RaiseEvent OnError(lErrorCode, [_ucsSfdResolve])
Else
uAddr.sin_family = AF_INET
uAddr.sin_port = ws_htons(m_uGetHostByName(0).Port)
'--- set sin_addr to first IP address resolved
Call CopyMemory(lPtr, m_uGetHostByName(0).Buffer(12), 4)
Call CopyMemory(lPtr, ByVal lPtr, 4)
Call CopyMemory(uAddr.sin_addr, ByVal lPtr, 4)
Erase m_uGetHostByName
m_lLastError = 0
RaiseEvent OnResolve(pvToString(ws_inet_ntoa(uAddr.sin_addr)))
If m_hSocket = INVALID_SOCKET Then
m_lLastError = WSAEINTR
GoTo QH
End If
If SockOpt(ucsSsoType) = ucsSckStream Then
'--- note uAddr is prepared above, before m_uGetHostByName being erased
If ws_connect(m_hSocket, uAddr, LenB(uAddr)) = SOCKET_ERROR Then
m_lLastError = Err.LastDllError
If m_lLastError <> WSAEWOULDBLOCK Then
RaiseEvent OnError(m_lLastError, ucsSfdConnect)
End If
Else
PostEvent ucsSfdConnect
End If
Else
PostEvent ucsSfdConnect
End If
End If
End If
QH:
End Sub
Private Function pvToSockAddr( _
Address As String, _
ByVal Port As Long, _
uAddr As SOCKADDR_IN, _
Optional ByVal Resolve As Boolean = True) As Boolean
Dim lPtr As Long
uAddr.sin_family = AF_INET
If LenB(Address) = 0 Then
uAddr.sin_addr = ws_htonl(INADDR_ANY)
Else
uAddr.sin_addr = ws_inet_addr(Address)
If uAddr.sin_addr = INADDR_NONE Then
If Resolve Then
lPtr = ws_gethostbyname(Address)
End If
If lPtr = 0 Then
m_lLastError = WSAEINVAL
GoTo QH
End If
Call CopyMemory(lPtr, ByVal UnsignedAdd(lPtr, 12), 4)
Call CopyMemory(lPtr, ByVal lPtr, 4)
Call CopyMemory(uAddr.sin_addr, ByVal lPtr, 4)
End If
End If
uAddr.sin_port = ws_htons(Port)
'--- success
pvToSockAddr = True
QH:
End Function
Private Sub pvFromSockAddr(uAddr As SOCKADDR_IN, Address As String, Port As Long)
Port = pvToLong(ws_ntohs(uAddr.sin_port))
Address = pvToString(ws_inet_ntoa(uAddr.sin_addr))
End Sub
Private Function pvToLong(ByVal nLoWord As Integer) As Long
Call CopyMemory(pvToLong, nLoWord, 2)
End Function
Private Function pvToString(ByVal lPtr As Long) As String
If lPtr <> 0 Then
pvToString = String$(lstrlen(lPtr), 0)
Call CopyMemory(ByVal pvToString, ByVal lPtr, Len(pvToString))
End If
End Function
Private Sub pvClose()
'--- note: used in terminate -> no error handling
If m_hSocket <> INVALID_SOCKET Then
Call WSAAsyncSelect(m_hSocket, m_oHelperWindow.frMessageHWnd, 0, 0)
m_oHelperWindow.frRemoveSocket Me, m_lIndex
m_hSocket = INVALID_SOCKET
Set m_pCleanup = Nothing
End If
End Sub
'= sync ==================================================================
#If ImplSync Then
Public Function SyncConnect(HostAddress As String, ByVal HostPort As Long, Optional ByVal Timeout As Long) As Boolean
Const FUNC_NAME As String = "SyncConnect"
On Error GoTo EH
If Timeout = 0 Then
Timeout = DEF_TIMEOUT
End If
If Not Connect(HostAddress, HostPort) Then
GoTo QH
End If
If Not SyncWaitForEvent(Timeout, ucsSfdConnect) Then
GoTo QH
End If
'--- success
m_lLastError = 0
SyncConnect = True
QH:
Exit Function
EH:
PrintError FUNC_NAME
End Function
Public Function SyncReceiveText( _
Optional ByVal NeedLen As Long, _
Optional ByVal Timeout As Long, _
Optional HostAddress As String = STR_CHR1, _
Optional HostPort As Long, _
Optional ByVal CodePage As UcsAsyncSocketCodePageEnum = ucsScpUtf8) As String
Const FUNC_NAME As String = "SyncReceiveText"
Dim baText() As Byte
Dim dblTimer As Double
Dim lElapsed As Long
Dim baBuffer() As Byte
Dim bResult As Boolean
On Error GoTo EH
If Timeout = 0 Then
Timeout = Znl(SockOpt(ucsSsoReceiveTimeout), DEF_TIMEOUT)
End If
baText = vbNullString
dblTimer = TimerEx
Do
If Timeout > 0 Then
lElapsed = Int((TimerEx - dblTimer) * 1000)
If lElapsed >= Timeout Then
m_lLastError = ERR_TIMEOUT
GoTo QH
End If
End If
bResult = SyncReceiveArray(baBuffer, NeedLen - Len(SyncReceiveText), Timeout - lElapsed, HostAddress, HostPort)
ReDim Preserve baText(0 To UBound(baText) + UBound(baBuffer) + 1) As Byte
Call CopyMemory(baText(UBound(baText) - UBound(baBuffer)), baBuffer(0), UBound(baBuffer) + 1)
SyncReceiveText = FromTextArray(baText, CodePage)
If Not bResult Then
GoTo QH
End If
Loop While Len(SyncReceiveText) < NeedLen And NeedLen > 0
'--- success
m_lLastError = 0
QH:
Exit Function
EH:
PrintError FUNC_NAME
End Function
Public Function SyncReceiveArray( _
Buffer() As Byte, _
Optional ByVal NeedLen As Long, _
Optional ByVal Timeout As Long, _
Optional HostAddress As String = STR_CHR1, _
Optional HostPort As Long, _
Optional ByVal Flags As Long = 0) As Boolean
Const FUNC_NAME As String = "SyncReceiveArray"
Dim lAvailable As Long
Dim dblTimer As Double
Dim lResult As Long
Dim uAddr As SOCKADDR_IN
Dim lBytes As Long
Dim lElapsed As Long
On Error GoTo EH
If Timeout = 0 Then
Timeout = Znl(SockOpt(ucsSsoReceiveTimeout), DEF_TIMEOUT)
End If
lAvailable = NeedLen
If lAvailable <= 0 Then
lAvailable = AvailableBytes
End If
If lAvailable <= 0 Then
lAvailable = SockOpt(ucsSsoReceiveBuffer)
End If
If lAvailable <= 0 Then
lAvailable = 4096
End If
ReDim Buffer(0 To lAvailable - 1) As Byte
dblTimer = TimerEx
Do
If HostAddress <> STR_CHR1 Then
lResult = ws_recvfrom(m_hSocket, Buffer(lBytes), lAvailable - lBytes, Flags, uAddr, LenB(uAddr))
Else
lResult = ws_recv(m_hSocket, Buffer(lBytes), lAvailable - lBytes, Flags)
End If
If lResult = SOCKET_ERROR Then
m_lLastError = Err.LastDllError
If m_lLastError <> WSAEWOULDBLOCK Then
GoTo QH
End If
ElseIf lResult > 0 Then
If uAddr.sin_family <> 0 Then
pvFromSockAddr uAddr, HostAddress, HostPort
End If
lBytes = lBytes + lResult
If lBytes >= NeedLen Or NeedLen = 0 Then
Exit Do
End If
End If
If Timeout > 0 Then
lElapsed = Int((TimerEx - dblTimer) * 1000)
If lElapsed >= Timeout Then
m_lLastError = ERR_TIMEOUT
GoTo QH
End If
End If
If Not SyncWaitForEvent(Timeout - lElapsed, ucsSfdRead) Then
GoTo QH
End If
Loop
'--- success
m_lLastError = 0
SyncReceiveArray = True
QH:
If UBound(Buffer) + 1 <> lBytes Then
If lBytes > 0 Then
ReDim Preserve Buffer(0 To lBytes - 1) As Byte
Else
Buffer = vbNullString
End If
End If
Exit Function
EH:
PrintError FUNC_NAME
End Function
Public Function SyncReceive( _
ByVal BufPtr As Long, _
ByVal BufLen As Long, _
Received As Long, _
Optional ByVal Timeout As Long, _
Optional HostAddress As String = STR_CHR1, _
Optional HostPort As Long, _
Optional ByVal Flags As Long = 0) As Boolean
Const FUNC_NAME As String = "SyncReceive"
Dim lResult As Long
Dim uAddr As SOCKADDR_IN
On Error GoTo EH
If Timeout = 0 Then
Timeout = Znl(SockOpt(ucsSsoReceiveTimeout), DEF_TIMEOUT)
End If
Do
If HostAddress <> STR_CHR1 Then
lResult = ws_recvfrom(m_hSocket, ByVal BufPtr, BufLen, Flags, uAddr, LenB(uAddr))
Else
lResult = ws_recv(m_hSocket, ByVal BufPtr, BufLen, Flags)
End If
If lResult = SOCKET_ERROR Then
m_lLastError = Err.LastDllError
If m_lLastError <> WSAEWOULDBLOCK Then
GoTo QH
End If
If Not SyncWaitForEvent(Timeout, ucsSfdRead) Then
GoTo QH
End If
ElseIf lResult = 0 Then
If Not SyncWaitForEvent(Timeout, ucsSfdRead) Then
GoTo QH
End If
Else
If uAddr.sin_family <> 0 Then
pvFromSockAddr uAddr, HostAddress, HostPort
End If
Received = lResult
Exit Do
End If
Loop
'--- success
m_lLastError = 0
SyncReceive = True
QH:
Exit Function
EH:
PrintError FUNC_NAME
End Function
Public Function SyncSendText( _
Text As String, _
Optional ByVal Timeout As Long, _
Optional HostAddress As String, _
Optional ByVal HostPort As Long, _
Optional ByVal CodePage As UcsAsyncSocketCodePageEnum = ucsScpUtf8) As Boolean
Const FUNC_NAME As String = "SendText"
On Error GoTo EH
SyncSendText = SyncSendArray(ToTextArray(Text, CodePage), Timeout, HostAddress, HostPort)
Exit Function
EH:
PrintError FUNC_NAME
End Function
Public Function SyncSendArray( _
Buffer() As Byte, _
Optional ByVal Timeout As Long, _
Optional HostAddress As String, _
Optional ByVal HostPort As Long, _
Optional ByVal Flags As Long = 0) As Boolean
Const FUNC_NAME As String = "SyncSendArray"
On Error GoTo EH
If UBound(Buffer) < 0 Then
SyncSendArray = True
Else
SyncSendArray = SyncSend(VarPtr(Buffer(0)), UBound(Buffer) + 1, Timeout, HostAddress, HostPort, Flags)
End If
Exit Function
EH:
PrintError FUNC_NAME
End Function
Public Function SyncSend( _
ByVal BufPtr As Long, _
ByVal BufLen As Long, _
Optional ByVal Timeout As Long, _
Optional HostAddress As String, _
Optional ByVal HostPort As Long, _
Optional ByVal Flags As Long = 0) As Boolean
Const FUNC_NAME As String = "SyncSend"
Dim uAddr As SOCKADDR_IN
Dim lResult As Long
On Error GoTo EH
If Timeout = 0 Then
Timeout = Znl(SockOpt(ucsSsoSendTimeout), DEF_TIMEOUT)
End If
If LenB(HostAddress) <> 0 Then
If Not pvToSockAddr(HostAddress, HostPort, uAddr) Then
SyncSend = SOCKET_ERROR
GoTo QH
End If
End If
Do
Do
If uAddr.sin_family <> 0 Then
lResult = ws_sendto(m_hSocket, ByVal BufPtr, BufLen, Flags, uAddr, LenB(uAddr))
Else
lResult = ws_send(m_hSocket, ByVal BufPtr, BufLen, Flags)
End If
If lResult >= 0 Then
Exit Do
End If
m_lLastError = Err.LastDllError
If m_lLastError <> WSAEWOULDBLOCK Then
GoTo QH
End If
If Not SyncWaitForEvent(Timeout, ucsSfdWrite) Then
GoTo QH
End If
Loop
If lResult = BufLen Then
Exit Do
End If
BufPtr = UnsignedAdd(BufPtr, lResult)
BufLen = BufLen - lResult
Loop
'--- success
m_lLastError = 0
SyncSend = True
QH:
Exit Function
EH:
PrintError FUNC_NAME
End Function
Public Function SyncWaitForEvent( _
ByVal Timeout As Long, _
Optional ByVal EventMask As UcsAsyncSocketEventMaskEnum = ucsSfdAll) As Boolean
Const FUNC_NAME As String = "SyncWaitForEvent"
Dim hWnd As Long
Dim uMsg As APIMSG
Dim lTimerID As Long
Dim bBlocking As Boolean
Dim bHandled As Boolean
Dim bPeek As Boolean
On Error GoTo EH
'--- check if no pending resolution
If (EventMask And [_ucsSfdResolve]) <> 0 Then
If pvResolveHandle = 0 Then
'--- success
m_lLastError = 0
SyncWaitForEvent = True
GoTo QH
End If
End If
If (EventMask And ucsSfdRead) <> 0 Then
EventMask = EventMask Or [_ucsSfdForceRead]
End If
bBlocking = m_bBlocking
m_bBlocking = True
hWnd = m_oHelperWindow.frMessageHWnd
If Timeout > 0 Then
lTimerID = SetTimer(hWnd, 1, Timeout, 0)
End If
bPeek = True
Do
If PeekMessage(uMsg, hWnd, WM_SOCKET_NOTIFY + m_lIndex, WM_SOCKET_NOTIFY + m_lIndex, PM_REMOVE) <> 0 Then
If uMsg.wParam <> INVALID_SOCKET And uMsg.lParam <> 0 Then
If uMsg.wParam = m_hSocket Then
If m_cMsgQueue Is Nothing Then
Set m_cMsgQueue = New Collection
End If
m_cMsgQueue.Add Array(WM_SOCKET_NOTIFY, uMsg.wParam, uMsg.lParam)
If (uMsg.lParam And EventMask) <> 0 Then
'--- success
m_lLastError = 0
SyncWaitForEvent = True
Exit Do
End If
If (uMsg.lParam And ucsSfdClose) <> 0 Then
m_lLastError = WSAENOTCONN
Exit Do
End If
End If
bPeek = True
End If
End If
If PeekMessage(uMsg, hWnd, WM_SOCKET_RESOLVE, WM_SOCKET_RESOLVE, PM_REMOVE) <> 0 Then
If uMsg.wParam = pvResolveHandle Then
pvDoResolve uMsg.wParam, uMsg.lParam
If (EventMask And [_ucsSfdResolve]) <> 0 Then
'--- success
m_lLastError = 0
SyncWaitForEvent = True
Exit Do
End If
End If
bPeek = True
End If
If PeekMessage(uMsg, hWnd, WM_TIMER, WM_TIMER, PM_REMOVE) <> 0 Then
m_lLastError = ERR_TIMEOUT
Exit Do
End If
If Not m_bBlocking Then
m_lLastError = WSAEINTR
Exit Do
End If
If bPeek Then
If PeekMessage(uMsg, 0, 0, 0, PM_NOREMOVE) <> 0 Then
bHandled = False
RaiseEvent OnMessagePending(bHandled)
If m_hSocket = INVALID_SOCKET Then
m_lLastError = WSAEINTR
GoTo QH
End If
If Not bHandled Then
If PeekMessage(uMsg, 0, WM_PAINT, WM_PAINT, PM_REMOVE) <> 0 Then
Call DispatchMessage(uMsg)
If m_hSocket = INVALID_SOCKET Then
m_lLastError = WSAEINTR
GoTo QH
End If
End If
End If
bPeek = False
Else
Call WaitMessage
bPeek = True
End If
Else
Call WaitMessage
bPeek = True
End If
Loop
If lTimerID <> 0 Then
Call KillTimer(hWnd, lTimerID)
End If
If Not m_bBlocking Then
m_lLastError = WSAEINTR
GoTo QH
End If
QH:
m_bBlocking = bBlocking
If Not m_cMsgQueue Is Nothing Then
If m_cMsgQueue.Count > 0 Then
Call PostMessage(hWnd, WM_SOCKET_NOTIFY + m_lIndex, INVALID_SOCKET, 0)
End If
End If
Exit Function
EH:
PrintError FUNC_NAME
End Function
Public Sub SyncCancelWait()
m_bBlocking = False
End Sub
Public Sub SyncProcessMsgQueue()
Const FUNC_NAME As String = "SyncProcessMsgQueue"
Dim vElem As Variant
On Error GoTo EH
If Not m_cMsgQueue Is Nothing Then
Do While m_cMsgQueue.Count > 0
vElem = m_cMsgQueue.Item(1)
m_cMsgQueue.Remove 1
Select Case vElem(0)
Case WM_SOCKET_NOTIFY
pvDoNotify vElem(1), vElem(2)
Case WM_SOCKET_RESOLVE
pvDoResolve vElem(1), vElem(2)
End Select
Loop
End If
Exit Sub
EH:
PrintError FUNC_NAME
End Sub
#End If
'= helper window =========================================================
Friend Function frAddSocket(Socket As cAsyncSocket, Index As Long) As Boolean
Const FUNC_NAME As String = "frAddSocket"
Dim lSize As Long
Dim lIdx As Long
On Error GoTo EH
If frMessageHWnd = 0 Then
GoTo QH
End If
With m_uWindowState(0)
If Index <> -1 Then
Debug.Assert .SocketPtr(Index) = ObjPtr(Socket)
'--- success
frAddSocket = True
Exit Function
End If
lSize = UBound(.SocketPtr) + 1
If .Count >= lSize Then
lSize = 2 * lSize
If lSize > MAX_SOCKETS Then
lSize = MAX_SOCKETS
End If
ReDim Preserve .SocketPtr(0 To lSize - 1) As Long
End If
For lIdx = 0 To UBound(.SocketPtr)
Index = (.Pos + lIdx) Mod lSize
If .SocketPtr(Index) = 0 Then
'--- note: weak reference
.SocketPtr(Index) = ObjPtr(Socket)
.Pos = Index + 1
.Count = .Count + 1
'--- success
frAddSocket = True
Exit Function
End If
Next
End With
QH:
Index = -1
Exit Function
EH:
PrintError FUNC_NAME
GoTo QH
End Function
Friend Function frRemoveSocket(Socket As cAsyncSocket, Index As Long) As Boolean
Const FUNC_NAME As String = "frRemoveSocket"
On Error GoTo EH
If frMessageHWnd = 0 Then
GoTo QH
End If
With m_uWindowState(0)
If Index <> -1 Then
Debug.Assert .SocketPtr(Index) = ObjPtr(Socket)
.SocketPtr(Index) = 0
Index = -1
.Count = .Count - 1
End If
'--- success
frRemoveSocket = True
End With
QH:
Exit Function
EH:
PrintError FUNC_NAME
GoTo QH
End Function
Private Function pvHandleNotify(ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long, Handled As Boolean) As Long
Const FUNC_NAME As String = "pvHandleNotify"
Dim lIdx As Long
On Error GoTo EH
If frMessageHWnd = 0 Then
GoTo QH
End If
With m_uWindowState(0)
Select Case wMsg
Case WM_SOCKET_NOTIFY - 1
For lIdx = 0 To UBound(.SocketPtr)
If .SocketPtr(lIdx) <> 0 Then
If pvToSocket(.SocketPtr(lIdx)).frNotifyGetHostByName(wParam, lParam) Then
pvHandleNotify = 1
Handled = True
GoTo QH
End If
End If
Next
Case WM_SOCKET_NOTIFY To WM_SOCKET_NOTIFY + UBound(.SocketPtr)
If wParam <> INVALID_SOCKET Then
lIdx = wMsg - WM_SOCKET_NOTIFY
If .SocketPtr(lIdx) <> 0 Then
pvToSocket(.SocketPtr(lIdx)).frNotifyEvent wParam, lParam
pvHandleNotify = 1
Handled = True
End If
End If
End Select
End With
QH:
Exit Function
EH:
PrintError FUNC_NAME
Resume QH
End Function
Private Function pvToSocket(ByVal lPtr As Long) As cAsyncSocket
Call vbaObjSetAddref(pvToSocket, lPtr)
End Function
Private Property Get pvAddressOfSubclassProc() As cAsyncSocket
Set pvAddressOfSubclassProc = InitAddressOfMethod(Me, 5)
End Property
Public Function SubclassProc(ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long, Handled As Boolean) As Long
Attribute SubclassProc.VB_MemberFlags = "40"
#If hWnd Then '--- touch args
#End If
SubclassProc = pvHandleNotify(wMsg, wParam, lParam, Handled)
End Function
'= shared ================================================================
#If Not ImplUseShared Then
Private Property Get TimerEx() As Double
Dim cFreq As Currency
Dim cValue As Currency
Call QueryPerformanceFrequency(cFreq)
Call QueryPerformanceCounter(cValue)
TimerEx = cValue / cFreq
End Property
Private Function Znl(ByVal lValue As Long, Optional IfEmptyLong As Variant = Null, Optional ByVal EmptyLong As Long = 0) As Variant
Znl = IIf(lValue = EmptyLong, IfEmptyLong, lValue)
End Function
Private Function UnsignedAdd(ByVal lUnsignedPtr As Long, ByVal lSignedOffset As Long) As Long
'--- note: safely add *signed* offset to *unsigned* ptr for *unsigned* retval w/o overflow in LARGEADDRESSAWARE processes
UnsignedAdd = ((lUnsignedPtr Xor &H80000000) + lSignedOffset) Xor &H80000000
End Function
Private Function Peek(ByVal lPtr As Long) As Long
Call CopyMemory(Peek, ByVal lPtr, 4)
End Function
'=========================================================================
' The Modern Subclassing Thunk (MST)
'=========================================================================
Private Function InitAddressOfMethod(pObj As Object, ByVal MethodParamCount As Long) As Object
Const STR_THUNK As String = "6AAAAABag+oFV4v6ge9QEMEAgcekEcEAuP9EJAS5+QcAAPOri8LB4AgFuQAAAKuLwsHoGAUAjYEAq7gIAAArq7hEJASLq7hJCIsEq7iBi1Qkq4tEJAzB4AIFCIkCM6uLRCQMweASBcDCCACriTrHQgQBAAAAi0QkCIsAiUIIi0QkEIlCDIHqUBDBAIvCBTwRwQCri8IFUBHBAKuLwgVgEcEAq4vCBYQRwQCri8IFjBHBAKuLwgWUEcEAq4vCBZwRwQCri8IFpBHBALn5BwAAq4PABOL6i8dfgcJQEMEAi0wkEIkRK8LCEAAPHwCLVCQE/0IEi0QkDIkQM8DCDABmkItUJAT/QgSLQgTCBAAPHwCLVCQE/0oEi0IEg/gAfgPCBABZWotCDGgAgAAAagBSUf/gZpC4AUAAgMIIALgBQACAwhAAuAFAAIDCGAC4AUAAgMIkAA==" ' 25.3.2019 14:01:08
Const THUNK_SIZE As Long = 16728
Dim hThunk As Long
Dim lSize As Long
hThunk = VirtualAlloc(0, THUNK_SIZE, MEM_COMMIT, PAGE_EXECUTE_READWRITE)
Call CryptStringToBinary(STR_THUNK, Len(STR_THUNK), CRYPT_STRING_BASE64, hThunk, THUNK_SIZE)
lSize = CallWindowProc(hThunk, ObjPtr(pObj), MethodParamCount, GetProcAddress(GetModuleHandle("kernel32"), "VirtualFree"), VarPtr(InitAddressOfMethod))
Debug.Assert lSize = THUNK_SIZE
End Function
Private Function InitSubclassingThunk(ByVal hWnd As Long, pObj As Object, ByVal pfnCallback As Long) As IUnknown
Const STR_THUNK As String = "6AAAAABag+oFgepwEB4BV1aLdCQUg8YIgz4AdC+L+oHHABIeAYvCBQgRHgGri8IFRBEeAauLwgVUER4Bq4vCBXwRHgGruQkAAADzpYHCABIeAVJqGP9SEFqL+IvCq7gBAAAAqzPAq4tEJAyri3QkFKWlg+8YagBX/3IM/3cM/1IYi0QkGIk4Xl+4NBIeAS1wEB4BwhAAZpCLRCQIgzgAdSqDeAQAdSSBeAjAAAAAdRuBeAwAAABGdRKLVCQE/0IEi0QkDIkQM8DCDAC4AkAAgMIMAJCLVCQE/0IEi0IEwgQADx8Ai1QkBP9KBItCBHUYiwpS/3EM/3IM/1Eci1QkBIsKUv9RFDPAwgQAkFWL7ItVGIsKi0EshcB0OFL/0FqJQgiD+AF3VIP4AHUJgX0MAwIAAHRGiwpS/1EwWoXAdTuLClJq8P9xJP9RKFqpAAAACHUoUjPAUFCNRCQEUI1EJARQ/3UU/3UQ/3UM/3UI/3IQ/1IUWVhahcl1EYsK/3UU/3UQ/3UM/3UI/1EgXcIYAA==" ' 1.4.2019 11:41:46
Const THUNK_SIZE As Long = 452
Static hThunk As Long
Dim aParams(0 To 10) As Long
Dim lSize As Long
aParams(0) = ObjPtr(pObj)
aParams(1) = pfnCallback
If hThunk = 0 Then
hThunk = pvThunkGlobalData("InitSubclassingThunk")
End If
If hThunk = 0 Then
hThunk = VirtualAlloc(0, THUNK_SIZE, MEM_COMMIT, PAGE_EXECUTE_READWRITE)
Call CryptStringToBinary(STR_THUNK, Len(STR_THUNK), CRYPT_STRING_BASE64, hThunk, THUNK_SIZE)
aParams(2) = GetProcAddress(GetModuleHandle("ole32"), "CoTaskMemAlloc")
aParams(3) = GetProcAddress(GetModuleHandle("ole32"), "CoTaskMemFree")
Call DefSubclassProc(0, 0, 0, 0) '--- load comctl32
aParams(4) = GetProcAddressByOrdinal(GetModuleHandle("comctl32"), 410) '--- 410 = SetWindowSubclass ordinal
aParams(5) = GetProcAddressByOrdinal(GetModuleHandle("comctl32"), 412) '--- 412 = RemoveWindowSubclass ordinal
aParams(6) = GetProcAddressByOrdinal(GetModuleHandle("comctl32"), 413) '--- 413 = DefSubclassProc ordinal
'--- for IDE protection
Debug.Assert pvGetIdeOwner(aParams(7))
If aParams(7) <> 0 Then
aParams(8) = GetProcAddress(GetModuleHandle("user32"), "GetWindowLongA")
aParams(9) = GetProcAddress(GetModuleHandle("vba6"), "EbMode")
aParams(10) = GetProcAddress(GetModuleHandle("vba6"), "EbIsResetting")
End If
pvThunkGlobalData("InitSubclassingThunk") = hThunk
End If
lSize = CallWindowProc(hThunk, hWnd, 0, VarPtr(aParams(0)), VarPtr(InitSubclassingThunk))
Debug.Assert lSize = THUNK_SIZE
End Function
Private Function InitCleanupThunk(ByVal hHandle As Long, sModuleName As String, sProcName As String) As IUnknown
Const STR_THUNK As String = "6AAAAABag+oFgepQEDwBV1aLdCQUgz4AdCeL+oHHPBE8AYvCBcwQPAGri8IFCBE8AauLwgUYETwBq7kCAAAA86WBwjwRPAFSahD/Ugxai/iLwqu4AQAAAKuLRCQMq4tEJBCrg+8Qi0QkGIk4Xl+4UBE8AS1QEDwBwhAAkItEJAiDOAB1KoN4BAB1JIF4CMAAAAB1G4F4DAAAAEZ1EotUJAT/QgSLRCQMiRAzwMIMALgCQACAwgwAkItUJAT/QgSLQgTCBAAPHwCLVCQE/0oEi0IEdRL/cgj/UgyLVCQEiwpS/1EQM8DCBAAPHwA=" ' 25.3.2019 14:03:56
Const THUNK_SIZE As Long = 256
Static hThunk As Long
Dim aParams(0 To 1) As Long
Dim pfnCleanup As Long
Dim lSize As Long
If hThunk = 0 Then
hThunk = pvThunkGlobalData("InitCleanupThunk")
End If
If hThunk = 0 Then
hThunk = VirtualAlloc(0, THUNK_SIZE, MEM_COMMIT, PAGE_EXECUTE_READWRITE)
Call CryptStringToBinary(STR_THUNK, Len(STR_THUNK), CRYPT_STRING_BASE64, hThunk, THUNK_SIZE)
aParams(0) = GetProcAddress(GetModuleHandle("ole32"), "CoTaskMemAlloc")
aParams(1) = GetProcAddress(GetModuleHandle("ole32"), "CoTaskMemFree")
pvThunkGlobalData("InitCleanupThunk") = hThunk
End If
pfnCleanup = GetProcAddress(GetModuleHandle(sModuleName), sProcName)
If pfnCleanup <> 0 Then
lSize = CallWindowProc(hThunk, hHandle, pfnCleanup, VarPtr(aParams(0)), VarPtr(InitCleanupThunk))
Debug.Assert lSize = THUNK_SIZE
End If
End Function
Private Property Get ThunkPrivateData(pThunk As IUnknown, Optional ByVal Index As Long) As Long
Dim lPtr As Long
lPtr = ObjPtr(pThunk)
If lPtr <> 0 Then
Call CopyMemory(ThunkPrivateData, ByVal (lPtr Xor SIGN_BIT) + 8 + Index * 4 Xor SIGN_BIT, 4)
End If
End Property
Private Property Let ThunkPrivateData(pThunk As IUnknown, Optional ByVal Index As Long, ByVal lValue As Long)
Dim lPtr As Long
lPtr = ObjPtr(pThunk)
If lPtr <> 0 Then
Call CopyMemory(ByVal (lPtr Xor SIGN_BIT) + 8 + Index * 4 Xor SIGN_BIT, lValue, 4)
End If
End Property
Private Function pvGetIdeOwner(hIdeOwner As Long) As Boolean
#If Not ImplNoIdeProtection Then
Dim lProcessId As Long
Do
hIdeOwner = FindWindowEx(0, hIdeOwner, "IDEOwner", vbNullString)
Call GetWindowThreadProcessId(hIdeOwner, lProcessId)
Loop While hIdeOwner <> 0 And lProcessId <> GetCurrentProcessId()
#End If
pvGetIdeOwner = True
End Function
Private Property Get pvThunkGlobalData(sKey As String) As Long
Dim sBuffer As String
sBuffer = String$(50, 0)
Call GetEnvironmentVariable("_MST_GLOBAL" & GetCurrentProcessId() & "_" & sKey, sBuffer, Len(sBuffer) - 1)
pvThunkGlobalData = Val(Left$(sBuffer, InStr(sBuffer, vbNullChar) - 1))
End Property
Private Property Let pvThunkGlobalData(sKey As String, ByVal lValue As Long)
Call SetEnvironmentVariable("_MST_GLOBAL" & GetCurrentProcessId() & "_" & sKey, lValue)
End Property
#End If
'=========================================================================
' Base class events
'=========================================================================
Private Sub Class_Initialize()
Dim sHelperName As String
Dim hWndHelper As Long
Dim lPtr As Long
Dim baWSAData() As Byte
sHelperName = GetCurrentProcessId() & ":" & App.ThreadID & ":" & STR_HELPER_NAME
hWndHelper = FindWindowEx(HWND_MESSAGE, 0, STR_HELPER_CLASS, sHelperName)
lPtr = GetWindowLong(hWndHelper, GWL_USERDATA)
If hWndHelper = 0 Or lPtr <> 0 Then
If hWndHelper = 0 Then
hWndHelper = CreateWindowEx(0, STR_HELPER_CLASS, sHelperName, 0, 0, 0, 0, 0, HWND_MESSAGE, 0, App.hInstance, ByVal 0)
End If
If lPtr <> 0 Then
Set m_oHelperWindow = pvToSocket(lPtr)
Else
Set m_oHelperWindow = New cAsyncSocket
End If
m_hSocket = INVALID_SOCKET
m_lIndex = -1
Else
'-- init helper window
ReDim baWSAData(0 To 1000) As Byte
ReDim m_uWindowState(0 To 0) As UcsHelperWindowStateType
With m_uWindowState(0)
If WSAStartup(&H101, baWSAData(0)) = 0 Then
.hWnd = hWndHelper
Call SetWindowLong(hWndHelper, GWL_USERDATA, ObjPtr(Me))
Set .Subclass = InitSubclassingThunk(hWndHelper, Me, pvAddressOfSubclassProc.SubclassProc(0, 0, 0, 0, 0))
Set .Cleanup = InitCleanupThunk(hWndHelper, "user32", "DestroyWindow")
End If
ReDim .SocketPtr(0 To 511) As Long
End With
End If
End Sub
Private Sub Class_Terminate()
If frMessageHWnd = 0 Then
pvClose
Set m_oHelperWindow = Nothing
Else
'-- terminate helper window
Call SetWindowLong(frMessageHWnd, GWL_USERDATA, 0)
Call WSACleanup
Erase m_uWindowState
End If
End Sub
You can’t perform that action at this time.