Office: IP auslesen auch bei 64 bit!!

StevEiserman · 21. September 2016

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
Code:

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

:)
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

haklesoft · 22. September 2016

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.: Code:

Option Explicit

' Beispiel aus VB Function to Find the IP Address/Addresses of the Local Computer (Visual Basic/VBasic/VBA)
' 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
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Noch deutlich kompakter und vermutlich auch Office64-kompatibel geht es mit WMI: Code:

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
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Fennek11 · 22. September 2016

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 · 22. September 2016

Bei mir funktioniert der Code mit dem cmd.

Grüße

Mathieu

StevEiserman · 23. September 2016

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:
Code:

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
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

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

haklesoft · 23. September 2016

Hallo Stev,

zur Übernahme als String musst Du den Code ein wenig umstellen: Code:

' 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
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

StevEiserman · 23. September 2016

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. September 2016

Hallo StevEiserman,

die Ereignis-Routine in 'DieseArbeitsmappe' muß auch so lauten: Code:

Private Sub Workbook_Open()
statt
Private Sub Workbook Open ()
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Gruß von Luschi
aus klein-Paris

StevEiserman · 23. September 2016

Hallo Luschi,

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

Office: IP auslesen auch bei 64 bit!!

IP auslesen auch bei 64 bit!!

IP auslesen auch bei 64 bit!!

IP auslesen auch bei 64 bit!!

IP auslesen auch bei 64 bit!!

IP auslesen auch bei 64 bit!! - Similar Threads - auslesen bit

Teile aus einem qrcode string auslesen

VBA Auslesen von Strings und erstellen neuer Zeilen in einer Tabelle

aktuelles Alter aus Geburtsdatum auslesen und runde Geburtstage markieren

Datum einer Datei per VBA auslesen

Werte auslesen mit s(w)verweis

textdatei auslesen

Auslesen eines Wertes aus verschiedenen Tabelle