Attribute VB_Name = "DnsRes"
Option Explicit

Private Const WSADESCRIPTION_LEN = 257
Private Const WSASYS_STATUS_LEN = 129

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

Private Type HOSTENTbuf
    H As HostEnt
    b(MAXGETHOSTSTRUCT) As Byte
End Type

Private Declare Function lstrcpy Lib "kernel32" Alias "lstrcpyA" ( _
    ByVal lpString1 As String, ByVal lpString2 As Long) As Long
Private Declare Function WSAAsyncGetHostByName Lib "wsock32.dll" ( _
    ByVal hwnd As Long, ByVal wMsg As Long, ByVal strHostName As _
    String, buf As Any, ByVal buflen As Long) As Long

Private ModulList As New Collection
Private hwnd As Long
Private WndMsg As Long
Private oldWnd As Long
Private udtHost As HOSTENTbuf
Private CancelDNS As Boolean

Public Sub DnsResolve(Connection As Object)
  ModulList.Add Connection
  If ModulList.Count < 2 Then NextDnsResolve
End Sub

Public Sub DnsCancel(Connection As Object)
  Dim I As Integer
  If ModulList.Count = 0 Then Exit Sub
  For I = 1 To ModulList.Count
    If ModulList(I) Is Connection Then
      ModulList.Remove I
      If I = 1 Then CancelDNS = True
      Exit For
    End If
  Next
End Sub

Private Sub NextDnsResolve()
  Dim Ret As Long
  If ModulList.Count < 1 Then Exit Sub
  udtHost.H.h_name = 0
  udtHost.H.h_aliases = 0
  udtHost.H.h_addrtype = 0
  udtHost.H.h_length = 0
  udtHost.H.h_addr_list = 0
  Ret = WSAAsyncGetHostByName(hwnd, WndMsg, ModulList(1).RealServer, udtHost, Len(udtHost))
  If Ret = 0 Then SendResult
End Sub

Private Sub SendResult()
  Dim ptrIP As Long
  Dim HA As Long
  Dim I As Integer
  If CancelDNS = True Then
    NextDnsResolve
    CancelDNS = False
    Exit Sub
  End If
  If udtHost.H.h_addr_list <> 0 Then
    MemCopy ptrIP, ByVal udtHost.H.h_addr_list, 4
    If ptrIP <> 0 Then
      MemCopy HA, ByVal ptrIP, 4
      On Error Resume Next
      ModulList(1).DnsResEvent StringFromPointer(inet_ntoa(HA))
      On Error GoTo 0
    End If
  End If
  If udtHost.H.h_addr_list = 0 Or ptrIP = 0 Then
    ModulList(1).DnsResEvent ""
  End If
  ModulList.Remove 1
  NextDnsResolve
End Sub

Private Function WindowProc(ByVal hwnd As Long, ByVal uMsg As Long, _
  ByVal WParam As Long, ByVal lParam As Long) As Long
  If uMsg = WndMsg Then
    SendResult
  Else
    WindowProc = CallWindowProcA(oldWnd, hwnd, uMsg, WParam, lParam)
  End If
 End Function

Private Function StringFromPointer(ByVal lPointer As Long) As String
  Dim strTemp As String
  Dim lRetVal As Long
  strTemp = String$(lstrlen(ByVal lPointer), 0)
  lRetVal = lstrcpy(ByVal strTemp, ByVal lPointer)
  If lRetVal Then StringFromPointer = strTemp
End Function

Public Sub DnsResInitialize()
  Dim wd As WSADataType
  WndMsg = RegisterWindowMessage(App.EXEName & ".WSAAsyncGetHostByName")
  hwnd = CreateWindowEx(0&, "STATIC", "SckHlpWindow", 0&, 0&, 0&, 0&, 0&, 0&, 0&, App.hInstance, 0)
  oldWnd = SetWindowLongA(hwnd, GWL_WNDPROC, AddressOf WindowProc)
  WSAStartup &H101, wd
End Sub

Public Sub DnsResTerminate()
  SetWindowLongA hwnd, GWL_WNDPROC, oldWnd
  DestroyWindow hwnd
  hwnd = 0
  WSACleanup
End Sub




