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
Exchange 2003 server offers change password
and further there is a full load mail.
