Eigene IP in Access ermitteln

Option Compare Database
Option Explicit

'IP-Adressen ermitteln  
Private Declare Function GetAdaptersInfo Lib "iphlpapi.dll" (pTcpTable As Any, pdwSize As Long) As Long  
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal dwLength As Long)  

Private Const MAX_ADAPTER_NAME_LENGTH         As Long = 256
Private Const MAX_ADAPTER_DESCRIPTION_LENGTH  As Long = 128
Private Const MAX_ADAPTER_ADDRESS_LENGTH      As Long = 8

Private Type IP_ADDRESS_STRING
    ipAddr(0 To 15)  As Byte
End Type

Private Type IP_MASK_STRING
    IpMask(0 To 15)  As Byte
End Type

Private Type IP_ADDR_STRING
    dwNext     As Long
    ipaddress  As IP_ADDRESS_STRING
    IpMask     As IP_MASK_STRING
    dwContext  As Long
End Type

Private Type IP_ADAPTER_INFO
  dwNext                As Long
  ComboIndex            As Long
  sAdapterName(0 To (MAX_ADAPTER_NAME_LENGTH + 3))        As Byte
  sDescription(0 To (MAX_ADAPTER_DESCRIPTION_LENGTH + 3)) As Byte
  dwAddressLength       As Long
  sIPAddress(0 To (MAX_ADAPTER_ADDRESS_LENGTH - 1))       As Byte
  dwIndex               As Long
  uType                 As Long
  uDhcpEnabled          As Long
  CurrentIpAddress      As Long
  IpAddressList         As IP_ADDR_STRING
  GatewayList           As IP_ADDR_STRING
  DhcpServer            As IP_ADDR_STRING
  bHaveWins             As Long
  PrimaryWinsServer     As IP_ADDR_STRING
  SecondaryWinsServer   As IP_ADDR_STRING
  LeaseObtained         As Long
  LeaseExpires          As Long
End Type

Private Function iperkennung() As String
On Error Resume Next
'für API-Aufrufe  
Dim cbRequired  As Long
Dim buff()      As Byte
Dim Adapter     As IP_ADAPTER_INFO
Dim AdapterStr  As IP_ADDR_STRING
'allgemeine Variablen  
Dim ptr1        As Long
Dim sIPAddr     As String
Dim sAllAddr    As String
   
Call GetAdaptersInfo(ByVal 0&, cbRequired)
If cbRequired > 0 Then
    ReDim buff(0 To cbRequired - 1) As Byte
    If GetAdaptersInfo(buff(0), cbRequired) = 0 Then
        'Zeiger (Pointer) zu den gespeicherten Daten (buff) ermitteln  
        ptr1 = VarPtr(buff(0))
        'ptr1 ist 0 wenn keine weiteren Adapter vorhanden sind  
        Do While (ptr1 <> 0)
            'aktuellen Zeiger auf Datenstrucktur (Adapter) zuweisen  
            CopyMemory Adapter, ByVal ptr1, LenB(Adapter)
            With Adapter
                'IP-Adresse des adapters auslesen  
                sIPAddr = TrimNull(StrConv(.IpAddressList.ipaddress.ipAddr, vbUnicode))
                'und Name des Adapters durch das Ascii-Zeichen 1 getrennt, anfügen  
                sAllAddr = sAllAddr & sIPAddr & Chr(1) & TrimNull(StrConv(.sDescription, vbUnicode)) & vbCrLf
                'Poiner auf nächsten Adapter setzen  
                ptr1 = .dwNext
            End With
        Loop
    End If
End If
MsgBox sIPAddr

'letzes vbcrlf entfernen, wenn Adapter gefunden wurden  
If Len(sAllAddr) > 0 Then sAllAddr = Left(sAllAddr, Len(sAllAddr) - 2)
'und Liste der Adapter mit ihren IP-Adressen ausgeben  
iperkennung = sAllAddr

End Function


Private Function TrimNull(ByVal str As String) As String
On Error Resume Next

TrimNull = Trim(Left(str, InStr(str, Chr(0)) - 1))
End Function


Private Sub cmdRefresh_Click()
'IP-Adressen incl. Adapter ermitteln  
'und das Ascii-Zeichen 1 durch das Trennzeichen " / " ersetzen  
txtIPs.Text = Replace(iperkennung, Chr(1), " / ")  
End Sub


Private Sub Form_Load()
'Anzeige aktualisieren  
Call cmdRefresh_Click
End Sub

End Function