|
Beispiel für das Auslesen der eigenen IP-Adresse.
Kann sehr nützlich sein, wenn für eine Anwendung ein Log geführt werden soll. Somit läßt sich der PC eindeutig identifizieren.
Option Explicit
Private Declare Function WSAGetLastError Lib "WSOCK32.DLL" () _
As Long
Private Declare Function WSAStartup Lib "WSOCK32.DLL" (ByVal _
wVersionRequired As Long, lpWSAData As WinSocketDataType) _
As Long
Private Declare Function WSACleanup Lib "WSOCK32.DLL" () _
As Long
Private Declare Function gethostname Lib "WSOCK32.DLL" (ByVal _
HostName As String, ByVal HostLen As Integer) As Long
Private Declare Function gethostbyname Lib "WSOCK32.DLL" _
(ByVal HostName As String) As Long
Private Declare Sub RtlMoveMemory Lib "kernel32" (hpvDest As _
Any, ByVal hpvSource As Long, ByVal cbCopy As Long)
Private Type HostDeType
hName As Long
hAliases As Long
hAddrType As Integer
hLength As Integer
hAddrList As Long
End Type
Const WS_VERSION_REQD As Long = &H101&
Const SOCKET_ERROR As Long = -1&
Const WSADESCRIPTION_LEN As Long = 256&
Const WSASYS_STATUS_LEN As Long = 128&
Private Type WinSocketDataType
wVersion As Integer
wHighVersion As Integer
szDescription(0 To WSADESCRIPTION_LEN) As Byte
szSystemStatus(0 To WSASYS_STATUS_LEN) As Byte
iMaxSockets As Integer
iMaxUdpDg As Integer
lpszVendorInfo As Long
End Type
Private strPCName As String
Private strPCIP As String
Private Sub GetIPs()
Dim IP As String, Host As String
Dim x As Integer
Call InitSocketAPI
Host = MyHostName
MsgBox (HostByName(Host, x))
Call CleanSockets
End Sub
Private Sub InitSocketAPI()
Dim Result As Integer
Dim SocketData As WinSocketDataType
Result = WSAStartup(WS_VERSION_REQD, SocketData)
If Result <> 0 Then
Call MsgBox("'winsock.dll' antwortet nicht !")
End
End If
End Sub
Private Function MyHostName() As String
Dim HostName As String * 256
If gethostname(HostName, 256) = SOCKET_ERROR Then
MsgBox "Windows Sockets error " & Str(WSAGetLastError())
Exit Function
Else
MyHostName = NextChar(Trim$(HostName), Chr$(0))
End If
End Function
Private Function HostByName(Name As String, Optional x As Integer = 0) As String
Dim MemIp() As Byte
Dim y As Integer
Dim HostDeAddress As Long, HostIp As Long
Dim IpAddress As String
Dim Host As HostDeType
HostDeAddress = gethostbyname(Name)
If HostDeAddress = 0 Then
HostByName = ""
Exit Function
End If
Call RtlMoveMemory(Host, HostDeAddress, LenB(Host))
For y = 0 To x
Call RtlMoveMemory(HostIp, Host.hAddrList + 4 * y, 4)
If HostIp = 0 Then
HostByName = ""
Exit Function
End If
Next y
ReDim MemIp(1 To Host.hLength)
Call RtlMoveMemory(MemIp(1), HostIp, Host.hLength)
IpAddress = ""
For y = 1 To Host.hLength
IpAddress = IpAddress & MemIp(y) & "."
Next y
IpAddress = Left$(IpAddress, Len(IpAddress) - 1)
HostByName = IpAddress
strPCIP = IpAddress
End Function
Private Sub CleanSockets()
Dim Result As Long
Result = WSACleanup()
If Result <> 0 Then
Call MsgBox("Socket Error " & Trim$(Str$(Result)) & _
" in Prozedur 'CleanSockets' aufgetreten !")
End
End If
End Sub
Private Function NextChar(Text As String, Char As String) As String
Dim pos As Integer
pos = InStr(1, Text, Char)
If pos = 0 Then
NextChar = Text
Text = ""
Else
NextChar = Left$(Text, pos - 1)
Text = Mid$(Text, pos + Len(Char))
End If
strPCName = NextChar
End Function
Eigene_IP-Adresse_anzeigen-VBA.zip
|
