Thema: DNS und IP abfragen

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

Beiträge aus dem Excel-Forum zu den Themen API und Internet