Email服务器

开发平台：
Visual Basic

MSocketSupport.bas：源码内容
							Attribute VB_Name = "MSocketSupport"
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 = &H0&         ' 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 Type sockaddr_in
    sin_family       As Integer
    sin_port         As Integer
    sin_addr         As Long
    sin_zero(1 To 8) 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)
'
'
'Socket types
'
Public Enum SocketType
    SOCK_STREAM = 1    ' /* stream socket */
    SOCK_DGRAM = 2     ' /* datagram socket */
    SOCK_RAW = 3       ' /* raw-protocol interface */
    SOCK_RDM = 4       ' /* reliably-delivered message */
    SOCK_SEQPACKET = 5 ' /* sequenced packet stream */
End Enum
'
Public Enum AddressFamily
    '
    AF_UNSPEC = 0      '/* unspecified */
'/*
' * Although  AF_UNSPEC  is  defined for backwards compatibility, using
' * AF_UNSPEC for the "af" parameter when creating a socket is STRONGLY
' * DISCOURAGED.    The  interpretation  of  the  "protocol"  parameter
' * depends  on the actual address family chosen.  As environments grow
' * to  include  more  and  more  address families that use overlapping
' * protocol  values  there  is  more  and  more  chance of choosing an
' * undesired address family when AF_UNSPEC is used.
' */
    AF_UNIX = 1        '/* local to host (pipes, portals) */
    AF_INET = 2        '/* internetwork: UDP, TCP, etc. */
    AF_IMPLINK = 3     '/* arpanet imp addresses */
    AF_PUP = 4         '/* pup protocols: e.g. BSP */
    AF_CHAOS = 5       '/* mit CHAOS protocols */
    AF_NS = 6          '/* XEROX NS protocols */
    AF_IPX = AF_NS     '/* IPX protocols: IPX, SPX, etc. */
    AF_ISO = 7         '/* ISO protocols */
    AF_OSI = AF_ISO    '/* OSI is ISO */
    AF_ECMA = 8        '/* european computer manufacturers */
    AF_DATAKIT = 9     '/* datakit protocols */
    AF_CCITT = 10      '/* CCITT protocols, X.25 etc */
    AF_SNA = 11        '/* IBM SNA */
    AF_DECnet = 12     '/* DECnet */
    AF_DLI = 13        '/* Direct data link interface */
    AF_LAT = 14        '/* LAT */
    AF_HYLINK = 15     '/* NSC Hyperchannel */
    AF_APPLETALK = 16  '/* AppleTalk */
    AF_NETBIOS = 17    '/* NetBios-style addresses */
    AF_VOICEVIEW = 18  '/* VoiceView */
    AF_FIREFOX = 19    '/* Protocols from Firefox */
    AF_UNKNOWN1 = 20   '/* Somebody is using this! */
    AF_BAN = 21        '/* Banyan */
    AF_ATM = 22        '/* Native ATM Services */
    AF_INET6 = 23      '/* Internetwork Version 6 */
    AF_CLUSTER = 24    '/* Microsoft Wolfpack */
    AF_12844 = 25      '/* IEEE 1284.4 WG AF */
    AF_MAX = 26
    '
End Enum
'
'/*
' * 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 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" (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 api_socket Lib "ws2_32.dll" Alias "socket" (ByVal af As Long, ByVal s_type As Long, ByVal protocol As Long) As Long
Public Declare Function api_closesocket Lib "ws2_32.dll" Alias "closesocket" (ByVal s As Long) As Long
Public 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
Public Declare Function getsockname Lib "ws2_32.dll" (ByVal s As Long, ByRef Name As sockaddr_in, ByRef namelen As Long) As Long
Public Declare Function getpeername Lib "ws2_32.dll" (ByVal s As Long, ByRef Name As sockaddr_in, ByRef namelen As Long) As Long
Public 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
Public Declare Function api_select 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" (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 sockaddr_in, 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 sockaddr_in, 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 sockaddr_in, 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
'
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
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)
Private Declare Sub RtlMoveMemory Lib "kernel32" (hpvDest As Any, ByVal hpvSource As Long, 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
'
Private m_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_blnGetHostRecv    As Boolean
Private m_blnWinsockInit    As Boolean
Private m_lngMaxMsgSize     As Long
Private Const WM_USER = &H400
'
'Private Const RESOLVE_MESSAGE = WM_USER + 1
'Private Const SOCKET_MESSAGE = WM_USER + 2
'
Private m_lngResolveMessage As Long 'Added: 04-MAR-2002
Private m_lngWinsockMessage As Long 'Added: 04-MAR-2002
'
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 = m_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
        '
    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.
'********************************************************************************
    '
    Dim lngEvents   As Long
    Dim lngRetValue As Long
    '
    If m_lngWindowHandle = 0 Then
        '
        'We have no window to catch the network events.
        'Create a new one.
        m_lngWindowHandle = CreateWinsockMessageWindow
        '
        If m_lngWindowHandle = 0 Then
            '
            'Can't create a new window. 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
    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 m_lngWindowHandle.
    lngRetValue = WSAAsyncSelect(lngSocketHandle, m_lngWindowHandle, m_lngWinsockMessage, lngEvents)    'Modified:04-MAR-2002
    '
    'Return value of this function
    RegisterSocket = Not CBool(lngRetValue)
    '
    '
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, m_lngWindowHandle, 0&, 0&)
    '
    'Remove the socket from the collection
    m_colSockets.Remove "S" & lngSocketHandle
    '
    UnregisterSocket = True
    '
    '
    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
        '
        '
        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 lngAddress          As Long '32-bit host address
    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
    '
    'Remember the memory block location
    m_colMemoryBlocks.Add lngMemoryHandle, "S" & CStr(lngObjectPointer)
    '
    '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(m_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(m_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
        '
    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.
    m_lngWindowHandle = CreateWindowEx(0&, "STATIC", "SOCKET_WINDOW", 0&, 0&, 0&, 0&, 0&, 0&, 0&, App.hInstance, ByVal 0&)
    '
    If m_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(m_lngWindowHandle, GWL_WNDPROC, AddressOf WindowProc)
        '
        'Just to let the caller know that the function was executed successfully
        CreateWinsockMessageWindow = m_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 m_lngWindowHandle, GWL_WNDPROC, m_lngPreviousValue
    'Destroy the window
    DestroyWindow m_lngWindowHandle
    '
    '
    'Reset the window handle variable
    m_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
            m_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

						