Sometimes it is necessary to resolve names (DNS HostA), or ip addresses (DNS PTR) in large numbers. Search in google.com found two articles on the forum "http://stackoverflow.com/questions/2215203/vb6-lookup-hostname-from-ip-specifying-dns-server ", "http://stackoverflow.com/questions/2256321/vb6-windows-api-call-to-dnsquery-function-and-pointer-question" Compiled code with these got this:
Download the sample file of 64bit MS Excel to query DNS A and PTR records
Option Explicit
Private Declare Function DnsQuery Lib "dnsapi" Alias "DnsQuery_A" (ByVal strname As String, ByVal wType As Integer, ByVal fOptions As Long, ByVal pServers As Long, ppQueryResultsSet As Long, ByVal pReserved As Long) As Long
Private Declare Function DnsRecordListFree Lib "dnsapi" (ByVal pDnsRecord As Long, ByVal FreeType As Long) As Long
Private Declare Function lstrlen Lib "kernel32" (ByVal straddress As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, ByVal Source As Long, ByVal Length As Long)
Private Declare Function inet_ntoa Lib "ws2_32.dll" (ByVal pIP As Long) As Long
Private Declare Function inet_addr Lib "ws2_32.dll" (ByVal sAddr As String) As Long
Private Const DnsFreeRecordList As Long = 1
Private Const DNS_TYPE_A As Long = &H1
Private Const DNS_TYPE_PTR As Long = &HC
Private Const DNS_QUERY_BYPASS_CACHE As Long = &H8
Private Type VBDnsRecord
pNext As Long
pName As Long
wType As Integer
wDataLength As Integer
flags As Long
dwTel As Long
dwReserved As Long
prt As Long
others(35) As Byte
End Type
Sub DNS_Resolve()
Dim strDName As String
Dim strDNames As Variant
Dim a, b
a = 2
b = 2
'Resolution PTR
While Not IsEmpty(Worksheets("Sheet1").Cells(a, 1))
strDName = Trim(Worksheets("Sheet1").Cells(a, 1))
strDNames = Split(strDName, ".")
strDName = strDNames(3) + "." + strDNames(2) + "." + strDNames(1) + "." + strDNames(0)
strDName = strDName + ".in-addr.arpa"
Worksheets("Sheet1").Cells(a, 2) = Resolve2(strDName, "8.8.8.8")
a = a + 1
Wend
'Resolution HostA
While Not IsEmpty(Worksheets("Sheet1").Cells(b, 3))
strDName = Worksheets("Sheet1").Cells(b, 3)
Worksheets("Sheet1").Cells(b, 4) = Resolve(strDName, "8.8.8.8")
b = b + 1
Wend
MsgBox ("Complete")
End Sub
'Resolution PTR
Private Function Resolve2(sAddr As String, Optional sDnsServers As String) As String
Dim pRecord As Long
Dim pNext As Long
Dim uRecord As VBDnsRecord
Dim lPtr As Long
Dim vSplit As Variant
Dim laServers() As Long
Dim pServers As Long
Dim sName As String
If LenB(sDnsServers) <> 0 Then
vSplit = Split(sDnsServers)
ReDim laServers(0 To UBound(vSplit) + 1)
laServers(0) = UBound(laServers)
For lPtr = 0 To UBound(vSplit)
laServers(lPtr + 1) = inet_addr(vSplit(lPtr))
Next
pServers = VarPtr(laServers(0))
End If
If DnsQuery(sAddr, DNS_TYPE_PTR, DNS_QUERY_BYPASS_CACHE, pServers, pRecord, 0) = 0 Then
pNext = pRecord
Do While pNext <> 0
Call CopyMemory(uRecord, pNext, Len(uRecord))
If uRecord.wType = DNS_TYPE_PTR Then
lPtr = uRecord.prt
sName = String(lstrlen(lPtr), 0)
Call CopyMemory(ByVal sName, lPtr, Len(sName))
If LenB(Resolve2) <> 0 Then
Resolve2 = Resolve2 & " "
End If
Resolve2 = Resolve2 & sName
End If
pNext = uRecord.pNext
Loop
Call DnsRecordListFree(pRecord, DnsFreeRecordList)
End If
End Function
'Resolution HostA
Private Function Resolve(sAddr As String, Optional sDnsServers As String) As String
Dim pRecord As Long
Dim pNext As Long
Dim uRecord As VBDnsRecord
Dim lPtr As Long
Dim vSplit As Variant
Dim laServers() As Long
Dim pServers As Long
Dim sName As String
If LenB(sDnsServers) <> 0 Then
vSplit = Split(sDnsServers)
ReDim laServers(0 To UBound(vSplit) + 1)
laServers(0) = UBound(laServers)
For lPtr = 0 To UBound(vSplit)
laServers(lPtr + 1) = inet_addr(vSplit(lPtr))
Next
pServers = VarPtr(laServers(0))
End If
If DnsQuery(sAddr, DNS_TYPE_A, DNS_QUERY_BYPASS_CACHE, pServers, pRecord, 0) = 0 Then
pNext = pRecord
Do While pNext <> 0
Call CopyMemory(uRecord, pNext, Len(uRecord))
If uRecord.wType = DNS_TYPE_A Then
lPtr = inet_ntoa(uRecord.prt)
sName = String(lstrlen(lPtr), 0)
Call CopyMemory(ByVal sName, lPtr, Len(sName))
If LenB(Resolve) <> 0 Then
Resolve = Resolve & " "
End If
Resolve = Resolve & sName
End If
pNext = uRecord.pNext
Loop
Call DnsRecordListFree(pRecord, DnsFreeRecordList)
End If
End Function
The result will be something like this
For 64-bit version of Office you need to change a little code:
Option Explicit Private Declare PtrSafe Function DnsQuery Lib "dnsapi" Alias "DnsQuery_A" (ByVal strname As String, ByVal wType As Integer, ByVal fOptions As Long, ByVal pServers As LongLong, ppQueryResultsSet As Long, ByVal pReserved As Long) As Long Private Declare PtrSafe Function DnsRecordListFree Lib "dnsapi" (ByVal pDnsRecord As Long, ByVal FreeType As Long) As Long Private Declare PtrSafe Function lstrlen Lib "kernel32" (ByVal straddress As Long) As Long Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, ByVal Source As Long, ByVal Length As Long) Private Declare PtrSafe Function inet_ntoa Lib "ws2_32.dll" (ByVal pIP As Long) As Long Private Declare PtrSafe Function inet_addr Lib "ws2_32.dll" (ByVal sAddr As String) As Long Private Const DnsFreeRecordList As Long = 1 Private Const DNS_TYPE_A As Long = &H1 Private Const DNS_TYPE_PTR As Long = &HC Private Const DNS_QUERY_BYPASS_CACHE As Long = &H8 Private Type VBDnsRecord pNext As Long pName As LongPtr wType As Integer wDataLength As Integer flags As Long dwTel As Long dwReserved As Long prt As Long others(35) As Byte End Type Sub DNS_Resolve() Dim strDName As String Dim strDNames As Variant Dim a, b a = 2 b = 2 While Not IsEmpty(Worksheets("Sheet1").Cells(a, 1)) strDName = Trim(Worksheets("Sheet1").Cells(a, 1)) strDNames = Split(strDName, ".") strDName = strDNames(3) + "." + strDNames(2) + "." + strDNames(1) + "." + strDNames(0) strDName = strDName + ".in-addr.arpa" Worksheets("Sheet1").Cells(a, 2) = Resolve2(strDName, "8.8.8.8") a = a + 1 Wend While Not IsEmpty(Worksheets("Sheet1").Cells(b, 3)) strDName = Worksheets("Sheet1").Cells(b, 3) Worksheets("Sheet1").Cells(b, 4) = Resolve(strDName, "8.8.8.8") b = b + 1 Wend MsgBox ("Complete") End Sub Private Function Resolve(sAddr As String, Optional sDnsServers As String) As String Dim pRecord As Long Dim pNext As Long Dim uRecord As VBDnsRecord Dim lPtr As Long Dim vSplit As Variant Dim laServers() As Long Dim pServers As LongLong Dim sName As String If LenB(sDnsServers) <> 0 Then vSplit = Split(sDnsServers) ReDim laServers(0 To UBound(vSplit) + 1) laServers(0) = UBound(laServers) For lPtr = 0 To UBound(vSplit) laServers(lPtr + 1) = inet_addr(vSplit(lPtr)) Next pServers = VarPtr(laServers(0)) End If If DnsQuery(sAddr, DNS_TYPE_A, DNS_QUERY_BYPASS_CACHE, pServers, pRecord, 0) = 0 Then pNext = pRecord Do While pNext <> 0 Call CopyMemory(uRecord, pNext, Len(uRecord)) If uRecord.wType = DNS_TYPE_A Then lPtr = inet_ntoa(uRecord.prt) sName = String(lstrlen(lPtr), 0) Call CopyMemory(ByVal sName, lPtr, Len(sName)) If LenB(Resolve) <> 0 Then Resolve = Resolve & " " End If Resolve = Resolve & sName End If pNext = uRecord.pNext Loop Call DnsRecordListFree(pRecord, DnsFreeRecordList) End If End Function Private Function Resolve2(sAddr As String, Optional sDnsServers As String) As String Dim pRecord As Long Dim pNext As Long Dim uRecord As VBDnsRecord Dim lPtr As Long Dim vSplit As Variant Dim laServers() As Long Dim pServers As LongLong Dim sName As String If LenB(sDnsServers) <> 0 Then vSplit = Split(sDnsServers) ReDim laServers(0 To UBound(vSplit) + 1) laServers(0) = UBound(laServers) For lPtr = 0 To UBound(vSplit) laServers(lPtr + 1) = inet_addr(vSplit(lPtr)) Next pServers = VarPtr(laServers(0)) End If If DnsQuery(sAddr, DNS_TYPE_PTR, DNS_QUERY_BYPASS_CACHE, pServers, pRecord, 0) = 0 Then pNext = pRecord Do While pNext <> 0 Call CopyMemory(uRecord, pNext, Len(uRecord)) If uRecord.wType = DNS_TYPE_PTR Then lPtr = uRecord.prt sName = String(lstrlen(lPtr), 0) Call CopyMemory(ByVal sName, lPtr, Len(sName)) If LenB(Resolve2) <> 0 Then Resolve2 = Resolve2 & " " End If Resolve2 = Resolve2 & sName End If pNext = uRecord.pNext Loop Call DnsRecordListFree(pRecord, DnsFreeRecordList) End If End Function
Hello Evgeny I,
ReplyDeleteThanks for sharing this VB script. It's a great tool to have. I have a question for you.
I've tried the script in a 32 Bit version of Excel but using the 64 Bit version that you have published, It crashes Excel 2013 64 Bit at the following statement:
Call CopyMemory(uRecord, pNext, Len(uRecord))
Within this function:
Private Function Resolve(sAddr As String, Optional sDnsServers As String) As String
Dim pRecord As Long
Dim pNext As Long
Dim uRecord As VBDnsRecord
Dim lPtr As Long
Dim vSplit As Variant
Dim laServers() As Long
Dim pServers As LongLong
Dim sName As String
If LenB(sDnsServers) <> 0 Then
vSplit = Split(sDnsServers)
ReDim laServers(0 To UBound(vSplit) + 1)
laServers(0) = UBound(laServers)
For lPtr = 0 To UBound(vSplit)
laServers(lPtr + 1) = inet_addr(vSplit(lPtr))
Next
pServers = VarPtr(laServers(0))
End If
If DnsQuery(sAddr, DNS_TYPE_A, DNS_QUERY_BYPASS_CACHE, pServers, pRecord, 0) = 0 Then
pNext = pRecord
Do While pNext <> 0
Call CopyMemory(uRecord, pNext, Len(uRecord))
If uRecord.wType = DNS_TYPE_A Then
lPtr = inet_ntoa(uRecord.prt)
sName = String(lstrlen(lPtr), 0)
Call CopyMemory(ByVal sName, lPtr, Len(sName))
If LenB(Resolve) <> 0 Then
Resolve = Resolve & " "
End If
Resolve = Resolve & sName
End If
pNext = uRecord.pNext
Loop
Call DnsRecordListFree(pRecord, DnsFreeRecordList)
End If
End Function
Are you able to fix it or tell me what needs to be done?
Thank you.
Which version of Office are you using?
DeleteI tried 2010.