| 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 ' Adress Type |
| Debug.Print "HOSTENT.h_length = " & CStr(AddrLength) ' Länger jeder Adresse in der Adress Liste |
| Debug.Print "HOSTENT.h_addr_list = " & Join(AddrList(), "; ") ' IP Adress Liste 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 |
|
zurück