Attribute VB_Name = "ModWinSock"
Option Explicit
'****************************************************************
'* This module can be used freely for any non-commercial use and
'* is presented here for educational purposes only.
'* Contact Computer Services Contracting at WebVB@CoSeCo.com
'* for permission to use this module or it's function for commercial
'* use.
'*
'****************************************************************
Private Const MODULE_NAME = "modWinSock"
' Propery Storage

'WSAData
Private lMaxSockets As Long
Private lMaxUdpDg As Long
Private sVersion As String
Private sHighVersion As String
Private sDescription As String
Private sSystemStatus As String
Private sVendorInfo As String

'GetHostName
Private sHostName As String

'GetHostByName
Private sHostIP As String
Private sSecondaryHostIPs As String
Private sHostNameAliasList As String

Private Const SOCKET_ERROR = -1

' All Windows Sockets error constants are biased by WSABASEERR from the "normal"

Global Const WSABASEERR% = 10000

Public Const WSAEINTR% = WSABASEERR + 4
Public Const WSAEFAULT% = WSABASEERR + 14
Public Const WSAEINVAL% = (WSABASEERR + 22)
Public Const WSAEINPROGRESS% = WSABASEERR + 36
Public Const WSAENETDOWN% = WSABASEERR + 50
Public Const WSASYSNOTREADY% = WSABASEERR + 91
Public Const WSAVERNOTSUPPORTED% = WSABASEERR + 92
Public Const WSANOTINITIALIZED% = WSABASEERR + 93
Public Const WSAHOST_NOT_FOUND% = WSABASEERR + 1001
Public Const WSATRY_AGAIN% = WSABASEERR + 1002
Public Const WSANO_RECOVERY% = WSABASEERR + 1003
Public Const WSANO_DATA% = WSABASEERR + 1004


Private Type HOSTENT
       hName As Long
       hAliases As Long
       hAddrType As Integer
       hLength As Integer
       hAddrList As Long
End Type

Type WSADATA
    wVersion As Integer
    wHighVersion As Integer
    szDescription As String * 257
    szSystemStatus As String * 129
    iMaxSockets As Integer
    iMaxUdpDg As Integer
    lpVendorInfo As Long
End Type

Type Inet_Addr
    B1 As Byte
    B2 As Byte
    B3 As Byte
    B4 As Byte
End Type

Private Declare Function apiWSAGetLastError Lib "wsock32.dll" Alias "WSAGetLastError" () As Long
Private Declare Function apiWSAStartup Lib "wsock32.dll" Alias "WSAStartup" (ByVal wVersionRequired As Integer, lpWSAData As WSADATA) As Long
Private Declare Function apiWSACleanup Lib "wsock32.dll" Alias "WSACleanup" () As Long
Private Declare Function apiGetHostName Lib "wsock32.dll" Alias "gethostname" (ByVal sHostName As String, ByVal whostlen As Integer) As Long
Private Declare Function apiGetHostByName Lib "wsock32.dll" Alias "gethostbyname" (ByVal sHostName As String) As Long
Private Declare Function apiGetHostByAddress Lib "wsock32.dll" Alias "gethostbyaddr" (ByVal lHostAddress As Long, ByVal wAddressLen As Integer, ByVal wAddressType As Integer) As Long

Public Declare Sub apiRtlMoveMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, ByVal hpvSource As Long, ByVal cbCopy As Long)
Private Declare Function apiLstrLen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As Any) As Long
Private Declare Function apiLstrCpy Lib "kernel32" Alias "lstrcpyA" (ByVal lpString1 As Any, ByVal lpString2 As Any) As Long

Public Function fncGetHostName() As String
Dim lCallChain As Long
lCallChain = fncAddProcedure(ModuleName & "-fncGetHostName")
Dim sHostName As String * 256
Dim lErr As Long
Dim sMsg As String
    
    sHostName = String(Len(sHostName), &H0)
    If apiGetHostName(sHostName, Len(sHostName)) = SOCKET_ERROR Then
        lErr = apiWSAGetLastError()
        sMsg = fncGetWinSockErrorDescription(lErr)
        sMsg = "Error:" & vbCrLf & "Error Code: " & lErr & vbCrLf & "Error Description: " & sMsg & vbCrLf
    Else
        sMsg = Trim$(fncTrimNulls(sHostName))
    End If
    HostName = sMsg
    fncGetHostName = HostName
subRemoveProcedureFromCallChain (lCallChain)
End Function

Public Function fncGetHostByName(sHostName As String) As String
Dim lCallChain As Long
lCallChain = fncAddProcedure(ModuleName & "-fncGetHostByName")
Dim lHostEnt_addr As Long
Dim lErr As Long
Dim sMsg As String

    lHostEnt_addr = apiGetHostByName(sHostName)
    If lHostEnt_addr = 0 Then
        lErr = apiWSAGetLastError()
        sMsg = fncGetWinSockErrorDescription(lErr)
        HostIP = "Error  Looking up Host by name" & vbCrLf & "Error Code: " & lErr & vbCrLf & "Error Description: " & sMsg & vbCrLf
    Else
        Call subGetHostEntInfo(lHostEnt_addr)
    End If
    fncGetHostByName = HostIP
subRemoveProcedureFromCallChain (lCallChain)
End Function

Public Sub subWSAStartup(iVersion As Integer)
Dim lCallChain As Long
lCallChain = fncAddProcedure(ModuleName & "-subWSAStartup")
Dim lErr As Long
Dim sMsg As String
Dim WSAD As WSADATA
Dim lReturn As Integer
    lReturn = apiWSAStartup(iVersion, WSAD)
    If lReturn <> 0 Then
        lErr = lReturn
        sMsg = fncGetWinSockErrorDescription(lErr)
        Err.Raise vbObjectError + lErr, "subWSAStartup", sMsg
    Else
        Version = CStr(WSAD.wVersion)
        sMsg = sMsg & "Version: " & Version & vbCrLf
        HighVersion = CStr(WSAD.wHighVersion)
        sMsg = sMsg & "HighVersion: " & HighVersion & vbCrLf
        Description = WSAD.szDescription
        sMsg = sMsg & "Description: " & Description & vbCrLf
        SystemStatus = WSAD.szSystemStatus
        sMsg = sMsg & "SystemStatus: " & SystemStatus & vbCrLf
        MaxSockets = fncCuIntToLng(WSAD.iMaxSockets)
        sMsg = sMsg & "MaxSockets: " & MaxSockets & vbCrLf
        MaxUdpDg = fncCuIntToLng(WSAD.iMaxUdpDg)
        sMsg = sMsg & "MaxUdpDg: " & MaxUdpDg & vbCrLf
        VendorInfo = CStr(WSAD.lpVendorInfo)
        sMsg = sMsg & "VendorInfo: " & VendorInfo & vbCrLf
    End If
    Debug.Print sMsg
subRemoveProcedureFromCallChain (lCallChain)
End Sub

Public Property Get MaxSockets() As Long
    MaxSockets = lMaxSockets
End Property

Public Property Let MaxSockets(ByVal lNewValue As Long)
    lMaxSockets = lNewValue
End Property

Public Property Get MaxUdpDg() As Long
    MaxUdpDg = lMaxUdpDg
End Property

Public Property Let MaxUdpDg(ByVal lNewValue As Long)
    lMaxUdpDg = lNewValue
End Property

Public Property Get Version() As String
    Version = sVersion
End Property

Public Property Let Version(ByVal sNewValue As String)
Dim i As Integer
    i = CInt(sNewValue)
    sVersion = fncMakeVersion(i)
End Property

Public Property Get HighVersion() As String
    HighVersion = sHighVersion
End Property

Public Property Let HighVersion(ByVal sNewValue As String)
Dim i As Integer
    i = CInt(sNewValue)
    sHighVersion = fncMakeVersion(i)
End Property

Public Property Get Description() As String
    Description = sDescription
End Property

Public Property Let Description(ByVal sNewValue As String)
    sDescription = Trim$(fncTrimNulls(sNewValue))
End Property

Public Property Get SystemStatus() As String
    SystemStatus = sSystemStatus
End Property

Public Property Let SystemStatus(ByVal sNewValue As String)
    sSystemStatus = Trim$(fncTrimNulls(sNewValue))
End Property

Public Property Get VendorInfo() As String
   VendorInfo = sVendorInfo
End Property

Public Property Let VendorInfo(ByVal sNewValue As String)
Dim l As Long
    l = CLng(sNewValue)
    If l = 0 Then
        sVendorInfo = "None"
    Else
        sVendorInfo = String(200, Chr$(0))
        Call apiRtlMoveMemory(sVendorInfo, l, Len(sVendorInfo))
        sVendorInfo = Trim$(fncTrimNulls(sVendorInfo))
    End If
End Property

Public Property Get HostName() As String
    HostName = sHostName
End Property

Public Property Let HostName(ByVal sNewValue As String)
    sHostName = sNewValue
End Property

Public Property Get HostIP() As String
    HostIP = sHostIP
End Property

Public Property Let HostIP(ByVal sNewValue As String)
    sHostIP = sNewValue
End Property

Public Property Get SecondaryHostIPs() As String
    SecondaryHostIPs = sSecondaryHostIPs
End Property

Public Property Let SecondaryHostIPs(ByVal sNewValue As String)
    If sNewValue = "" Then sNewValue = "None"
    sSecondaryHostIPs = sNewValue
End Property

Public Sub subWSACleanup()
Dim lCallChain As Long
lCallChain = fncAddProcedure(ModuleName & "-subWSACleanup")
Dim lReturn As Long
    lReturn = apiWSACleanup()
subRemoveProcedureFromCallChain (lCallChain)
End Sub
Public Property Get ModuleName() As String
    ModuleName = MODULE_NAME
End Property
Public Function fncMakeVersion(w As Integer) As String
Dim lCallChain As Long
lCallChain = fncAddProcedure(ModuleName & "-fncMakeVersion")
    fncMakeVersion = fncHiByte(w) & "." & fncLoByte(w)
subRemoveProcedureFromCallChain (lCallChain)
End Function


Public Function fncGetWinSockErrorDescription(lErroCode As Long)
Dim lCallChain As Long
lCallChain = fncAddProcedure(ModuleName & "-fncGetWinSockErrorDescription")
    Select Case lErroCode
        Case WSAEINTR
            fncGetWinSockErrorDescription = "The (blocking) call was canceled via WSACancelBlockingCall()."
        Case WSAEFAULT
            fncGetWinSockErrorDescription = "The namelen parameter is too small."
        Case WSANOTINITIALIZED
            fncGetWinSockErrorDescription = "A successful WSAStartup() must occur before using this API."
        Case WSAENETDOWN
            fncGetWinSockErrorDescription = "The Windows Sockets implementation has detected that the network subsystem has failed."
        Case WSAEINPROGRESS
            fncGetWinSockErrorDescription = "A blocking Windows Sockets operation is in progress."
        Case WSAHOST_NOT_FOUND
            fncGetWinSockErrorDescription = "Authoritative Answer Host not found."
        Case WSATRY_AGAIN
            fncGetWinSockErrorDescription = "Non-Authoritative Host not found, or SERVERFAIL."
        Case WSANO_RECOVERY
            fncGetWinSockErrorDescription = "Non recoverable errors, FORMERR, REFUSED, NOTIMP."
        Case WSANO_DATA
            fncGetWinSockErrorDescription = "Valid name, no data record of requested type."
        Case WSAEINVAL
            fncGetWinSockErrorDescription = "The (blocking) call was canceled via WSACancelBlockingCall()."
        Case WSAVERNOTSUPPORTED
            fncGetWinSockErrorDescription = "The version of Windows Sockets API support requested is not provided by this particular Windows Sockets implementation."
        Case WSASYSNOTREADY
            fncGetWinSockErrorDescription = "The Windows Sockets version specified by the application is not supported by this DLL."
        Case Else
            fncGetWinSockErrorDescription = "Unknown"
    End Select
subRemoveProcedureFromCallChain (lCallChain)
End Function

Public Function fncIsIPAddress(sIPAddress As String) As Boolean
Dim lCallChain As Long
lCallChain = fncAddProcedure(ModuleName & "-fncMakeVersion")
Dim i As Integer
Dim sChar As String
Dim wDotCount As Integer
    fncIsIPAddress = True
    wDotCount = 0
    For i = 1 To Len(sIPAddress)
        sChar = Mid$(sIPAddress, i, 1)
        If sChar <> "." Then
            If sChar < "0" Or sChar > "9" Then
                fncIsIPAddress = False
            End If
        Else
            wDotCount = wDotCount + 1
        End If
    Next i
    If wDotCount <> 3 Then fncIsIPAddress = False
subRemoveProcedureFromCallChain (lCallChain)
End Function

Public Function fncGetHostByAddress(sHostAddress As String) As String
Dim lCallChain As Long
lCallChain = fncAddProcedure(ModuleName & "-fncGetHostByAddress")
Dim lHostAddress As Long
Dim lHostEnt_addr As Long
Dim lErr As Long
Dim sMsg As String

'   convert dotted address to network address
    lHostAddress = fncInet_Addr(sHostAddress)
    lHostEnt_addr = apiGetHostByAddress(VarPtr(lHostAddress), 4, 2)
    If lHostEnt_addr = 0 Then
        lErr = apiWSAGetLastError()
        sMsg = fncGetWinSockErrorDescription(lErr)
        HostName = "Error Looking up Host by address" & vbCrLf & "Error Code: " & lErr & vbCrLf & "Error Description: " & sMsg & vbCrLf
    Else
        Call subGetHostEntInfo(lHostEnt_addr)
    End If
    fncGetHostByAddress = HostName
subRemoveProcedureFromCallChain (lCallChain)
End Function

Public Property Get HostNameAliasList() As String
    HostNameAliasList = sHostNameAliasList
End Property

Public Property Let HostNameAliasList(ByVal sNewValue As String)
    If sNewValue = "" Then sNewValue = "None"
    sHostNameAliasList = sNewValue
End Property

Public Function fncInet_Addr(sIPAddress As String) As Long
'convet dotted IP address to network address
Dim lCallChain As Long
lCallChain = fncAddProcedure(ModuleName & "-fncMakeVersion")
Dim wStart As Integer
Dim wLength As Integer
Dim IPAddr As Inet_Addr
Dim lAddress As Long
    
    If fncIsIPAddress(sIPAddress) Then
        wStart = 1
        wLength = InStr(wStart, sIPAddress, ".") - 1
        IPAddr.B1 = CByte(Val(Mid$(sIPAddress, wStart, wLength)))
        wStart = wStart + wLength + 1
        wLength = InStr(wStart, sIPAddress, ".") - wStart
        IPAddr.B2 = CByte(Mid$(sIPAddress, wStart, wLength))
        wStart = wStart + wLength + 1
        wLength = InStr(wStart, sIPAddress, ".") - wStart
        IPAddr.B3 = CByte(Mid$(sIPAddress, wStart, wLength))
        wStart = wStart + wLength + 1
        wLength = Len(sIPAddress) - wStart + 1
        IPAddr.B4 = CByte(Mid$(sIPAddress, wStart, wLength))
        Call apiRtlMoveMemory(lAddress, VarPtr(IPAddr), 4)
        
    Else
        lAddress = 0
    End If
    fncInet_Addr = lAddress

subRemoveProcedureFromCallChain (lCallChain)
End Function

Public Function fncIPAddr_Ntoa(IPAddr As Inet_Addr) As String
Dim lCallChain As Long
lCallChain = fncAddProcedure(ModuleName & "-fncGetHostByName")
            fncIPAddr_Ntoa = IPAddr.B1 & "." & IPAddr.B2 & "." & IPAddr.B3 & "." & IPAddr.B4
subRemoveProcedureFromCallChain (lCallChain)
End Function
Public Function fncInet_Ntoa(lIP_Address As Long) As String
Dim lCallChain As Long
lCallChain = fncAddProcedure(ModuleName & "-fncGetHostByName")
Dim IPAddr As Inet_Addr
            Call apiRtlMoveMemory(IPAddr, VarPtr(lIP_Address), 4)
            fncInet_Ntoa = IPAddr.B1 & "." & IPAddr.B2 & "." & IPAddr.B3 & "." & IPAddr.B4
subRemoveProcedureFromCallChain (lCallChain)
End Function


Public Sub subClearHostEntInfo()
Dim lCallChain As Long
lCallChain = fncAddProcedure(ModuleName & "-subClearHostEntInfo")
        HostName = ""
        HostNameAliasList = ""
        HostIP = sHostIP
        SecondaryHostIPs = ""
subRemoveProcedureFromCallChain (lCallChain)
End Sub

Public Sub subGetHostEntInfo(lHostEnt_addr As Long)
Dim lCallChain As Long
lCallChain = fncAddProcedure(ModuleName & "-subGetHostEntInfo")
Dim host As HOSTENT
Dim sHostName As String
Dim lpHostAliasList As Long
Dim lHostAlias_addr As Long
Dim sHostAliasList As String
Dim sHostAlias As String
Dim lpHostAddressList As Long
Dim lHostIP_addr As Long
Dim IPAddr As Inet_Addr
Dim sHostIP As String
Dim sIP_Address As String

    Call subClearHostEntInfo

'   Get the Host Structure
    Call apiRtlMoveMemory(host, lHostEnt_addr, LenB(host))

'   Get the Host Name
    sHostName = String(apiLstrLen(host.hName) + 1, " ")
    Call apiLstrCpy(sHostName, host.hName)
    sHostName = fncTrimNulls(sHostName)
    
'   Get the list of host alias names
    lpHostAliasList = host.hAliases
    Call apiRtlMoveMemory(lHostAlias_addr, lpHostAliasList, 4)
    sHostAliasList = ""
    Do While (lHostAlias_addr <> 0)
        sHostAlias = String(apiLstrLen(lHostAlias_addr) + 1, " ")
        Call apiLstrCpy(sHostAlias, lHostAlias_addr)
        sHostAlias = fncTrimNulls(sHostAlias)
        sHostAliasList = sHostAliasList & sHostAlias & vbCrLf
        lpHostAliasList = lpHostAliasList + LenB(lpHostAliasList)
        Call apiRtlMoveMemory(lHostAlias_addr, lpHostAliasList, 4)
    Loop
'   Get the IP Address list
    lpHostAddressList = host.hAddrList
    Call apiRtlMoveMemory(lHostIP_addr, lpHostAddressList, 4)

'   Get the Default IP Address
    Call apiRtlMoveMemory(IPAddr, lHostIP_addr, host.hLength)
    sHostIP = IPAddr.B1 & "." & IPAddr.B2 & "." & IPAddr.B3 & "." & IPAddr.B4
    
    'get all of the IP address if machine is  multi-homed
    lpHostAddressList = lpHostAddressList + LenB(lpHostAddressList)
    Call apiRtlMoveMemory(lHostIP_addr, lpHostAddressList, 4)
    sIP_Address = ""
    Do While (lHostIP_addr <> 0)
       Call apiRtlMoveMemory(IPAddr, lHostIP_addr, host.hLength)
       sIP_Address = sIP_Address & IPAddr.B1 & "." & IPAddr.B2 & "." & IPAddr.B3 & "." & IPAddr.B4 & vbCrLf
       lpHostAddressList = lpHostAddressList + LenB(lpHostAddressList)
       Call apiRtlMoveMemory(lHostIP_addr, lpHostAddressList, 4)
    Loop
    HostName = sHostName
    HostNameAliasList = sHostAliasList
    HostIP = sHostIP
    SecondaryHostIPs = sIP_Address
    
subRemoveProcedureFromCallChain (lCallChain)
End Sub