Attribute VB_Name = "Module1"
Option Explicit
Private Const IP_STATUS_BASE = 11000
Private Const IP_SUCCESS = 0
Private Const IP_BUF_TOO_SMALL = (11000 + 1)
Private Const IP_DEST_NET_UNREACHABLE = (11000 + 2)
Private Const IP_DEST_HOST_UNREACHABLE = (11000 + 3)
Private Const IP_DEST_PROT_UNREACHABLE = (11000 + 4)
Private Const IP_DEST_PORT_UNREACHABLE = (11000 + 5)
Private Const IP_NO_RESOURCES = (11000 + 6)
Private Const IP_BAD_OPTION = (11000 + 7)
Private Const IP_HW_ERROR = (11000 + 8)
Private Const IP_PACKET_TOO_BIG = (11000 + 9)
Private Const IP_REQ_TIMED_OUT = (11000 + 10)
Private Const IP_BAD_REQ = (11000 + 11)
Private Const IP_BAD_ROUTE = (11000 + 12)
Private Const IP_TTL_EXPIRED_TRANSIT = (11000 + 13)
Private Const IP_TTL_EXPIRED_REASSEM = (11000 + 14)
Private Const IP_PARAM_PROBLEM = (11000 + 15)
Private Const IP_SOURCE_QUENCH = (11000 + 16)
Private Const IP_OPTION_TOO_BIG = (11000 + 17)
Private Const IP_BAD_DESTINATION = (11000 + 18)
Private Const IP_ADDR_DELETED = (11000 + 19)
Private Const IP_SPEC_MTU_CHANGE = (11000 + 20)
Private Const IP_MTU_CHANGE = (11000 + 21)
Private Const IP_UNLOAD = (11000 + 22)
Private Const IP_ADDR_ADDED = (11000 + 23)
Private Const IP_GENERAL_FAILURE = (11000 + 50)
Private Const MAX_IP_STATUS = 11000 + 50
Private Const IP_PENDING = (11000 + 255)
Private Const PING_TIMEOUT = 200
Private Const WS_VERSION_REQD = &H101
Private Const WS_VERSION_MAJOR = WS_VERSION_REQD \ &H100 And &HFF&
Private Const WS_VERSION_MINOR = WS_VERSION_REQD And &HFF&
Private Const MIN_SOCKETS_REQD = 1
Private Const SOCKET_ERROR = -1
Private Const AF_INET = 2
Private Const MAX_WSADescription = 256
Private Const MAX_WSASYSStatus = 128
Private Type ICMP_OPTIONS
    ttl             As Byte
    Tos             As Byte
    Flags           As Byte
    OptionsSize     As Byte
    OptionsData     As Long
End Type
Private ICMPOPT As ICMP_OPTIONS
Private Type ICMP_ECHO_REPLY
    Address         As Long
    Status          As Long
    RoundTripTime   As Long
    datasize        As Long
    DataPointer     As Long
    Options         As ICMP_OPTIONS
    Data            As String * 250
End Type
Private Type HOSTENT
    hName As Long
    hAliases As Long
    hAddrType As Integer
    hLen As Integer
    hAddrList As Long
End Type
Private Type WSADATA
    wVersion As Integer
    wHighVersion As Integer
    szDescription(0 To MAX_WSADescription) As Byte
    szSystemStatus(0 To MAX_WSASYSStatus) As Byte
    wMaxSockets As Long
    wMaxUDPDG As Long
    dwVendorInfo As Long
End Type
Private Const NCBASTAT = &H33
Private Const NCBNAMSZ = 16
Private Const HEAP_ZERO_MEMORY = &H8
Private Const HEAP_GENERATE_EXCEPTIONS = &H4
Private Const NCBRESET = &H32
Private Type NCB
  ncb_command As Byte
  ncb_retcode As Byte
  ncb_lsn As Byte
  ncb_num As Byte
  ncb_buffer As Long
  ncb_length As Integer
  ncb_callname As String * NCBNAMSZ
  ncb_name As String * NCBNAMSZ
  ncb_rto As Byte
  ncb_sto As Byte
  ncb_post As Long
  ncb_lana_num As Byte
  ncb_cmd_cplt As Byte
  ncb_reserve(9) As Byte
  ncb_event As Long
End Type
Private Type ADAPTER_STATUS
  adapter_address(5) As Byte
  rev_major As Byte
  reserved0 As Byte
  adapter_type As Byte
  rev_minor As Byte
  duration As Integer
  frmr_recv As Integer
  frmr_xmit As Integer
  iframe_recv_err As Integer
  xmit_aborts As Integer
  xmit_success As Long
  recv_success As Long
  iframe_xmit_err As Integer
  recv_buff_unavail As Integer
  t1_timeouts As Integer
  ti_timeouts As Integer
  Reserved1 As Long
  free_ncbs As Integer
  max_cfg_ncbs As Integer
  max_ncbs As Integer
  xmit_buf_unavail As Integer
  max_dgram_size As Integer
  pending_sess As Integer
  max_cfg_sess As Integer
  max_sess As Integer
  max_sess_pkt_size As Integer
  name_count As Integer
End Type
Private Type NAME_BUFFER
  name As String * NCBNAMSZ
  name_num As Integer
  name_flags As Integer
End Type
Private Type ASTAT
  adapt As ADAPTER_STATUS
  NameBuff(30) As NAME_BUFFER
End Type
Private Const CONNECT_UPDATE_PROFILE = &H1
Private Const RESOURCETYPE_DISK = &H1
Private Type NETRESOURCE
    dwScope As Long
    dwType As Long
    dwDisplayType As Long
    dwUsage As Long
    lpLocalName As String
    lpRemoteName As String
    lpComment As String
    lpProvider As String
End Type
Private lpNetResourse As NETRESOURCE
Private Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
Private Declare Function IcmpCreateFile Lib "icmp.dll" () As Long
Private Declare Function IcmpCloseHandle Lib "icmp.dll" (ByVal IcmpHandle As Long) As Long
Private Declare Function IcmpSendEcho Lib "icmp.dll" (ByVal IcmpHandle As Long, ByVal DestinationAddress As Long, ByVal RequestData As String, ByVal RequestSize As Long, ByVal RequestOptions As Long, ReplyBuffer As ICMP_ECHO_REPLY, ByVal ReplySize As Long, ByVal Timeout As Long) As Long
Private Declare Function WSAGetLastError Lib "wsock32.dll" () As Long
Private Declare Function WSAStartup Lib "wsock32.dll" (ByVal wVersionRequired As Long, lpWSADATA As WSADATA) As Long
Private Declare Function WSACleanup Lib "wsock32.dll" () As Long
Private Declare Function gethostname Lib "wsock32.dll" (ByVal szHost As String, ByVal dwHostLen As Long) As Long
Private Declare Sub RtlMoveMemory Lib "kernel32" (hpvDest As Any, ByVal hpvSource As Long, ByVal cbCopy As Long)
Private Declare Function Netbios Lib "netapi32.dll" (pncb As NCB) As Byte
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, ByVal hpvSource As Long, ByVal cbCopy As Long)
Private Declare Function GetProcessHeap Lib "kernel32" () As Long
Private Declare Function HeapAlloc Lib "kernel32" (ByVal hHeap As Long, ByVal dwFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function HeapFree Lib "kernel32" (ByVal hHeap As Long, ByVal dwFlags As Long, lpMem As Any) As Long
Private Declare Function WNetAddConnection2 Lib "mpr.dll" Alias "WNetAddConnection2A" (lpNetResource As NETRESOURCE, ByVal lpPassword As String, ByVal lpUsername As String, ByVal dwFlags As Long) As Long
Private Declare Function WNetCancelConnection2 Lib "mpr.dll" Alias "WNetCancelConnection2A" (ByVal lpName As String, ByVal dwFlags As Long, ByVal fForce As Long) As Long
Private Declare Function inet_addr Lib "wsock32.dll" (ByVal s As String) As Long
Private Declare Function gethostbyaddr Lib "wsock32.dll" (haddr As Long, ByVal hnlen As Long, ByVal addrtype As Long) As Long
Private Declare Function gethostbyname Lib "wsock32.dll" (ByVal szHost As String) As Long
Private Declare Function inet_ntoa Lib "wsock32.dll" (ByVal addr As Long) As Long
Private Declare Function lstrcpyA Lib "kernel32" (ByVal RetVal As String, ByVal Ptr As Long) As Long
Private Declare Function lstrlenA Lib "kernel32" (ByVal Ptr As Any) As Long
Private Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Public Function ConnectNetworkDrive(ByVal strNetworkConnection As String, ByVal strUsername As String, ByVal strPassword As String) As String
    Dim strDrive As String
    Dim lngReturnCode As Long
    strDrive = NextFreeDrive
    lpNetResourse.dwType = RESOURCETYPE_DISK
    lpNetResourse.lpLocalName = strDrive & Chr(0)
    lpNetResourse.lpRemoteName = strNetworkConnection & Chr(0)
    lpNetResourse.lpProvider = Chr(0)
    lngReturnCode = WNetAddConnection2(lpNetResourse, strPassword & Chr(0), strUsername & Chr(0), CONNECT_UPDATE_PROFILE)
    If lngReturnCode = 0 Then
        ConnectNetworkDrive = strDrive
    End If
End Function
Public Function ComputerName() As String
    Dim lngReturnCode As Long
    Dim strHostname As String
    strHostname = Space$(50)
    lngReturnCode = GetComputerName(strHostname, 50)
    ComputerName = Left$(strHostname, InStr(strHostname, Chr$(0)) - 1)
End Function
Public Sub DisconnectDrive(ByVal strDrive As String)
    Call WNetCancelConnection2(strDrive & Chr(0), CONNECT_UPDATE_PROFILE, 1)
End Sub
Public Function GetEthernetAddress(Optional ByVal LanaNumber As Long = 0) As String
    Dim udtNCB As NCB
    Dim bytResponse As Byte
    Dim udtASTAT As ASTAT
    Dim udtTempASTAT As ASTAT
    Dim lngASTAT As Long
    Dim strEthernetAddress As String
    Dim lngIterator As Long
    udtNCB.ncb_command = NCBRESET
    bytResponse = Netbios(udtNCB)
    udtNCB.ncb_command = NCBASTAT
    udtNCB.ncb_lana_num = LanaNumber
    udtNCB.ncb_callname = "* "
    udtNCB.ncb_length = Len(udtASTAT)
    lngASTAT = HeapAlloc(GetProcessHeap(), HEAP_GENERATE_EXCEPTIONS Or HEAP_ZERO_MEMORY, udtNCB.ncb_length)
    strEthernetAddress = ""
    If lngASTAT Then
        udtNCB.ncb_buffer = lngASTAT
        bytResponse = Netbios(udtNCB)
        CopyMemory udtASTAT, udtNCB.ncb_buffer, Len(udtASTAT)
        With udtASTAT.adapt
            For lngIterator = 0 To 5
                strEthernetAddress = strEthernetAddress & Right$("00" & Hex$(.adapter_address(lngIterator)), 2)
            Next lngIterator
        End With
        HeapFree GetProcessHeap(), 0, lngASTAT
    End If
    GetEthernetAddress = Trim$(strEthernetAddress)
End Function
Public Function GetHostNameFromIP(ByVal strIPAddress As String) As String
    Dim nbytes As Long
    Dim ptrHosent As Long
    Dim lookupIP As String
    Dim lngIPAddress As Long
    If SocketsInitialize() Then
        lngIPAddress = inet_addr(strIPAddress)
        ptrHosent = gethostbyaddr(lngIPAddress, 4, AF_INET)
        If ptrHosent <> 0 Then
            CopyMemory ptrHosent, ByVal ptrHosent, 4
            nbytes = lstrlenA(ByVal ptrHosent)
            If nbytes > 0 Then
                lookupIP = Space$(nbytes)
                CopyMemory ByVal lookupIP, ByVal ptrHosent, nbytes
                GetHostNameFromIP = lookupIP
            End If
        Else
            GetHostNameFromIP = ""
        End If
        SocketsCleanup
    End If
End Function
Public Function GetIPFromHostName(ByVal strHostname As String) As String
    Dim ptrHosent As Long
    Dim ptrName As Long
    Dim ptrAddress As Long
    Dim ptrIPAddress As Long
    Dim dwAddress As Long
    If SocketsInitialize() Then
        ptrHosent = gethostbyname(strHostname & vbNullChar)
        If ptrHosent <> 0 Then
            ptrName = ptrHosent
            ptrAddress = ptrHosent + 12
            CopyMemory ptrAddress, ByVal ptrAddress, 4
            CopyMemory ptrIPAddress, ByVal ptrAddress, 4
            CopyMemory dwAddress, ByVal ptrIPAddress, 4
            GetIPFromHostName = PtrStr(inet_ntoa(dwAddress))
        End If
        SocketsCleanup
    End If
End Function
Public Function Ping(ByVal strIPAddress As String) As Long
    Dim udtECHO As ICMP_ECHO_REPLY
    If SocketsInitialize() Then
        strIPAddress = GetIPFromHostName(strIPAddress)
        Call PerformPing(strIPAddress, udtECHO)
        Select Case udtECHO.Status
            Case IP_SUCCESS:
                Ping = udtECHO.RoundTripTime
            Case Else:
                Err.Raise vbObjectError + 999, "Ping", GetStatusCode(udtECHO.Status)
                Ping = 0
        End Select
        SocketsCleanup
   End If
End Function
Private Function PtrStr(ByVal lpszA As Long) As String
   PtrStr = String$(lstrlenA(ByVal lpszA), 0)
   Call lstrcpyA(ByVal PtrStr, ByVal lpszA)
End Function
Private Function GetStatusCode(lngStatusCode As Long) As String
    Dim strStatusDescription As String
    Select Case lngStatusCode
    Case IP_SUCCESS:
        strStatusDescription = "IP Success"
    Case IP_BUF_TOO_SMALL:
        strStatusDescription = "IP Buffer Too Small"
    Case IP_DEST_NET_UNREACHABLE:
        strStatusDescription = "IP Dest Net Unreachable"
    Case IP_DEST_HOST_UNREACHABLE:
        strStatusDescription = "IP Dest Host Unreachable"
    Case IP_DEST_PROT_UNREACHABLE:
        strStatusDescription = "IP Dest Prot Unreachable"
    Case IP_DEST_PORT_UNREACHABLE:
        strStatusDescription = "IP Dest Port Unreachable"
    Case IP_NO_RESOURCES:
        strStatusDescription = "IP No Resources"
    Case IP_BAD_OPTION:
        strStatusDescription = "IP Bad Option"
    Case IP_HW_ERROR:
        strStatusDescription = "IP HW Error"
    Case IP_PACKET_TOO_BIG:
        strStatusDescription = "IP Packet Too Big"
    Case IP_REQ_TIMED_OUT:
        strStatusDescription = "IP Req Timed Out"
    Case IP_BAD_REQ:
        strStatusDescription = "IP Bad Req"
    Case IP_BAD_ROUTE:
        strStatusDescription = "IP Bad Route"
    Case IP_TTL_EXPIRED_TRANSIT:
        strStatusDescription = "IP TTL Expired Transit"
    Case IP_TTL_EXPIRED_REASSEM:
        strStatusDescription = "IP TTL Expired Reassembly"
    Case IP_PARAM_PROBLEM:
        strStatusDescription = "IP Param Problem"
    Case IP_SOURCE_QUENCH:
        strStatusDescription = "IP Source Quench"
    Case IP_OPTION_TOO_BIG:
        strStatusDescription = "IP Option Too Big"
    Case IP_BAD_DESTINATION:
        strStatusDescription = "IP Bad Destination"
    Case IP_ADDR_DELETED:
        strStatusDescription = "IP Addr Deleted"
    Case IP_SPEC_MTU_CHANGE:
        strStatusDescription = "IP Spec MTU Change"
    Case IP_MTU_CHANGE:
        strStatusDescription = "IP MTU Change"
    Case IP_UNLOAD:
        strStatusDescription = "IP Unload"
    Case IP_ADDR_ADDED:
        strStatusDescription = "IP Addr Added"
    Case IP_GENERAL_FAILURE:
        strStatusDescription = "IP General Failure"
    Case IP_PENDING:
        strStatusDescription = "IP Pending"
    Case PING_TIMEOUT:
        strStatusDescription = "Ping Timeout"
    Case Else:
        strStatusDescription = "Unknown Status Description Returned"
    End Select
    GetStatusCode = CStr(lngStatusCode) & "   [ " & strStatusDescription & " ]"
End Function
Private Function HiByte(ByVal lngData As Long) As Integer
    HiByte = lngData \ &H100 And &HFF&
End Function
Private Function LoByte(ByVal lngData As Long) As Integer
    LoByte = lngData And &HFF&
End Function
Private Sub PerformPing(ByVal strIPAddress As String, ByRef udtECHO As ICMP_ECHO_REPLY)
   Dim lngPort As Long
   Dim lngAddress As Long
   Dim strDataToSend As String
   strDataToSend = "Ping"
   lngAddress = AddressStringToLong(strIPAddress)
   lngPort = IcmpCreateFile()
   Call IcmpSendEcho(lngPort, lngAddress, strDataToSend, Len(strDataToSend), 0, udtECHO, Len(udtECHO), PING_TIMEOUT)
   Call IcmpCloseHandle(lngPort)
End Sub
Public Function AddressStringToLong(ByVal strData As String) As Long
   Dim lngIterator As Long
   Dim strAddressBytes(1 To 4) As String
   lngIterator = 0
   While InStr(strData, ".") > 0
      lngIterator = lngIterator + 1
      strAddressBytes(lngIterator) = Mid(strData, 1, InStr(strData, ".") - 1)
      strData = Mid(strData, InStr(strData, ".") + 1)
   Wend
   lngIterator = lngIterator + 1
   strAddressBytes(lngIterator) = strData
   If lngIterator <> 4 Then
      AddressStringToLong = 0
      Exit Function
   End If
   AddressStringToLong = Val("&H" & Right("00" & Hex(strAddressBytes(4)), 2) & Right("00" & Hex(strAddressBytes(3)), 2) & Right("00" & Hex(strAddressBytes(2)), 2) & Right("00" & Hex(strAddressBytes(1)), 2))
End Function
Public Function LongToAddressString(ByVal lngIPAddress As Long) As String
   Dim ptrString As Long
   ptrString = inet_ntoa(lngIPAddress)
   LongToAddressString = PtrStr(ptrString)
End Function
Private Sub SocketsCleanup()
   Call WSACleanup
End Sub
Private Function SocketsInitialize() As Boolean
    Dim WSAD As WSADATA
    Dim lngReturnCode As Integer
    Dim strLoByte As String
    Dim strHiByte As String
    Dim strBuffer As String
    lngReturnCode = WSAStartup(WS_VERSION_REQD, WSAD)
    If lngReturnCode <> 0 Then
        Err.Raise vbObjectError + 999, "SocketsInitialize", "Windows Sockets for 32 bit Windows environments is not successfully responding."
        Exit Function
    End If
    If LoByte(WSAD.wVersion) < WS_VERSION_MAJOR Or (LoByte(WSAD.wVersion) = WS_VERSION_MAJOR And HiByte(WSAD.wVersion) < WS_VERSION_MINOR) Then
        strHiByte = Trim$(Str$(HiByte(WSAD.wVersion)))
        strLoByte = Trim$(Str$(LoByte(WSAD.wVersion)))
        strBuffer = "Windows Sockets Version " & strLoByte & "." & strHiByte
        strBuffer = strBuffer & " is not supported by Windows " & "Sockets for 32 bit Windows environments."
        Err.Raise vbObjectError + 999, "SocketsInitialize", strBuffer, vbExclamation
        Exit Function
    End If
    If WSAD.wMaxSockets < MIN_SOCKETS_REQD Then
        strBuffer = "This application requires a minimum of " & Trim$(Str$(MIN_SOCKETS_REQD)) & " supported sockets."
        Err.Raise vbObjectError + 999, "SocketsInitialize", strBuffer, vbExclamation
        Exit Function
    End If
    SocketsInitialize = True
End Function
Private Function NextFreeDrive() As String
    Dim lngDriveIterator As Long
    Dim lngDriveType As Long
    lngDriveIterator = 64
    Do Until lngDriveIterator > 67 And lngDriveType = 1
        lngDriveIterator = lngDriveIterator + 1
        lngDriveType = GetDriveType(Chr$(lngDriveIterator) & ":")
    Loop
    NextFreeDrive = Chr$(lngDriveIterator) + ":"
End Function