PDA

Vollständige Version anzeigen : IP auslesen auch bei 64 bit!!


StevEiserman
23.09.2016, 09:00
Hallo,

ich habe damals im Internet ein schönes VBA gefunden, wo ich die IP und die
Application.Version,Application.Build,... auslesen kann um später bei Problemen
schneller den Fehler zu finden.
Das ganze funktioniert aber mit 64 bit Versionen nicht mehr, könnt Ihr mir
helfen, das das VBA unter 32/64 bit läuft????

Der Fehler (rot) liegt bei:
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)

Vielen Dank
Stev
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Public Declare Function GetIpAddrTable Lib "IPHlpApi" (pIPAdrTable As Byte, pdwSize As Long, ByVal Sort As Long) As Long
Const MAX_IP = 5 'To make a buffer... i dont think you have more than 5 ip on your pc..
Type IPINFO
dwAddr As Long ' IP address
dwIndex As Long ' interface index
dwMask As Long ' subnet mask
dwBCastAddr As Long ' broadcast address
dwReasmSize As Long ' assembly size
unused1 As Integer ' not currently used
unused2 As Integer '; not currently used
End Type
Type MIB_IPADDRTABLE
dEntrys As Long 'number of entries in the table
mIPInfo(MAX_IP) As IPINFO 'array of IP address entries
End Type
Type IP_Array
mBuffer As MIB_IPADDRTABLE
BufferLen As Long
End Type
Public Function ConvertAddressToString(longAddr As Long) As String
Dim myByte(3) As Byte
Dim Cnt As Long
CopyMemory myByte(0), longAddr, 4
For Cnt = 0 To 3
ConvertAddressToString = ConvertAddressToString + CStr(myByte(Cnt)) + "."
Next Cnt
ConvertAddressToString = Left$(ConvertAddressToString, Len(ConvertAddressToString) - 1)
End Function


Function GetIP()
Dim Ret As Long, Tel As Long
Dim bBytes() As Byte
Dim Listing As MIB_IPADDRTABLE
Dim IPtext As String
On Error GoTo END1
GetIpAddrTable ByVal 0&, Ret, True
If Ret <= 0 Then Exit Function
ReDim bBytes(0 To Ret - 1) As Byte
GetIpAddrTable bBytes(0), Ret, False
CopyMemory Listing.dEntrys, bBytes(0), 4
Tel = 0
CopyMemory Listing.mIPInfo(Tel), bBytes(4 + (Tel * Len(Listing.mIPInfo(0)))), Len(Listing.mIPInfo(Tel))
IPtext = ConvertAddressToString(Listing.mIPInfo(Tel).dwAddr)
IPtext = IPtext & "."
GetIP = IPtext 'hier gegebenenfalls an eine Zelle übergeben
Exit Function
END1:
GetIP = "ERROR"
End Function

haklesoft
23.09.2016, 10:09
Hallo Stev,

Du musst die API-Funktionen für 64bit kompatibel machen. Stichwort PtrSafe.

Hier ein etwas etwas kompakteres Beispiel für das Auslesen der IP-Adressen, wobei ich versucht habe, PtrSafe und LongPtr einzubauen. Da ich kein 64-bit-Office habe, musst Du das selber testen.:Option Explicit

' Beispiel aus http://www.source-code.biz/snippets/vbasic/8.htm
' Author: Christian d'Heureuse (www.source-code.biz, www.inventec.ch/chdh)

Private Declare PtrSafe Function GetIpAddrTable_API Lib "IpHlpApi" Alias "GetIpAddrTable" (pIPAddrTable As Any, pdwSize As LongPtr, ByVal bOrder As LongPtr) As Long

' Returns an array with the local IP addresses (as strings).
Public Function GetIpAddrTable()
Dim Buf(0 To 511) As Byte
Dim BufSize As Long: BufSize = UBound(Buf) + 1
Dim rc As Long
rc = GetIpAddrTable_API(Buf(0), BufSize, 1)
If rc <> 0 Then Err.Raise vbObjectError, , "GetIpAddrTable failed with return value " & rc
Dim NrOfEntries As Integer: NrOfEntries = Buf(1) * 256 + Buf(0)
If NrOfEntries = 0 Then GetIpAddrTable = Array(): Exit Function
ReDim IpAddrs(0 To NrOfEntries - 1) As String
Dim i As Integer
For i = 0 To NrOfEntries - 1
Dim j As Integer, s As String: s = ""
For j = 0 To 3: s = s & IIf(j > 0, ".", "") & Buf(4 + i * 24 + j): Next
IpAddrs(i) = s
Next
GetIpAddrTable = IpAddrs
End Function

' Test program for GetIpAddrTable.
Public Sub TestIP()
Dim IpAddrs
IpAddrs = GetIpAddrTable
Debug.Print "Nr of IP addresses: " & UBound(IpAddrs) - LBound(IpAddrs) + 1
Dim i As Integer
For i = LBound(IpAddrs) To UBound(IpAddrs)
Debug.Print IpAddrs(i)
Next
End Sub
Noch deutlich kompakter und vermutlich auch Office64-kompatibel geht es mit WMI:Sub ListIPs()
Dim i As Long, objWMI As Object, objData As Object, colData As Object, v As Variant
Set objWMI = GetObject("winmgmts:\\" & "." & "\root\cimv2")
Set colData = objWMI.ExecQuery("Select * from Win32_NetworkAdapterConfiguration Where IPEnabled = True")
For Each objData In colData
v = objData.IPAddress
For i = 0 To UBound(v) 'mit IPv6-Adresse
Debug.Print v(i)
Next
Next
End Sub

Fennek11
23.09.2016, 10:21
Hallo,

da ich gerne aus Halbwissen Fragen stelle:

mit cmd: ipconfig

kann man die IP-Adressen auslesen. Warum geht ein Ansatz analog zu "Dir" nicht:

ungetestet:

sn = Split(CreateObject("wscript.shell").exec("cmd /c ipconfig").stdout.readall, vbCrLf)
For Each d In sn
Debug.Print d
Next d

mfg

mathieu_91
23.09.2016, 10:42
Bei mir funktioniert der Code mit dem cmd.

Grüße

Mathieu

StevEiserman
23.09.2016, 12:25
Hallo haklesoft, Hallo Fennek11,

Danke für Eure schnelle Hilfe, es funktionieren alle drei Varianten aber ich
habe noch ein Problem beim einbinden in meiner anderen Prozedur Workbook_Open() für Euch wahrscheinlich eine Kleinigkeit aber für mich als VBA Neuling ziemlich hakelig!! Er schreibt mir einfach die IP nicht weg bei folgenden
Makro:

Private Sub Workbook_Open()


Call Optimizing_Init

With Sheets("Tabelle1")
lr = .Cells(Rows.Count, "A").End(xlUp).Row + 1
.Range("A" & lr) = Now()
.Range("D" & lr) = Environ("username")
.Range("E" & lr) = Application.Version
.Range("F" & lr) = Environ("computername")
.Range("G" & lr) = Application.Build
.Range("H" & lr) = ListIPs

End With
End Sub

Habe es auch schon als Funktion getestet, alle Felder werden gefüllt bis auf die IP, was mache ich verkehrt????!!!!

haklesoft
23.09.2016, 12:39
Hallo Stev,

zur Übernahme als String musst Du den Code ein wenig umstellen:' Liefert einen Kommaseparierten String mit IP-Infos
Public Function ListIPs() As String
Dim sIPs As String
Dim i As Long, objWMI As Object, objData As Object, colData As Object, v As Variant
Set objWMI = GetObject("winmgmts:\\" & "." & "\root\cimv2")
Set colData = objWMI.ExecQuery("Select * from Win32_NetworkAdapterConfiguration Where IPEnabled = True")
For Each objData In colData
v = objData.IPAddress
For i = 0 To UBound(v)
sIPs = sIPs & v(i) & ","
Next i
Next
If Len(sIPs) > 1 Then sIPs = Left(sIPs, Len(sIPs) - 1)
ListIPs = sIPs
End Function

StevEiserman
23.09.2016, 13:24
Hallo haklesoft,

Klasse es funktioniert gut, das einzigste Problem ist, das bei meinen
Excel 2016 (16) Build 6741 "Private Sub Workbook Open ()" nicht
automatisch ausgeführt wird obwohl es in "diese Arbeitsmappe" hinterlegt ist!!
Bei der 2010er Version funktioniert es prima!!!

Luschi
23.09.2016, 13:43
Hallo StevEiserman,

die Ereignis-Routine in 'DieseArbeitsmappe' muß auch so lauten: Private Sub Workbook_Open()
statt
Private Sub Workbook Open ()Gruß von Luschi
aus klein-Paris

StevEiserman
23.09.2016, 14:06
Hallo Luschi,

Du hast recht es ist auch bei mir "Private Sub Workbook_Open()"
habe mich verschrieben!!!!
Entschuldigung!!!