Hallo Lars,
Den nachstehenden Code in ein Standardmodul eingeben, einer Schaltfläche zuweisen und starten.
StandardModule: Modul1
Private Declare Function WSAGetLastError Lib "WSOCK32.DLL" () _
As Long
Private Declare Function WSAStartup Lib "WSOCK32.DLL" (ByVal _
wVersionRequired&, lpWSAData As WinSocketDataType) _
As Long
Private Declare Function WSACleanup Lib "WSOCK32.DLL" () _
As Long
Private Declare Function gethostname Lib "WSOCK32.DLL" (ByVal _
HostName$, ByVal HostLen%) As Long
Private Declare Function gethostbyname Lib "WSOCK32.DLL" _
(ByVal HostName$) As Long
Private Declare Function gethostbyaddr Lib "WSOCK32.DLL" _
(ByVal addr$, ByVal laenge%, ByVal typ%) As Long
Private Declare Sub RtlMoveMemory Lib "kernel32" (hpvDest As _
Any, ByVal hpvSource&, ByVal cbCopy&)
Const WS_VERSION_REQD = &H101
Const SOCKET_ERROR = -1
Const WSADescription_Len = 256
Const WSASYS_Status_Len = 128
Private Type HostDeType
hName As Long
hAliases As Long
hAddrType As Integer
hLength As Integer
hAddrList As Long
End Type
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 Declare Function RasEnumConnections Lib "RasApi32.DLL" _
Alias "RasEnumConnectionsA" (lpRasCon As Any, lpcb As _
Long, lpcConnections As Long) As Long
Private Declare Function RasGetConnectStatus Lib "RasApi32.DLL" _
Alias "RasGetConnectStatusA" (ByVal hRasCon As Long, _
lpStatus As Any) As Long
Private Declare Function RasEnumEntries Lib "RasApi32.DLL" _
Alias "RasEnumEntriesA" (ByVal reserved$, ByVal _
lpszPhonebook$, lprasentryname As Any, lpcb As Long, _
lpcEntries As Long) As Long
Private Declare Function RasHangUp Lib "RasApi32.DLL" _
Alias "RasHangUpA" (ByVal hRasConn As Long) As Long
Const RAS_MaxEntryName = 256
Const RAS_MaxDeviceType = 16
Const RAS_MaxDeviceName = 32
Private Type RASType
dwSize As Long
hRasCon As Long
szEntryName(RAS_MaxEntryName) As Byte
szDeviceType(RAS_MaxDeviceType) As Byte
szDeviceName(RAS_MaxDeviceName) As Byte
End Type
Private Type RASStatusType
dwSize As Long
RasConnState As Long
dwError As Long
szDeviceType(RAS_MaxDeviceType) As Byte
szDeviceName(RAS_MaxDeviceName) As Byte
End Type
Private Type RASENTRYNAME95
dwSize As Long
szEntryName(RAS_MaxEntryName) As Byte
End Type
Dim DFÜName$
Sub AufrufDNS()
Dim sIP As String
sIP = InputBox("IP-Adresse:", , "212.227.119.87")
If sIP = "" Then Exit Sub
Call WWWAddress(sIP)
End Sub
Sub AufrufIP()
Dim sDNS As String
sDNS = InputBox("DNS-Adresse:", , "www.herber.de")
Call WWWAddress(sDNS)
End Sub
Sub WWWAddress(strAddress As String)
Dim X%
Dim IP$, DNS$, HOST$
If Not Online Then Exit Sub
Call InitSockets
If IsNumeric(Left(strAddress, 1)) Then
DNS = HostByAddress(strAddress)
IP = strAddress
Else
IP = HostByName(strAddress)
DNS = strAddress
End If
ActiveCell.Value = "DNS: " & DNS & " " & "IP: " & IP
Call CleanSockets
End Sub
Private Sub InitSockets()
Dim Result%
Dim LoBy%, HiBy%
Dim SocketData As WinSocketDataType
Result = WSAStartup(WS_VERSION_REQD, SocketData)
If Result <> 0 Then
MsgBox ("'winsock.dll' antwortet nicht !")
End
End If
End Sub
Private Function HostByName(Name$, Optional X% = 0) As String
Dim MemIp() As Byte
Dim Y%
Dim HostDeAddress&, HostIp&
Dim IPAddress$
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
End Function
Private Function DFÜStatus() As Boolean
Dim RAS(255) As RASType, RASStatus As RASStatusType
Dim lg&, lpcon&, Result&
RAS(0).dwSize = 412
lg = 256 * RAS(0).dwSize
Result = RasEnumConnections(RAS(0), lg, lpcon)
If lpcon = 0 Then
DFÜStatus = False
Else
RASStatus.dwSize = 160
Result = RasGetConnectStatus(RAS(0).hRasCon, RASStatus)
If RASStatus.RasConnState = &H2000 Then
DFÜStatus = True
Else
DFÜStatus = False
End If
End If
End Function
Private Function Online() As Boolean
Dim Test As Boolean
Test = DFÜStatus
If Test = False Then MsgBox _
("Keine Online Verbindung vorhanden ! Bitte einwählen !")
Online = Test
End Function
Private Function HostByAddress(ByVal Addresse$) As String
Dim X%
Dim HostDeAddress&
Dim aa$, BB As String * 5
Dim HOST As HostDeType
aa = Chr$(Val(NextChar(Addresse, ".")))
aa = aa + Chr$(Val(NextChar(Addresse, ".")))
aa = aa + Chr$(Val(NextChar(Addresse, ".")))
aa = aa + Chr$(Val(Addresse))
HostDeAddress = gethostbyaddr(aa, Len(aa), 2)
If HostDeAddress = 0 Then
HostByAddress = ""
Exit Function
End If
Call RtlMoveMemory(HOST, HostDeAddress, LenB(HOST))
aa = ""
X = 0
Do
Call RtlMoveMemory(ByVal BB, HOST.hName + X, 1)
If Left$(BB, 1) = Chr$(0) Then Exit Do
aa = aa + Left$(BB, 1)
X = X + 1
Loop
HostByAddress = aa
End Function
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 Sub CleanSockets()
Dim Result&
Result = WSACleanup()
If Result <> 0 Then
MsgBox ("Socket Error " & Trim$(Str$(Result)) & _
" in Prozedur 'CleanSockets' aufgetreten !")
End
End If
End Sub
Private Function NextChar(Text$, Char$) As String
Dim POS%
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
End Function
Gruß Tommy