Attribute VB_Name = "ModuleIp"
Option Explicit
Public Const WSADESCRIPTION_LEN = 256
Public Const WSASYSSTATUS_LEN = 256
Public Const WSADESCRIPTION_LEN_1 = WSADESCRIPTION_LEN + 1
Public Const WSASYSSTATUS_LEN_1 = WSASYSSTATUS_LEN + 1
Public Const SOCKET_ERROR = -1


' Code de déclaration pour faire un ping
Public Const PING_TIMEOUT = 200
 
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 Type ip_option_information
 TTL             As Byte     'Time To Live [ Nb Max de sauts de routeurs ]
 Tos             As Byte     'Type Of Service [ Type de trame ]
 Flags           As Byte     'IP header flags [ En-tête de la trame ]
 OptionsSize     As Byte     'Taille des trames
 OptionsData     As Long     'Options ( hops, TargetIP,... )
End Type

Public Type icmp_echo_reply
 Address         As Long                     'Replying address
 Status          As Long                     'Reply IP_STATUS, values as defined above
 RoundTripTime   As Long                     'RTT in milliseconds
 DataSize        As Integer                  'Reply data size in bytes
 Reserved        As Integer                  'Reserved for system use
 DataPointer     As Long                     'Pointer to the reply data
 Options         As ip_option_information    'Reply options
 Data            As String * 250             'Reply data which should be a copy of the string sent, NULL terminated
End Type                                     ' this field length should be large enough to contain the string sent

Private Const AF_INET = 2
Private Type hostent
    hName As Long
    hAliases As Long
    hAddrType As Integer
    hLen As Integer
    hAddrList As Long
End Type

Public Type tagWSAData
 wVersion            As Integer
 wHighVersion        As Integer
 szDescription       As String * WSADESCRIPTION_LEN_1
 szSystemStatus      As String * WSASYSSTATUS_LEN_1
 iMaxSockets         As Integer
 iMaxUdpDg           As Integer
 lpVendorInfo        As String * 200
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, RequestOptions As ip_option_information, 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)
Public Declare Function gethostbyname Lib "wsock32.dll" (ByVal szHost As String) As Long
Public Declare Function gethostname Lib "wsock32.dll" (ByVal HostName As String, ByVal HostLen As Integer) As Long
Public Declare Function inet_ntoa Lib "wsock32.dll" (ByVal addr As Long) As Long
Public Declare Function inet_addr Lib "wsock32.dll" (ByVal s As String) As Long
Public Declare Function gethostbyaddr Lib "wsock32.dll" (haddr As Long, hnlen As Long, ByVal addrtype As Long) As Long
Public Declare Function WSAStartup Lib "wsock32.dll" (ByVal wVersionRequested As Integer, lpWSAData As tagWSAData) As Integer
Public Declare Function WSACleanup Lib "wsock32.dll" () As Integer



Public Function GetLocalIp() As String
' Retourne l'adresse IP local
Dim iVal As Integer
Dim pWsaData As tagWSAData
Dim TblByte(4) As Byte
Dim HostAddr As Long
Dim HostName As String * 256
Dim VHostent As hostent

iVal = WSAStartup(&H101, pWsaData)
If iVal <> 0 Then
    ' Erreur
    Exit Function
End If
If gethostname(HostName, Len(HostName)) = SOCKET_ERROR Then
    iVal = WSACleanup()
    Exit Function
End If
HostAddr = gethostbyname(HostName)
If HostAddr = 0 Then
    iVal = WSACleanup()
    Exit Function
End If
RtlMoveMemory VHostent, HostAddr, Len(VHostent)
RtlMoveMemory HostAddr, VHostent.hAddrList, 4

' Mise en forme de l'adresse Ip
RtlMoveMemory TblByte(1), HostAddr, 4

iVal = WSACleanup()

GetLocalIp = Trim$(Str$(TblByte(1))) & "." & Trim$(Str$(TblByte(2))) & "." & Trim$(Str$(TblByte(3))) & "." & Trim$(Str$(TblByte(4)))

End Function


Public Function GetHostNameFromIp(IpString As String) As String
Dim HostAddr As Long
Dim HostName As String * 256
Dim VHostent As hostent
Dim IpAddress As Long
Dim Nom As String
Dim x As Integer
Nom = ""
IpAddress = inet_addr(IpString)
HostAddr = gethostbyaddr(IpAddress, 4, AF_INET)
If HostAddr <> 0 Then
    CopyMemory VHostent, ByVal HostAddr, Len(VHostent)
    
    CopyMemory ByVal HostName, ByVal VHostent.hName, 256
    ' Recherche null
    x = InStr(HostName, Chr$(0))
    If x > 1 Then
        Nom = Left$(HostName, x - 1)
    End If
End If

GetHostNameFromIp = Nom

End Function

Public Function IsIpString(Chaine As String) As Boolean
' Cette fonction verifie que la chaine passée en paramètre
' est une adresse Ip au format x.x.x.x
' x peut avoir une valeur entre 1 et 255
' Si c'est le cas la fonction retourne True
Dim i, j, l, x As Integer
Dim Txt As String
Dim Champ As String

IsIpString = False

Txt = Trim$(Chaine)
l = Len(Txt)
If l = 0 Then Exit Function
' Comptage des champs séparé par .
' Il faut 3 points soit 4 champ
j = 0
For i = 1 To l
    If Mid$(Txt, i, 1) = "." Then j = j + 1

Next i
If j <> 3 Then Exit Function
' Analyse des champs
For i = 1 To 4
    ' on prend à gauche du .
    x = InStr(Txt, ".")
    If x <> 0 Then
        If x > 1 Then
            Champ = Left$(Txt, x - 1)
            ' Contenu incorrecte
            If (CInt(Champ) < 0) Or (CInt(Champ) > 255) Then Exit Function
        Else
            ' Longueur du champ incorrecte
            Exit Function
        End If
        ' Recalcul de TXT
        If Len(Txt) - x > 0 Then
            Txt = Right$(Txt, Len(Txt) - x)
        Else
            Txt = ""
        End If
    Else
        If Len(Txt) > 0 Then
            Champ = Txt
            ' Contenu incorrecte
            If (CInt(Champ) < 0) Or (CInt(Champ) > 255) Then Exit Function
        Else
            ' Longueur Champ Incorrecte
            Exit Function
        End If
    End If
Next i

' Si on arrive ici c'est tout bon
IsIpString = True

End Function

Public Function IpPing(AddressIp As String, ReponseMs As Long) As Boolean
' Effectue un Ping sur une address IP
' Retourne True si OK

' Execute un Ping sur la station données
Dim hFile As Long
Dim lRet As Long
Dim lIpAddress As Long
Dim StrMessage As String
Dim pOptions As ip_option_information
Dim pReturn As icmp_echo_reply
Dim iVal As Integer
Dim lPingRet As Long
Dim pWsaData As tagWSAData
Dim TblByte(4) As Byte
'Dim Octet As Byte

' Mise en forme de l'adresse Ip
'CopyMemory TblByte(1), TargetIp, 4

'Octet = TblByte(1)
'TblByte(1) = TblByte(4)
'TblByte(4) = Octet
'Octet = TblByte(2)
'TblByte(2) = TblByte(3)
'TblByte(3) = Octet

'CopyMemory lIpAddress, TblByte(1), 4




' Mise en forme de IP
' ===================

Dim Part(4) As String
Dim xPart As Integer
Dim Fin As Boolean
Dim Texte As String
Dim Pos As Integer

Texte = Trim$(AddressIp)

For xPart = 1 To 4
    TblByte(xPart) = 0
Next xPart

xPart = 0
While Fin = False
    Pos = InStr(Texte, ".")
    If Pos > 0 Then
        xPart = xPart + 1
        If Pos > 1 Then
            TblByte(xPart) = CByte(Left$(Texte, Pos - 1))
        Else
            TblByte(xPart) = CByte("0")
        End If
        Texte = Right$(Texte, Len(Texte) - Pos)
    Else
        xPart = xPart + 1
        TblByte(xPart) = CByte(Texte)
        Texte = ""
    End If
    If xPart = 4 Then
        Fin = True
    ElseIf Len(Texte) = 0 Then
        Fin = True
    End If
Wend
'For xPart = 1 To 4
    'IpTexte(xPart) = Part(xPart)
'Next xPart


CopyMemory lIpAddress, TblByte(1), 4

StrMessage = "Echo pour ping"
iVal = WSAStartup(&H101, pWsaData)

hFile = IcmpCreateFile()
pOptions.TTL = 30
lRet = IcmpSendEcho(hFile, lIpAddress, StrMessage, Len(StrMessage), pOptions, pReturn, Len(pReturn), PING_TIMEOUT)
If lRet = 0 Then
    ' Error
    IpPing = False
Else
    If pReturn.Status <> 0 Then
        ' Error
        IpPing = False
    Else
        ' Gagné
        IpPing = True
        ReponseMs = pReturn.RoundTripTime
    End If
End If
lRet = IcmpCloseHandle(hFile)
iVal = WSACleanup()


End Function

Public Function GetIpStringFromIpLong(IpLng As Long) As String
Dim Txt As String
Dim x As Long


x = IpLng And &HFF000000
If x > 0 Then
    Txt = CStr((x) / &H1000000)

Else
    x = x / &H1000000
    'x = x * (-1)
    x = x + 256
    Txt = CStr(x)
End If
IpLng = IpLng And &HFFFFFF

Txt = Txt & "." & CStr((IpLng And &HFF0000) / &H10000)

'Debug.Print "2" & Hex$(IpLng And &HFF00&)
'Debug.Print "2" & Hex$((IpLng And &HFF00&) / &H100&)

Txt = Txt & "." & CStr((IpLng And &HFF00&) / &H100&)
Txt = Txt & "." & CStr(IpLng And &HFF)

GetIpStringFromIpLong = Txt

End Function

Public Function GetIpLongFromIpString(IpString As String) As Long
' Convertion d'une chaine au format a.b.c.d
' en long aabbccdd
' ================
Dim i, j, l, x As Integer
Dim Txt As String
Dim Champ As String
Dim IpLong As Long

Txt = Trim$(IpString)
l = Len(Txt)
If l = 0 Then Exit Function
' Comptage des champs séparé par .
' Il faut 3 points soit 4 champ
j = 0
For i = 1 To l
    If Mid$(Txt, i, 1) = "." Then j = j + 1

Next i
If j <> 3 Then Exit Function
' Analyse des champs
For i = 1 To 4
    ' on prend à gauche du .
    x = InStr(Txt, ".")
    If x <> 0 Then
        If x > 1 Then
            Champ = Left$(Txt, x - 1)
            ' Contenu incorrecte
            'If (CInt(Champ) < 1) Or (CInt(Champ) > 255) Then Exit Function
        Else
            ' Longueur du champ incorrecte
            Exit Function
        End If
        ' Recalcul de TXT
        If Len(Txt) - x > 0 Then
            Txt = Right$(Txt, Len(Txt) - x)
        Else
            Txt = ""
        End If
    Else
        If Len(Txt) > 0 Then
            Champ = Txt
            ' Contenu incorrecte
            'If (CInt(Champ) < 1) Or (CInt(Champ) > 255) Then Exit Function
        Else
            ' Longueur Champ Incorrecte
            Exit Function
        End If
    End If
    
    Champ = Champ And &HFF
    Select Case i
        Case 1
        If Champ <= &H7F Then
            IpLong = IpLong Or ((CLng(Champ) * &H1000000))
        Else
            Champ = (256 - Champ) * (-1)
            IpLong = IpLong Or ((CLng(Champ) * &H1000000))
            'IpLong = IpLong * (-1)
        End If

        Case 2
        IpLong = IpLong Or ((CLng(Champ) * &H10000))

        Case 3
        IpLong = IpLong Or ((CLng(Champ) * &H100))

        Case 4
        IpLong = IpLong Or ((CLng(Champ) * &H1))

    End Select
    
Next i

GetIpLongFromIpString = IpLong
End Function

Public Function GetIpFromHostName(HostString As String) As String
Dim IpString As String
Dim HostAddr As Long
'Dim HostName As String * 256
Dim VHostent As hostent
Dim IpAddress As Long
Dim Nom As String
Dim x As Integer
Dim AddrData As Long
Dim TblByte() As Byte
Dim i As Integer


GetIpFromHostName = ""
Exit Function

' N O T A :  N E     F O N C T I O N N E    P A S
' ===============================================


IpString = ""
HostAddr = gethostbyname(HostString)
If HostAddr <> 0 Then
    CopyMemory VHostent, ByVal HostAddr, Len(VHostent)
    ReDim TblByte(1 To VHostent.hLen)
    ' Aie
    CopyMemory IpAddress, ByVal VHostent.hAddrType, 4
    CopyMemory TblByte(1), ByVal IpAddress, VHostent.hLen
    For i = 1 To VHostent.hLen
        IpString = IpString & TblByte(i) & "."
    Next i
    IpString = Left$(IpString, Len(IpString) - 1)
End If
GetIpFromHostName = IpString


'Dim WSAD As WSAData
'Dim LngHostent As Long
'Dim LngLstIpAddress() As Byte
'Dim LngIPAddress As Long
'Dim HostStruct As hostent
'Dim i As Long
'Dim Adresse As String
'Dim STemp As String
'
'If WSAStartup(&H101, WSAD) <> 0 Then
'    ' Erreur initialisation socket
'Else
'    LngHostent = gethostbyname(Domaine)
'    If LngHostent <> 0 Then
'        RtlMoveMemory HostStruct, LngHostent, LenB(HostStruct)
'        ReDim LngLstIpAddress(1 To HostStruct.hLen)
'        RtlMoveMemory LngIPAddress, ByVal HostStruct.hAddrList, 4
'        RtlMoveMemory LngLstIpAddress(1), ByVal LngIPAddress, HostStruct.hLen
'        For i = 1 To HostStruct.hLen
'            Adresse = Adresse & LngLstIpAddress(i) & "."
'        Next i
'        STemp = Left$(Adresse, Len(Adresse) - 1)
'    End If
'    If WSACleanup() <> 0 Then
'        ' Erreur fermeture socket
'    End If
'End If
'

End Function
