PROGRAMMATION WSOCK32 EN VISUAL BASIC

Option Explicit

Public smessageEcho As String
Public sVersion

'----------------------------------------------
'-- Recherche l'IP du poste
Public Const MAX_WSADescription = 256
Public Const MAX_WSASYSStatus = 128
Public Const ERROR_SUCCESS              As Long = 0
Public Const WS_VERSION_REQD            As Long = &H101
Public Const WS_VERSION_MAJOR           As Long = WS_VERSION_REQD \ &H100 And &HFF&
Public Const WS_VERSION_MINOR           As Long = WS_VERSION_REQD And &HFF&
Public Const MIN_SOCKETS_REQD           As Long = 1
Public Const SOCKET_ERROR               As Long = -1
'----------------------------------------------
Public Type hostent
    hName       As Long
    hAliases    As Long
    hAddrType   As Integer
    hLen        As Integer
    hAddrList   As Long
End Type
'----------------------------------------------
Public Type WSADATA
    wVersion                                As Integer
    wHighVersion                            As Integer
    szDescription(0 To MAX_WSADescription)  As Byte
    szSystemStatus(0 To MAX_WSASYSStatus)   As Byte
    wMaxSockets                             As Integer
    wMaxUDPDG                               As Integer
    dwVendorInfo                            As Long
End Type
'----------------------------------------------
Public Declare Function WSAGetLastError Lib "wsock32.dll" () As Long

Public Declare Function WSAStartup Lib "wsock32.dll" (ByVal wVersionRequired As Long, IpWSADATA As WSADATA) As Long

Public Declare Function WSACleanup Lib "wsock32.dll" () As Long

Public Declare Function gethostname Lib "wsock32.dll" (ByVal szHost As String, ByVal dwHostLen As Long) As Long

Public Declare Function gethostbyname Lib "wsock32.dll" (ByVal szHost As String) As Long

Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, ByVal hpvSource As Long, ByVal cbCopy As Long)

'----------------------------------------------
'-- Détermine l'adresse M.A.C.
Public Const NCBASTAT                   As Long = &H33
Public Const NCBNAMSZ                   As Long = 16
Public Const HEAP_ZERO_MEMORY           As Long = &H8
Public Const HEAP_GENERATE_EXCEPTIONS   As Long = &H4
Public Const NCBRESET                   As Long = &H32
'----------------------------------------------
Public Type NET_CONTROL_BLOCK '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
'----------------------------------------------
Public 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
'----------------------------------------------
Public Type NAME_BUFFER
    name        As String * NCBNAMSZ
    name_num    As Integer
    name_flags  As Integer
End Type
'----------------------------------------------
Public Type ASTAT
    adapt           As ADAPTER_STATUS
    NameBuff(30)    As NAME_BUFFER
End Type
'----------------------------------------------
Public Declare Function Netbios Lib "netapi32.dll" (pncb As NET_CONTROL_BLOCK) As Byte

Public Declare Function GetProcessHeap Lib "kernel32" () As Long

Public Declare Function HeapAlloc Lib "kernel32" (ByVal hHeap As Long, ByVal dwFlags As Long, ByVal dwBytes As Long) As Long

Public Declare Function HeapFree Lib "kernel32" (ByVal hHeap As Long, ByVal dwFlags As Long, IpMem As Any) As Long
'----------------------------------------------
'-- Déclaration pour la fonction Ping
Public Const IP_STATUS_BASE = 11000
Public Const IP_SUCCESS = 0
Public Const IP_BUF_TOO_SMALL = (11000 + 1)
Public Const IP_DEST_NET_UNREACHABLE = (11000 + 2)
Public Const IP_DEST_HOST_UNREACHABLE = (11000 + 3)
Public Const IP_DEST_PROT_UNREACHABLE = (11000 + 4)
Public Const IP_DEST_PORT_UNREACHABLE = (11000 + 5)
Public Const IP_NO_RESOURCES = (11000 + 6)
Public Const IP_BAD_OPTION = (11000 + 7)
Public Const IP_HW_ERROR = (11000 + 8)
Public Const IP_PACKET_TOO_BIG = (11000 + 9)
Public Const IP_REQ_TIMED_OUT = (11000 + 10)
Public Const IP_BAD_REQ = (11000 + 11)
Public Const IP_BAD_ROUTE = (11000 + 12)
Public Const IP_TTL_EXPIRED_TRANSIT = (11000 + 13)
Public Const IP_TTL_EXPIRED_REASSEM = (11000 + 14)
Public Const IP_PARAM_PROBLEM = (11000 + 15)
Public Const IP_SOURCE_QUENCH = (11000 + 16)
Public Const IP_OPTION_TOO_BIG = (11000 + 17)
Public Const IP_BAD_DESTINATION = (11000 + 18)
Public Const IP_ADDR_DELETED = (11000 + 19)
Public Const IP_SPEC_MTU_CHANGE = (11000 + 20)
Public Const IP_MTU_CHANGE = (11000 + 21)
Public Const IP_UNLOAD = (11000 + 22)
Public Const IP_ADDR_ADDED = (11000 + 23)
Public Const IP_GENERAL_FAILURE = (11000 + 50)
Public Const MAX_IP_STATUS = 11000 + 50
Public Const IP_PENDING = (11000 + 255)
Public Const PING_TIMEOUT = 200
'----------------------------------------------
Public Type ICMP_OPTIONS
    Ttl         As Byte
    Tos         As Byte
    Flags       As Byte
    OptionsSize  As Byte
    OptionsData  As Long
End Type
'----------------------------------------------
Dim ICMPOPT As ICMP_OPTIONS
'----------------------------------------------
Public Type ICMP_ECHO_REPLY
    Address             As Long
    status              As Long
    RoundTripTime       As Long
    DataSize            As Integer
    Reserved            As Integer
    DataPointer         As Long
    Options             As ICMP_OPTIONS
    Data                As String * 250
End Type
'----------------------------------------------
Public Declare Function IcmpCreateFile Lib "Icmp.dll" () As Long

Public Declare Function IcmpCloseHandle Lib "Icmp.dll" (ByVal IcmpHandle As Long) As Long

Public Declare Function IcmpSendEcho Lib "Icmp.dll" (ByVal IcmpHandle As Long, _
    ByVal DestinationAddress As Long, ByVal RequestData As String, _
    ByVal RequestSize As Integer, ByVal RequestOptions As Long, _
    ReplyBuffer As ICMP_ECHO_REPLY, ByVal ReplySize As Long, _
    ByVal Timeout As Long) As Long

Public Declare Sub RtlMoveMemory Lib "kernel32" (hpvDest As Any, ByVal hpvSource As Long, ByVal cbCopy As Long)
'----------------------------------------------
'-- Recherche de l'adresse du poste cible :
Declare Function inet_addr Lib "wsock32.dll" (ByVal addr As String) As Long
Declare Function gethostbyaddr Lib "wsock32.dll" (addr As Long, ByVal addr_len As Long, _
    ByVal addr_type As Long) As Long
Public Const AF_INET = 2
'----------------------------------------------
Function AddressStringToLong(ByVal tmp As String) As Long

    Dim i As Integer
    Dim parts(1 To 4) As String
    
    i = 0
    
    While InStr(tmp, ".") > 0
        i = i + 1
        parts(i) = Mid(tmp, 1, InStr(tmp, ".") - 1)
        tmp = Mid(tmp, InStr(tmp, ".") + 1)
    Wend
    
    i = i + 1
    parts(i) = tmp
    
    If i <> 4 Then
        AddressStringToLong = 0
        Exit Function
    End If
    
    AddressStringToLong = Val("&H" & Right("00" & Hex(parts(4)), 2) & _
        Right("00" & Hex(parts(3)), 2) & _
        Right("00" & Hex(parts(2)), 2) & _
        Right("00" & Hex(parts(1)), 2))
        
End Function
'----------------------------------------------
Public Function GetIPAddress() As String

    Dim sHostName As String * 256
    Dim lpHost As Long
    Dim HOST As hostent
    Dim dwIPAddr As Long
    Dim tmpIPAddr() As Byte
    Dim i As Integer
    Dim sIPAddr As String
    
    If Not SocketsInitialize() Then
        GetIPAddress = ""
        Exit Function
    End If
    
    '-- Si echec de GetHostName():
    If gethostname(sHostName, 256) = SOCKET_ERROR Then
        GetIPAddress = ""
        SocketsCleanup
        Exit Function
    End If
    
    sHostName = Trim$(sHostName)
    lpHost = gethostbyname(sHostName)
    
    '-- pas de réponse du sockets:
    If lpHost = 0 Then
        GetIPAddress = ""
        SocketsCleanup
        Exit Function
    End If
    
    CopyMemory HOST, lpHost, Len(HOST)
    CopyMemory dwIPAddr, HOST.hAddrList, 4
    
    ReDim tmpIPAddr(1 To HOST.hLen)
    CopyMemory tmpIPAddr(1), dwIPAddr, HOST.hLen
    
    '-- Construit l'adr. IP sous la forme xx.xx.xx.xx
    For i = 1 To HOST.hLen
        sIPAddr = sIPAddr & tmpIPAddr(i) & "."
    Next
    
    '-- Enlève le dernier "."
    GetIPAddress = Mid$(sIPAddr, 1, Len(sIPAddr) - 1)
    
    SocketsCleanup
    
End Function
'----------------------------------------------
Public Function GetIPHostName() As String

    Dim sHostName As String * 256
    
    If Not SocketsInitialize() Then
        GetIPHostName = ""
        Exit Function
    End If
    
    If gethostname(sHostName, 256) = SOCKET_ERROR Then
        GetIPHostName = ""
        '-- RAPPEL: on peux extraire l'erreur via
        '-- Str$(WSAGetLastError())
        SocketsCleanup
        Exit Function
    End If
    
    GetIPHostName = Left$(sHostName, InStr(sHostName, Chr(0)) - 1)
    SocketsCleanup
    
End Function
'----------------------------------------------
Public Function GetMACAddress() As String

    Dim tmp As String
    Dim pASTAT As Long
    Dim NCB As NET_CONTROL_BLOCK
    Dim AST As ASTAT
    
    NCB.ncb_command = NCBRESET
    Call Netbios(NCB)
    
    NCB.ncb_callname = "*      "
    NCB.ncb_command = NCBASTAT
    
    NCB.ncb_lana_num = 0
    NCB.ncb_length = Len(AST)
    
    pASTAT = HeapAlloc(GetProcessHeap(), HEAP_GENERATE_EXCEPTIONS Or HEAP_ZERO_MEMORY, NCB.ncb_length)
    
    If pASTAT = 0 Then
        Debug.Print "L'allocation de mémoire à échoué!"
        Exit Function
    End If
    
    NCB.ncb_buffer = pASTAT
    Call Netbios(NCB)
    
    CopyMemory AST, NCB.ncb_buffer, Len(AST)
    
    tmp = Format$(Hex(AST.adapt.adapter_address(0)), "00") & "" & _
        Format$(Hex(AST.adapt.adapter_address(1)), "00") & "" & _
        Format$(Hex(AST.adapt.adapter_address(2)), "00") & "" & _
        Format$(Hex(AST.adapt.adapter_address(3)), "00") & "" & _
        Format$(Hex(AST.adapt.adapter_address(4)), "00") & "" & _
        Format$(Hex(AST.adapt.adapter_address(5)), "00")
        
    HeapFree GetProcessHeap(), 0, pASTAT
    
    GetMACAddress = tmp
    
End Function
'----------------------------------------------
Public Function GetStatusCode(status As Long) As String

    Dim msg As String
    
    Select Case status
        Case IP_SUCCESS:                msg = "ip success"
        Case IP_BUF_TOO_SMALL:          msg = "ip buf too_small"
        Case IP_DEST_NET_UNREACHABLE:   msg = "ip dest net unreachable"
        Case IP_DEST_HOST_UNREACHABLE:  msg = "ip dest host unreachable"
        Case IP_DEST_PROT_UNREACHABLE:  msg = "ip dest prot unreachable"
        Case IP_DEST_PORT_UNREACHABLE:  msg = "ip dest port unreachable"
        Case IP_NO_RESOURCES:           msg = "ip no resources"
        Case IP_BAD_OPTION:             msg = "ip bad option"
        Case IP_HW_ERROR:               msg = "ip hw_error"
        Case IP_PACKET_TOO_BIG:         msg = "ip packet too big"
        Case IP_REQ_TIMED_OUT:          msg = "ip req timed out"
        Case IP_BAD_REQ:                msg = "ip bad req"
        Case IP_BAD_ROUTE:              msg = "ip bad route"
        Case IP_TTL_EXPIRED_TRANSIT:    msg = "ip ttl expired transit"
        Case IP_TTL_EXPIRED_REASSEM:    msg = "ip ttl expired reassem"
        Case IP_PARAM_PROBLEM:          msg = "ip param problem"
        Case IP_SOURCE_QUENCH:          msg = "ip source quench"
        Case IP_OPTION_TOO_BIG:         msg = "ip option too big"
        Case IP_BAD_DESTINATION:        msg = "ip bad destination"
        Case IP_ADDR_DELETED:           msg = "ip addr deleted"
        Case IP_SPEC_MTU_CHANGE:        msg = "ip spec mtu change"
        Case IP_MTU_CHANGE:             msg = "ip mtu change"
        Case IP_UNLOAD:                 msg = "ip unload"
        Case IP_ADDR_ADDED:             msg = "ip addr added"
        Case IP_GENERAL_FAILURE:        msg = "ip general failure"
        Case IP_PENDING:                msg = "ip pending"
        Case PING_TIMEOUT:              msg = "ping timeout"
        Case Else:                      msg = "unknown msg returned"
    End Select
    
    GetStatusCode = CStr(status) & "[" & msg & "]"
    
End Function
'----------------------------------------------
Public Function HiByte(ByVal wParam As Integer)

    HiByte = wParam \ &H100 And &HFF&
    
End Function
'----------------------------------------------
Public Function LoByte(ByVal wParam As Integer)

    LoByte = wParam And &HFF&
    
End Function
'---------------------------------------------
Public Function Ping(szAddress As String, ECHO As ICMP_ECHO_REPLY) As Long

    Dim hPort As Long
    Dim dwAddress As Long
    Dim sDataToSend As String
    Dim iOpt As Long
    
    sDataToSend = smessageEcho
    dwAddress = AddressStringToLong(szAddress)
    
    hPort = IcmpCreateFile()
    
    If IcmpSendEcho(hPort, dwAddress, sDataToSend, Len(sDataToSend), 0, ECHO, Len(ECHO), PING_TIMEOUT) Then
        Ping = ECHO.RoundTripTime
    Else: Ping = ECHO.status * -1
    End If
    
    Call IcmpCloseHandle(hPort)
    
End Function
'----------------------------------------------
Public Function SocketsCleanup() As Boolean

    Dim X As Long
    
    X = WSACleanup()
    
    If X <> 0 Then
        SocketsCleanup = False
    Else
        SocketsCleanup = True
    End If
    
End Function
'----------------------------------------------
Public Function SocketsInitialize() As Boolean

    Dim WSAD As WSADATA
    Dim X As Integer
    Dim szLoByte As String, szHiByte As String, szBuf As String
    
    X = WSAStartup(WS_VERSION_REQD, WSAD)
    
    If X <> 0 Then
        SocketsInitialize = False
        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
        
        szHiByte = Trim$(Str$(HiByte(WSAD.wVersion)))
        szLoByte = Trim$(Str$(LoByte(WSAD.wVersion)))
        sVersion = "La version des sockets Windows est " & szLoByte & "." & szHiByte
        
        SocketsInitialize = False
        Exit Function
    End If
    
    '-- Erreur car il faut un minimum de
    '-- Sockets disponibles (MIN_SOCKETS_REQD)
    If WSAD.wMaxSockets < MIN_SOCKETS_REQD Then
        SocketsInitialize = False
        Exit Function
    End If
    
    SocketsInitialize = True
    
End Function
'----------------------------------------------
Function vbGetHostByAddress(ByVal sAddress As String) As String

    Dim lAddress As Long
    Dim PointerToMemoryLocation As Long
    Dim HostName As String
    Dim hostent As hostent
    
    '-- Vous devez d'abord transformer cette chaîne IP
    '-- en un nombre utilisable par les sockets:
    lAddress = inet_addr(sAddress)
    '-- L'adresse IP se transforme en nom DNS via GetHostByAddr():
    PointerToMemoryLocation = gethostbyaddr(lAddress, 4, AF_INET)
    
    If PointerToMemoryLocation <> 0 Then
    
        CopyMemory hostent, ByVal PointerToMemoryLocation, Len(hostent)
        
        '-- Vous devez créer la variable avec 256 * la valeur 0
        HostName = String(256, 0)
        
        '-- Copie vers la variables HostName
        CopyMemory ByVal HostName, ByVal hostent.hName, 256
        If HostName = "" Then vbGetHostByAddress = "Impossible d'établir un nom DNS !"
        
            vbGetHostByAddress = Left(HostName, InStr(HostName, Chr(0)) - 1)
        Else
            '-- Aucune entrée dans la base répartie du service
            '-- des nom de domaine:
            vbGetHostByAddress = "Aucune entrée DNS !"
        End If
        
End Function
'----------------------------------------------