sans MsgBoxReDim Temp(1 To Host.hLength)
'<VBA_INSPECTOR_RUN />
Option Explicit
Public Type HOSTENT
hName As Long
haliases As Long
hAddrtype As Integer
hLength As Integer
hAddrList As Long
End Type
'
Public Type WSADATA
wVersion As Integer
wHighVersion As Integer
szDescription(0 To 256) As Byte
szSystemStatus(0 To 128) As Byte
iMaxsockets As Integer
iMaxUpDg As Integer
lpszVendorInfo As Long
End Type
'
#If VBA7 Then
Public Declare PtrSafe Function WSAStartup Lib "wsock32.dll" _
(ByVal wVersion&, lpWSAData As WSADATA) As Long
Public Declare PtrSafe Function WSACleanup Lib "wsock32.dll" () As Long
Public Declare PtrSafe Function gethostname Lib "wsock32.dll" _
(ByVal HostName As String, ByVal HostLen As Integer) As Long
Public Declare PtrSafe Function gethostbyname Lib "wsock32.dll" _
(ByVal HostName As String) As Long
Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, source As Any, ByVal Length As LongPtr)
#Else
Public Declare Function WSAStartup Lib "wsock32.dll" _
(ByVal wVersion&, lpWSAData As WSADATA) As Long
Public Declare Function WSACleanup Lib "wsock32.dll" () As Long
Public Declare Function gethostname Lib "wsock32.dll" _
(ByVal HostName As String, ByVal HostLen As Integer) As Long
Public Declare Function gethostbyname Lib "wsock32.dll" _
(ByVal HostName As String) As Long
'<VBA_INSPECTOR>
' <DECLARE>
' <MESSAGE>Contains a Windows 32-bit API call that will need to be updated for 64bit compatibility.</MESSAGE>
' <ITEM>UPDATED: Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)</ITEM>
' <URL>[I]Ce lien n'existe plus[/I] </URL>
' </DECLARE>
'</VBA_INSPECTOR>
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(Dest As Any, ByVal source As Long, _
ByVal cbCopy As Long)
#End If
Public Const SOCKET_ERROR = -1
'
Public Type IPtype
Nom As String * 256
AdresseIP As String * 64
End Type
Public Function ObtenirAdresseIP() As IPtype
Dim WSAD As WSADATA
Dim Host As HOSTENT
Dim RetVal As Long
Dim Nom As String * 256
Dim Adresse As Long
Dim IPadr As String
#If Win64 Then
Dim Temp() As Long
Dim i As Long
#Else
Dim Temp() As Byte
Dim i As Byte
#End If
'
RetVal = WSAStartup(&H101, WSAD)
If RetVal <> 0 Then
MsgBox "Winsock.dll ne répond pas"
ObtenirAdresseIP.Nom = ""
ObtenirAdresseIP.AdresseIP = ""
Exit Function
End If
If gethostname(Nom, Len(Nom)) = SOCKET_ERROR Then
MsgBox "Erreur Winsock"
ObtenirAdresseIP.Nom = ""
ObtenirAdresseIP.AdresseIP = ""
Exit Function
End If
Adresse = gethostbyname(Nom)
If Adresse = 0 Then
MsgBox "Winwock.dll ne repond pas"
ObtenirAdresseIP.Nom = ""
ObtenirAdresseIP.AdresseIP = ""
Exit Function
End If
'
CopyMemory Host, Adresse, Len(Host)
CopyMemory Adresse, Host.hAddrList, 4
'
ReDim Temp(1 To Host.hLength)
'
CopyMemory Temp(1), Adresse, Host.hLength
'
For i = 1 To Host.hLength
IPadr = IPadr & Temp(i) & "."
Next i
'
IPadr = Left$(IPadr, Len(IPadr) - 1)
ObtenirAdresseIP.AdresseIP = IPadr
RetVal = WSACleanup()
End Function
Sub AficherAdresseIP()
'%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
'source : [url=http://www.vbfrance.com/code.aspx?ID=24055]CONNAITRE MON ADRESSE IP ET LE NOM D'ORDINATEUR , Source N°24055 Visual Basic, VB6, VB.NET, VB 2005, VB[/url]
'%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
Dim Adr As IPtype
Dim Adresse As String
Dim P As Integer
Adr = ObtenirAdresseIP
P = InStr(Adr.Nom, Chr$(0))
If P <> 0 Then
Adresse = Trim$(Adr.AdresseIP)
MsgBox "Adresse IP du poste = " & Adresse
End If
End Sub
--------------------------------------------------
Information systeme Le 14.04.2012 16:19:46
source RAPPORT SYSTEME , Source N°25414 Visual Basic, VB6, VB.NET, VB 2005, VB
by racattac13
--------------------------------------------------
Systeme d'exploitation :
Nom de l'OS : Microsoft Windows*7 Édition Familiale Premium |C:\Windows|\Device\Harddisk0\Partition2
Version : 6.1.7601
Nom du Fabricant : Microsoft Corporation
Repertoire windows : C:\Windows
Chemin Locale : 100c
Memoire physique dispo : 2645956
Memoire virtuelle total : 7861048
Memoire virtuelle dispo : 6473564
Memoire partager : 3931448
Systeme ordinateur:
Nom de l'ordinateur : WIN7
Nom du Fabricant : Hewlett-Packard
Nom de produit : 100-5100ch
Zone horaire : 120
Memoire physique totale : 4025802752
Processeur:
Processeur : AMD64 Family 16 Model 6 Stepping 3
Fréquence actuelle : 1800
Fréquence Maximum : 1800
Zones en rouges dans les modules
Adresse_IP
#If VBA7 Then
Public Declare PtrSafe Function WSAStartup Lib "wsock32.dll" _
(ByVal wVersion&, lpWSAData As WSADATA) As Long
Public Declare PtrSafe Function WSACleanup Lib "wsock32.dll" () As Long
Public Declare PtrSafe Function gethostname Lib "wsock32.dll" _
(ByVal HostName As String, ByVal HostLen As Integer) As Long
Public Declare PtrSafe Function gethostbyname Lib "wsock32.dll" _
(ByVal HostName As String) As Long
Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
#Else
MémPhysique
Declare PtrSafe Sub GlobalMemoryStatus Lib "kernel32" (lpBuffer As MEMORYSTATUS)
Declare PtrSafe Function GetComputerName& Lib "kernel32" Alias "GetComputerNameA" (ByVal lbbuffer As String, nSize As Long)
PC_Imprimante
#If VBA7 Then
Declare PtrSafe Function EnumPrintersA Lib "Winspool.drv" _
(ByVal flags As Long, ByVal name As String, ByVal Level As Long, _
pPrinterEnum As Long, ByVal cdBuf As Long, _
pcbNeeded As Long, pcReturned As Long) As Long
Declare PtrSafe Function lstrlenA Lib "kernel32" (ByVal lpString As Any) As Long
Declare PtrSafe Function lstrcpyA Lib "kernel32" (ByVal lpString1 As String, ByVal lpString2 As Long) As Long
#Else
Resolution_ecran
#If VBA7 Then
Public Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Public Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal Hdc As Long, ByVal nIndex As Long) As Long
#Else
Version_Os
#If VBA7 Then
Private Declare PtrSafe Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" _
(lpVersionInformation As Any) As Long
#Else
C'est normal que tu aies ces lignes en rouge mais cela ne doit pas poser de problème normalement (pas chez moi sur la v2007 en tout cas). Si tu les passes en commentaire, tu perds le bénéfice de la compatibilité des versions d'Office 32-64 bits, donc aucun intérêt : à ce moment-là, utilise le fichier fourni par Jean-Claude.Et J'ai des lignes inscrites en rouge un peu dans tous les modules, mais je viens de les mettres comme commentaires et il n'y a pas u de bugs.