La question etant souvent posé et les sources de vbfrance introuvable, voici une version pour un module. Ca fait partie d'un de mes Projets.
Source / Exemple :
'---------------------------------
' Ip INTERNET
' TheSaib pour Codes-sources.com
' Copyright Codes-sources.Com
' modIP.bas
'---------------------------------
'MsgBox Ip_courante(True)
Public Const WS_VERSION_REQD = &H101 'version nécessaire
Public Const WS_VERSION_MAJOR = WS_VERSION_REQD \ &H100 And &HFF& 'version la + haute
Public Const WS_VERSION_MINOR = WS_VERSION_REQD And &HFF& 'version la + petite
Public Const MIN_SOCKETS_REQD = 1 'Min de socket
Public Const SOCKET_ERROR = -1 'Error d'initialisation socket
Public Const WSADESCRIPTION_LEN = 256 'Longueur du champs description
Public Const WSASYS_Status_Len = 128 'Idem champs status
Public Type HOSTENT 'Enregistre info relatif a un poste ou un réseau
hName As Long 'Pointeur vers le domaine de la machine
hAliases As Long 'Pointeur vers le domaine alternatif si il y a
hAddrType As Integer 'famille d'adresse utilisé par le protocole
hLength As Integer 'longueur en octetde chaque adresse pointé par hAddrType
hAddrList As Long 'list des adresse
End Type
'type winsock
Public Type WSADATA 'utilsé par startup
wVersion As Integer 'version Winsock
wHighVersion As Integer 'Version la + haute de wsk que Win supporte
szDescription(0 To WSADESCRIPTION_LEN) As Byte 'Implémentation de winsok qui sera utilisé (doit finir par zero)
szSystemStatus(0 To WSASYS_Status_Len) As Byte 'statut implémentation actuell winsock
iMaxSockets As Integer 'nombre maximum de socket possible (32327)
iMaxUdpDg As Integer 'pas usé
lpszVendorInfo As Long ' pas usé
End Type
Public Declare Function WSAGetLastError Lib "WSOCK32.DLL" () As Long 'Récupération erreur lié socket
Public Declare Function WSAStartup Lib "WSOCK32.DLL" (ByVal wVersionRequired&, lpWSAData As WSADATA) As Long 'Initialise socket
Public Declare Function WSACleanup Lib "WSOCK32.DLL" () As Long 'Destructeur de socket
Public Declare Function gethostname Lib "WSOCK32.DLL" (ByVal hostname$, ByVal HostLen As Long) As Long 'Récupere nom host
Public Declare Function gethostbyname Lib "WSOCK32.DLL" (ByVal hostname$) As Long 'Recupere ip a partir host
Public Declare Sub RtlMoveMemory Lib "kernel32" (hpvDest As Any, ByVal hpvSource&, ByVal cbCopy&)
Function BitPdsFort(ByVal Valeur As Integer) 'Récupère bit de poid fort du parametre
BitPdsFort = Valeur \ &H100 And &HFF& 'Et bit a bit
End Function
Function BitPdsFaible(ByVal Valeur As Integer) 'Récupère bit de poid faible du parametre
BitPdsFaible = Valeur And &HFF& 'Et bit a bit
End Function
Sub Init_socket() 'Initialisation des sockets
Dim WSAD As WSADATA 'pointeur vers objet wsk
Dim DemarrSck As Integer 'Valeur du démarrage d'un socket wsk
Dim sBitFaible As String, sBitFort As String, sMsg As String
DemarrSck = WSAStartup(WS_VERSION_REQD, WSAD) 'Initialisation Socket
'Test Erreur d'init socket
If DemarrSck <> 0 Then
MsgBox "Erreur Winsock.dll."
Exit Sub
End If
'Test si version nécessaire est indisponible
If BitPdsFaible(WSAD.wVersion) < WS_VERSION_MAJOR Or (BitPdsFaible(WSAD.wVersion) = _
WS_VERSION_MAJOR And BitPdsFort(WSAD.wVersion) < WS_VERSION_MINOR) Then
sBitFort = Trim$(Str$(BitPdsFort(WSAD.wVersion)))
sBitFaible = Trim$(Str$(BitPdsFaible(WSAD.wVersion)))
sMsg = "Windows Sockets version : " & sBitFaible & "." & sBitFort
MsgBox sMsg
Exit Sub
End If
End Sub
Public Function Ip_courante(RetourIPExterne As Boolean)
Init_socket
Dim hostname As String * 256 'Nom de la machine étendu de 0
Dim host_adresse As Long 'Adresse machine
Dim host As HOSTENT 'Type machine
Dim Adresse_ip_host As Long 'Adresse IP
Dim Adresse_ip_temporaire() As Byte 'Quartet temporaire
Dim i As Integer
Dim Adresse_ip As String 'Adresse ip de retour
Dim Ip As String
'Recupere le nom de la machine
If gethostname(hostname, 256) = SOCKET_ERROR Then
MsgBox Err.Number
Exit Function
Else
hostname = Trim$(hostname)
End If
'Pointeur vers l'adresse
host_adresse = gethostbyname(hostname)
If host_adresse = 0 Then
MsgBox "Erreur de Winsock.dll"
Exit Function
End If
'Récupération dans le tableau de l'adresse
RtlMoveMemory host, host_adresse, LenB(host)
RtlMoveMemory Adresse_ip_host, host.hAddrList, 4
'Recupere les 4 quartets de l'adresse
Do
ReDim Adresse_ip_temporaire(1 To host.hLength)
RtlMoveMemory Adresse_ip_temporaire(1), Adresse_ip_host, host.hLength
'Met en forme les quartets en @ Ip valide
For i = 1 To host.hLength
Adresse_ip = Adresse_ip & Adresse_ip_temporaire(i) & "."
Next
Adresse_ip = Mid$(Adresse_ip, 1, Len(Adresse_ip) - 1)
'Copie de l'ip
Interne = Mon_IP
Externe = Adresse_ip
Mon_IP = Adresse_ip
Adresse_ip = ""
host.hAddrList = host.hAddrList + LenB(host.hAddrList)
RtlMoveMemory Adresse_ip_host, host.hAddrList, 4
Loop While (Adresse_ip_host <> 0)
If RetourIPExterne = True Then
Ip_courante = Externe
Else
Ip_courante = Interne
End If
End Function
Sub DestrucSocket()
Dim lretour As Long
lretour = WSACleanup()
If lretour <> 0 Then
MsgBox "Erreur socket" & Trim$(Str$(lretour)) & " pendant sa destruction "
Exit Sub
End If
End Sub
Vous n'êtes pas encore membre ?
inscrivez-vous, c'est gratuit et ça prend moins d'une minute !
Les membres obtiennent plus de réponses que les utilisateurs anonymes.
Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.
Le fait d'être membre vous permet d'avoir des options supplémentaires.