Autor
|
Tema: Error de la api del winsock (Leído 2,040 veces)
|
Snort
Desconectado
Mensajes: 338
|
(CSocketMaster) Wenas, estaba leyendo el manual de troyano desde cero, para usar la api bastan con poner en google:
CSocketMaster VB
y socket.bas
con esos 2 archivos se imita el uso de winsock, solo hay que declararlo
Código: Dim WithEvents ws As CSocketMaster
y
Código: Set ws = New CSocketMaster he intentao probarlo en mi nueva herramienta de administracion remota (xD), y ha empezao a darme errores, la mayoria los e conseguio solucionar, como por ejempo en lugar de poner ws.Close poner ws.CloseSck, porqe esta si qe esta en el modulo y si no da error... Bueno, una vez hecho esto, al ejecutar mi servidor me ha dao un error "Error 10048 en tiempo de ejecucion: Address already in use" supongo qe sera el puerto, nose pero el server es lo unico qe tengo en ejecucion y por si sirve de algo y me podeis ayudar me lleva a esta linea del codigo del modulo de clase Err.Raise lngErrorCode, "CSocketMaster.BindInternal", GetErrorDescription(lngErrorCode) Os pongo donde se encuentra... End With
'bind the socket lngResult = api_bind(m_lngSocketHandle, udtSockAddr, LenB(udtSockAddr))
If lngResult = SOCKET_ERROR Then
lngErrorCode = Err.LastDllError Err.Raise lngErrorCode, "CSocketMaster.BindInternal", GetErrorDescription(lngErrorCode) Else
m_strLocalIP = strIP If lngLocalPortInternal <> 0 Then Debug.Print "OK Bind HOST: " & strLocalHostInternal & " PORT: " & lngLocalPortInternal m_lngLocalPort = lngLocalPortInternal Else lngResult = GetLocalPort(m_lngSocketHandle) If lngResult = SOCKET_ERROR Then lngErrorCode = Err.LastDllError Err.Raise lngErrorCode, "CSocketMaster.BindInternal", GetErrorDescription(lngErrorCode) Else Debug.Print "OK Bind HOST: " & strLocalHostInternal & " PORT: " & lngResult m_lngLocalPortBind = lngResult End If End If BindInternal = True End If End Function Bueno, pues eso si me podeis exar una manita, gracias adelantadas
|
|
|
En línea
|
|
|
|
~~
|
Hola: Mira te la cuelgo entera por q no me apetece andar buscando esas lineas xDD modSocketMaster.bas '************************************************************************************** ' 'modSocketMaster module 1.1 'Copyright (c) 2004 by Emiliano Scavuzzo <anshoku@yahoo.com> ' 'Rosario, Argentina ' '************************************************************************************** 'This module contains API declarations and helper functions for the CSocketMaster class '**************************************************************************************
Option Explicit
'============================================================================== 'API FUNCTIONS '==============================================================================
Public Declare Sub api_CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long) Public Declare Function api_WSAGetLastError Lib "ws2_32.dll" Alias "WSAGetLastError" () As Long Public Declare Function api_GlobalAlloc Lib "kernel32" Alias "GlobalAlloc" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long Public Declare Function api_GlobalFree Lib "kernel32" Alias "GlobalFree" (ByVal hMem As Long) As Long Private Declare Function api_WSAStartup Lib "ws2_32.dll" Alias "WSAStartup" (ByVal wVersionRequired As Long, lpWSADATA As WSAData) As Long Private Declare Function api_WSACleanup Lib "ws2_32.dll" Alias "WSACleanup" () As Long Private Declare Function api_WSAAsyncGetHostByName Lib "ws2_32.dll" Alias "WSAAsyncGetHostByName" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal strHostName As String, buf As Any, ByVal buflen As Long) As Long Private Declare Function api_WSAAsyncSelect Lib "wsock32.dll" Alias "WSAAsyncSelect" (ByVal s As Long, ByVal hwnd As Long, ByVal wMsg As Long, ByVal lEvent As Long) As Long Private Declare Function api_CreateWindowEx Lib "user32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Any) As Long Private Declare Function api_DestroyWindow Lib "user32" Alias "DestroyWindow" (ByVal hwnd As Long) As Long Private Declare Function api_lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As Any) As Long Private Declare Function api_lstrcpy Lib "kernel32" Alias "lstrcpyA" (ByVal lpString1 As String, ByVal lpString2 As Long) As Long
'============================================================================== 'CONSTANTS '==============================================================================
Public Const SOCKET_ERROR As Integer = -1 Public Const INVALID_SOCKET As Integer = -1 Public Const INADDR_NONE As Long = &HFFFF
Private Const WSADESCRIPTION_LEN As Integer = 257 Private Const WSASYS_STATUS_LEN As Integer = 129
Private Enum WinsockVersion SOCKET_VERSION_11 = &H101 SOCKET_VERSION_22 = &H202 End Enum
Public Const MAXGETHOSTSTRUCT = 1024
Public Const AF_INET As Long = 2 Public Const SOCK_STREAM As Long = 1 Public Const SOCK_DGRAM As Long = 2 Public Const IPPROTO_TCP As Long = 6 Public Const IPPROTO_UDP As Long = 17
Public Const FD_READ = &H1& Public Const FD_WRITE = &H2& Public Const FD_ACCEPT = &H8& Public Const FD_CONNECT = &H10& Public Const FD_CLOSE = &H20&
Private Const OFFSET_2 = 65536 Private Const MAXINT_2 = 32767
Public Const GMEM_FIXED = &H0 Public Const LOCAL_HOST_BUFF As Integer = 256
Public Const SOL_SOCKET As Long = 65535 Public Const SO_SNDBUF As Long = &H1001& Public Const SO_RCVBUF As Long = &H1002& Public Const SO_MAX_MSG_SIZE As Long = &H2003 Public Const SO_BROADCAST As Long = &H20 Public Const FIONREAD As Long = &H4004667F
'============================================================================== 'ERROR CODES '==============================================================================
Public Const WSABASEERR As Long = 10000 Public Const WSAEINTR As Long = (WSABASEERR + 4) Public Const WSAEACCES As Long = (WSABASEERR + 13) Public Const WSAEFAULT As Long = (WSABASEERR + 14) Public Const WSAEINVAL As Long = (WSABASEERR + 22) Public Const WSAEMFILE As Long = (WSABASEERR + 24) Public Const WSAEWOULDBLOCK As Long = (WSABASEERR + 35) Public Const WSAEINPROGRESS As Long = (WSABASEERR + 36) Public Const WSAEALREADY As Long = (WSABASEERR + 37) Public Const WSAENOTSOCK As Long = (WSABASEERR + 38) Public Const WSAEDESTADDRREQ As Long = (WSABASEERR + 39) Public Const WSAEMSGSIZE As Long = (WSABASEERR + 40) Public Const WSAEPROTOTYPE As Long = (WSABASEERR + 41) Public Const WSAENOPROTOOPT As Long = (WSABASEERR + 42) Public Const WSAEPROTONOSUPPORT As Long = (WSABASEERR + 43) Public Const WSAESOCKTNOSUPPORT As Long = (WSABASEERR + 44) Public Const WSAEOPNOTSUPP As Long = (WSABASEERR + 45) Public Const WSAEPFNOSUPPORT As Long = (WSABASEERR + 46) Public Const WSAEAFNOSUPPORT As Long = (WSABASEERR + 47) Public Const WSAEADDRINUSE As Long = (WSABASEERR + 48) Public Const WSAEADDRNOTAVAIL As Long = (WSABASEERR + 49) Public Const WSAENETDOWN As Long = (WSABASEERR + 50) Public Const WSAENETUNREACH As Long = (WSABASEERR + 51) Public Const WSAENETRESET As Long = (WSABASEERR + 52) Public Const WSAECONNABORTED As Long = (WSABASEERR + 53) Public Const WSAECONNRESET As Long = (WSABASEERR + 54) Public Const WSAENOBUFS As Long = (WSABASEERR + 55) Public Const WSAEISCONN As Long = (WSABASEERR + 56) Public Const WSAENOTCONN As Long = (WSABASEERR + 57) Public Const WSAESHUTDOWN As Long = (WSABASEERR + 58) Public Const WSAETIMEDOUT As Long = (WSABASEERR + 60) Public Const WSAEHOSTUNREACH As Long = (WSABASEERR + 65) Public Const WSAECONNREFUSED As Long = (WSABASEERR + 61) Public Const WSAEPROCLIM As Long = (WSABASEERR + 67) Public Const WSASYSNOTREADY As Long = (WSABASEERR + 91) Public Const WSAVERNOTSUPPORTED As Long = (WSABASEERR + 92) Public Const WSANOTINITIALISED As Long = (WSABASEERR + 93) Public Const WSAHOST_NOT_FOUND As Long = (WSABASEERR + 1001) Public Const WSATRY_AGAIN As Long = (WSABASEERR + 1002) Public Const WSANO_RECOVERY As Long = (WSABASEERR + 1003) Public Const WSANO_DATA As Long = (WSABASEERR + 1004)
'============================================================================== 'WINSOCK CONTROL ERROR CODES '==============================================================================
Public Const sckOutOfMemory = 7 Public Const sckBadState = 40006 Public Const sckInvalidArg = 40014 Public Const sckUnsupported = 40018 Public Const sckInvalidOp = 40020
'============================================================================== 'STRUCTURES '==============================================================================
Private Type WSAData wVersion As Integer wHighVersion As Integer szDescription As String * WSADESCRIPTION_LEN szSystemStatus As String * WSASYS_STATUS_LEN iMaxSockets As Integer iMaxUdpDg As Integer lpVendorInfo As Long End Type
Public Type HOSTENT hName As Long hAliases As Long hAddrType As Integer hLength As Integer hAddrList As Long End Type
Public Type sockaddr_in sin_family As Integer sin_port As Integer sin_addr As Long sin_zero(1 To 8) As Byte End Type
'============================================================================== 'MEMBER VARIABLES '==============================================================================
Private m_blnInitiated As Boolean 'specify if winsock service was initiated Private m_lngSocksQuantity As Long 'number of instances created Private m_colSocketsInst As Collection 'sockets list and instance owner Private m_colAcceptList As Collection 'sockets in queue that need to be accepted Private m_lngWindowHandle As Long 'message window handle
'============================================================================== 'SUBCLASSING DECLARATIONS 'by Paul Caton '============================================================================== Private Declare Function api_IsWindow Lib "user32" Alias "IsWindow" (ByVal hwnd As Long) As Long Private Declare Function api_GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long Private Declare Function api_SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Private Declare Function api_GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long Private Declare Function api_GetProcAddress Lib "kernel32" Alias "GetProcAddress" (ByVal hModule As Long, ByVal lpProcName As String) As Long
Private Const PATCH_06 As Long = 106 Private Const PATCH_09 As Long = 137
Private Const GWL_WNDPROC = (-4)
Private Const WM_USER = &H400
Public Const RESOLVE_MESSAGE As Long = WM_USER + &H400 Public Const SOCKET_MESSAGE As Long = WM_USER + &H401
Private lngMsgCntA As Long 'TableA entry count Private lngMsgCntB As Long 'TableB entry count Private lngTableA1() As Long 'TableA1: list of async handles Private lngTableA2() As Long 'TableA2: list of async handles owners Private lngTableB1() As Long 'TableB1: list of sockets Private lngTableB2() As Long 'TableB2: list of sockets owners Private hWndSub As Long 'window handle subclassed Private nAddrSubclass As Long 'address of our WndProc Private nAddrOriginal As Long 'address of original WndProc
'This function initiates the processes needed to keep 'control of sockets. Returns 0 if it has success. Public Function InitiateProcesses() As Long
InitiateProcesses = 0 m_lngSocksQuantity = m_lngSocksQuantity + 1
'if the service wasn't initiated yet we do it now If Not m_blnInitiated Then Subclass_Initialize m_blnInitiated = True Dim lngResult As Long lngResult = InitiateService If lngResult = 0 Then Debug.Print "OK Winsock service initiated" Else Debug.Print "ERROR trying to initiate winsock service" Err.Raise lngResult, "modSocketMaster.InitiateProcesses", GetErrorDescription(lngResult) InitiateProcesses = lngResult End If End If End Function
'This function initiate the winsock service calling 'the api_WSAStartup funtion and returns resulting value. Private Function InitiateService() As Long Dim udtWSAData As WSAData Dim lngResult As Long
lngResult = api_WSAStartup(SOCKET_VERSION_11, udtWSAData) InitiateService = lngResult End Function
'Once we are done with the class instance we call this 'function to discount it and finish winsock service if 'it was the last one. 'Returns 0 if it has success. Public Function FinalizeProcesses() As Long FinalizeProcesses = 0 m_lngSocksQuantity = m_lngSocksQuantity - 1
'if the service was initiated and there's no more instances 'of the class then we finish the service If m_blnInitiated And m_lngSocksQuantity = 0 Then If FinalizeService = SOCKET_ERROR Then Dim lngErrorCode As Long lngErrorCode = Err.LastDllError FinalizeProcesses = lngErrorCode Err.Raise lngErrorCode, "modSocketMaster.FinalizeProcesses", GetErrorDescription(lngErrorCode) Else Debug.Print "OK Winsock service finalized" End If Subclass_Terminate m_blnInitiated = False End If
End Function
'Finish winsock service calling the function 'api_WSACleanup and returns the result. Private Function FinalizeService() As Long Dim lngResultado As Long lngResultado = api_WSACleanup FinalizeService = lngResultado End Function
'This function receives a number that represents an error 'and returns the corresponding description string. Public Function GetErrorDescription(ByVal lngErrorCode As Long) As String Select Case lngErrorCode Case WSAEACCES GetErrorDescription = "Permission denied." Case WSAEADDRINUSE GetErrorDescription = "Address already in use." Case WSAEADDRNOTAVAIL GetErrorDescription = "Cannot assign requested address." Case WSAEAFNOSUPPORT GetErrorDescription = "Address family not supported by protocol family." Case WSAEALREADY GetErrorDescription = "Operation already in progress." Case WSAECONNABORTED GetErrorDescription = "Software caused connection abort." Case WSAECONNREFUSED GetErrorDescription = "Connection refused." Case WSAECONNRESET GetErrorDescription = "Connection reset by peer." Case WSAEDESTADDRREQ GetErrorDescription = "Destination address required." Case WSAEFAULT GetErrorDescription = "Bad address." Case WSAEHOSTUNREACH GetErrorDescription = "No route to host." Case WSAEINPROGRESS GetErrorDescription = "Operation now in progress." Case WSAEINTR GetErrorDescription = "Interrupted function call." Case WSAEINVAL GetErrorDescription = "Invalid argument." Case WSAEISCONN GetErrorDescription = "Socket is already connected." Case WSAEMFILE GetErrorDescription = "Too many open files." Case WSAEMSGSIZE GetErrorDescription = "Message too long." Case WSAENETDOWN GetErrorDescription = "Network is down." Case WSAENETRESET GetErrorDescription = "Network dropped connection on reset." Case WSAENETUNREACH GetErrorDescription = "Network is unreachable." Case WSAENOBUFS GetErrorDescription = "No buffer space available." Case WSAENOPROTOOPT GetErrorDescription = "Bad protocol option." Case WSAENOTCONN GetErrorDescription = "Socket is not connected." Case WSAENOTSOCK GetErrorDescription = "Socket operation on nonsocket." Case WSAEOPNOTSUPP GetErrorDescription = "Operation not supported." Case WSAEPFNOSUPPORT GetErrorDescription = "Protocol family not supported." Case WSAEPROCLIM GetErrorDescription = "Too many processes." Case WSAEPROTONOSUPPORT GetErrorDescription = "Protocol not supported." Case WSAEPROTOTYPE GetErrorDescription = "Protocol wrong type for socket." Case WSAESHUTDOWN GetErrorDescription = "Cannot send after socket shutdown." Case WSAESOCKTNOSUPPORT GetErrorDescription = "Socket type not supported." Case WSAETIMEDOUT GetErrorDescription = "Connection timed out." Case WSAEWOULDBLOCK GetErrorDescription = "Resource temporarily unavailable." Case WSAHOST_NOT_FOUND GetErrorDescription = "Host not found." Case WSANOTINITIALISED GetErrorDescription = "Successful WSAStartup not yet performed." Case WSANO_DATA GetErrorDescription = "Valid name, no data record of requested type." Case WSANO_RECOVERY GetErrorDescription = "This is a nonrecoverable error." Case WSASYSNOTREADY GetErrorDescription = "Network subsystem is unavailable." Case WSATRY_AGAIN GetErrorDescription = "Nonauthoritative host not found." Case WSAVERNOTSUPPORTED GetErrorDescription = "Winsock.dll version out of range." Case Else GetErrorDescription = "Unknown error." End Select
End Function
'Create a window that is used to capture sockets messages. 'Returns 0 if it has success. Private Function CreateWinsockMessageWindow() As Long m_lngWindowHandle = api_CreateWindowEx(0&, "STATIC", "SOCKET_WINDOW", 0&, 0&, 0&, 0&, 0&, 0&, 0&, App.hInstance, ByVal 0&)
If m_lngWindowHandle = 0 Then CreateWinsockMessageWindow = sckOutOfMemory Exit Function Else CreateWinsockMessageWindow = 0 Debug.Print "OK Created winsock message window " & m_lngWindowHandle End If End Function
'Destroy the window that is used to capture sockets messages. 'Returns 0 if it has success. Private Function DestroyWinsockMessageWindow() As Long DestroyWinsockMessageWindow = 0
If m_lngWindowHandle = 0 Then Debug.Print "WARNING lngWindowHandle is ZERO" Exit Function End If Dim lngResult As Long
lngResult = api_DestroyWindow(m_lngWindowHandle) If lngResult = 0 Then DestroyWinsockMessageWindow = sckOutOfMemory Err.Raise sckOutOfMemory, "modSocketMaster.DestroyWinsockMessageWindow", "Out of memory" Else Debug.Print "OK Destroyed winsock message window " & m_lngWindowHandle m_lngWindowHandle = 0 End If End Function
'When a socket needs to resolve a hostname in asynchronous way 'it calls this function. If it has success it returns a nonzero 'number that represents the async task handle and register this 'number in the TableA list. 'Returns 0 if it fails. Public Function ResolveHost(ByVal strHost As String, ByVal lngHOSTENBuf As Long, ByVal lngObjectPointer As Long) As Long Dim lngAsynHandle As Long lngAsynHandle = api_WSAAsyncGetHostByName(m_lngWindowHandle, RESOLVE_MESSAGE, strHost, ByVal lngHOSTENBuf, MAXGETHOSTSTRUCT) If lngAsynHandle <> 0 Then Subclass_AddResolveMessage lngAsynHandle, lngObjectPointer ResolveHost = lngAsynHandle End Function
'Returns the hi word from a double word. Public Function HiWord(lngValue As Long) As Long If (lngValue And &H80000000) = &H80000000 Then HiWord = ((lngValue And &H7FFF0000) \ &H10000) Or &H8000& Else HiWord = (lngValue And &HFFFF0000) \ &H10000 End If End Function
'Returns the low word from a double word. Public Function LoWord(lngValue As Long) As Long LoWord = (lngValue And &HFFFF&) End Function
'Receives a string pointer and it turns it into a regular string. Public Function StringFromPointer(ByVal lPointer As Long) As String Dim strTemp As String Dim lRetVal As Long
strTemp = String$(api_lstrlen(ByVal lPointer), 0) lRetVal = api_lstrcpy(ByVal strTemp, ByVal lPointer) If lRetVal Then StringFromPointer = strTemp End Function
'The function takes an unsigned Integer from and API and 'converts it to a Long for display or arithmetic purposes Public Function UnsignedToInteger(Value As Long) As Integer If Value < 0 Or Value >= OFFSET_2 Then Error 6 ' Overflow If Value <= MAXINT_2 Then UnsignedToInteger = Value Else UnsignedToInteger = Value - OFFSET_2 End If End Function
'The function takes a Long containing a value in the range 'of an unsigned Integer and returns an Integer that you 'can pass to an API that requires an unsigned Integer Public Function IntegerToUnsigned(Value As Integer) As Long If Value < 0 Then IntegerToUnsigned = Value + OFFSET_2 Else IntegerToUnsigned = Value End If End Function
'Adds the socket to the m_colSocketsInst collection, and 'registers that socket with WSAAsyncSelect Winsock API 'function to receive network events for the socket. 'If this socket is the first one to be registered, the 'window and collection will be created in this function as well. Public Function RegisterSocket(ByVal lngSocket As Long, ByVal lngObjectPointer As Long, ByVal blnEvents As Boolean) As Boolean
If m_colSocketsInst Is Nothing Then Set m_colSocketsInst = New Collection Debug.Print "OK Created socket collection" If CreateWinsockMessageWindow <> 0 Then Err.Raise sckOutOfMemory, "modSocketMaster.RegisterSocket", "Out of memory" End If Subclass_Subclass (m_lngWindowHandle) End If
Subclass_AddSocketMessage lngSocket, lngObjectPointer
'Do we need to register socket events? If blnEvents Then Dim lngEvents As Long Dim lngResult As Long Dim lngErrorCode As Long
lngEvents = FD_READ Or FD_WRITE Or FD_ACCEPT Or FD_CONNECT Or FD_CLOSE lngResult = api_WSAAsyncSelect(lngSocket, m_lngWindowHandle, SOCKET_MESSAGE, lngEvents) If lngResult = SOCKET_ERROR Then Debug.Print "ERROR trying to register events from socket " & lngSocket lngErrorCode = Err.LastDllError Err.Raise lngErrorCode, "modSocketMaster.RegisterSocket", GetErrorDescription(lngErrorCode) Else Debug.Print "OK Registered events from socket " & lngSocket End If End If
m_colSocketsInst.Add lngObjectPointer, "S" & lngSocket RegisterSocket = True End Function
'Removes the socket from the m_colSocketsInst collection 'If it is the last socket in that collection, the window 'and colection will be destroyed as well. Public Sub UnregisterSocket(ByVal lngSocket As Long) Subclass_DelSocketMessage lngSocket On Error Resume Next m_colSocketsInst.Remove "S" & lngSocket
If m_colSocketsInst.Count = 0 Then Set m_colSocketsInst = Nothing Subclass_UnSubclass DestroyWinsockMessageWindow Debug.Print "OK Destroyed socket collection" End If End Sub
'Returns TRUE si the socket that is passed is registered 'in the colSocketsInst collection. Public Function IsSocketRegistered(ByVal lngSocket As Long) As Boolean On Error GoTo Error_Handler
m_colSocketsInst.Item ("S" & lngSocket) IsSocketRegistered = True
Exit Function
Error_Handler: IsSocketRegistered = False End Function
'When ResolveHost is called an async task handle is added 'to TableA list. Use this function to remove that record. Public Sub UnregisterResolution(ByVal lngAsynHandle As Long) Subclass_DelResolveMessage lngAsynHandle End Sub
'It turns a CSocketMaster instance pointer into an actual instance. Private Function SocketObjectFromPointer(ByVal lngPointer As Long) As CSocketMaster
Dim objSocket As CSocketMaster
api_CopyMemory objSocket, lngPointer, 4& Set SocketObjectFromPointer = objSocket api_CopyMemory objSocket, 0&, 4&
End Function
'Assing a temporal instance of CSocketMaster to a 'socket and register this socket to the accept list. Public Sub RegisterAccept(ByVal lngSocket As Long) If m_colAcceptList Is Nothing Then Set m_colAcceptList = New Collection Debug.Print "OK Created accept collection" End If Dim Socket As CSocketMaster Set Socket = New CSocketMaster Socket.Accept lngSocket m_colAcceptList.Add Socket, "S" & lngSocket End Sub
'Returns True is lngSocket is registered on the 'accept list. Public Function IsAcceptRegistered(ByVal lngSocket As Long) As Boolean On Error GoTo Error_Handler
m_colAcceptList.Item ("S" & lngSocket) IsAcceptRegistered = True
Exit Function
Error_Handler: IsAcceptRegistered = False End Function
'Unregister lngSocket from the accept list. Public Sub UnregisterAccept(ByVal lngSocket As Long) m_colAcceptList.Remove "S" & lngSocket
If m_colAcceptList.Count = 0 Then Set m_colAcceptList = Nothing Debug.Print "OK Destroyed accept collection" End If End Sub
'Return the accept instance class from a socket. Public Function GetAcceptClass(ByVal lngSocket As Long) As CSocketMaster Set GetAcceptClass = m_colAcceptList("S" & lngSocket) End Function
'============================================================================== 'SUBCLASSING CODE 'based on code by Paul Caton '==============================================================================
Private Sub Subclass_Initialize() Const PATCH_01 As Long = 15 'Code buffer offset to the location of the relative address to EbMode Const PATCH_03 As Long = 76 'Relative address of SetWindowsLong Const PATCH_05 As Long = 100 'Relative address of CallWindowProc Const FUNC_EBM As String = "EbMode" 'VBA's EbMode function allows the machine code thunk to know if the IDE has stopped or is on a breakpoint Const FUNC_SWL As String = "SetWindowLongA" 'SetWindowLong allows the cSubclasser machine code thunk to unsubclass the subclasser itself if it detects via the EbMode function that the IDE has stopped Const FUNC_CWP As String = "CallWindowProcA" 'We use CallWindowProc to call the original WndProc Const MOD_VBA5 As String = "vba5" 'Location of the EbMode function if running VB5 Const MOD_VBA6 As String = "vba6" 'Location of the EbMode function if running VB6 Const MOD_USER As String = "user32" 'Location of the SetWindowLong & CallWindowProc functions Dim i As Long 'Loop index Dim nLen As Long 'String lengths Dim sHex As String 'Hex code string Dim sCode As String 'Binary code string 'Store the hex pair machine code representation in sHex sHex = "5850505589E55753515231C0EB0EE8xxxxx01x83F802742285C074258B45103D0008000074433D01080000745BE8200000005A595B5FC9C21400E813000000EBF168xxxxx02x6AFCFF750CE8xxxxx03xEBE0FF7518FF7514FF7510FF750C68xxxxx04xE8xxxxx05xC3BBxxxxx06x8B4514BFxxxxx07x89D9F2AF75B629CB4B8B1C9Dxxxxx08xEB1DBBxxxxx09x8B4514BFxxxxx0Ax89D9F2AF759729CB4B8B1C9Dxxxxx0Bx895D088B1B8B5B1C89D85A595B5FC9FFE0" nLen = Len(sHex) 'Length of hex pair string 'Convert the string from hex pairs to bytes and store in the ASCII string opcode buffer For i = 1 To nLen Step 2 'For each pair of hex characters sCode = sCode & ChrB$(Val("&H" & Mid$(sHex, i, 2))) 'Convert a pair of hex characters to a byte and append to the ASCII string Next i 'Next pair nLen = LenB(sCode) 'Get the machine code length nAddrSubclass = api_GlobalAlloc(0, nLen) 'Allocate fixed memory for machine code buffer Debug.Print "OK Subclass memory allocated at: " & nAddrSubclass
'Copy the code to allocated memory Call api_CopyMemory(ByVal nAddrSubclass, ByVal StrPtr(sCode), nLen)
If Subclass_InIDE Then 'Patch the jmp (EB0E) with two nop's (90) enabling the IDE breakpoint/stop checking code Call api_CopyMemory(ByVal nAddrSubclass + 12, &H9090, 2) i = Subclass_AddrFunc(MOD_VBA6, FUNC_EBM) 'Get the address of EbMode in vba6.dll If i = 0 Then 'Found? i = Subclass_AddrFunc(MOD_VBA5, FUNC_EBM) 'VB5 perhaps, try vba5.dll End If
Debug.Assert i 'Ensure the EbMode function was found Call Subclass_PatchRel(PATCH_01, i) 'Patch the relative address to the EbMode api function End If Call Subclass_PatchRel(PATCH_03, Subclass_AddrFunc(MOD_USER, FUNC_SWL)) 'Address of the SetWindowLong api function Call Subclass_PatchRel(PATCH_05, Subclass_AddrFunc(MOD_USER, FUNC_CWP)) 'Address of the CallWindowProc api function End Sub
'UnSubclass and release the allocated memory Private Sub Subclass_Terminate() Call Subclass_UnSubclass 'UnSubclass if the Subclass thunk is active Call api_GlobalFree(nAddrSubclass) 'Release the allocated memory Debug.Print "OK Freed subclass memory at: " & nAddrSubclass nAddrSubclass = 0 ReDim lngTableA1(1 To 1) ReDim lngTableA2(1 To 1) ReDim lngTableB1(1 To 1) ReDim lngTableB2(1 To 1) End Sub
'Return whether we're running in the IDE. Public for general utility purposes Private Function Subclass_InIDE() As Boolean Debug.Assert Subclass_SetTrue(Subclass_InIDE) End Function
'Set the window subclass Private Function Subclass_Subclass(ByVal hwnd As Long) As Boolean Const PATCH_02 As Long = 66 'Address of the previous WndProc Const PATCH_04 As Long = 95 'Address of the previous WndProc If hWndSub = 0 Then Debug.Assert api_IsWindow(hwnd) 'Invalid window handle hWndSub = hwnd 'Store the window handle 'Get the original window proc nAddrOriginal = api_GetWindowLong(hwnd, GWL_WNDPROC) Call Subclass_PatchVal(PATCH_02, nAddrOriginal) 'Original WndProc address for CallWindowProc, call the original WndProc Call Subclass_PatchVal(PATCH_04, nAddrOriginal) 'Original WndProc address for SetWindowLong, unsubclass on IDE stop 'Set our WndProc in place of the original nAddrOriginal = api_SetWindowLong(hwnd, GWL_WNDPROC, nAddrSubclass) If nAddrOriginal <> 0 Then nAddrOriginal = 0 Subclass_Subclass = True 'Success End If End If Debug.Assert Subclass_Subclass End Function
'Stop subclassing the window Private Function Subclass_UnSubclass() As Boolean If hWndSub <> 0 Then lngMsgCntA = 0 lngMsgCntB = 0 Call Subclass_PatchVal(PATCH_06, lngMsgCntA) 'Patch the TableA entry count to ensure no further Proc callbacks Call Subclass_PatchVal(PATCH_09, lngMsgCntB) 'Patch the TableB entry count to ensure no further Proc callbacks 'Restore the original WndProc Call api_SetWindowLong(hWndSub, GWL_WNDPROC, nAddrOriginal) hWndSub = 0 'Indicate the subclasser is inactive
Subclass_UnSubclass = True 'Success End If End Function
'Return the address of the passed function in the passed dll Private Function Subclass_AddrFunc(ByVal sDLL As String, _ ByVal sProc As String) As Long Subclass_AddrFunc = api_GetProcAddress(api_GetModuleHandle(sDLL), sProc) End Function
'Return the address of the low bound of the passed table array Private Function Subclass_AddrMsgTbl(ByRef aMsgTbl() As Long) As Long On Error Resume Next 'The table may not be dimensioned yet so we need protection Subclass_AddrMsgTbl = VarPtr(aMsgTbl(1)) 'Get the address of the first element of the passed message table On Error GoTo 0 'Switch off error protection End Function
'Patch the machine code buffer offset with the relative address to the target address Private Sub Subclass_PatchRel(ByVal nOffset As Long, _ ByVal nTargetAddr As Long) Call api_CopyMemory(ByVal (nAddrSubclass + nOffset), nTargetAddr - nAddrSubclass - nOffset - 4, 4) End Sub
'Patch the machine code buffer offset with the passed value Private Sub Subclass_PatchVal(ByVal nOffset As Long, _ ByVal nValue As Long) Call api_CopyMemory(ByVal (nAddrSubclass + nOffset), nValue, 4) End Sub
'Worker function for InIDE - will only be called whilst running in the IDE Private Function Subclass_SetTrue(bValue As Boolean) As Boolean Subclass_SetTrue = True bValue = True End Function
Private Sub Subclass_AddResolveMessage(ByVal lngAsync As Long, ByVal lngObjectPointer As Long) Dim Count As Long For Count = 1 To lngMsgCntA Select Case lngTableA1(Count) Case -1 lngTableA1(Count) = lngAsync lngTableA2(Count) = lngObjectPointer Exit Sub Case lngAsync Debug.Print "WARNING: Async already registered!" Exit Sub End Select Next Count
lngMsgCntA = lngMsgCntA + 1 ReDim Preserve lngTableA1(1 To lngMsgCntA) ReDim Preserve lngTableA2(1 To lngMsgCntA) lngTableA1(lngMsgCntA) = lngAsync lngTableA2(lngMsgCntA) = lngObjectPointer Subclass_PatchTableA
End Sub
Private Sub Subclass_AddSocketMessage(ByVal lngSocket As Long, ByVal lngObjectPointer As Long) Dim Count As Long For Count = 1 To lngMsgCntB Select Case lngTableB1(Count) Case -1 lngTableB1(Count) = lngSocket lngTableB2(Count) = lngObjectPointer Exit Sub Case lngSocket Debug.Print "WARNING: Socket already registered!" Exit Sub End Select Next Count
lngMsgCntB = lngMsgCntB + 1 ReDim Preserve lngTableB1(1 To lngMsgCntB) ReDim Preserve lngTableB2(1 To lngMsgCntB) lngTableB1(lngMsgCntB) = lngSocket lngTableB2(lngMsgCntB) = lngObjectPointer Subclass_PatchTableB
End Sub
Private Sub Subclass_DelResolveMessage(ByVal lngAsync As Long) Dim Count As Long For Count = 1 To lngMsgCntA If lngTableA1(Count) = lngAsync Then lngTableA1(Count) = -1 lngTableA2(Count) = -1 Exit Sub End If Next Count End Sub
Private Sub Subclass_DelSocketMessage(ByVal lngSocket As Long) Dim Count As Long For Count = 1 To lngMsgCntB If lngTableB1(Count) = lngSocket Then lngTableB1(Count) = -1 lngTableB2(Count) = -1 Exit Sub End If Next Count End Sub
Private Sub Subclass_PatchTableA() Const PATCH_07 As Long = 114 Const PATCH_08 As Long = 130
Call Subclass_PatchVal(PATCH_06, lngMsgCntA) Call Subclass_PatchVal(PATCH_07, Subclass_AddrMsgTbl(lngTableA1)) Call Subclass_PatchVal(PATCH_08, Subclass_AddrMsgTbl(lngTableA2)) End Sub
Private Sub Subclass_PatchTableB() Const PATCH_0A As Long = 145 Const PATCH_0B As Long = 161
Call Subclass_PatchVal(PATCH_09, lngMsgCntB) Call Subclass_PatchVal(PATCH_0A, Subclass_AddrMsgTbl(lngTableB1)) Call Subclass_PatchVal(PATCH_0B, Subclass_AddrMsgTbl(lngTableB2)) End Sub
Public Sub Subclass_ChangeOwner(ByVal lngSocket As Long, ByVal lngObjectPointer As Long) Dim Count As Long For Count = 1 To lngMsgCntB If lngTableB1(Count) = lngSocket Then lngTableB2(Count) = lngObjectPointer Exit Sub End If Next Count End Sub
|
|
« Última modificación: 7 Octubre 2006, 21:36 pm por E0N »
|
En línea
|
|
|
|
~~
|
CSocketMaster.cls '******************************************************************************** ' 'Name.......... CSocketMaster 'File.......... CSocketMaster.cls 'Version....... 1.1 'Dependencies.. Requires modSocketMaster.bas code module 'Description... Winsock api implementation class 'Author........ Emiliano Scavuzzo <anshoku@yahoo.com> 'Date.......... February, 22nd 2004
'Copyright (c) 2004 by Emiliano Scavuzzo 'Rosario, Argentina ' 'Based on CSocket by Oleg Gdalevich 'Subclassing based on WinSubHook2 by Paul Caton <Paul_Caton@hotmail.com> ' '********************************************************************************
Option Explicit
'============================================================================== 'API FUNCTIONS '==============================================================================
Private Declare Function api_socket Lib "ws2_32.dll" Alias "socket" (ByVal af As Long, ByVal s_type As Long, ByVal Protocol As Long) As Long Private Declare Function api_GlobalLock Lib "kernel32" Alias "GlobalLock" (ByVal hMem As Long) As Long Private Declare Function api_GlobalUnlock Lib "kernel32" Alias "GlobalUnlock" (ByVal hMem As Long) As Long Private Declare Function api_htons Lib "ws2_32.dll" Alias "htons" (ByVal hostshort As Integer) As Integer Private Declare Function api_ntohs Lib "ws2_32.dll" Alias "ntohs" (ByVal netshort As Integer) As Integer Private Declare Function api_connect Lib "ws2_32.dll" Alias "connect" (ByVal s As Long, ByRef name As sockaddr_in, ByVal namelen As Long) As Long Private Declare Function api_gethostname Lib "ws2_32.dll" Alias "gethostname" (ByVal host_name As String, ByVal namelen As Long) As Long Private Declare Function api_gethostbyname Lib "ws2_32.dll" Alias "gethostbyname" (ByVal host_name As String) As Long Private Declare Function api_bind Lib "ws2_32.dll" Alias "bind" (ByVal s As Long, ByRef name As sockaddr_in, ByRef namelen As Long) As Long Private Declare Function api_getsockname Lib "ws2_32.dll" Alias "getsockname" (ByVal s As Long, ByRef name As sockaddr_in, ByRef namelen As Long) As Long Private Declare Function api_getpeername Lib "ws2_32.dll" Alias "getpeername" (ByVal s As Long, ByRef name As sockaddr_in, ByRef namelen As Long) As Long Private Declare Function api_inet_addr Lib "ws2_32.dll" Alias "inet_addr" (ByVal cp As String) As Long Private Declare Function api_send Lib "ws2_32.dll" Alias "send" (ByVal s As Long, ByRef buf As Any, ByVal buflen As Long, ByVal flags As Long) As Long Private Declare Function api_sendto Lib "ws2_32.dll" 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 api_getsockopt Lib "ws2_32.dll" 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 api_setsockopt Lib "ws2_32.dll" 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 api_recv Lib "ws2_32.dll" Alias "recv" (ByVal s As Long, ByRef buf As Any, ByVal buflen As Long, ByVal flags As Long) As Long Private Declare Function api_recvfrom Lib "ws2_32.dll" 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 api_WSACancelAsyncRequest Lib "ws2_32.dll" Alias "WSACancelAsyncRequest" (ByVal hAsyncTaskHandle As Long) As Long Private Declare Function api_listen Lib "ws2_32.dll" Alias "listen" (ByVal s As Long, ByVal backlog As Long) As Long Private Declare Function api_accept Lib "ws2_32.dll" Alias "accept" (ByVal s As Long, ByRef addr As sockaddr_in, ByRef addrlen As Long) As Long Private Declare Function api_inet_ntoa Lib "ws2_32.dll" Alias "inet_ntoa" (ByVal inn As Long) As Long Private Declare Function api_gethostbyaddr Lib "ws2_32.dll" Alias "gethostbyaddr" (addr As Long, ByVal addr_len As Long, ByVal addr_type As Long) As Long Private Declare Function api_ioctlsocket Lib "ws2_32.dll" Alias "ioctlsocket" (ByVal s As Long, ByVal cmd As Long, ByRef argp As Long) As Long Private Declare Function api_closesocket Lib "ws2_32.dll" Alias "closesocket" (ByVal s As Long) As Long
'============================================================================== 'CONSTANTS '============================================================================== Public Enum SockState sckClosed = 0 sckOpen sckListening sckConnectionPending sckResolvingHost sckHostResolved sckConnecting sckConnected sckClosing sckError End Enum
Public Enum DestResolucion 'asynchronic host resolution destination destConnect = 0 'destSendUDP = 1 End Enum
Private Const SOMAXCONN As Long = 5
Public Enum ProtocolConstants sckTCPProtocol = 0 sckUDPProtocol = 1 End Enum
Private Const MSG_PEEK As Long = &H2
'============================================================================== 'EVENTS '==============================================================================
Public Event CloseSck() Public Event Connect() Public Event ConnectionRequest(ByVal requestID As Long) Public Event DataArrival(ByVal bytesTotal As Long) Public Event Error(ByVal Number As Integer, Description As String, ByVal sCode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean) Public Event SendComplete() Public Event SendProgress(ByVal bytesSent As Long, ByVal bytesRemaining As Long)
'============================================================================== 'MEMBER VARIABLES '============================================================================== Private m_lngSocketHandle As Long 'socket handle Private m_enmState As SockState 'socket state Private m_strTag As String 'tag Private m_strRemoteHost As String 'remote host Private m_lngRemotePort As Long 'remote port Private m_strRemoteHostIP As String 'remote host ip Private m_lngLocalPort As Long 'local port Private m_lngLocalPortBind As Long 'temporary local port Private m_strLocalIP As String 'local IP Private m_enmProtocol As ProtocolConstants 'protocol used (TCP / UDP)
Private m_lngMemoryPointer As Long 'memory pointer used as buffer when resolving host Private m_lngMemoryHandle As Long 'buffer memory handle
Private m_lngSendBufferLen As Long 'winsock buffer size for sends Private m_lngRecvBufferLen As Long 'winsock buffer size for receives
Private m_strSendBuffer As String 'local incoming buffer Private m_strRecvBuffer As String 'local outgoing buffer
Private m_blnAcceptClass As Boolean 'if True then this is a Accept socket class Private m_colWaitingResolutions As Collection 'hosts waiting to be resolved by the system
' **** WARNING WARNING WARNING WARNING ****** 'This sub MUST be the first on the class. DO NOT attempt 'to change it's location or the code will CRASH. 'This sub receives system messages from our WndProc. Public Sub WndProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) Select Case uMsg
Case RESOLVE_MESSAGE PostResolution wParam, HiWord(lParam) Case SOCKET_MESSAGE PostSocket LoWord(lParam), HiWord(lParam) End Select End Sub
Private Sub Class_Initialize() 'socket's handle default value m_lngSocketHandle = INVALID_SOCKET
'initiate resolution collection Set m_colWaitingResolutions = New Collection
'initiate processes and winsock service modSocketMaster.InitiateProcesses End Sub
Private Sub Class_Terminate() 'clean hostname resolution system CleanResolutionSystem
'destroy socket if it exists If Not m_blnAcceptClass Then DestroySocket
'clean processes and finish winsock service modSocketMaster.FinalizeProcesses
'clean resolution collection Set m_colWaitingResolutions = Nothing End Sub
'============================================================================== 'PROPERTIES '==============================================================================
Public Property Get RemotePort() As Long RemotePort = m_lngRemotePort End Property
Public Property Let RemotePort(ByVal lngPort As Long) If m_enmProtocol = sckTCPProtocol And m_enmState <> sckClosed Then Err.Raise sckInvalidOp, "CSocketMaster.RemotePort", "Invalid operation at current state" End If
If lngPort < 0 Or lngPort > 65535 Then Err.Raise sckInvalidArg, "CSocketMaster.RemotePort", "The argument passed to a function was not in the correct format or in the specified range." Else m_lngRemotePort = lngPort End If End Property
Public Property Get RemoteHost() As String RemoteHost = m_strRemoteHost End Property
Public Property Let RemoteHost(ByVal strHost As String) If m_enmProtocol = sckTCPProtocol And m_enmState <> sckClosed Then Err.Raise sckInvalidOp, "CSocketMaster.RemoteHost", "Invalid operation at current state" End If
m_strRemoteHost = strHost End Property
Public Property Get RemoteHostIP() As String RemoteHostIP = m_strRemoteHostIP End Property
Public Property Get LocalPort() As Long If m_lngLocalPortBind = 0 Then LocalPort = m_lngLocalPort Else LocalPort = m_lngLocalPortBind End If End Property
Public Property Let LocalPort(ByVal lngPort As Long) If m_enmState <> sckClosed Then Err.Raise sckInvalidOp, "CSocketMaster.LocalPort", "Invalid operation at current state" End If If lngPort < 0 Or lngPort > 65535 Then Err.Raise sckInvalidArg, "CSocketMaster.LocalPort", "The argument passed to a function was not in the correct format or in the specified range." Else m_lngLocalPort = lngPort End If End Property
Public Property Get State() As SockState State = m_enmState End Property
Public Property Get LocalHostName() As String LocalHostName = GetLocalHostName End Property
Public Property Get LocalIP() As String If m_enmState = sckOpen Or m_enmState = sckListening Then LocalIP = m_strLocalIP Else LocalIP = GetLocalIP End If End Property
Public Property Get BytesReceived() As Long If m_enmProtocol = sckTCPProtocol Then BytesReceived = Len(m_strRecvBuffer) Else BytesReceived = GetBufferLenUDP End If End Property
Public Property Get SocketHandle() As Long SocketHandle = m_lngSocketHandle End Property
Public Property Get Tag() As String Tag = m_strTag End Property
Public Property Let Tag(ByVal strTag As String) m_strTag = strTag End Property
Public Property Get Protocol() As ProtocolConstants Protocol = m_enmProtocol End Property
Public Property Let Protocol(ByVal enmProtocol As ProtocolConstants) If m_enmState <> sckClosed Then Err.Raise sckInvalidOp, "CSocketMaster.Protocol", "Invalid operation at current state" Else m_enmProtocol = enmProtocol End If End Property
'Destroys the socket if it exists and unregisters it 'from control list. Private Sub DestroySocket() If Not m_lngSocketHandle = INVALID_SOCKET Then
Dim lngResult As Long lngResult = api_closesocket(m_lngSocketHandle) If lngResult = SOCKET_ERROR Then m_enmState = sckError: Debug.Print "STATE: sckError" Dim lngErrorCode As Long lngErrorCode = Err.LastDllError Err.Raise lngErrorCode, "CSocketMaster.DestroySocket", GetErrorDescription(lngErrorCode) Else Debug.Print "OK Destroyed socket " & m_lngSocketHandle modSocketMaster.UnregisterSocket m_lngSocketHandle m_lngSocketHandle = INVALID_SOCKET End If End If End Sub
Public Sub CloseSck() If m_lngSocketHandle = INVALID_SOCKET Then Exit Sub
m_enmState = sckClosing: Debug.Print "STATE: sckClosing" CleanResolutionSystem DestroySocket m_lngLocalPortBind = 0 m_strRemoteHostIP = "" m_strRecvBuffer = "" m_strSendBuffer = "" m_lngSendBufferLen = 0 m_lngRecvBufferLen = 0
m_enmState = sckClosed: Debug.Print "STATE: sckClosed"
End Sub
'Tries to create a socket if there isn't one yet and registers 'it to the control list. 'Returns TRUE if it has success Private Function SocketExists() As Boolean SocketExists = True Dim lngResult As Long Dim lngErrorCode As Long
'check if there is a socket already If m_lngSocketHandle = INVALID_SOCKET Then 'decide what kind of socket we are creating, TCP or UDP If m_enmProtocol = sckTCPProtocol Then lngResult = api_socket(AF_INET, SOCK_STREAM, IPPROTO_TCP) Else lngResult = api_socket(AF_INET, SOCK_DGRAM, IPPROTO_UDP) End If If lngResult = INVALID_SOCKET Then m_enmState = sckError: Debug.Print "STATE: sckError" Debug.Print "ERROR trying to create socket" SocketExists = False lngErrorCode = Err.LastDllError Dim blnCancelDisplay As Boolean blnCancelDisplay = True RaiseEvent Error(lngErrorCode, GetErrorDescription(lngErrorCode), 0, "CSocketMaster.SocketExists", "", 0, blnCancelDisplay) If blnCancelDisplay = False Then MsgBox GetErrorDescription(lngErrorCode), vbOKOnly, "CSocketMaster.SocketExists" Else Debug.Print "OK Created socket: " & lngResult m_lngSocketHandle = lngResult 'set and get some socket options ProcessOptions SocketExists = modSocketMaster.RegisterSocket(m_lngSocketHandle, ObjPtr(Me), True) End If End If End Function
'Tries to connect to RemoteHost if it was passed, or uses 'm_strRemoteHost instead. If it is a hostname tries to 'resolve it first. Public Sub Connect(Optional RemoteHost As Variant, Optional RemotePort As Variant) If m_enmState <> sckClosed Then Err.Raise sckInvalidOp, "CSocketMaster.Connect", "Invalid operation at current state" End If
If Not IsMissing(RemoteHost) Then m_strRemoteHost = CStr(RemoteHost) End If
'for some reason we get a GPF if we try to 'resolve a null string, so we replace it with 'an empty string If m_strRemoteHost = vbNullString Then m_strRemoteHost = "" End If
'check if RemotePort is a number between 1 and 65535 If Not IsMissing(RemotePort) Then If IsNumeric(RemotePort) Then If CLng(RemotePort) > 65535 Or CLng(RemotePort) < 1 Then Err.Raise sckInvalidArg, "CSocketMaster.Connect", "The argument passed to a function was not in the correct format or in the specified range." Else m_lngRemotePort = CLng(RemotePort) End If Else Err.Raise sckUnsupported, "CSocketMaster.Connect", "Unsupported variant type." End If End If
'create a socket if there isn't one yet If Not SocketExists Then Exit Sub
'If we are using UDP we just bind the socket and exit 'silently. Remember UDP is a connectionless protocol. If m_enmProtocol = sckUDPProtocol Then If BindInternal Then m_enmState = sckOpen: Debug.Print "STATE: sckOpen" End If Exit Sub End If
'try to get a 32 bits long that is used to identify a host Dim lngAddress As Long lngAddress = ResolveIfHostname(m_strRemoteHost, destConnect)
'We've got two options here: '1) m_strRemoteHost was an IP, so a resolution wasn't ' necessary, and now lngAddress is a 32 bits long and ' we proceed to connect. '2) m_strRemoteHost was a hostname, so a resolution was ' necessary and it's taking place right now. We leave ' silently.
If lngAddress <> vbNull Then ConnectToIP lngAddress, 0 End If
End Sub
'When the system resolves a hostname in asynchronous way we 'call this function to decide what to do with the result. Private Sub PostResolution(ByVal lngAsynHandle As Long, ByVal lngErrorCode As Long) If m_enmState <> sckResolvingHost Then Exit Sub
Dim enmDestination As DestResolucion
'find out what the resolution destination was enmDestination = m_colWaitingResolutions.Item("R" & lngAsynHandle) 'erase that record from the collection since we won't need it any longer m_colWaitingResolutions.Remove "R" & lngAsynHandle
If lngErrorCode = 0 Then 'if there weren't errors trying to resolve the hostname m_enmState = sckHostResolved: Debug.Print "STATE: sckHostResolved" Dim udtHostent As HOSTENT Dim lngPtrToIP As Long Dim arrIpAddress(1 To 4) As Byte Dim lngRemoteHostAddress As Long Dim Count As Integer Dim strIpAddress As String api_CopyMemory udtHostent, ByVal m_lngMemoryPointer, LenB(udtHostent) api_CopyMemory lngPtrToIP, ByVal udtHostent.hAddrList, 4 api_CopyMemory arrIpAddress(1), ByVal lngPtrToIP, 4 api_CopyMemory lngRemoteHostAddress, ByVal lngPtrToIP, 4 'free memmory, won't need it any longer FreeMemory 'We turn the 32 bits long into a readable string. 'Note: we don't need this string. I put this here just 'in case you need it. For Count = 1 To 4 strIpAddress = strIpAddress & arrIpAddress(Count) & "." Next strIpAddress = Left$(strIpAddress, Len(strIpAddress) - 1) 'Decide what to do with the result according to the destination Select Case enmDestination Case destConnect ConnectToIP lngRemoteHostAddress, 0 End Select
Else 'there were errors trying to resolve the hostname
'free buffer memory FreeMemory Select Case enmDestination Case destConnect ConnectToIP vbNull, lngErrorCode End Select
End If End Sub
'This procedure is called by the WindowProc callback function 'from the modSocketMaster module. The lngEventID argument is an 'ID of the network event occurred for the socket. The lngErrorCode 'argument contains an error code only if an error was occurred 'during an asynchronous execution. Private Sub PostSocket(ByVal lngEventID As Long, ByVal lngErrorCode As Long)
'handle any possible error If lngErrorCode <> 0 Then m_enmState = sckError: Debug.Print "STATE: sckError" Dim blnCancelDisplay As Boolean blnCancelDisplay = True RaiseEvent Error(lngErrorCode, GetErrorDescription(lngErrorCode), 0, "CSocketMaster.PostSocket", "", 0, blnCancelDisplay) If blnCancelDisplay = False Then MsgBox GetErrorDescription(lngErrorCode), vbOKOnly, "CSocketMaster.PostSocket" Exit Sub End If
Dim udtSockAddr As sockaddr_in Dim lngResult As Long Dim lngBytesReceived As Long
Select Case lngEventID
'======================================================================
Case FD_CONNECT
'Arrival of this message means that the connection initiated by the call 'of the connect Winsock API function was successfully established.
Debug.Print "FD_CONNECT " & m_lngSocketHandle If m_enmState <> sckConnecting Then Debug.Print "WARNING: Omitting FD_CONNECT" Exit Sub End If 'Get the connection local end-point parameters lngResult = api_getpeername(m_lngSocketHandle, udtSockAddr, LenB(udtSockAddr)) If lngResult = 0 Then m_lngRemotePort = modSocketMaster.IntegerToUnsigned(api_ntohs(udtSockAddr.sin_port)) m_strRemoteHostIP = StringFromPointer(api_inet_ntoa(udtSockAddr.sin_addr)) End If m_enmState = sckConnected: Debug.Print "STATE: sckConnected" RaiseEvent Connect
'======================================================================
Case FD_WRITE
'This message means that the socket in a write-able 'state, that is, buffer for outgoing data of the transport 'service is empty and ready to receive data to send through 'the network. Debug.Print "FD_WRITE " & m_lngSocketHandle If m_enmState <> sckConnected Then Debug.Print "WARNING: Omitting FD_WRITE" Exit Sub End If If Len(m_strSendBuffer) > 0 Then SendBufferedData End If '======================================================================
Case FD_READ
'Some data has arrived for this socket.
Debug.Print "FD_READ " & m_lngSocketHandle If m_enmProtocol = sckTCPProtocol Then If m_enmState <> sckConnected Then Debug.Print "WARNING: Omitting FD_READ" Exit Sub End If 'Call the RecvDataToBuffer function that move arrived data 'from the Winsock buffer to the local one and returns number 'of bytes received. lngBytesReceived = RecvDataToBuffer If lngBytesReceived > 0 Then RaiseEvent DataArrival(Len(m_strRecvBuffer)) End If Else 'UDP protocol If m_enmState <> sckOpen Then Debug.Print "WARNING: Omitting FD_READ" Exit Sub End If 'If we use UDP we don't remove data from winsock buffer. 'We just let the user know the amount received so 'he/she can decide what to do. lngBytesReceived = GetBufferLenUDP If lngBytesReceived > 0 Then RaiseEvent DataArrival(lngBytesReceived) End If 'Now the buffer is emptied no matter what the user 'dicided to do with the received data EmptyBuffer End If '======================================================================
Case FD_ACCEPT
'When the socket is in a listening state, arrival of this message 'means that a connection request was received. Call the accept 'Winsock API function in oreder to create a new socket for the 'requested connection. Debug.Print "FD_ACCEPT " & m_lngSocketHandle If m_enmState <> sckListening Then Debug.Print "WARNING: Omitting FD_ACCEPT" Exit Sub End If lngResult = api_accept(m_lngSocketHandle, udtSockAddr, LenB(udtSockAddr)) If lngResult = INVALID_SOCKET Then lngErrorCode = Err.LastDllError Err.Raise lngErrorCode, "CSocketMaster.PostSocket", GetErrorDescription(lngErrorCode) Else 'We assign a temporal instance of CSocketMaster to 'handle this new socket until user accepts (or not) 'the new connection modSocketMaster.RegisterAccept lngResult 'We change remote info before firing ConnectionRequest 'event so the user can see which host is trying to 'connect. Dim lngTempRP As Long Dim strTempRHIP As String Dim strTempRH As String lngTempRP = m_lngRemotePort strTempRHIP = m_strRemoteHostIP strTempRH = m_strRemoteHost GetRemoteInfo lngResult, m_lngRemotePort, m_strRemoteHostIP, m_strRemoteHost Debug.Print "OK Accepted socket: " & lngResult RaiseEvent ConnectionRequest(lngResult) 'we return original info If m_enmState = sckListening Then m_lngRemotePort = lngTempRP m_strRemoteHostIP = strTempRHIP m_strRemoteHost = strTempRH End If 'This is very important. If the connection wasn't accepted 'we must close the socket. If IsAcceptRegistered(lngResult) Then api_closesocket lngResult modSocketMaster.UnregisterSocket lngResult modSocketMaster.UnregisterAccept lngResult Debug.Print "OK Closed accepted socket: " & lngResult End If End If '====================================================================== Case FD_CLOSE 'This message means that the remote host is closing the conection Debug.Print "FD_CLOSE " & m_lngSocketHandle If m_enmState <> sckConnected Then Debug.Print "WARNING: Omitting FD_CLOSE" Exit Sub End If m_enmState = sckClosing: Debug.Print "STATE: sckClosing" RaiseEvent CloseSck End Select End Sub
'Connect to a given 32 bits long ip Private Sub ConnectToIP(ByVal lngRemoteHostAddress As Long, ByVal lngErrorCode As Long)
Dim blnCancelDisplay As Boolean
'Check and handle errors If lngErrorCode <> 0 Then m_enmState = sckError: Debug.Print "STATE: sckError" blnCancelDisplay = True RaiseEvent Error(lngErrorCode, GetErrorDescription(lngErrorCode), 0, "CSocketMaster.ConnectToIP", "", 0, blnCancelDisplay) If blnCancelDisplay = False Then MsgBox GetErrorDescription(lngErrorCode), vbOKOnly, "CSocketMaster.ConnectToIP" Exit Sub End If
'Here we bind the socket If Not BindInternal Then Exit Sub
Debug.Print "OK Connecting to: " + m_strRemoteHost + " " + m_strRemoteHostIP m_enmState = sckConnecting: Debug.Print "STATE: sckConnecting"
Dim udtSockAddr As sockaddr_in Dim lngResult As Long
'Build the sockaddr_in structure to pass it to the connect 'Winsock API function as an address of the remote host. With udtSockAddr .sin_addr = lngRemoteHostAddress .sin_family = AF_INET .sin_port = api_htons(modSocketMaster.UnsignedToInteger(m_lngRemotePort)) End With
'Call the connect Winsock API function in order to establish connection. lngResult = api_connect(m_lngSocketHandle, udtSockAddr, LenB(udtSockAddr))
'Check and handle errors If lngResult = SOCKET_ERROR Then lngErrorCode = Err.LastDllError If lngErrorCode <> WSAEWOULDBLOCK Then If lngErrorCode = WSAEADDRNOTAVAIL Then Err.Raise WSAEADDRNOTAVAIL, "CSocketMaster.ConnectToIP", GetErrorDescription(WSAEADDRNOTAVAIL) Else m_enmState = sckError: Debug.Print "STATE: sckError" blnCancelDisplay = True RaiseEvent Error(lngErrorCode, GetErrorDescription(lngErrorCode), 0, "CSocketMaster.ConnectToIP", "", 0, blnCancelDisplay) If blnCancelDisplay = False Then MsgBox GetErrorDescription(lngErrorCode), vbOKOnly, "CSocketMaster.ConnectToIP" End If End If End If
End Sub
Public Sub Bind(Optional LocalPort As Variant, Optional LocalIP As Variant) If m_enmState <> sckClosed Then Err.Raise sckInvalidOp, "CSocketMaster.Bind", "Invalid operation at current state" End If
If BindInternal(LocalPort, LocalIP) Then m_enmState = sckOpen: Debug.Print "STATE: sckOpen" End If End Sub
'This function binds a socket to a local port and IP. 'Retunrs TRUE if it has success. Private Function BindInternal(Optional ByVal varLocalPort As Variant, Optional ByVal varLocalIP As Variant) As Boolean If m_enmState = sckOpen Then BindInternal = True Exit Function End If
Dim lngLocalPortInternal As Long Dim strLocalHostInternal As String Dim strIP As String Dim lngAddressInternal As Long Dim lngResult As Long Dim lngErrorCode As Long
BindInternal = False
'Check if varLocalPort is a number between 0 and 65535 If Not IsMissing(varLocalPort) Then If IsNumeric(varLocalPort) Then If varLocalPort < 0 Or varLocalPort > 65535 Then BindInternal = False Err.Raise sckInvalidArg, "CSocketMaster.BindInternal", "The argument passed to a function was not in the correct format or in the specified range." Else lngLocalPortInternal = CLng(varLocalPort) End If Else BindInternal = False Err.Raise sckUnsupported, "CSocketMaster.BindInternal", "Unsupported variant type." End If Else lngLocalPortInternal = m_lngLocalPort End If
If Not IsMissing(varLocalIP) Then If varLocalIP <> vbNullString Then strLocalHostInternal = CStr(varLocalIP) Else strLocalHostInternal = GetLocalIP End If Else strLocalHostInternal = GetLocalIP End If
'get a 32 bits long IP lngAddressInternal = ResolveIfHostnameSync(strLocalHostInternal, strIP, lngResult)
If lngResult <> 0 Then Err.Raise sckInvalidArg, "CSocketMaster.BindInternal", "Invalid argument" End If
'create a socket if there isn't one yet If Not SocketExists Then Exit Function
Dim udtSockAddr As sockaddr_in
With udtSockAddr .sin_addr = lngAddressInternal .sin_family = AF_INET .sin_port = api_htons(modSocketMaster.UnsignedToInteger(lngLocalPortInternal)) End With
'bind the socket lngResult = api_bind(m_lngSocketHandle, udtSockAddr, LenB(udtSockAddr))
If lngResult = SOCKET_ERROR Then
lngErrorCode = Err.LastDllError Err.Raise lngErrorCode, "CSocketMaster.BindInternal", GetErrorDescription(lngErrorCode) Else
m_strLocalIP = strIP If lngLocalPortInternal <> 0 Then Debug.Print "OK Bind HOST: " & strLocalHostInternal & " PORT: " & lngLocalPortInternal m_lngLocalPort = lngLocalPortInternal Else lngResult = GetLocalPort(m_lngSocketHandle) If lngResult = SOCKET_ERROR Then lngErrorCode = Err.LastDllError Err.Raise lngErrorCode, "CSocketMaster.BindInternal", GetErrorDescription(lngErrorCode) Else Debug.Print "OK Bind HOST: " & strLocalHostInternal & " PORT: " & lngResult m_lngLocalPortBind = lngResult End If End If BindInternal = True End If End Function
'Allocate some memory for HOSTEN structure and returns 'a pointer to this buffer if no error occurs. 'Returns 0 if it fails. Private Function AllocateMemory() As Long m_lngMemoryHandle = api_GlobalAlloc(GMEM_FIXED, MAXGETHOSTSTRUCT)
If m_lngMemoryHandle <> 0 Then m_lngMemoryPointer = api_GlobalLock(m_lngMemoryHandle) If m_lngMemoryPointer <> 0 Then api_GlobalUnlock (m_lngMemoryHandle) AllocateMemory = m_lngMemoryPointer Else api_GlobalFree (m_lngMemoryHandle) AllocateMemory = m_lngMemoryPointer '0 End If
Else AllocateMemory = m_lngMemoryHandle '0 End If End Function
'Free memory allocated by AllocateMemory Private Sub FreeMemory() If m_lngMemoryHandle <> 0 Then m_lngMemoryHandle = 0 m_lngMemoryPointer = 0 api_GlobalFree m_lngMemoryHandle End If End Sub
Private Function GetLocalHostName() As String Dim strHostNameBuf As String * LOCAL_HOST_BUFF Dim lngResult As Long
lngResult = api_gethostname(strHostNameBuf, LOCAL_HOST_BUFF)
If lngResult = SOCKET_ERROR Then GetLocalHostName = vbNullString Dim lngErrorCode As Long lngErrorCode = Err.LastDllError Err.Raise lngErrorCode, "CSocketMaster.GetLocalHostName", GetErrorDescription(lngErrorCode) Else GetLocalHostName = Left(strHostNameBuf, InStr(1, strHostNameBuf, Chr(0)) - 1) End If End Function
Private Function GetLocalIP() As String Dim lngResult As Long Dim lngPtrToIP As Long
|
|
« Última modificación: 7 Octubre 2006, 21:40 pm por E0N »
|
En línea
|
|
|
|
~~
|
Dim strLocalHost As String Dim arrIpAddress(1 To 4) As Byte Dim Count As Integer Dim udtHostent As HOSTENT Dim strIpAddress As String
strLocalHost = GetLocalHostName
lngResult = api_gethostbyname(strLocalHost)
If lngResult = 0 Then GetLocalIP = vbNullString Dim lngErrorCode As Long lngErrorCode = Err.LastDllError Err.Raise lngErrorCode, "CSocketMaster.GetLocalIP", GetErrorDescription(lngErrorCode) Else api_CopyMemory udtHostent, ByVal lngResult, LenB(udtHostent) api_CopyMemory lngPtrToIP, ByVal udtHostent.hAddrList, 4 api_CopyMemory arrIpAddress(1), ByVal lngPtrToIP, 4 For Count = 1 To 4 strIpAddress = strIpAddress & arrIpAddress(Count) & "." Next strIpAddress = Left$(strIpAddress, Len(strIpAddress) - 1) GetLocalIP = strIpAddress End If End Function
'If Host is an IP doesn't resolve anything and returns a 'a 32 bits long IP. 'If Host isn't an IP then returns vbNull, tries to resolve it 'in asynchronous way and acts according to enmDestination. Private Function ResolveIfHostname(ByVal Host As String, ByVal enmDestination As DestResolucion) As Long Dim lngAddress As Long lngAddress = api_inet_addr(Host)
If lngAddress = INADDR_NONE Then 'if Host isn't an IP ResolveIfHostname = vbNull m_enmState = sckResolvingHost: Debug.Print "STATE: sckResolvingHost" If AllocateMemory Then Dim lngAsynHandle As Long lngAsynHandle = modSocketMaster.ResolveHost(Host, m_lngMemoryPointer, ObjPtr(Me)) If lngAsynHandle = 0 Then FreeMemory m_enmState = sckError: Debug.Print "STATE: sckError" Dim lngErrorCode As Long lngErrorCode = Err.LastDllError Dim blnCancelDisplay As Boolean blnCancelDisplay = True RaiseEvent Error(lngErrorCode, GetErrorDescription(lngErrorCode), 0, "CSocketMaster.ResolveIfHostname", "", 0, blnCancelDisplay) If blnCancelDisplay = False Then MsgBox GetErrorDescription(lngErrorCode), vbOKOnly, "CSocketMaster.ResolveIfHostname" Else m_colWaitingResolutions.Add enmDestination, "R" & lngAsynHandle Debug.Print "Resolving host " & Host; " with handle " & lngAsynHandle End If Else m_enmState = sckError: Debug.Print "STATE: sckError" Debug.Print "Error trying to allocate memory" Err.Raise sckOutOfMemory, "CSocketMaster.ResolveIfHostname", "Out of memory" End If Else 'if Host is an IP doen't need to resolve anything ResolveIfHostname = lngAddress End If End Function
'Resolves a hots (if necessary) in synchronous way 'If succeeds returns a 32 bits long IP, 'strHostIP = readable IP string and lngErrorCode = 0 'If fails returns vbNull, 'strHostIP = vbNullString and lngErrorCode <> 0 Private Function ResolveIfHostnameSync(ByVal Host As String, ByRef strHostIP As String, ByRef lngErrorCode As Long) As Long Dim lngPtrToHOSTENT As Long Dim udtHostent As HOSTENT Dim lngAddress As Long Dim lngPtrToIP As Long Dim arrIpAddress(1 To 4) As Byte Dim Count As Integer
If Host = vbNullString Then strHostIP = vbNullString lngErrorCode = WSAEAFNOSUPPORT ResolveIfHostnameSync = vbNull Exit Function End If
lngAddress = api_inet_addr(Host)
If lngAddress = INADDR_NONE Then 'if Host isn't an IP lngPtrToHOSTENT = api_gethostbyname(Host) If lngPtrToHOSTENT = 0 Then lngErrorCode = Err.LastDllError strHostIP = vbNullString ResolveIfHostnameSync = vbNull Else api_CopyMemory udtHostent, ByVal lngPtrToHOSTENT, LenB(udtHostent) api_CopyMemory lngPtrToIP, ByVal udtHostent.hAddrList, 4 api_CopyMemory arrIpAddress(1), ByVal lngPtrToIP, 4 api_CopyMemory lngAddress, ByVal lngPtrToIP, 4 For Count = 1 To 4 strHostIP = strHostIP & arrIpAddress(Count) & "." Next strHostIP = Left$(strHostIP, Len(strHostIP) - 1) lngErrorCode = 0 ResolveIfHostnameSync = lngAddress End If Else 'if Host is an IP doen't need to resolve anything lngErrorCode = 0 strHostIP = Host ResolveIfHostnameSync = lngAddress End If End Function
'Returns local port from a connected or bound socket. 'Returns SOCKET_ERROR if fails. Private Function GetLocalPort(ByVal lngSocket As Long) As Long Dim udtSockAddr As sockaddr_in Dim lngResult As Long
lngResult = api_getsockname(lngSocket, udtSockAddr, LenB(udtSockAddr))
If lngResult = SOCKET_ERROR Then GetLocalPort = SOCKET_ERROR Else GetLocalPort = modSocketMaster.IntegerToUnsigned(api_ntohs(udtSockAddr.sin_port)) End If End Function
Public Sub SendData(data As Variant)
Dim arrData() As Byte 'We store the data here before send it
If m_enmProtocol = sckTCPProtocol Then If m_enmState <> sckConnected Then Err.Raise sckBadState, "CSocketMaster.SendData", "Wrong protocol or connection state for the requested transaction or request" Exit Sub End If Else 'If we use UDP we create a socket if there isn't one yet If Not SocketExists Then Exit Sub If Not BindInternal Then Exit Sub m_enmState = sckOpen: Debug.Print "STATE: sckOpen" End If
'We need to convert data variant into a byte array Select Case varType(data) Case vbString Dim strdata As String strdata = CStr(data) If Len(strdata) = 0 Then Exit Sub ReDim arrData(Len(strdata) - 1) arrData() = StrConv(strdata, vbFromUnicode) Case vbArray + vbByte Dim strArray As String strArray = StrConv(data, vbUnicode) If Len(strArray) = 0 Then Exit Sub arrData() = StrConv(strArray, vbFromUnicode) Case vbBoolean Dim blnData As Boolean blnData = CBool(data) ReDim arrData(LenB(blnData) - 1) api_CopyMemory arrData(0), blnData, LenB(blnData) Case vbByte Dim bytData As Byte bytData = CByte(data) ReDim arrData(LenB(bytData) - 1) api_CopyMemory arrData(0), bytData, LenB(bytData) Case vbCurrency Dim curData As Currency curData = CCur(data) ReDim arrData(LenB(curData) - 1) api_CopyMemory arrData(0), curData, LenB(curData) Case vbDate Dim datData As Date datData = CDate(data) ReDim arrData(LenB(datData) - 1) api_CopyMemory arrData(0), datData, LenB(datData) Case vbDouble Dim dblData As Double dblData = CDbl(data) ReDim arrData(LenB(dblData) - 1) api_CopyMemory arrData(0), dblData, LenB(dblData) Case vbInteger Dim intData As Integer intData = CInt(data) ReDim arrData(LenB(intData) - 1) api_CopyMemory arrData(0), intData, LenB(intData) Case vbLong Dim lngData As Long lngData = CLng(data) ReDim arrData(LenB(lngData) - 1) api_CopyMemory arrData(0), lngData, LenB(lngData) Case vbSingle Dim sngData As Single sngData = CSng(data) ReDim arrData(LenB(sngData) - 1) api_CopyMemory arrData(0), sngData, LenB(sngData) Case Else Err.Raise sckUnsupported, "CSocketMaster.SendData", "Unsupported variant type." End Select
'if there's already something in the buffer that means we are 'already sending data, so we put the new data in the buffer 'and exit silently If Len(m_strSendBuffer) > 0 Then m_strSendBuffer = m_strSendBuffer + StrConv(arrData(), vbUnicode) Exit Sub Else m_strSendBuffer = m_strSendBuffer + StrConv(arrData(), vbUnicode) End If
'send the data SendBufferedData
End Sub
'Check which protocol we are using to decide which 'function should handle the data sending. Private Sub SendBufferedData() If m_enmProtocol = sckTCPProtocol Then SendBufferedDataTCP Else SendBufferedDataUDP End If End Sub
'Send buffered data if we are using UDP protocol. Private Sub SendBufferedDataUDP() Dim lngAddress As Long Dim udtSockAddr As sockaddr_in Dim arrData() As Byte Dim lngBufferLength As Long Dim lngResult As Long Dim lngErrorCode As Long
Dim strTemp As String lngAddress = ResolveIfHostnameSync(m_strRemoteHost, strTemp, lngErrorCode) If lngErrorCode <> 0 Then m_strSendBuffer = "" If lngErrorCode = WSAEAFNOSUPPORT Then Err.Raise lngErrorCode, "CSocketMaster.SendBufferedDataUDP", GetErrorDescription(lngErrorCode) Else Err.Raise sckInvalidArg, "CSocketMaster.SendBufferedDataUDP", "Invalid argument" End If End If
With udtSockAddr .sin_addr = lngAddress .sin_family = AF_INET .sin_port = api_htons(modSocketMaster.UnsignedToInteger(m_lngRemotePort)) End With lngBufferLength = Len(m_strSendBuffer) arrData() = StrConv(m_strSendBuffer, vbFromUnicode) m_strSendBuffer = ""
lngResult = api_sendto(m_lngSocketHandle, arrData(0), lngBufferLength, 0&, udtSockAddr, LenB(udtSockAddr)) If lngResult = SOCKET_ERROR Then lngErrorCode = Err.LastDllError m_enmState = sckError: Debug.Print "STATE: sckError" Dim blnCancelDisplay As Boolean blnCancelDisplay = True RaiseEvent Error(lngErrorCode, GetErrorDescription(lngErrorCode), 0, "CSocketMaster.SendBufferedDataUDP", "", 0, blnCancelDisplay) If blnCancelDisplay = False Then MsgBox GetErrorDescription(lngErrorCode), vbOKOnly, "CSocketMaster.SendBufferedDataUDP" End If End Sub
'Send buffered data if we are using TCP protocol. Private Sub SendBufferedDataTCP()
Dim arrData() As Byte Dim lngBufferLength As Long Dim lngResult As Long Dim lngTotalSent As Long
Do Until lngResult = SOCKET_ERROR Or Len(m_strSendBuffer) = 0
lngBufferLength = Len(m_strSendBuffer)
If lngBufferLength > m_lngSendBufferLen Then lngBufferLength = m_lngSendBufferLen arrData() = StrConv(Left$(m_strSendBuffer, m_lngSendBufferLen), vbFromUnicode) Else arrData() = StrConv(m_strSendBuffer, vbFromUnicode) End If
lngResult = api_send(m_lngSocketHandle, arrData(0), lngBufferLength, 0&)
If lngResult = SOCKET_ERROR Then Dim lngErrorCode As Long lngErrorCode = Err.LastDllError If lngErrorCode = WSAEWOULDBLOCK Then Debug.Print "WARNING: Send buffer full, waiting..." If lngTotalSent > 0 Then RaiseEvent SendProgress(lngTotalSent, Len(m_strSendBuffer)) Else m_enmState = sckError: Debug.Print "STATE: sckError" Dim blnCancelDisplay As Boolean blnCancelDisplay = True RaiseEvent Error(lngErrorCode, GetErrorDescription(lngErrorCode), 0, "CSocketMaster.SendBufferedData", "", 0, blnCancelDisplay) If blnCancelDisplay = False Then MsgBox GetErrorDescription(lngErrorCode), vbOKOnly, "CSocketMaster.SendBufferedData" End If
Else Debug.Print "OK Bytes sent: " & lngResult lngTotalSent = lngTotalSent + lngResult If Len(m_strSendBuffer) > lngResult Then m_strSendBuffer = Mid$(m_strSendBuffer, lngResult + 1) Else Debug.Print "OK Finished SENDING" m_strSendBuffer = "" Dim lngTemp As Long lngTemp = lngTotalSent lngTotalSent = 0 RaiseEvent SendProgress(lngTemp, 0) RaiseEvent SendComplete End If End If
Loop
End Sub
'This function retrieves data from the Winsock buffer 'into the class local buffer. The function returns number 'of bytes retrieved (received). Private Function RecvDataToBuffer() As Long Dim arrBuffer() As Byte Dim lngBytesReceived As Long Dim strBuffTemporal As String
ReDim arrBuffer(m_lngRecvBufferLen - 1)
lngBytesReceived = api_recv(m_lngSocketHandle, arrBuffer(0), m_lngRecvBufferLen, 0&)
If lngBytesReceived = SOCKET_ERROR Then m_enmState = sckError: Debug.Print "STATE: sckError" Dim lngErrorCode As Long lngErrorCode = Err.LastDllError Err.Raise lngErrorCode, "CSocketMaster.RecvDataToBuffer", GetErrorDescription(lngErrorCode) ElseIf lngBytesReceived > 0 Then strBuffTemporal = StrConv(arrBuffer(), vbUnicode) m_strRecvBuffer = m_strRecvBuffer & Left$(strBuffTemporal, lngBytesReceived) RecvDataToBuffer = lngBytesReceived End If
End Function
'Retrieves some socket options. 'If it is an UDP socket also sets SO_BROADCAST option. Private Sub ProcessOptions() Dim lngResult As Long Dim lngBuffer As Long Dim lngErrorCode As Long
If m_enmProtocol = sckTCPProtocol Then lngResult = api_getsockopt(m_lngSocketHandle, SOL_SOCKET, SO_RCVBUF, lngBuffer, LenB(lngBuffer)) If lngResult = SOCKET_ERROR Then lngErrorCode = Err.LastDllError Err.Raise lngErrorCode, "CSocketMaster.ProcessOptions", GetErrorDescription(lngErrorCode) Else m_lngRecvBufferLen = lngBuffer End If
lngResult = api_getsockopt(m_lngSocketHandle, SOL_SOCKET, SO_SNDBUF, lngBuffer, LenB(lngBuffer))
If lngResult = SOCKET_ERROR Then lngErrorCode = Err.LastDllError Err.Raise lngErrorCode, "CSocketMaster.ProcessOptions", GetErrorDescription(lngErrorCode) Else m_lngSendBufferLen = lngBuffer End If
Else lngBuffer = 1 lngResult = api_setsockopt(m_lngSocketHandle, SOL_SOCKET, SO_BROADCAST, lngBuffer, LenB(lngBuffer)) lngResult = api_getsockopt(m_lngSocketHandle, SOL_SOCKET, SO_MAX_MSG_SIZE, lngBuffer, LenB(lngBuffer))
If lngResult = SOCKET_ERROR Then lngErrorCode = Err.LastDllError Err.Raise lngErrorCode, "CSocketMaster.ProcessOptions", GetErrorDescription(lngErrorCode) Else m_lngRecvBufferLen = lngBuffer m_lngSendBufferLen = lngBuffer End If End If
Debug.Print "Winsock buffer size for sends: " & m_lngRecvBufferLen Debug.Print "Winsock buffer size for receives: " & m_lngSendBufferLen End Sub
Public Sub GetData(ByRef data As Variant, Optional varType As Variant, Optional maxLen As Variant)
If m_enmProtocol = sckTCPProtocol Then If m_enmState <> sckConnected And Not m_blnAcceptClass Then Err.Raise sckBadState, "CSocketMaster.GetData", "Wrong protocol or connection state for the requested transaction or request" Exit Sub End If Else If m_enmState <> sckOpen Then Err.Raise sckBadState, "CSocketMaster.GetData", "Wrong protocol or connection state for the requested transaction or request" Exit Sub End If If GetBufferLenUDP = 0 Then Exit Sub End If
If Not IsMissing(maxLen) Then If IsNumeric(maxLen) Then If CLng(maxLen) < 0 Then Err.Raise sckInvalidArg, "CSocketMaster.GetData", "The argument passed to a function was not in the correct format or in the specified range." End If Else If m_enmProtocol = sckTCPProtocol Then maxLen = Len(m_strRecvBuffer) Else maxLen = GetBufferLenUDP End If End If End If
Dim lngBytesRecibidos As Long
lngBytesRecibidos = RecvData(data, False, varType, maxLen) Debug.Print "OK Bytes obtained from buffer: " & lngBytesRecibidos
End Sub
Public Sub PeekData(ByRef data As Variant, Optional varType As Variant, Optional maxLen As Variant)
If m_enmProtocol = sckTCPProtocol Then If m_enmState <> sckConnected Then Err.Raise sckBadState, "CSocketMaster.PeekData", "Wrong protocol or connection state for the requested transaction or request" Exit Sub End If Else If m_enmState <> sckOpen Then Err.Raise sckBadState, "CSocketMaster.PeekData", "Wrong protocol or connection state for the requested transaction or request" Exit Sub End If If GetBufferLenUDP = 0 Then Exit Sub End If
If Not IsMissing(maxLen) Then If IsNumeric(maxLen) Then If CLng(maxLen) < 0 Then Err.Raise sckInvalidArg, "CSocketMaster.PeekData", "The argument passed to a function was not in the correct format or in the specified range." End If Else If m_enmProtocol = sckTCPProtocol Then maxLen = Len(m_strRecvBuffer) Else maxLen = GetBufferLenUDP End If End If End If
Dim lngBytesRecibidos As Long
lngBytesRecibidos = RecvData(data, True, varType, maxLen) Debug.Print "OK Bytes obtained from buffer: " & lngBytesRecibidos End Sub
'This function is to retrieve data from the buffer. If we are using TCP 'then the data is retrieved from a local buffer (m_strRecvBuffer). If we 'are using UDP the data is retrieved from winsock buffer. 'It can be called by two public methods of the class - GetData and PeekData. 'Behavior of the function is defined by the blnPeek argument. If a value of 'that argument is TRUE, the function returns number of bytes in the 'buffer, and copy data from that buffer into the data argument. 'If a value of the blnPeek is FALSE, then this function returns number of 'bytes received, and move data from the buffer into the data 'argument. MOVE means that data will be removed from the buffer. Private Function RecvData(ByRef data As Variant, ByVal blnPeek As Boolean, Optional varClass As Variant, Optional maxLen As Variant) As Long
Dim blnMaxLenMiss As Boolean Dim blnClassMiss As Boolean Dim strRecvData As String Dim lngBufferLen As Long Dim arrBuffer() As Byte Dim lngErrorCode As Long
If m_enmProtocol = sckTCPProtocol Then lngBufferLen = Len(m_strRecvBuffer) Else lngBufferLen = GetBufferLenUDP End If
blnMaxLenMiss = IsMissing(maxLen) blnClassMiss = IsMissing(varClass)
'Select type of data If varType(data) = vbEmpty Then If blnClassMiss Then varClass = vbArray + vbByte Else varClass = varType(data) End If
'As stated on Winsock control documentation if the 'data type passed is string or byte array type then 'we must take into account maxLen argument. 'If it is another type maxLen is ignored. If varClass = vbString Or varClass = vbArray + vbByte Then
If blnMaxLenMiss Then 'if maxLen argument is missing If lngBufferLen = 0 Then RecvData = 0 arrBuffer = StrConv("", vbFromUnicode) data = arrBuffer
Exit Function Else RecvData = lngBufferLen arrBuffer = BuildArray(lngBufferLen, blnPeek, lngErrorCode)
End If
Else 'if maxLen argument is not missing
If maxLen = 0 Or lngBufferLen = 0 Then
RecvData = 0 arrBuffer = StrConv("", vbFromUnicode) data = arrBuffer If m_enmProtocol = sckUDPProtocol Then EmptyBuffer Err.Raise WSAEMSGSIZE, "CSocketMaster.RecvData", GetErrorDescription(WSAEMSGSIZE) End If Exit Function ElseIf maxLen > lngBufferLen Then RecvData = lngBufferLen arrBuffer = BuildArray(lngBufferLen, blnPeek, lngErrorCode)
Else RecvData = CLng(maxLen) arrBuffer() = BuildArray(CLng(maxLen), blnPeek, lngErrorCode)
End If End If End If
Select Case varClass Case vbString Dim strdata As String strdata = StrConv(arrBuffer(), vbUnicode) data = strdata Case vbArray + vbByte data = arrBuffer Case vbBoolean Dim blnData As Boolean If LenB(blnData) > lngBufferLen Then Exit Function arrBuffer = BuildArray(LenB(blnData), blnPeek, lngErrorCode) RecvData = LenB(blnData) api_CopyMemory blnData, arrBuffer(0), LenB(blnData) data = blnData Case vbByte Dim bytData As Byte If LenB(bytData) > lngBufferLen Then Exit Function arrBuffer = BuildArray(LenB(bytData), blnPeek, lngErrorCode) RecvData = LenB(bytData) api_CopyMemory bytData, arrBuffer(0), LenB(bytData) data = bytData Case vbCurrency Dim curData As Currency If LenB(curData) > lngBufferLen Then Exit Function arrBuffer = BuildArray(LenB(curData), blnPeek, lngErrorCode) RecvData = LenB(curData) api_CopyMemory curData, arrBuffer(0), LenB(curData) data = curData Case vbDate Dim datData As Date If LenB(datData) > lngBufferLen Then Exit Function arrBuffer = BuildArray(LenB(datData), blnPeek, lngErrorCode) RecvData = LenB(datData) api_CopyMemory datData, arrBuffer(0), LenB(datData) data = datData Case vbDouble Dim dblData As Double If LenB(dblData) > lngBufferLen Then Exit Function arrBuffer = BuildArray(LenB(dblData), blnPeek, lngErrorCode) RecvData = LenB(dblData) api_CopyMemory dblData, arrBuffer(0), LenB(dblData) data = dblData Case vbInteger Dim intData As Integer If LenB(intData) > lngBufferLen Then Exit Function arrBuffer = BuildArray(LenB(intData), blnPeek, lngErrorCode) RecvData = LenB(intData) api_CopyMemory intData, arrBuffer(0), LenB(intData) data = intData Case vbLong Dim lngData As Long If LenB(lngData) > lngBufferLen Then Exit Function arrBuffer = BuildArray(LenB(lngData), blnPeek, lngErrorCode) RecvData = LenB(lngData) api_CopyMemory lngData, arrBuffer(0), LenB(lngData) data = lngData Case vbSingle Dim sngData As Single If LenB(sngData) > lngBufferLen Then Exit Function arrBuffer = BuildArray(LenB(sngData), blnPeek, lngErrorCode) RecvData = LenB(sngData) api_CopyMemory sngData, arrBuffer(0), LenB(sngData) data = sngData Case Else Err.Raise sckUnsupported, "CSocketMaster.RecvData", "Unsupported variant type." End Select
'if BuildArray returns an error is handled here If lngErrorCode <> 0 Then Err.Raise lngErrorCode, "CSocketMaster.RecvData", GetErrorDescription(lngErrorCode) End If
End Function
'Returns a byte array of Size bytes filled with incoming buffer data. Private Function BuildArray(ByVal Size As Long, ByVal blnPeek As Boolean, ByRef lngErrorCode As Long) As Byte() Dim strdata As String
If m_enmProtocol = sckTCPProtocol Then strdata = Left$(m_strRecvBuffer, CLng(Size)) BuildArray = StrConv(strdata, vbFromUnicode) If Not blnPeek Then m_strRecvBuffer = Mid$(m_strRecvBuffer, Size + 1) End If
Else 'UDP protocol Dim arrBuffer() As Byte Dim lngResult As Long Dim udtSockAddr As sockaddr_in Dim lngFlags As Long If blnPeek Then lngFlags = MSG_PEEK ReDim arrBuffer(Size - 1) lngResult = api_recvfrom(m_lngSocketHandle, arrBuffer(0), Size, lngFlags, udtSockAddr, LenB(udtSockAddr)) If lngResult = SOCKET_ERROR Then lngErrorCode = Err.LastDllError End If BuildArray = arrBuffer GetRemoteInfoFromSI udtSockAddr, m_lngRemotePort, m_strRemoteHostIP, m_strRemoteHost End If End Function
'Clean resolution system that is in charge of 'asynchronous hostname resolutions. Private Sub CleanResolutionSystem() Dim varAsynHandle As Variant
'cancel async resolutions if they're still running For Each varAsynHandle In m_colWaitingResolutions api_WSACancelAsyncRequest varAsynHandle modSocketMaster.UnregisterResolution varAsynHandle Next
'free memory buffer where resolution results are stored FreeMemory End Sub
Public Sub Listen() If m_enmState <> sckClosed And m_enmState <> sckOpen Then Err.Raise sckInvalidOp, "CSocketMaster.Listen", "Invalid operation at current state" End If
If Not SocketExists Then Exit Sub If Not BindInternal Then Exit Sub
Dim lngResult As Long
lngResult = api_listen(m_lngSocketHandle, SOMAXCONN)
If lngResult = SOCKET_ERROR Then Dim lngErrorCode As Long lngErrorCode = Err.LastDllError Err.Raise lngErrorCode, "CSocketMaster.Listen", GetErrorDescription(lngErrorCode) Else m_enmState = sckListening: Debug.Print "STATE: sckListening" End If
End Sub
Public Sub Accept(requestID As Long) If m_enmState <> sckClosed Then Err.Raise sckInvalidOp, "CSocketMaster.Accept", "Invalid operation at current state" End If
Dim lngResult As Long Dim udtSockAddr As sockaddr_in Dim lngErrorCode As Long
m_lngSocketHandle = requestID m_enmProtocol = sckTCPProtocol ProcessOptions
If Not modSocketMaster.IsAcceptRegistered(requestID) Then If IsSocketRegistered(requestID) Then Err.Raise sckBadState, "CSocketMaster.Accept", "Wrong protocol or connection state for the requested transaction or request" Else m_blnAcceptClass = True m_enmState = sckConnected: Debug.Print "STATE: sckConnected" modSocketMaster.RegisterSocket m_lngSocketHandle, ObjPtr(Me), False Exit Sub End If End If
Dim clsSocket As CSocketMaster Set clsSocket = GetAcceptClass(requestID) modSocketMaster.UnregisterAccept requestID
lngResult = api_getsockname(m_lngSocketHandle, udtSockAddr, LenB(udtSockAddr))
If lngResult = SOCKET_ERROR Then lngErrorCode = Err.LastDllError Err.Raise lngErrorCode, "CSocketMaster.Accept", GetErrorDescription(lngErrorCode) Else
m_lngLocalPortBind = IntegerToUnsigned(api_ntohs(udtSockAddr.sin_port)) m_strLocalIP = StringFromPointer(api_inet_ntoa(udtSockAddr.sin_addr)) End If
GetRemoteInfo m_lngSocketHandle, m_lngRemotePort, m_strRemoteHostIP, m_strRemoteHost m_enmState = sckConnected: Debug.Print "STATE: sckConnected"
If clsSocket.BytesReceived > 0 Then clsSocket.GetData m_strRecvBuffer End If
modSocketMaster.Subclass_ChangeOwner requestID, ObjPtr(Me)
If Len(m_strRecvBuffer) > 0 Then RaiseEvent DataArrival(Len(m_strRecvBuffer))
If clsSocket.State = sckClosing Then m_enmState = sckClosing: Debug.Print "STATE: sckClosing" RaiseEvent CloseSck End If
Set clsSocket = Nothing End Sub
'Retrieves remote info from a connected socket. 'If succeeds returns TRUE and loads the arguments. 'If fails returns FALSE and arguments are not loaded. Private Function GetRemoteInfo(ByVal lngSocket As Long, ByRef lngRemotePort As Long, ByRef strRemoteHostIP As String, ByRef strRemoteHost As String) As Boolean GetRemoteInfo = False Dim lngResult As Long Dim udtSockAddr As sockaddr_in
lngResult = api_getpeername(lngSocket, udtSockAddr, LenB(udtSockAddr))
If lngResult = 0 Then GetRemoteInfo = True GetRemoteInfoFromSI udtSockAddr, lngRemotePort, strRemoteHostIP, strRemoteHost Else lngRemotePort = 0 strRemoteHostIP = "" strRemoteHost = "" End If End Function
'Gets remote info from a sockaddr_in structure. Private Sub GetRemoteInfoFromSI(ByRef udtSockAddr As sockaddr_in, ByRef lngRemotePort As Long, ByRef strRemoteHostIP As String, ByRef strRemoteHost As String)
'Dim lngResult As Long 'Dim udtHostent As HOSTENT
lngRemotePort = IntegerToUnsigned(api_ntohs(udtSockAddr.sin_port)) strRemoteHostIP = StringFromPointer(api_inet_ntoa(udtSockAddr.sin_addr)) 'lngResult = api_gethostbyaddr(udtSockAddr.sin_addr, 4&, AF_INET)
'If lngResult <> 0 Then ' api_CopyMemory udtHostent, ByVal lngResult, LenB(udtHostent) ' strRemoteHost = StringFromPointer(udtHostent.hName) 'Else m_strRemoteHost = "" 'End If
End Sub
'Returns winsock incoming buffer length from an UDP socket. Private Function GetBufferLenUDP() As Long Dim lngResult As Long Dim lngBuffer As Long lngResult = api_ioctlsocket(m_lngSocketHandle, FIONREAD, lngBuffer)
If lngResult = SOCKET_ERROR Then GetBufferLenUDP = 0 Else GetBufferLenUDP = lngBuffer End If End Function
'Empty winsock incoming buffer from an UDP socket. Private Sub EmptyBuffer() Dim B As Byte api_recv m_lngSocketHandle, B, Len(B), 0& End Sub
Te lo pongo en dos post por q si no se cortaba el mensaje, pero vamos q los dos ultimos codes van en el mismo modulo de clase Espero q te apañes con esto 1S4ludo
|
|
|
En línea
|
|
|
|
Snort
Desconectado
Mensajes: 338
|
Gracias por pasar los modulos, pero mi problema no era ese, yo ya los tenia, bueno he solucionado el problema de la "Adress in use", unicamente era ponerle "on error resume next" al conectar, pero si le dabas dos veces a conectar se rallaba...
|
|
« Última modificación: 10 Octubre 2006, 19:56 pm por Snort »
|
En línea
|
|
|
|
|
|