| Pubblicazione File: MSocketSupport Documento generato mediante: Documentation Creator By BGSoftware |
Attribute VB_Name = "MSocketSupport" ' ********************************************************************* '* CLASS Modulo necessario per utilizzare le Socket in Visual Basic. '* <BR/><B>Copyright 2002 by Oleg Gdalevich</B> '* E-Mail: <A HREF="mailto:giorgio.bernardi@studio.unibo.it">Giorgio.Bernardi@studio.unibo.it</A> '* Version: 1.0.12 Modified: 17-OCT-2002 '* <DIV CLASS="ClassDescription"> '* Modulo sviluppato esternamente e adattato da Giorgio Bernardi. '* </DIV> ' ********************************************************************* '******************************************************************************** 'MSocketSupport module 'Copyright 2002 by Oleg Gdalevich 'Visual Basic Internet Programming website (http://www.vbip.com) '******************************************************************************** 'This module contains API declarations and helper functions for the CSocket class '******************************************************************************** 'Version: 1.0.12 Modified: 17-OCT-2002 '******************************************************************************** 'To get latest version of this code please visit the following web page: 'http://www.vbip.com/winsock-api/csocket-class/csocket-class-01.asp '******************************************************************************** Option Explicit ' Public Const INADDR_NONE = &HFFFF ' Public Const SOCKET_ERROR = -1 Public Const INVALID_SOCKET = -1 Public Const INADDR_ANY = &H0 ' Public Const FD_SETSIZE = 64 ' '/* ' * Define constant based on rfc883, used by gethostbyxxxx() calls. ' */ Public Const MAXGETHOSTSTRUCT = 1024 ' '/* ' * WinSock 2 extension -- manifest constants for shutdown() ' */ Public Const SD_RECEIVE = &H0 Public Const SD_SEND = &H1 Public Const SD_BOTH = &H2 ' Public Const MSG_OOB = &H1 '/* process out-of-band data */ Public Const MSG_PEEK = &H2 '/* peek at incoming message */ Public Const MSG_DONTROUTE = &H4 '/* send without using routing tables */ Public Const MSG_PARTIAL = &H8000 '/* partial send or recv for message xport */ ' Public Const FD_READ = &H1& Public Const FD_WRITE = &H2& Public Const FD_OOB = &H4& Public Const FD_ACCEPT = &H8& Public Const FD_CONNECT = &H10& Public Const FD_CLOSE = &H20& ' Public Const SOL_SOCKET = 65535 ' ' option flags per socket Public Const SO_DEBUG = &H1& ' Turn on debugging info recording Public Const SO_ACCEPTCONN = &H2& ' Socket has had listen() - READ-ONLY. Public Const SO_REUSEADDR = &H4& ' Allow local address reuse. Public Const SO_KEEPALIVE = &H8& ' Keep connections alive. Public Const SO_DONTROUTE = &H10& ' Just use interface addresses. Public Const SO_BROADCAST = &H20& ' Permit sending of broadcast msgs. Public Const SO_USELOOPBACK = &H40& ' Bypass hardware when possible. Public Const SO_LINGER = &H80& ' Linger on close if data present. Public Const SO_OOBINLINE = &H100& ' Leave received OOB data in line. Public Const SO_DONTLINGER = Not SO_LINGER Public Const SO_EXCLUSIVEADDRUSE = Not SO_REUSEADDR ' Disallow local address reuse. ' Additional options. Public Const SO_SNDBUF = &H1001& ' Send buffer size. Public Const SO_RCVBUF = &H1002& ' Receive buffer size. Public Const SO_ERROR = &H1007& ' Get error status and clear. Public Const SO_TYPE = &H1008& ' Get socket type - READ-ONLY. ' Public Const WSADESCRIPTION_LEN = 257 Public Const WSASYS_STATUS_LEN = 129 ' Public 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 Const WSANOERROR = 0 Type IN_ADDR S_addr As Long End Type Type SOCK_ADDR sin_family As Integer sin_port As Integer sin_addr As IN_ADDR sin_zero(0 To 7) As Byte End Type Public Type fd_set fd_count As Long '// how many are SET? fd_array(1 To FD_SETSIZE) As Long '// an array of SOCKETs End Type ' '/* ' * All Windows Sockets error constants are biased by WSABASEERR from ' * the "normal" ' */ Public Const WSABASEERR = 10000 '/* ' * Windows Sockets definitions of regular Microsoft C error constants ' */ Public Const WSAEINTR = (WSABASEERR + 4) Public Const WSAEBADF = (WSABASEERR + 9) Public Const WSAEACCES = (WSABASEERR + 13) Public Const WSAEFAULT = (WSABASEERR + 14) Public Const WSAEINVAL = (WSABASEERR + 22) Public Const WSAEMFILE = (WSABASEERR + 24) '/* ' * Windows Sockets definitions of regular Berkeley error constants ' */ Public Const WSAEWOULDBLOCK = (WSABASEERR + 35) Public Const WSAEINPROGRESS = (WSABASEERR + 36) Public Const WSAEALREADY = (WSABASEERR + 37) Public Const WSAENOTSOCK = (WSABASEERR + 38) Public Const WSAEDESTADDRREQ = (WSABASEERR + 39) Public Const WSAEMSGSIZE = (WSABASEERR + 40) Public Const WSAEPROTOTYPE = (WSABASEERR + 41) Public Const WSAENOPROTOOPT = (WSABASEERR + 42) Public Const WSAEPROTONOSUPPORT = (WSABASEERR + 43) Public Const WSAESOCKTNOSUPPORT = (WSABASEERR + 44) Public Const WSAEOPNOTSUPP = (WSABASEERR + 45) Public Const WSAEPFNOSUPPORT = (WSABASEERR + 46) Public Const WSAEAFNOSUPPORT = (WSABASEERR + 47) Public Const WSAEADDRINUSE = (WSABASEERR + 48) Public Const WSAEADDRNOTAVAIL = (WSABASEERR + 49) Public Const WSAENETDOWN = (WSABASEERR + 50) Public Const WSAENETUNREACH = (WSABASEERR + 51) Public Const WSAENETRESET = (WSABASEERR + 52) Public Const WSAECONNABORTED = (WSABASEERR + 53) Public Const WSAECONNRESET = (WSABASEERR + 54) Public Const WSAENOBUFS = (WSABASEERR + 55) Public Const WSAEISCONN = (WSABASEERR + 56) Public Const WSAENOTCONN = (WSABASEERR + 57) Public Const WSAESHUTDOWN = (WSABASEERR + 58) Public Const WSAETOOMANYREFS = (WSABASEERR + 59) Public Const WSAETIMEDOUT = (WSABASEERR + 60) Public Const WSAECONNREFUSED = (WSABASEERR + 61) Public Const WSAELOOP = (WSABASEERR + 62) Public Const WSAENAMETOOLONG = (WSABASEERR + 63) Public Const WSAEHOSTDOWN = (WSABASEERR + 64) Public Const WSAEHOSTUNREACH = (WSABASEERR + 65) Public Const WSAENOTEMPTY = (WSABASEERR + 66) Public Const WSAEPROCLIM = (WSABASEERR + 67) Public Const WSAEUSERS = (WSABASEERR + 68) Public Const WSAEDQUOT = (WSABASEERR + 69) Public Const WSAESTALE = (WSABASEERR + 70) Public Const WSAEREMOTE = (WSABASEERR + 71) '/* ' * Extended Windows Sockets error constant definitions ' */ Public Const WSASYSNOTREADY = (WSABASEERR + 91) Public Const WSAVERNOTSUPPORTED = (WSABASEERR + 92) Public Const WSANOTINITIALISED = (WSABASEERR + 93) Public Const WSAEDISCON = (WSABASEERR + 101) Public Const WSAENOMORE = (WSABASEERR + 102) Public Const WSAECANCELLED = (WSABASEERR + 103) Public Const WSAEINVALIDPROCTABLE = (WSABASEERR + 104) Public Const WSAEINVALIDPROVIDER = (WSABASEERR + 105) Public Const WSAEPROVIDERFAILEDINIT = (WSABASEERR + 106) Public Const WSASYSCALLFAILURE = (WSABASEERR + 107) Public Const WSASERVICE_NOT_FOUND = (WSABASEERR + 108) Public Const WSATYPE_NOT_FOUND = (WSABASEERR + 109) Public Const WSA_E_NO_MORE = (WSABASEERR + 110) Public Const WSA_E_CANCELLED = (WSABASEERR + 111) Public Const WSAEREFUSED = (WSABASEERR + 112) ' '/* Authoritative Answer: Host not found */ Public Const WSAHOST_NOT_FOUND = (WSABASEERR + 1001) '/* Non-Authoritative: Host not found, or SERVERFAIL */ Public Const WSATRY_AGAIN = (WSABASEERR + 1002) '/* Non recoverable errors, FORMERR, REFUSED, NOTIMP */ Public Const WSANO_RECOVERY = (WSABASEERR + 1003) '/* Valid name, no data record of requested type */ Public Const WSANO_DATA = (WSABASEERR + 1004) '/* ' * Protocols ' */ Public Enum SocketProtocol IPPROTO_IP = 0 '/* dummy for IP */ IPPROTO_ICMP = 1 '/* control message protocol */ IPPROTO_IGMP = 2 '/* internet group management protocol */ IPPROTO_GGP = 3 '/* gateway^2 (deprecated) */ IPPROTO_TCP = 6 '/* tcp */ IPPROTO_PUP = 12 '/* pup */ IPPROTO_UDP = 17 '/* user datagram protocol */ IPPROTO_IDP = 22 '/* xns idp */ IPPROTO_ND = 77 '/* UNOFFICIAL net disk proto */ IPPROTO_RAW = 255 '/* raw IP packet */ IPPROTO_MAX = 256 End Enum ' Public Type HOSTENT hName As Long hAliases As Long hAddrType As Integer hLength As Integer hAddrList As Long End Type Public 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 Public Declare Function gethostbyaddr Lib "ws2_32.dll" (addr As Long, ByVal addr_len As Long, ByVal addr_type As Long) As Long Public Declare Function gethostbyname Lib "ws2_32.dll" (ByVal host_name As String) As Long Public Declare Function getHostName Lib "ws2_32.dll" Alias "gethostname" (ByVal host_name As String, ByVal namelen As Long) As Long Public Declare Function getservbyname Lib "ws2_32.dll" (ByVal serv_name As String, ByVal proto As String) As Long Public Declare Function getprotobynumber Lib "ws2_32.dll" (ByVal proto As Long) As Long Public Declare Function getprotobyname Lib "ws2_32.dll" (ByVal proto_name As String) As Long Public Declare Function getservbyport Lib "ws2_32.dll" (ByVal Port As Integer, ByVal proto As Long) As Long Public Declare Function inet_addr Lib "ws2_32.dll" (ByVal cp As String) As Long Public Declare Function inet_ntoa Lib "ws2_32.dll" (ByVal inn As Long) As Long Public Declare Function htons Lib "ws2_32.dll" (ByVal hostshort As Integer) As Integer Public Declare Function htonl Lib "ws2_32.dll" (ByVal hostlong As Long) As Long Public Declare Function ntohl Lib "ws2_32.dll" (ByVal netlong As Long) As Long Public Declare Function ntohs Lib "ws2_32.dll" (ByVal netshort As Integer) As Integer Public Declare Function sSocket Lib "ws2_32.dll" Alias "socket" (ByVal af As Long, ByVal s_type As Long, ByVal Protocol As Long) As Long Public Declare Function sCloseSocket Lib "ws2_32.dll" Alias "closesocket" (ByVal s As Long) As Long Public Declare Function sConnect Lib "ws2_32.dll" Alias "connect" (ByVal s As Long, ByRef Name As SOCK_ADDR, ByVal namelen As Long) As Long Public Declare Function getsockname Lib "ws2_32.dll" (ByVal s As Long, ByRef Name As SOCK_ADDR, ByRef namelen As Long) As Long Public Declare Function getpeername Lib "ws2_32.dll" (ByVal s As Long, ByRef Name As SOCK_ADDR, ByRef namelen As Long) As Long Public Declare Function sBind Lib "ws2_32.dll" Alias "bind" (ByVal s As Long, ByRef Name As SOCK_ADDR, ByRef namelen As Long) As Long Public Declare Function sSelect Lib "ws2_32.dll" Alias "select" (ByVal nfds As Long, ByRef readfds As Any, ByRef writefds As Any, ByRef exceptfds As Any, ByRef TimeOut As Long) As Long Public Declare Function recv Lib "ws2_32.dll" (ByVal s As Long, ByRef buf As Any, ByVal buflen As Long, ByVal flags As Long) As Long Public Declare Function 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 Public Declare Function shutdown Lib "ws2_32.dll" (ByVal s As Long, ByVal how As Long) As Long Public Declare Function api_listen Lib "ws2_32.dll" Alias "listen" (ByVal s As Long, ByVal backlog As Long) As Long Public Declare Function api_accept Lib "ws2_32.dll" Alias "accept" (ByVal s As Long, ByRef addr As SOCK_ADDR, ByRef addrlen As Long) As Long Public Declare Function setsockopt Lib "ws2_32.dll" (ByVal s As Long, ByVal level As Long, ByVal optname As Long, optval As Any, ByVal optlen As Long) As Long Public Declare Function getsockopt Lib "ws2_32.dll" (ByVal s As Long, ByVal level As Long, ByVal optname As Long, optval As Any, optlen As Long) As Long Public Declare Function sendto Lib "ws2_32.dll" (ByVal s As Long, ByRef buf As Any, ByVal buflen As Long, ByVal flags As Long, ByRef toaddr As SOCK_ADDR, ByVal tolen As Long) As Long Public Declare Function recvfrom Lib "ws2_32.dll" (ByVal s As Long, ByRef buf As Any, ByVal buflen As Long, ByVal flags As Long, ByRef from As SOCK_ADDR, ByRef fromlen As Long) As Long Public Declare Function WSAAsyncSelect Lib "ws2_32.dll" (ByVal s As Long, ByVal hwnd As Long, ByVal wMsg As Long, ByVal lEvent As Long) As Long Public Declare Function WSAAsyncGetHostByAddr Lib "ws2_32.dll" (ByVal hwnd As Long, ByVal wMsg As Long, ByRef lngAddr As Long, ByVal lngLenght As Long, ByVal lngType As Long, buf As Any, ByVal lngBufLen As Long) As Long Public Declare Function WSAAsyncGetHostByName Lib "ws2_32.dll" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal strHostName As String, buf As Any, ByVal buflen As Long) As Long Public Declare Function WSAStartup Lib "ws2_32.dll" (ByVal wVR As Long, lpWSAD As WSAData) As Long Public Declare Function WSACleanup Lib "ws2_32.dll" () As Long Declare Function WSACancelBlockingCall Lib "ws2_32" () As Long Declare Function WSAGetLastError Lib "ws2_32" () As Long Private Const GWL_WNDPROC = -4 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 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 DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long 'Added: 04-MAR-2002 Private Declare Function RegisterWindowMessage Lib "user32" Alias "RegisterWindowMessageA" (ByVal lpString As String) As Long 'Added: 17-OCT-2002 Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc&, ByVal hwnd&, ByVal msg&, ByVal wParam&, ByVal lParam&) As Long Private Declare Function lstrcpy Lib "kernel32" Alias "lstrcpyA" (ByVal lpString1 As String, ByVal lpString2 As Long) As Long Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As Any) As Long Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long) Public Const GMEM_FIXED = &H0 Public Const GMEM_MOVEABLE = &H2 ' Public Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long Public Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long Public Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long Public Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long '--------------------------------------------- 'Modified: 23-AUG-2002 '--------------------------------------------- 'The variable scope has been changed to Public to be 'visible from the CSocket class module 'Private m_lngWindowHandle As Long Public p_lngWindowHandle As Long '--------------------------------------------- Private m_colSockets As Collection Private m_colResolvers As Collection Private m_colMemoryBlocks As Collection Private m_lngPreviousValue As Long Private m_blnWinsockInit As Boolean Private m_lngMaxMsgSize As Long ' 'Private Const RESOLVE_MESSAGE = WM_USER + 1 'Private Const SOCKET_MESSAGE = WM_USER + 2 ' Private m_lngResolveMessage As Long 'Added: 04-MAR-2002 '--------------------------------------------- 'Modified: 23-AUG-2002 '--------------------------------------------- 'The variable scope has been changed to Public to be 'visible from the CSocket class module 'Private m_lngWinsockMessage As Long 'Added: 04-MAR-2002 Public p_lngWinsockMessage As Long '--------------------------------------------- ' Private Const OFFSET_4 = 4294967296# Private Const MAXINT_4 = 2147483647 Private Const OFFSET_2 = 65536 Private Const MAXINT_2 = 32767 Private Function WindowProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long ' 'This the callback function of the window created to hook 'messages sent by the Winsock service. It handles only two 'types of messages - network events for the sockets the 'WSAAsyncSelect fucntion was called for, and the messages 'sent in response to the WSAAsyncGetHostByName and 'WSAAsyncGetHostByAddress Winsock API functions. ' 'Then the message is received, this function creates illegal 'reference to the instance of the CSocket class and calls 'either the PostSocketEvent or PostGetHostEvent method of the 'class to pass that message to the class. ' Dim objSocket As CSocket 'the illegal reference to an 'instance of the CSocket class Dim lngObjPointer As Long 'pointer to the existing instance 'of the CSocket class Dim lngEventID As Long 'network event Dim lngErrorCode As Long 'code of the error message Dim lngMemoryHandle As Long 'descriptor of the allocated 'memory object Dim lngMemoryPointer As Long 'pointer to the allocated memory Dim lngHostAddress As Long '32-bit host address Dim strHostName As String 'a host hame Dim udtHost As HOSTENT 'structure of the data in the 'allocated memory block Dim lngIpAddrPtr As Long 'pointer to the IP address string ' On Error GoTo ERORR_HANDLER ' If uMsg = p_lngWinsockMessage Then 'Modified: 04-MAR-2002 ' 'All the pointers to the existing instances of the CSocket class 'are stored in the m_colSockets collection. Key of the collection's 'item contains a value of the socket handle, and a value of the 'collection item is the Long value that is a pointer the object, 'instance of the CSocket class. Since the wParam argument of the 'callback function contains a value of the socket handle the 'function has received the network event message for, we can use 'that value to get the object's pointer. With the pointer value 'we can create the illegal reference to the object to be able to 'call any Public or Friend subroutine of that object. ' Set objSocket = SocketObjectFromPointer(CLng(m_colSockets("S" & wParam))) ' 'Retrieve the network event ID lngEventID = LoWord(lParam) 'Retrieve the error code lngErrorCode = HiWord(lParam) ' 'Forward the message to the instance of the CSocket class objSocket.PostSocketEvent lngEventID, lngErrorCode ' ElseIf uMsg = m_lngResolveMessage Then 'Modified: 04-MAR-2002 ' 'A message has been received in response to the call of 'the WSAAsyncGetHostByName or WSAAsyncGetHostByAddress. ' 'Retrieve the error code lngErrorCode = HiWord(lParam) ' 'The wParam parameter of the callback function contains 'the task handle returned by the original function call '(see the ResolveHost function for more info). This value 'is used as a key of the m_colResolvers collection item. 'The item of that collection contains a pointer to the 'instance of the CSocket class. So, if we know a value 'of the task handle, we can find out the pointer to the 'object which called the ResolveHost function in this module. ' 'Get the object pointer by the task handle value lngObjPointer = CLng(m_colResolvers("R" & wParam)) ' 'A value of the pointer to the instance of the CSocket class 'is used also as a key for the m_colMemoryBlocks collection 'item that contains a handle of the allocated memory block 'object. That memory block is the buffer where the 'WSAAsyncGetHostByName and WSAAsyncGetHostByAddress functions 'store the result HOSTENT structure. ' 'Get the handle of the allocated memory block object by the 'pointer to the instance of the CSocket class. lngMemoryHandle = CLng(m_colMemoryBlocks("S" & lngObjPointer)) ' 'Lock the memory block and get address of the buffer where 'the HOSTENT structure data is stored. lngMemoryPointer = GlobalLock(lngMemoryHandle) ' 'Create an illegal reference to the instance of the 'CSocket class Set objSocket = SocketObjectFromPointer(lngObjPointer) ' 'Now we can forward the message to that instance. ' If lngErrorCode <> 0 Then ' 'If the host was not resolved, pass the error code value objSocket.PostGetHostEvent 0, 0, "", lngErrorCode ' Else ' 'Move data from the allocated memory block to the 'HOSTENT structure - udtHost CopyMemory udtHost, ByVal lngMemoryPointer, Len(udtHost) ' 'Get a 32-bit host address CopyMemory lngIpAddrPtr, ByVal udtHost.hAddrList, 4 CopyMemory lngHostAddress, ByVal lngIpAddrPtr, 4 ' 'Get a host name strHostName = StringFromPointer(udtHost.hName) ' 'Call the PostGetHostEvent friend method of the objSocket 'to forward the retrieved information. objSocket.PostGetHostEvent wParam, lngHostAddress, strHostName ' End If ' 'The task to resolve the host name is completed, thus we don't 'need the allocated memory block anymore and corresponding items 'in the m_colMemoryBlocks and m_colResolvers collections as well. ' 'Unlock the memory block Call GlobalUnlock(lngMemoryHandle) 'Free that memory Call GlobalFree(lngMemoryHandle) ' 'Rremove the items from the collections m_colMemoryBlocks.Remove "S" & lngObjPointer m_colResolvers.Remove "R" & wParam ' 'If there are no more resolving tasks in progress, 'destroy the collection objects to free resources. If m_colResolvers.Count = 0 Then Set m_colMemoryBlocks = Nothing Set m_colResolvers = Nothing End If ' '--------------------------------------------------------------------- 'Added: 17-OCT-2002 Else 'Pass other messages to the original window procedure WindowProc = CallWindowProc(m_lngPreviousValue, hwnd, uMsg, wParam, lParam) '--------------------------------------------------------------------- End If ' EXIT_LABEL: ' Exit Function ' ERORR_HANDLER: ' 'Err.Raise Err.Number, "CSocket.WindowProc", Err.Description ' 'GoTo EXIT_LABEL ' End Function Public Function RegisterSocket(ByVal lngSocketHandle As Long, ByVal lngObjectPointer As Long) As Boolean '******************************************************************************** 'Author :Oleg Gdalevich 'Date/Time :17-12-2001 'Purpose :Adds the socket to the m_colSockets 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. 'Arguments :lngSocketHandle - the socket handle ' lngObjectPointer - pointer to an object, instance of the CSocket class 'Returns :If the argument is valid and no error occurred - True. '******************************************************************************** ' On Error GoTo ERROR_HANDLER 'Added: 04-JUNE-2002 ' Dim lngEvents As Long Dim lngRetValue As Long ' If p_lngWindowHandle = 0 Then ' 'We have no window to catch the network events. 'Create a new one. p_lngWindowHandle = CreateWinsockMessageWindow ' If p_lngWindowHandle = 0 Then ' 'Cannot create a new window. '--------------------------------------------------- 'Added: 04-JUNE-2002 '--------------------------------------------------- 'Set the error info to pass to the caller subroutine Err.Number = sckOpCanceled Err.Description = "The operation was canceled." Err.Source = "MSocketSupport.RegisterSocket" '--------------------------------------------------- 'Just exit to return False Exit Function ' End If ' End If ' 'The m_colSockets collection holds information 'about all the sockets. If the current socket is 'the first one, create the collection object. If m_colSockets Is Nothing Then Set m_colSockets = New Collection 'Debug.Print "The m_colSockets is created" End If ' 'Add a new item to the m_colSockets collection. 'The item key contains the socket handle, and the item's data 'is the pointer to the instance of the CSocket class. m_colSockets.Add lngObjectPointer, "S" & lngSocketHandle ' 'The lngEvents variable contains a bitmask of events we are 'going to catch with the window callback function. lngEvents = FD_CONNECT Or FD_READ Or FD_WRITE Or FD_CLOSE Or FD_ACCEPT ' 'Force the Winsock service to send the network event notifications 'to the window which handle is p_lngWindowHandle. lngRetValue = WSAAsyncSelect(lngSocketHandle, p_lngWindowHandle, p_lngWinsockMessage, lngEvents) 'Modified:04-MAR-2002 ' '------------------------------------------------------------------ 'Added: 04-JUNE-2002 '------------------------------------------------------------------ If lngRetValue = SOCKET_ERROR Then ' 'If the WSAAsyncSelect call failed this function must 'return False. In this case, the caller subroutine will 'raise an error. Let's pass the error info with the Err object. ' RegisterSocket = False ' Err.Number = Err.LastDllError Err.Description = GetErrorDescription(Err.LastDllError) Err.Source = "MSocketSupport.RegisterSocket" ' Else ' RegisterSocket = True ' End If '------------------------------------------------------------------- 'Debug.Print lngSocketHandle & ": registered" ' Exit Function 'Added: 04-JUNE-2002 ' ERROR_HANDLER: 'Added: 04-JUNE-2002 ' RegisterSocket = False 'Added: 04-JUNE-2002 ' End Function Public Function UnregisterSocket(ByVal lngSocketHandle As Long) As Boolean '******************************************************************************** 'Author :Oleg Gdalevich 'Date/Time :17-12-2001 'Purpose :Removes the socket from the m_colSockets collection ' If it is the last socket in that collection, the window ' and colection will be destroyed as well. 'Returns :If the argument is valid and no error occurred - True. '******************************************************************************** ' If (lngSocketHandle = INVALID_SOCKET) Or (m_colSockets Is Nothing) Then ' 'Something wrong with the caller of this function :) 'Return False Exit Function ' End If ' Call WSAAsyncSelect(lngSocketHandle, p_lngWindowHandle, 0&, 0&) ' 'Remove the socket from the collection m_colSockets.Remove "S" & lngSocketHandle ' UnregisterSocket = True ' 'Debug.Print lngSocketHandle & ": unregistered" ' If m_colSockets.Count = 0 Then ' 'If there are no more sockets in the collection 'destroy the collection object and the window ' Set m_colSockets = Nothing ' 'Debug.Print "m_colSockets destroyed" ' UnregisterSocket = DestroyWinsockMessageWindow ' End If ' End Function Public Function ResolveHost(strHostAddress As String, ByVal lngObjectPointer As Long) As Long '******************************************************************************** 'Author :Oleg Gdalevich 'Date/Time :17-12-2001 'Purpose :Receives requests to resolve a host address from the CSocket class. 'Returns :If no errors occurred - ID of the request. Otherwise - 0. '******************************************************************************** ' 'Since this module is supposed to serve several instances of the 'CSocket class, this function can be called to start several 'resolving tasks that could be executed simultaneously. To 'distinguish the resolving tasks the m_colResolvers collection 'is used. The key of the collection's item contains a pointer to 'the instance of the CSocket class and the item's data is the 'Request ID, the value returned by the WSAAsyncGetHostByXXXX 'Winsock API function. So in order to get the pointer to the 'instance of the CSocket class by the task ID value the following 'line of code can be used: ' 'lngObjPointer = CLng(m_colResolvers("R" & lngTaskID)) ' 'The WSAAsyncGetHostByXXXX function needs the buffer (the buf argument) 'where the data received from DNS server will be stored. We cannot use 'a local byte array for this purpose as this buffer must be available 'from another subroutine in this module - WindowProc, also we cannot 'use a module level array as several tasks can be executed simultaneously 'At least, we need a dynamic module level array of arrays - too complicated. 'I decided to use Windows API functions for allocation some memory for 'each resolving task: GlobalAlloc, GlobalLock, GlobalUnlock, and GlobalFree. ' 'To distinguish those memory blocks, the m_colMemoryBlocks collection is 'used. The key of the collection's item contains value of the object 'pointer, and the item's value is a handle of the allocated memory 'block object, value returned by the GlobalAlloc function. So in order to 'get value of the handle of the allocated memory block object by the 'pointer to the instance of CSocket class we can use the following code: ' 'lngMemoryHandle = CLng(m_colMemoryBlocks("S" & lngObjPointer)) ' 'Why do we need all this stuff? ' 'The problem is that the callback function give us only the resolving task 'ID value, but we need information about: ' - where the data returned from the DNS server is stored ' - which instance of the CSocket class we need to post the info to ' 'So, if we know the task ID value, we can find out the object pointer: ' lngObjPointer = CLng(m_colResolvers("R" & lngTaskID)) ' 'If we know the object pointer value we can find out where the data is strored: ' lngMemoryHandle = CLng(m_colMemoryBlocks("S" & lngObjPointer)) ' 'That's it. :)) ' Dim lngRequestID As Long 'value returned by WSAAsyncGetHostByXXX Dim lngMemoryHandle As Long 'handle of the allocated memory block object Dim lngMemoryPointer As Long 'address of the memory block ' 'Allocate some memory lngMemoryHandle = GlobalAlloc(GMEM_FIXED, MAXGETHOSTSTRUCT) ' If lngMemoryHandle > 0 Then ' 'Lock the memory block just to get the address 'of that memory into the lngMemoryPointer variable lngMemoryPointer = GlobalLock(lngMemoryHandle) ' If lngMemoryPointer = 0 Then ' 'Memory allocation error Call GlobalFree(lngMemoryHandle) Exit Function ' Else 'Unlock the memory block GlobalUnlock (lngMemoryHandle) ' End If ' Else ' 'Memory allocation error Exit Function ' End If ' 'If this request is the first one, create the collections If m_colResolvers Is Nothing Then Set m_colMemoryBlocks = New Collection Set m_colResolvers = New Collection End If ' '------------------------------------------------------------------ 'Added: 09-JULY-2002 '------------------------------------------------------------------ Dim strKey As String ' strKey = "S" & CStr(lngObjectPointer) ' Call RemoveIfExists(strKey) '------------------------------------------------------------------ 'Remember the memory block location m_colMemoryBlocks.Add lngMemoryHandle, strKey ' '------------------------------------------------------------------ 'Modified: 08-JULY-2002 '------------------------------------------------------------------ 'Here is a major change. Since version 1.0.6 (08-JULY-2002) the 'SCocket class doesn't try to resolve the IP address into a 'domain name while connecting. '------------------------------------------------------------------ ' 'Try to get 32-bit address 'lngAddress = inet_addr(strHostAddress) ' 'If lngAddress = INADDR_NONE Then ' 'If strHostAddress is not an IP address, try to resolve by name lngRequestID = WSAAsyncGetHostByName(p_lngWindowHandle, m_lngResolveMessage, strHostAddress, ByVal lngMemoryPointer, MAXGETHOSTSTRUCT) 'Modified: 04-MAR-2002 ' 'Else ' 'strHostAddress contains an IP address, resolve by address to get a host name ' lngRequestID = WSAAsyncGetHostByAddr(p_lngWindowHandle, m_lngResolveMessage, lngAddress, 4&, AF_INET, ByVal lngMemoryPointer, MAXGETHOSTSTRUCT) 'Modified: 04-MAR-2002 ' 'End If ' '------------------------------------------------------------------ ' If lngRequestID <> 0 Then ' 'If the call of the WSAAsyncGetHostByXXXX is successful, the 'lngRequestID variable contains the task ID value. 'Remember it. m_colResolvers.Add lngObjectPointer, "R" & CStr(lngRequestID) ' 'Return value ResolveHost = lngRequestID ' Else ' 'If the call of the WSAAsyncGetHostByXXXX is not successful, 'remove the item from the m_colMemoryBlocks collection. m_colMemoryBlocks.Remove ("S" & CStr(lngObjectPointer)) ' 'Free allocated memory block Call GlobalFree(lngMemoryHandle) ' 'If there are no more resolving tasks in progress, 'destroy the collection objects. If m_colResolvers.Count = 0 Then Set m_colResolvers = Nothing Set m_colMemoryBlocks = Nothing End If ' 'Set the error info. Err.Number = Err.LastDllError Err.Description = GetErrorDescription(Err.LastDllError) Err.Source = "MSocketSupport.ResolveHost" ' End If ' End Function Private Function CreateWinsockMessageWindow() As Long '******************************************************************************** 'Author :Oleg Gdalevich 'Date/Time :17-12-2001 'Purpose :Creates a window to hook the winsock messages 'Returns :The window handle '******************************************************************************** ' 'Create a window. It will be used for hooking messages for registered 'sockets, and we'll not see this window as the ShowWindow is never called. p_lngWindowHandle = CreateWindowEx(0&, "STATIC", "SOCKET_WINDOW", 0&, 0&, 0&, 0&, 0&, 0&, 0&, App.hInstance, ByVal 0&) ' If p_lngWindowHandle = 0 Then ' 'I really don't know - is this possible? Probably - yes, 'due the lack of the system resources, for example. ' 'In this case the function returns 0. ' Else ' 'Register a callback function for the window created a moment ago in this function 'm_lngPreviousValue - stores the returned value that is the pointer to the previous 'callback window function. We'll need this value to destroy the window. m_lngPreviousValue = SetWindowLong(p_lngWindowHandle, GWL_WNDPROC, AddressOf WindowProc) ' 'Just to let the caller know that the function was executed successfully CreateWinsockMessageWindow = p_lngWindowHandle ' 'Debug.Print "The window is created: " & p_lngWindowHandle ' End If ' End Function Private Function DestroyWinsockMessageWindow() As Boolean '******************************************************************************** 'Author :Oleg Gdalevich 'Date/Time :17-12-2001 'Purpose :Destroyes the window 'Returns :If the window was destroyed successfully - True. '******************************************************************************** ' On Error GoTo ERR_HANDLER ' 'Return the previous window procedure SetWindowLong p_lngWindowHandle, GWL_WNDPROC, m_lngPreviousValue 'Destroy the window DestroyWindow p_lngWindowHandle ' 'Debug.Print "The window " & p_lngWindowHandle & " is destroyed" ' 'Reset the window handle variable p_lngWindowHandle = 0 'If no errors occurred, the function returns True DestroyWinsockMessageWindow = True ' ERR_HANDLER: End Function Private Function SocketObjectFromPointer(ByVal lngPointer As Long) As CSocket ' Dim objSocket As CSocket ' CopyMemory objSocket, lngPointer, 4& Set SocketObjectFromPointer = objSocket CopyMemory objSocket, 0&, 4& ' End Function Private Function LoWord(lngValue As Long) As Long LoWord = (lngValue And &HFFFF&) End Function Private 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 Public Function GetErrorDescription(ByVal lngErrorCode As Long) As String ' Dim strDesc As String ' Select Case lngErrorCode ' Case WSAEACCES strDesc = "Permission denied." Case WSAEADDRINUSE strDesc = "Address already in use." Case WSAEADDRNOTAVAIL strDesc = "Cannot assign requested address." Case WSAEAFNOSUPPORT strDesc = "Address family not supported by protocol family." Case WSAEALREADY strDesc = "Operation already in progress." Case WSAECONNABORTED strDesc = "Software caused connection abort." Case WSAECONNREFUSED strDesc = "Connection refused." Case WSAECONNRESET strDesc = "Connection reset by peer." Case WSAEDESTADDRREQ strDesc = "Destination address required." Case WSAEFAULT strDesc = "Bad address." Case WSAEHOSTDOWN strDesc = "Host is down." Case WSAEHOSTUNREACH strDesc = "No route to host." Case WSAEINPROGRESS strDesc = "Operation now in progress." Case WSAEINTR strDesc = "Interrupted function call." Case WSAEINVAL strDesc = "Invalid argument." Case WSAEISCONN strDesc = "Socket is already connected." Case WSAEMFILE strDesc = "Too many open files." Case WSAEMSGSIZE strDesc = "Message too long." Case WSAENETDOWN strDesc = "Network is down." Case WSAENETRESET strDesc = "Network dropped connection on reset." Case WSAENETUNREACH strDesc = "Network is unreachable." Case WSAENOBUFS strDesc = "No buffer space available." Case WSAENOPROTOOPT strDesc = "Bad protocol option." Case WSAENOTCONN strDesc = "Socket is not connected." Case WSAENOTSOCK strDesc = "Socket operation on nonsocket." Case WSAEOPNOTSUPP strDesc = "Operation not supported." Case WSAEPFNOSUPPORT strDesc = "Protocol family not supported." Case WSAEPROCLIM strDesc = "Too many processes." Case WSAEPROTONOSUPPORT strDesc = "Protocol not supported." Case WSAEPROTOTYPE strDesc = "Protocol wrong type for socket." Case WSAESHUTDOWN strDesc = "Cannot send after socket shutdown." Case WSAESOCKTNOSUPPORT strDesc = "Socket type not supported." Case WSAETIMEDOUT strDesc = "Connection timed out." Case WSATYPE_NOT_FOUND strDesc = "Class type not found." Case WSAEWOULDBLOCK strDesc = "Resource temporarily unavailable." Case WSAHOST_NOT_FOUND strDesc = "Host not found." Case WSANOTINITIALISED strDesc = "Successful WSAStartup not yet performed." Case WSANO_DATA strDesc = "Valid name, no data record of requested type." Case WSANO_RECOVERY strDesc = "This is a nonrecoverable error." Case WSASYSCALLFAILURE strDesc = "System call failure." Case WSASYSNOTREADY strDesc = "Network subsystem is unavailable." Case WSATRY_AGAIN strDesc = "Nonauthoritative host not found." Case WSAVERNOTSUPPORTED strDesc = "Winsock.dll version out of range." Case WSAEDISCON strDesc = "Graceful shutdown in progress." Case Else strDesc = "Unknown error." End Select ' GetErrorDescription = strDesc ' End Function Public Function InitWinsockService() As Long ' 'This functon does two things; it initializes the Winsock 'service and returns value of maximum size of the UDP 'message. Since this module is supposed to serve multiple 'instances of the CSocket class, this function can be 'called several times. But we need to call the WSAStartup 'Winsock API function only once when the first instance of 'the CSocket class is created. ' Dim lngRetVal As Long 'value returned by WSAStartup Dim strErrorMsg As String 'error description string Dim udtWinsockData As WSAData 'structure to pass to WSAStartup as an argument ' If Not m_blnWinsockInit Then ' 'start up winsock service lngRetVal = WSAStartup(&H101, udtWinsockData) ' If lngRetVal <> 0 Then ' 'The system cannot load the Winsock library. ' Select Case lngRetVal Case WSASYSNOTREADY strErrorMsg = "The underlying network subsystem is not " & _ "ready for network communication." Case WSAVERNOTSUPPORTED strErrorMsg = "The version of Windows Sockets API support " & _ "requested is not provided by this particular " & _ "Windows Sockets implementation." Case WSAEINVAL strErrorMsg = "The Windows Sockets version specified by the " & _ "application is not supported by this DLL." End Select ' Err.Raise Err.LastDllError, "MSocketSupport.InitWinsockService", strErrorMsg ' Else ' 'The Winsock library is loaded successfully. ' m_blnWinsockInit = True ' 'This function returns returns value of 'maximum size of the UDP message m_lngMaxMsgSize = IntegerToUnsigned(udtWinsockData.iMaxUdpDg) InitWinsockService = m_lngMaxMsgSize ' m_lngResolveMessage = RegisterWindowMessage(App.EXEName & ".ResolveMessage") 'Added: 04-MAR-2002 p_lngWinsockMessage = RegisterWindowMessage(App.EXEName & ".WinsockMessage") 'Added: 04-MAR-2002 ' ' End If ' Else ' 'If this function has been called before by another 'instance of the CSocket class, the code to init the 'Winsock service must not be executed, but the function 'returns maximum size of the UDP message anyway. InitWinsockService = m_lngMaxMsgSize ' End If ' End Function Public Sub CleanupWinsock() '******************************************************************************** 'This subroutine is called from the Class_Terminate() event 'procedure of any instance of the CSocket class. But the WSACleanup 'Winsock API function is called only if the calling object is the 'last instance of the CSocket class within the current process. '******************************************************************************** ' 'If the Winsock library was loaded 'before and there are no more sockets. If m_blnWinsockInit And m_colSockets Is Nothing Then ' 'Unload library and free the system resources Call WSACleanup ' 'Turn off the m_blnWinsockInit flag variable m_blnWinsockInit = False ' End If ' End Sub Public Function StringFromPointer(ByVal lPointer As Long) As String ' Dim strTemp As String Dim lRetVal As Long ' 'prepare the strTemp buffer strTemp = String$(lstrlen(ByVal lPointer), 0) ' 'copy the string into the strTemp buffer lRetVal = lstrcpy(ByVal strTemp, ByVal lPointer) ' 'return a string If lRetVal Then StringFromPointer = strTemp ' End Function Public Function UnsignedToLong(Value As Double) As Long ' 'The function takes a Double containing a value in the 'range of an unsigned Long and returns a Long that you 'can pass to an API that requires an unsigned Long ' If Value < 0 Or Value >= OFFSET_4 Then Error 6 ' Overflow ' If Value <= MAXINT_4 Then UnsignedToLong = Value Else UnsignedToLong = Value - OFFSET_4 End If ' End Function Public Function LongToUnsigned(Value As Long) As Double ' 'The function takes an unsigned Long from an API and 'converts it to a Double for display or arithmetic purposes ' If Value < 0 Then LongToUnsigned = Value + OFFSET_4 Else LongToUnsigned = Value End If ' End Function Public Function UnsignedToInteger(Value As Long) As Integer ' 'The function takes a Long containing a value in the range 'of an unsigned Integer and returns an Integer that you 'can pass to an API that requires an unsigned Integer ' If Value < 0 Or Value >= OFFSET_2 Then Error 6 ' Overflow ' If Value <= MAXINT_2 Then UnsignedToInteger = Value Else UnsignedToInteger = Value - OFFSET_2 End If ' End Function Public Function IntegerToUnsigned(Value As Integer) As Long ' 'The function takes an unsigned Integer from and API and 'converts it to a Long for display or arithmetic purposes ' If Value < 0 Then IntegerToUnsigned = Value + OFFSET_2 Else IntegerToUnsigned = Value End If ' End Function Private Sub RemoveIfExists(ByVal strKey As String) ' On Error Resume Next ' m_colMemoryBlocks.Remove strKey ' End Sub |
Documento generato mediante: Documentation Creator By BGSoftware |