Const MAX_ADAPTER_NAME_LENGTH As Long = 256
Const MAX_ADAPTER_DESCRIPTION_LENGTH As Long = 128
Const MAX_ADAPTER_ADDRESS_LENGTH As Long = 8
Const ERROR_SUCCESS As Long = 0
Type IP_ADDRESS_STRING
IpAddr(0 To 15) As Byte
End Type
Type IP_MASK_STRING
IpMask(0 To 15) As Byte
End Type
Type IP_ADDR_STRING
dwNext As Long
IpAddress As IP_ADDRESS_STRING
IpMask As IP_MASK_STRING
dwContext As Long
End Type
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
Declare Function GetAdaptersInfo Lib "iphlpapi.dll" _
(pTcpTable As Any, _
pdwSize As Long) As Long
Declare Sub CopyMemory Lib "kernel32" Alias _
"RtlMoveMemory" _
(dst As Any, _
src As Any, _
ByVal bcount As Long)
Function LocalIPAddress() As String
Dim lRequired As Long
Dim btBuffer() As Byte
Dim uAdapter As IP_ADAPTER_INFO
' Dim AdapterStr As IP_ADDR_STRING
Dim lPtr As Long
Dim sIPAddr As String
Dim bFound As Boolean
Call GetAdaptersInfo(ByVal 0&, lRequired)
If lRequired > 0 Then
ReDim btBuffer(0 To lRequired - 1) As Byte
If GetAdaptersInfo(btBuffer(0), lRequired) = ERROR_SUCCESS Then
'// Pointer zu den Daten im btBuffer() Array ermitteln
lPtr = VarPtr(btBuffer(0))
Do While (lPtr <> 0) 'And (bFound = False)
'// Speicherdaten kopieren
CopyMemory uAdapter, ByVal lPtr, LenB(uAdapter)
With uAdapter
sIPAddr = _
TrimNull(StrConv(.IpAddressList.IpAddress.IpAddr, vbUnicode))
If Len(sIPAddr) > 0 Then
bFound = True
Exit Do
End If
lPtr = .dwNext
End With 'With uAdapter
Loop 'Do While (lPtr <> 0)
End If 'If GetAdaptersInfo
End If 'If lRequired > 0
LocalIPAddress = sIPAddr
End Function
Private Function TrimNull(sValue As String)
Dim iPos As Integer
iPos = InStr(sValue, Chr$(0))
If iPos Then
TrimNull = Left$(sValue, iPos - 1)
Else: TrimNull = sValue
End If
End Function
