Get Host - IP-Adressen lesen

Get Host - IP-Adressen lesen via WindowProc
Hostnamen & -Adressen via Internet einlesen
Private Const MAX_QUERY_COUNT As Long = 4
Private objQuery(1 To MAX_QUERY_COUNT) As clsQuery
Private lngNextIndex As Long
Private blnCancel As Boolean
Private Sub Form_Load()
Dim i As Long
For i = 1 To MAX_QUERY_COUNT
Set objQuery(i) = New clsQuery
Next i
Listview_AddItem "localhost"
Listview_AddItem "127.0.0.1"
Listview_AddItem "google.com"
Listview_AddItem "google.de"
Listview_AddItem "www.google.com"
Listview_AddItem "www.google.de"
Listview_AddItem "groups.google.com"
Listview_AddItem "groups.google.de"
Listview_AddItem "66.102.11.104"
Set lvwMain.SelectedItem = Nothing
End Sub
Private Sub Form_Unload(Cancel As Integer)
Dim i As Long
For i = 1 To MAX_QUERY_COUNT
Set objQuery(i) = Nothing
Next i
Set frmMain = Nothing
End Sub
Private Sub Form_SetCaption(strCaption As String)
If strCaption = "" Then
frmMain.Caption = "GetHostAsyn"
Else
frmMain.Caption = "GetHostAsyn (" & strCaption & ")"
End If
End Sub
'Listview
Private Sub lvwMain_DblClick()
Call cmdCopy_Click
End Sub
Private Sub lvwMain_ItemClick(ByVal Item As MSComctlLib.ListItem)
cmdCopy.Enabled = Item.ForeColor = RGB(0, 128, 0)
End Sub
Private Sub lvwMain_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
Select Case Button
Case vbLeftButton, vbRightButton
If lvwMain.HitTest(x, y) Is Nothing Then
If Not lvwMain.SelectedItem Is Nothing Then
lvwMain.SelectedItem.Selected = False
Set lvwMain.SelectedItem = Nothing
End If
End If
End Select
End Sub
Private Function Listview_AddItem(strHost As String) As Boolean
Dim itmX As ListItem
Dim sKey As String
On Error Resume Next
sKey = "HOST_" & strHost
Set itmX = lvwMain.ListItems.Add(, sKey, strHost)
If Err.Number = 0 Then
itmX.SubItems(colHostname) = "-"
itmX.SubItems(colAliases) = "-"
itmX.SubItems(colAddrType) = "-"
itmX.SubItems(colAddrLength) = "-"
itmX.SubItems(colAddrList) = "-"
itmX.Selected = False
Listview_AddItem = True
Else
MsgBox "Fehler " & CStr(Err.Number) & ": " & Err.Description, _
vbOKOnly Or vbExclamation
Err.Clear
Listview_AddItem = False
End If
End Function
'Buttons
Private Sub cmdQuery_Click()
Dim itmX As ListItem
For Each itmX In lvwMain.ListItems
itmX.Selected = False
itmX.ForeColor = vbBlack
itmX.ListSubItems(colHostname).ForeColor = vbBlack
itmX.SubItems(colHostname) = "-"
itmX.ListSubItems(colAliases).ForeColor = vbBlack
itmX.SubItems(colAliases) = "-"
itmX.ListSubItems(colAddrType).ForeColor = vbBlack
itmX.SubItems(colAddrType) = "-"
itmX.ListSubItems(colAddrLength).ForeColor = vbBlack
itmX.SubItems(colAddrLength) = "-"
itmX.ListSubItems(colAddrList).ForeColor = vbBlack
itmX.SubItems(colAddrList) = "-"
Next itmX
cmdQuery.Enabled = False
cmdCancel.Enabled = True
cmdCopy.Enabled = False
blnCancel = False
lngNextIndex = 1
tmrQuery.Enabled = True
End Sub
Private Sub cmdCancel_Click()
blnCancel = True
'
cmdCancel.Enabled = False
End Sub
Private Sub cmdCopy_Click()
Dim strClipboard As String
If Not lvwMain.SelectedItem Is Nothing Then
With lvwMain.SelectedItem
strClipboard = "HOSTENT.h_name = " & .SubItems(colHostname) & vbCrLf & _
"HOSTENT.h_aliases = " & .SubItems(colAliases) & vbCrLf & _
"HOSTENT.h_addrtype = " & .SubItems(colAddrType) & vbCrLf & _
"HOSTENT.h_length = " & .SubItems(colAddrLength) & vbCrLf & _
"HOSTENT.h_addr_list = " & .SubItems(colAddrList) & vbCrLf
Clipboard.SetText strClipboard, vbCFText
End With
End If
End Sub
'Timer
Private Sub tmrQuery_Timer()
Dim lngFreeIndex As Long
Dim lngInUse As Long
Dim i As Long
For i = 1 To MAX_QUERY_COUNT
If objQuery(i).InUse = True Then
lngInUse = lngInUse + 1
Else
If lngFreeIndex < 1 Then
lngFreeIndex = i
End If
End If
Next i
If ((lngNextIndex <= lvwMain.ListItems.Count) And (blnCancel = False)) Then
If lngFreeIndex > 0 Then
With lvwMain.ListItems(lngNextIndex)
.ForeColor = vbBlue
.ListSubItems(colHostname).ForeColor = vbBlue
.SubItems(colHostname) = "-"
.ListSubItems(colAliases).ForeColor = vbBlue
.SubItems(colAliases) = "-"
.ListSubItems(colAddrType).ForeColor = vbBlue
.SubItems(colAddrType) = "-"
.ListSubItems(colAddrLength).ForeColor = vbBlue
.SubItems(colAddrLength) = "-"
.ListSubItems(colAddrList).ForeColor = vbBlue
.SubItems(colAddrList) = "-"
.EnsureVisible
objQuery(lngFreeIndex).GetHostInfo .Text
End With
lngNextIndex = lngNextIndex + 1
lngInUse = lngInUse + 1
End If
Form_SetCaption CStr(lngInUse) & " von " & CStr(MAX_QUERY_COUNT) & " Abfragen aktiv"
Else
If lngInUse < 1 Then
tmrQuery.Enabled = False
cmdQuery.Enabled = True
cmdCancel.Enabled = False
Form_SetCaption IIf(blnCancel, "Abgebrochen", "Fertig")
Else
Form_SetCaption IIf(blnCancel, "Abbrechen", "Beende") & "; " & _
CStr(lngInUse) & " von " & CStr(MAX_QUERY_COUNT) & " Abfragen aktiv"
End If
End If
End Sub
Das steht im Modul:
Public colHost As New Collection ' collection of clsHost classes
Public lngResolveMessage As Long ' WindowProc resolve message
Public blnWinsockInit As Boolean ' is winsock already initialized ?
'WindowProc
Public Function WindowProc(ByVal hWnd As Long, ByVal uMsg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long
Dim objHost As clsHost
Debug.Print "hWnd = " & CStr(hWnd) & String$(12 - Len(CStr(hWnd)), " ") & _
" (0x" & Right$(String$(8, "0") & UCase$(Hex$(hWnd)), 8) & ")"
Debug.Print "uMsg = " & CStr(uMsg) & String$(12 - Len(CStr(uMsg)), " ") & _
" (0x" & Right$(String$(8, "0") & UCase$(Hex$(uMsg)), 8) & ")"
Debug.Print "wParam = " & CStr(wParam) & String$(12 - Len(CStr(wParam)), " ") & _
" (0x" & Right$(String$(8, "0") & UCase$(Hex$(wParam)), 8) & ")"
Debug.Print "lParam = " & CStr(lParam) & String$(12 - Len(CStr(lParam)), " ") & _
" (0x" & Right$(String$(8, "0") & UCase$(Hex$(lParam)), 8) & ")"
Debug.Print "----------------------------------------------------------------------------"
On Error Resume Next
Set objHost = colHost("HWND_" & CStr(hWnd))
If Not objHost Is Nothing Then
WindowProc = objHost.IncommingMessage(hWnd, uMsg, wParam, lParam)
Else
WindowProc = 0
End If
End Function
Das steht im Klassenmodul clsHost
'Memory Management Functions
Private Declare Function GlobalAlloc Lib "kernel32" _
(ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
'Message and Message Queue Functions
Private Declare Function RegisterWindowMessage Lib "user32" _
Alias "RegisterWindowMessageA" (ByVal lpString As String) As Long
'Runtime Library Routines
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(Destination As Any, ByVal Source As Long, ByVal Length As Long)
'String Manipulation Functions
Private Declare Function lstrcpy Lib "kernel32" Alias "lstrcpyA" _
(ByVal lpString1 As String, ByVal lpString2 As Long) As Long
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" _
(ByVal lpString As Any) As Long
'Socket Functions
Private Declare Function inet_addr Lib "ws2_32" (ByVal cp As String) As Long
Private Declare Function inet_ntoa Lib "ws2_32" (ByVal inn As Long) As Long
Private Declare Function WSAAsyncGetHostByAddr Lib "ws2_32" _
(ByVal hWnd As Long, ByVal wMsg As Long, ByRef lngAddr As Long, _
ByVal lngLenght As Long, ByVal lngType As Long, buf As Any, _
ByVal lngBufLen As Long) As Long
Private Declare Function WSAAsyncGetHostByName Lib "ws2_32" (ByVal hWnd As Long, _
ByVal wMsg As Long, ByVal strHostname As String, buf As Any, ByVal buflen As Long) As Long
Private Declare Function WSACleanup Lib "ws2_32" () As Long
Private Declare Function WSAStartup Lib "ws2_32" (ByVal wVersionRequested As Long, _
lpWsaData As WSADATA) As Long
'Window Functions
Private Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" _
(ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, _
ByVal dwStyle As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, _
ByVal nHeight As Long, ByVal hWndParent As Long, ByVal hMenu As Long, _
ByVal hInstance As Long, lpParam As Any) As Long
Private Declare Function DestroyWindow Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
(ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
'Window Procedure Functions
Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" _
(ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal uMsg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long
'Events
Public Event HostResolved(ByVal Hostname As String, ByRef Aliases() As String, _
ByVal AddrType As String, ByVal AddrLength As Long, ByRef AddrList() As String)
Public Event Error(ByVal Number As Integer, Description As String, ByVal Source As String)
'Const
Private Const CLASS_NAME As String = "clsHost" ' name of this class
Private Const WSABASEERR As Long = 10000 ' Winsock Base Error
'Windows Sockets definitions of regular Microsoft C error constants
Private Const WSAEINTR As Long = (WSABASEERR + 4)
Private Const WSAEBADF As Long = (WSABASEERR + 9) '
Private Const WSAEACCES As Long = (WSABASEERR + 13) '
Private Const WSAEFAULT As Long = (WSABASEERR + 14) '
Private Const WSAEINVAL As Long = (WSABASEERR + 22) '
Private Const WSAEMFILE As Long = (WSABASEERR + 24) '
'Windows Sockets definitions of regular Berkeley error constants
Private Const WSAEWOULDBLOCK As Long = (WSABASEERR + 35)
Private Const WSAEINPROGRESS As Long = (WSABASEERR + 36) '
Private Const WSAEALREADY As Long = (WSABASEERR + 37) '
Private Const WSAENOTSOCK As Long = (WSABASEERR + 38) '
Private Const WSAEDESTADDRREQ As Long = (WSABASEERR + 39) '
Private Const WSAEMSGSIZE As Long = (WSABASEERR + 40) '
Private Const WSAEPROTOTYPE As Long = (WSABASEERR + 41) '
Private Const WSAENOPROTOOPT As Long = (WSABASEERR + 42) '
Private Const WSAEPROTONOSUPPORT As Long = (WSABASEERR + 43) '
Private Const WSAESOCKTNOSUPPORT As Long = (WSABASEERR + 44) '
Private Const WSAEOPNOTSUPP As Long = (WSABASEERR + 45) '
Private Const WSAEPFNOSUPPORT As Long = (WSABASEERR + 46) '
Private Const WSAEAFNOSUPPORT As Long = (WSABASEERR + 47) '
Private Const WSAEADDRINUSE As Long = (WSABASEERR + 48) '
Private Const WSAEADDRNOTAVAIL As Long = (WSABASEERR + 49) '
Private Const WSAENETDOWN As Long = (WSABASEERR + 50) '
Private Const WSAENETUNREACH As Long = (WSABASEERR + 51) '
Private Const WSAENETRESET As Long = (WSABASEERR + 52) '
Private Const WSAECONNABORTED As Long = (WSABASEERR + 53) '
Private Const WSAECONNRESET As Long = (WSABASEERR + 54) '
Private Const WSAENOBUFS As Long = (WSABASEERR + 55) '
Private Const WSAEISCONN As Long = (WSABASEERR + 56) '
Private Const WSAENOTCONN As Long = (WSABASEERR + 57) '
Private Const WSAESHUTDOWN As Long = (WSABASEERR + 58) '
Private Const WSAETOOMANYREFS As Long = (WSABASEERR + 59) '
Private Const WSAETIMEDOUT As Long = (WSABASEERR + 60) '
Private Const WSAECONNREFUSED As Long = (WSABASEERR + 61) '
Private Const WSAELOOP As Long = (WSABASEERR + 62) '
Private Const WSAENAMETOOLONG As Long = (WSABASEERR + 63) '
Private Const WSAEHOSTDOWN As Long = (WSABASEERR + 64) '
Private Const WSAEHOSTUNREACH As Long = (WSABASEERR + 65) '
Private Const WSAENOTEMPTY As Long = (WSABASEERR + 66) '
Private Const WSAEPROCLIM As Long = (WSABASEERR + 67) '
Private Const WSAEUSERS As Long = (WSABASEERR + 68) '
Private Const WSAEDQUOT As Long = (WSABASEERR + 69) '
Private Const WSAESTALE As Long = (WSABASEERR + 70) '
Private Const WSAEREMOTE As Long = (WSABASEERR + 71) '
'Extended Windows Sockets error constant definitions
Private Const WSASYSNOTREADY As Long = (WSABASEERR + 91)
Private Const WSAVERNOTSUPPORTED As Long = (WSABASEERR + 92) '
Private Const WSANOTINITIALISED As Long = (WSABASEERR + 93) '
Private Const WSAEDISCON As Long = (WSABASEERR + 101) '
Private Const WSAENOMORE As Long = (WSABASEERR + 102) '
Private Const WSAECANCELLED As Long = (WSABASEERR + 103) '
Private Const WSAEINVALIDPROCTABLE As Long = (WSABASEERR + 104) '
Private Const WSAEINVALIDPROVIDER As Long = (WSABASEERR + 105) '
Private Const WSAEPROVIDERFAILEDINIT As Long = (WSABASEERR + 106) '
Private Const WSASYSCALLFAILURE As Long = (WSABASEERR + 107) '
Private Const WSASERVICE_NOT_FOUND As Long = (WSABASEERR + 108) '
Private Const WSATYPE_NOT_FOUND As Long = (WSABASEERR + 109) '
Private Const WSA_E_NO_MORE As Long = (WSABASEERR + 110) '
Private Const WSA_E_CANCELLED As Long = (WSABASEERR + 111) '
Private Const WSAEREFUSED As Long = (WSABASEERR + 112) '
Private Const WSAHOST_NOT_FOUND As Long = (WSABASEERR + 1001) ' Authoritative Answer: Host not found
Private Const WSATRY_AGAIN As Long = (WSABASEERR + 1002) ' Non-Authoritative: Host not found, or SERVERFAIL
Private Const WSANO_RECOVERY As Long = (WSABASEERR + 1003) ' Non recoverable errors, FORMERR, REFUSED, NOTIMP
Private Const WSANO_DATA As Long = (WSABASEERR + 1004) ' Valid name, no data record of requested type
Private Const AF_UNSPEC As Long = 0 ' unspecified
Private Const AF_UNIX As Long = 1 ' local to host (pipes, portals)
Private Const AF_INET As Long = 2 ' internetwork: UDP, TCP, etc.
Private Const AF_IMPLINK As Long = 3 ' arpanet imp addresses
Private Const AF_PUP As Long = 4 ' pup protocols: e.g. BSP
Private Const AF_CHAOS As Long = 5 ' mit CHAOS protocols
Private Const AF_NS As Long = 6 ' XEROX NS protocols
Private Const AF_IPX As Long = AF_NS ' IPX protocols: IPX, SPX, etc.
Private Const AF_ISO As Long = 7 ' ISO protocols
Private Const AF_OSI As Long = AF_ISO ' OSI is ISO
Private Const AF_ECMA As Long = 8 ' european computer manufacturers
Private Const AF_DATAKIT As Long = 9 ' datakit protocols
Private Const AF_CCITT As Long = 10 ' CCITT protocols, X.25 etc
Private Const AF_SNA As Long = 11 ' IBM SNA
Private Const AF_DECnet As Long = 12 ' DECnet
Private Const AF_DLI As Long = 13 ' Direct data link interface
Private Const AF_LAT As Long = 14 ' LAT
Private Const AF_HYLINK As Long = 15 ' NSC Hyperchannel
Private Const AF_APPLETALK As Long = 16 ' AppleTalk
Private Const AF_NETBIOS As Long = 17 ' NetBios-style addresses
Private Const AF_VOICEVIEW As Long = 18 ' VoiceView
Private Const AF_FIREFOX As Long = 19 ' Protocols from Firefox
Private Const AF_UNKNOWN1 As Long = 20 ' Somebody is using this!
Private Const AF_BAN As Long = 21 ' Banyan
Private Const AF_ATM As Long = 22 ' Native ATM Services
Private Const AF_INET6 As Long = 23 ' Internetwork Version 6
Private Const AF_CLUSTER As Long = 24 ' Microsoft Wolfpack
Private Const AF_12844 As Long = 25 ' IEEE 1284.4 WG AF
Private Const WS_VERSION_MINOR As Long = &H1& '
Private Const WS_VERSION_MAJOR As Long = &H100& '
Private Const WS_VERSION_REQD As Long = WS_VERSION_MINOR Or WS_VERSION_MAJOR
Private Const WSADESCRIPTION_LEN As Long = 256 ' WSADATA.szDescription length
Private Const WSASYS_STATUS_LEN As Long = 128 ' WSADATA.szSystemStatus length
Private Const MAXGETHOSTSTRUCT As Long = 1024 ' Define constant based on rfc883, used by gethostbyxxxx() calls
Private Const INADDR_NONE As Long = &HFFFFFFFF '
Private Const GMEM_FIXED As Long = &H0 ' Allocates fixed memory. The return value is a pointer
Private Const GWL_WNDPROC As Long = &HFFFFFFFC ' Sets a new address for the window procedure
'Types
Private Type WSADATA
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
lpVendorInfo As Long
End Type
Private Type HOSTENT
h_name As Long
h_aliases As Long
h_addrtype As Integer
h_length As Integer
h_addr_list As Long
End Type
'Variables
Private lngWindowHandle As Long ' socket window handle
Private lngOldWindowProc As Long ' old WindowProc
Private lngRequestID As Long ' WSAAsyncGetHostBy Addr/Name requets id
Private lngMemoryHandle As Long ' handle of the allocated memory block object
Private lngMemoryPointer As Long ' address of the memory block
'Class
Private Sub Class_Initialize()
If modWinsock.blnWinsockInit = False Then
Dim lpWsaData As WSADATA
Dim lngReturn As Long
'
lngReturn = WSAStartup(WS_VERSION_REQD, lpWsaData)
If lngReturn = 0 Then
If modWinsock.lngResolveMessage = 0 Then
modWinsock.lngResolveMessage = RegisterWindowMessage("WSA.ResolveMessage")
Debug.Print "WSADATA.wVersion = " & Format(HiByte(lpWsaData.wVersion), "####0") & _
"." & Format(LoByte(lpWsaData.wVersion), "####0")
Debug.Print "WSADATA.wHighVersion = " & Format(HiByte(lpWsaData.wHighVersion), "####0") & _
"." & Format(LoByte(lpWsaData.wHighVersion), "####0")
Debug.Print "WSADATA.szDescription = " & StripNull(StrConv(lpWsaData.szDescription(), vbUnicode))
Debug.Print "WSADATA.szSystemStatus = " & StripNull(StrConv(lpWsaData.szSystemStatus(), vbUnicode))
Debug.Print "WSADATA.iMaxSockets = " & Format(lpWsaData.iMaxSockets, "###,###,###,##0")
Debug.Print "WSADATA.iMaxUdpDg = " & Format(lpWsaData.iMaxUdpDg And &HFF&, "###,###,###,##0")
Debug.Print "WSADATA.lpVendorInfo = " & Format(lpWsaData.lpVendorInfo, "###,###,###,##0")
Debug.Print "----------------------------------------------------------------------------"
Debug.Print "modWinsock.lngResolveMessage = " & CStr(modWinsock.lngResolveMessage)
Debug.Print "----------------------------------------------------------------------------"
End If
modWinsock.blnWinsockInit = True
Else
Err.Raise 2001, CLASS_NAME, "Die Funktion WSAStartup() ist fehlgeschlagen."
Exit Sub
End If
End If
If modWinsock.blnWinsockInit = True Then
lngWindowHandle = CreateWindowEx(0&, "STATIC", "SOCKET_WINDOW", _
0&, 0&, 0&, 0&, 0&, 0&, 0&, App.hInstance, ByVal 0&)
Debug.Print "lngWindowHandle = " & CStr(lngWindowHandle)
If lngWindowHandle = 0 Then
Err.Raise 2002, CLASS_NAME, "Die Funktion CreateWindowEx() ist fehlgeschlagen."
Exit Sub
End If
lngOldWindowProc = SetWindowLong(lngWindowHandle, GWL_WNDPROC, AddressOf modWinsock.WindowProc)
Debug.Print "lngOldWindowProc = " & CStr(lngOldWindowProc)
Debug.Print "----------------------------------------------------------------------------"
If lngOldWindowProc = 0 Then
Err.Raise 2003, CLASS_NAME, "Die Funktion SetWindowLong() ist fehlgeschlagen."
Exit Sub
End If
End If
modWinsock.colHost.Add Me, "HWND_" & CStr(lngWindowHandle)
End Sub
Private Sub Class_Terminate()
Dim lngReturn As Long
Dim i As Long
If lngWindowHandle <> 0 Then
If lngOldWindowProc <> 0 Then
lngReturn = SetWindowLong(lngWindowHandle, GWL_WNDPROC, lngOldWindowProc)
lngOldWindowProc = 0
End If
lngReturn = DestroyWindow(lngWindowHandle)
lngWindowHandle = 0
End If
For i = 1 To modWinsock.colHost.Count
If modWinsock.colHost(i) Is Me Then
modWinsock.colHost.Remove i
Exit For
End If
Next i
If ((modWinsock.blnWinsockInit = True) And (modWinsock.colHost.Count = 0)) Then
lngReturn = WSACleanup()
modWinsock.blnWinsockInit = False
End If
End Sub
'GetHostInfo
Public Sub GetHostInfo(HostnameOrIP As String)
Dim lngAddr As Long
lngMemoryHandle = GlobalAlloc(GMEM_FIXED, MAXGETHOSTSTRUCT)
If lngMemoryHandle > 0 Then
lngMemoryPointer = GlobalLock(lngMemoryHandle)
If lngMemoryPointer <> 0 Then 'Unlock the memory block
GlobalUnlock (lngMemoryHandle)
Else 'Memory allocation error
Call GlobalFree(lngMemoryHandle)
Err.Raise 2005, CLASS_NAME, "Die Funktion GlobalLock() ist fehlgeschlagen."
Exit Sub
End If
Else 'Memory allocation error
Err.Raise 2004, CLASS_NAME, "Die Funktion GlobalAlloc() ist fehlgeschlagen."
Exit Sub
End If
lngAddr = inet_addr(HostnameOrIP)
If lngAddr = INADDR_NONE Then
lngRequestID = WSAAsyncGetHostByName(lngWindowHandle, modWinsock.lngResolveMessage, _
HostnameOrIP, ByVal lngMemoryPointer, MAXGETHOSTSTRUCT)
Else
lngRequestID = WSAAsyncGetHostByAddr(lngWindowHandle, modWinsock.lngResolveMessage, _
lngAddr, 4&, AF_INET, ByVal lngMemoryPointer, MAXGETHOSTSTRUCT)
End If
Debug.Print "lngRequestID = " & CStr(lngRequestID)
Debug.Print "----------------------------------------------------------------------------"
End Sub
'Incoming Message
Public Function IncommingMessage(ByVal hWnd As Long, ByVal uMsg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long
Dim udtHostent As HOSTENT ' HOSTENT struct
Dim strHostname As String ' resolved hostname
Dim strAddrType As String ' address type
Dim lngAddrLength As Long ' address length
Dim strAliases() As String ' list of alternate hostnames (if any)
Dim lngAliasesCount As Long ' count of alternate hostnames
Dim lngAliasesPtr As Long ' pointer to an alternate hostname
Dim strAddrList() As String ' list of ip addresses for the host
Dim lngAddrListCount As Long ' count of ip addresses for the host
Dim lngAddrListPtr As Long ' pointer to an array of pointers with ip addresses for the host
Dim strAddr As String ' a address
Dim lngAddr As Long ' a address
Dim lngAddrPtr As Long ' a address pointer
Dim lngErrorCode As Long ' winsock error code
Select Case uMsg ' which message did we get
Case modWinsock.lngResolveMessage ' host resolved message ?
lngErrorCode = HiWord(lParam) ' get the error code
If lngErrorCode = 0 Then ' no error :)
lngMemoryPointer = GlobalLock(lngMemoryHandle) ' lock the memory an get a pointer to the first byte
Call CopyMemory(udtHostent, lngMemoryPointer, _
LenB(udtHostent)) ' fill the hostent struct with the memory
strHostname = StrFromPtr(udtHostent.h_name) ' get the hostname from string pointer
strAddrType = GetAddressType(udtHostent.h_addrtype) ' get the address type
lngAddrLength = udtHostent.h_length ' get the address length
Do
Call CopyMemory(lngAliasesPtr, udtHostent.h_aliases, 4) ' get the pointer to the next alias name
If lngAliasesPtr <> 0 Then ' did we get a address ?
lngAliasesCount = lngAliasesCount + 1 ' increase alias count
ReDim Preserve strAliases(1 To lngAliasesCount) ' redim aliases array
strAliases(lngAliasesCount) = StrFromPtr(lngAliasesPtr) ' get the alias from string pointer and add it to the array
udtHostent.h_aliases = udtHostent.h_aliases + 4 ' address for the next pointer
End If
Loop While (lngAliasesPtr <> 0) ' loop while we get a pointer to an alias hostname
If lngAliasesCount < 1 Then ' no alias hostnames ?
ReDim strAliases(0 To 0) ' empty alias list (ubound = 0)
End If
If udtHostent.h_addrtype = AF_INET Then ' if address type is AF_INET
Do
Call CopyMemory(lngAddrListPtr, udtHostent.h_addr_list, 4) ' get the pointer to the next ip address
If lngAddrListPtr <> 0 Then ' did we get a address ?
Call CopyMemory(lngAddr, lngAddrListPtr, udtHostent.h_length) ' get the long ip addr from pointer
lngAddrPtr = inet_ntoa(lngAddr) ' get the pointer to the string ip address
strAddr = StrFromPtr(lngAddrPtr) ' get the ip address from string pointer
lngAddrListCount = lngAddrListCount + 1 ' increase the address count
ReDim Preserve strAddrList(1 To lngAddrListCount) ' redim the address list
strAddrList(lngAddrListCount) = strAddr ' add the string ip address to the array
udtHostent.h_addr_list = udtHostent.h_addr_list + 4 ' address for the next pointer
End If
Loop While (lngAddrListPtr <> 0)
Else
lngAddrListCount = 1
ReDim strAddrList(1 To lngAddrListCount)
strAddrList(lngAddrListCount) = "Not an IP host!"
End If
If lngAddrListCount < 1 Then ' no addresses ?
ReDim strAddrList(0 To 0) ' empty address list (ubound = 0)
End If
'Debug.Print "udtHostent.h_name = " & CStr(udtHostent.h_name) & " (" & strHostname & ")"
'Debug.Print "udtHostent.h_aliases = " & CStr(udtHostent.h_aliases) & " (" & Join(strAliases(), "; ") & ")"
'Debug.Print "udtHostent.h_addrtype = " & CStr(udtHostent.h_addrtype) & " (" & strAddrType & ")"
'Debug.Print "udtHostent.h_length = " & CStr(udtHostent.h_length)
'Debug.Print "udtHostent.h_addr_list = " & CStr(udtHostent.h_addr_list) & " (" & Join(strAddrList(), "; ") & ")"
'Debug.Print ""
Call GlobalUnlock(lngMemoryHandle) ' unlock the memory
Call GlobalFree(lngMemoryHandle) ' free the memory
RaiseEvent HostResolved(strHostname, strAliases(), strAddrType, _
lngAddrLength, strAddrList()) ' raise the host resolved event
Else
Call GlobalUnlock(lngMemoryHandle) ' unlock the memory
Call GlobalFree(lngMemoryHandle) ' free the memory
RaiseEvent Error(lngErrorCode, GetErrorDescription(lngErrorCode), CLASS_NAME) ' raise the host resolved event
End If
IncommingMessage = 0
Case Else
IncommingMessage = CallWindowProc(lngOldWindowProc, hWnd, uMsg, wParam, lParam)
End Select
End Function
'Helper
Private Function GetAddressType(ByVal lngAddrType As Long) As String
Dim strAddrType As String
Select Case lngAddrType
Case AF_UNSPEC: strAddrType = "AF_UNSPEC"
Case AF_UNIX: strAddrType = "AF_UNIX"
Case AF_INET: strAddrType = "AF_INET"
Case AF_IMPLINK: strAddrType = "AF_IMPLINK"
Case AF_PUP: strAddrType = "AF_PUP"
Case AF_CHAOS: strAddrType = "AF_CHAOS"
Case AF_NS: strAddrType = "AF_NS"
Case AF_IPX: strAddrType = "AF_IPX"
Case AF_ISO: strAddrType = "AF_ISO"
Case AF_OSI: strAddrType = "AF_OSI"
Case AF_ECMA: strAddrType = "AF_ECMA"
Case AF_DATAKIT: strAddrType = "AF_DATAKIT"
Case AF_CCITT: strAddrType = "AF_CCITT"
Case AF_SNA: strAddrType = "AF_SNA"
Case AF_DECnet: strAddrType = "AF_DECnet"
Case AF_DLI: strAddrType = "AF_DLI"
Case AF_LAT: strAddrType = "AF_LAT"
Case AF_HYLINK: strAddrType = "AF_HYLINK"
Case AF_APPLETALK: strAddrType = "AF_APPLETALK"
Case AF_NETBIOS: strAddrType = "AF_NETBIOS"
Case AF_VOICEVIEW: strAddrType = "AF_VOICEVIEW"
Case AF_FIREFOX: strAddrType = "AF_FIREFOX"
Case AF_UNKNOWN1: strAddrType = "AF_UNKNOWN1"
Case AF_BAN: strAddrType = "AF_BAN"
Case AF_ATM: strAddrType = "AF_ATM"
Case AF_INET6: strAddrType = "AF_INET6"
Case AF_CLUSTER: strAddrType = "AF_CLUSTER"
Case AF_12844: strAddrType = "AF_12844"
Case Else: strAddrType = "Unknown"
End Select
GetAddressType = strAddrType
End Function
Private Function GetErrorDescription(ByVal lngErrorCode As Long) As String
Dim strDesc As String
Select Case lngErrorCode
Case WSAEACCES: strDesc = "Permission denied."
Case WSAEADDRINUSE: strDesc = "Address already in use."
Case WSAEADDRNOTAVAIL: strDesc = "Cannot assign requested address."
Case WSAEAFNOSUPPORT: strDesc = "Address family not supported by protocol family."
Case WSAEALREADY: strDesc = "Operation already in progress."
Case WSAECONNABORTED: strDesc = "Software caused connection abort."
Case WSAECONNREFUSED: strDesc = "Connection refused."
Case WSAECONNRESET: strDesc = "Connection reset by peer."
Case WSAEDESTADDRREQ: strDesc = "Destination address required."
Case WSAEFAULT: strDesc = "Bad address."
Case WSAEHOSTDOWN: strDesc = "Host is down."
Case WSAEHOSTUNREACH: strDesc = "No route to host."
Case WSAEINPROGRESS: strDesc = "Operation now in progress."
Case WSAEINTR: strDesc = "Interrupted function call."
Case WSAEINVAL: strDesc = "Invalid argument."
Case WSAEISCONN: strDesc = "Socket is already connected."
Case WSAEMFILE: strDesc = "Too many open files."
Case WSAEMSGSIZE: strDesc = "Message too long."
Case WSAENETDOWN: strDesc = "Network is down."
Case WSAENETRESET: strDesc = "Network dropped connection on reset."
Case WSAENETUNREACH: strDesc = "Network is unreachable."
Case WSAENOBUFS: strDesc = "No buffer space available."
Case WSAENOPROTOOPT: strDesc = "Bad protocol option."
Case WSAENOTCONN: strDesc = "Socket is not connected."
Case WSAENOTSOCK: strDesc = "Socket operation on nonsocket."
Case WSAEOPNOTSUPP: strDesc = "Operation not supported."
Case WSAEPFNOSUPPORT: strDesc = "Protocol family not supported."
Case WSAEPROCLIM: strDesc = "Too many processes."
Case WSAEPROTONOSUPPORT: strDesc = "Protocol not supported."
Case WSAEPROTOTYPE: strDesc = "Protocol wrong type for socket."
Case WSAESHUTDOWN: strDesc = "Cannot send after socket shutdown."
Case WSAESOCKTNOSUPPORT: strDesc = "Socket type not supported."
Case WSAETIMEDOUT: strDesc = "Connection timed out."
Case WSATYPE_NOT_FOUND: strDesc = "Class type not found."
Case WSAEWOULDBLOCK: strDesc = "Resource temporarily unavailable."
Case WSAHOST_NOT_FOUND: strDesc = "Host not found."
Case WSANOTINITIALISED: strDesc = "Successful WSAStartup not yet performed."
Case WSANO_DATA: strDesc = "Valid name, no data record of requested type."
Case WSANO_RECOVERY: strDesc = "This is a nonrecoverable error."
Case WSASYSCALLFAILURE: strDesc = "System call failure."
Case WSASYSNOTREADY: strDesc = "Network subsystem is unavailable."
Case WSATRY_AGAIN: strDesc = "Nonauthoritative host not found."
Case WSAVERNOTSUPPORTED: strDesc = "Winsock.dll version out of range."
Case WSAEDISCON: strDesc = "Graceful shutdown in progress."
Case Else: strDesc = "Unknown error."
End Select
GetErrorDescription = strDesc
End Function
Private Function StrFromPtr(ptr As Long) As String
Dim sBuff As String
Dim lSize As Long
Dim lRet As Long
lSize = lstrlen(ptr)
If lSize > 0 Then
sBuff = String$(lSize, vbNullChar)
lRet = lstrcpy(sBuff, ptr)
If lRet <> 0 Then
StrFromPtr = sBuff
End If
End If
End Function
Private Function StripNull(sData As String)
Dim lPos As Long
lPos = InStr(sData, vbNullChar)
If lPos > 0 Then
StripNull = Left$(sData, lPos - 1)
Else
StripNull = sData
End If
End Function
Private Function LoWord(lngValue As Long) As Long
LoWord = (lngValue And &HFFFF&)
End Function
Private Function HiWord(lngValue As Long) As Long
If (lngValue And &H80000000) = &H80000000 Then
HiWord = ((lngValue And &H7FFF0000) \ &H10000) Or &H8000&
Else
HiWord = (lngValue And &HFFFF0000) \ &H10000
End If
End Function
Private Function LoByte(ByVal wParam As Integer)
LoByte = wParam And &HFF
End Function
Private Function HiByte(ByVal wParam As Integer)
'HiByte = wParam \ &H100 And &HFF&
HiByte = (wParam And &HFF00) / &H100
End Function
Klassenmodul clsQuery
'Enums
Public Enum LISTVIEW_COLUMN
colHost
colHostname
colAliases
colAddrType
colAddrLength
colAddrList
End Enum
'Variables
Private WithEvents objHost As clsHost
Private strHost As String
Private blnInUse As Boolean
'Property Host
Private Property Get Host() As String
Host = strHost
End Property
Private Property Let Host(strNewHost As String)
strHost = strNewHost
End Property
'Property In Use
Public Property Get InUse() As Boolean
InUse = blnInUse
End Property
Private Property Let InUse(blnNewInUse As Boolean)
blnInUse = blnNewInUse
End Property
'Class
Private Sub Class_Initialize()
Set objHost = New clsHost
End Sub
Private Sub Class_Terminate()
Set objHost = Nothing
End Sub
Public Sub GetHostInfo(HostnameOrIP As String)
Host = HostnameOrIP
InUse = True
objHost.GetHostInfo HostnameOrIP
End Sub
'Events
Private Sub objHost_HostResolved(ByVal Hostname As String, ByRef Aliases() As String, _
ByVal AddrType As String, ByVal AddrLength As Long, ByRef AddrList() As String)
Dim sKey As String
Dim lCol As Long
Debug.Print "Results for " & Host & ":"
Debug.Print String$(Len("Results for " & Host & ":"), "")
Debug.Print "HOSTENT.h_name = " & Hostname ' Hostname aus der HOSTENT Struktur
Debug.Print "HOSTENT.h_aliases = " & Join(Aliases(), "; ") ' Alias Hostnamen aus der HOSTENT Struktur
Debug.Print "HOSTENT.h_addrtype = " & AddrType ' Address Type
Debug.Print "HOSTENT.h_length = " & CStr(AddrLength) ' Länge jeder Adresse in der Address List
Debug.Print "HOSTENT.h_addr_list = " & Join(AddrList(), "; ") ' IP Address List aus der HOSTENT Struktur
Debug.Print "----------------------------------------------------------------------------"
sKey = "HOST_" & Host
lCol = RGB(0, 128, 0)
With frmMain.lvwMain.ListItems(sKey)
.ForeColor = lCol
.ListSubItems(colHostname).ForeColor = lCol
.SubItems(colHostname) = Hostname
.ListSubItems(colAliases).ForeColor = lCol
.SubItems(colAliases) = Join(Aliases(), "; ")
.ListSubItems(colAddrType).ForeColor = lCol
.SubItems(colAddrType) = AddrType
.ListSubItems(colAddrLength).ForeColor = lCol
.SubItems(colAddrLength) = CStr(AddrLength)
.ListSubItems(colAddrList).ForeColor = lCol
.SubItems(colAddrList) = Join(AddrList(), "; ")
End With
InUse = False
Host = vbNullString
End Sub
Private Sub objHost_Error(ByVal Number As Integer, Description As String, ByVal Source As String)
Dim sKey As String
Dim lCol As Long
Debug.Print "Results for " & Host & ":"
Debug.Print String$(Len("Results for " & Host & ":"), "")
Debug.Print "Err.Number = " & CStr(Number)
Debug.Print "Err.Description = " & Description
Debug.Print "Err.Source = " & Source
Debug.Print "----------------------------------------------------------------------------"
sKey = "HOST_" & Host
lCol = RGB(255, 0, 0)
With frmMain.lvwMain.ListItems(sKey)
.ForeColor = lCol
.ListSubItems(colHostname).ForeColor = lCol
.SubItems(colHostname) = "Fehler " & CStr(Number) & ": " & Description & " (Source: " & Source & ")"
.ListSubItems(colAliases).ForeColor = lCol
.SubItems(colAliases) = ""
.ListSubItems(colAddrType).ForeColor = lCol
.SubItems(colAddrType) = ""
.ListSubItems(colAddrLength).ForeColor = lCol
.SubItems(colAddrLength) = ""
.ListSubItems(colAddrList).ForeColor = lCol
.SubItems(colAddrList) = ""
End With
InUse = False
Host = vbNullString
End Sub

Mehr Tipps: Internet: TCP- und IP-Statistik

Sponsoren und Investoren

Sponsoren und Investoren sind jederzeit herzlich willkommen!
Wenn Sie die Information(en) auf dieser Seite interessant fanden, freuen wir uns über eine kleine Spende. Empfehlen Sie uns bitte auch in Ihren Netzwerken (z. B. Twitter, Facebook oder Google+). Herzlichen Dank!

Nach oben Sitemap
Impressum & Kontakt