Die Community zu .NET und Classic VB.

Startseite / Tipps / VB 5/6-Tipp 0610: DNS-Einträge auslesen (nur für 2000 und XP)

VB 5/6-Tipp 0610: DNS-Einträge auslesen (nur für 2000 und XP)

 von Kai Liebenau

Schwierigkeitsgrad:

Verwendete API-Aufrufe: RtlMoveMemory (CopyMem), DnsQuery_A (DnsQuery), DnsRecordListFree, lstrcpyA (StrCopyA), lstrlenA (StrLenA), inet_ntoa

Download: Download des Beispielprojektes [5,81 KB]

'Dieser Quellcode stammt von http://www.activevb.de
'und kann frei verwendet werden. Für eventuelle Schäden
'wird nicht gehaftet.

'Um Fehler oder Fragen zu klären, nutzen Sie bitte unser Forum.
'Ansonsten viel Spaß und Erfolg mit diesem Source!

'------------- Anfang Projektdatei Projekt1.vbp -------------
'--------- Anfang Formular "Form1" alias Form1.frm  ---------
' Steuerelement: Kombinationsliste "Combo1"
' Steuerelement: Schaltfläche "Command1"
' Steuerelement: Textfeld "Text2"
' Steuerelement: Textfeld "Text1"



' Beispiel um eine DNS Namensauflösung direkt durch den DNS Server
' zu machen.

' Es kann jeder DNS-Eintrag ausgelesen werden, den ein DNS Server
' für die Verwaltung einer Zone benötigt oder zusätzlich mitführt.
' Zum Beispiel den Eintrag SOA = Start of Authority oder ein
' MX = Mailserver. Zum Auflösen einer IP Addresse in einen Namen
' muss die IP umgewandelt werden, was aber die Funktion erledigt.

' Dieses Beispiel läuft erst ab Win2000 und höher, NT4 oder Win9x
' wird nicht unterstützt

' erstellt von Kai Liebenau für ActiveVB

Option Explicit

Private Sub Command1_Click()
    Dim lType As Long
    Dim DNSEntrys() As DNSRecord
    Dim EntriesRead As Long
    Dim x As Long
    Dim rv As Long
    
    ' DNS Querytype auswählen
    If Combo1.TEXT = "DNS_TYPE_ALL" Then
        lType = 255
    Else
        lType = Combo1.ListIndex + 1
    End If
    
    ' Clear der Ausgabe Textbox
    Text2 = ""
    
    If lType > 0 Then
        ' Query beginnen
        rv = GetDNSLookup(Text1, DNSEntrys(), EntriesRead, lType)
        
        ' Rückgabewert prüfen
        If rv = 0 Then
            For x = 0 To EntriesRead - 1
                
                ' Ermittelte DNS Einträge ausgeben
                Text2 = Text2 & "Entrie: " & vbTab & vbTab & x + 1 & vbCrLf
                Text2 = Text2 & "Type: " & vbTab & vbTab & _
                    Combo1.List(DNSEntrys(x).Type - 1) & vbCrLf
                Text2 = Text2 & "RR Name: " & vbTab & DNSEntrys(x).Name & vbCrLf
                Select Case DNSEntrys(x).Type
                    Case DNS_TYPE_A
                        Text2 = Text2 & "IP Addresse: " & vbTab & DNSEntrys(x).RR & vbCrLf
                    Case DNS_TYPE_MX
                        Text2 = Text2 & "MX Record: " & vbTab & _
                            DNSEntrys(x).MX.pNameExchange & vbCrLf
                    Case DNS_TYPE_SOA
                        Text2 = Text2 & "SOA Admin: " & vbTab & _
                            DNSEntrys(x).SOA.pNameAdministrator & vbCrLf
                        Text2 = Text2 & "SOA Server: " & vbTab & _
                            DNSEntrys(x).SOA.pNamePrimaryServer & vbCrLf
                        Text2 = Text2 & "SOA SerialNumber: " & _
                            vbTab & DNSEntrys(x).SOA.dwSerialNo & vbCrLf
                        Text2 = Text2 & "SOA Retrys: " & vbTab & _
                            DNSEntrys(x).SOA.dwRetry & " Sek" & vbCrLf
                        Text2 = Text2 & "SOA Refresh: " & vbTab & _
                            DNSEntrys(x).SOA.dwRefresh & " Sek" & vbCrLf
                        Text2 = Text2 & "SOA Expired: " & vbTab & _
                            DNSEntrys(x).SOA.dwExpire & " Sek" & vbCrLf
                        Text2 = Text2 & "SOA Default TTL: " & vbTab & _
                            DNSEntrys(x).SOA.dwDefaultTtl & " Sek" & vbCrLf
                    Case DNS_TYPE_TEXT
                        Text2 = Text2 & "TEXT Record: " & vbTab & _
                            DNSEntrys(x).TEXT.DNSText & vbCrLf
                    Case DNS_TYPE_NS
                        Text2 = Text2 & "NameServer: " & vbTab & _
                            DNSEntrys(x).NS.pNameServer & vbCrLf
                    Case DNS_TYPE_PTR
                        Text2 = Text2 & "HostName: " & vbTab & _
                            DNSEntrys(x).PTR.pHostName & vbCrLf
                    Case Else
                        Text2 = Text2 & "RR Menge: " & vbTab & _
                            DNSEntrys(x).RR & vbCrLf
                End Select
                Text2 = Text2 & vbCrLf
            Next
        Else
            Text2 = "Fehler: " & rv
        End If
    Else
        ' Eingabefehler ausgeben
        Text2 = "Falscher Abfagetyp!"
    End If
End Sub

Private Sub Form_Load()
    ' Combobox mit den DNS Querytypes laden
    Combo1.AddItem "DNS_TYPE_A"
    Combo1.AddItem "DNS_TYPE_NS"
    Combo1.AddItem "DNS_TYPE_MD"
    Combo1.AddItem "DNS_TYPE_MF"
    Combo1.AddItem "DNS_TYPE_CNAME"
    Combo1.AddItem "DNS_TYPE_SOA"
    Combo1.AddItem "DNS_TYPE_MB"
    Combo1.AddItem "DNS_TYPE_MG"
    Combo1.AddItem "DNS_TYPE_MR"
    Combo1.AddItem "DNS_TYPE_NULL"
    Combo1.AddItem "DNS_TYPE_WKS"
    Combo1.AddItem "DNS_TYPE_PTR"
    Combo1.AddItem "DNS_TYPE_HINFO"
    Combo1.AddItem "DNS_TYPE_MINFO"
    Combo1.AddItem "DNS_TYPE_MX"
    Combo1.AddItem "DNS_TYPE_TEXT"
    Combo1.AddItem "DNS_TYPE_ALL"

    Text1.TEXT = "www.ActiveVB.de"
    Text2.TEXT = ""
    
    ' Bei Textbox 2 sollte die ScrollBar Eigenschaft auf
    ' 2 - Vertikal eingestellt werden
    Command1.Caption = "Abfragen"
End Sub

Private Sub Text1_KeyPress(KeyAscii As Integer)
    If KeyAscii = 13 Then Command1_Click
End Sub
'---------- Ende Formular "Form1" alias Form1.frm  ----------
'--------- Anfang Modul "Module1" alias Module1.bas ---------



'Name:      DNS Querymodul
'API'S:     DnsQuery_A, DnsRecordListFree, inet_ntoa, RtlMoveMemory
'           lstrcpyA, lstrlenA
'
'Function:  Abfrage eines DNS Record's vom DNS Server.
'           Die Rückgabemenge ist nicht gefiltert!!!
'
'Benutzung: GetDNSLookup (DNSEntry, Records, Entries,
'                         DNSType, lngQueryFlag) As long
'
'Argumente: DNSEntry     = Ein String mit dem abzufragenden Inhalt.
'                         z.B. www.ActiveVB.de
'          Records      = Ein UDTArray mit der Rückgabemenge
'          Entries      = Anzahl der Einträge in der Rückgabemenge.
'                         (Base = 1)
'          DNSType      = Optional! Definiert den Abfragetyp
'          lngQueryFlag = Optional! Beeinflußt die Abfrag sehr stark!
'                         Nur für erfahrene Programmierer, die Kenntnisse
'                         über die Namensauflösung besitzen!!

'Ersteller: Kai Liebenau

Option Explicit

Private Declare Function DnsQuery Lib "Dnsapi.dll" Alias "DnsQuery_A" ( _
    ByVal Name As String, ByVal wType As Integer, ByVal Options As Long, _
    aipServers As Any, ppQueryResultsSet As Long, ByVal pReserved As Long) As Long
    
Private Declare Function DnsRecordListFree Lib "Dnsapi.dll" ( _
    ByVal pDnsRecord As Long, ByVal DnsFreeRecordListDeep As Long) As Long
    
Private Declare Function inet_ntoa Lib "ws2_32.dll" (ByVal hMem As Long) As Long

Private Declare Sub CopyMem Lib "kernel32.dll" Alias "RtlMoveMemory" ( _
    pTo As Any, uFrom As Any, ByVal lSize As Long)
    
Private Declare Function StrCopyA Lib "kernel32.dll" Alias "lstrcpyA" ( _
    ByVal retval As String, ByVal PTR As Long) As Long
    
Private Declare Function StrLenA Lib "kernel32.dll" Alias "lstrlenA" ( _
    ByVal PTR As Long) As Long

' Deklaration Type's
Private Type DNS_SOA_DATA
    pNamePrimaryServer As String
    pNameAdministrator As String
    dwSerialNo As Long
    dwRefresh As Long
    dwRetry As Long
    dwExpire As Long
    dwDefaultTtl As Long
End Type

Private Type DNS_TEXT_DATA
    DNSText As String
End Type

Private Type DNS_MX_DATA
    pNameExchange As String
End Type

Private Type DNS_NS_DATA
    pNameServer As String
End Type

Private Type DNS_PTR_DATA
    pHostName As String
End Type

Private Type VBDnsRecord
    pNext As Long
    pName As Long
    wType As Integer
    wDataLength As Integer
    Flags As Long
    dwTTL As Long
    dwReserved  As Long
    prt As Long
    others(9) As Long
End Type

Public Type DNSRecord
    Name As String
    Type As Integer
    RR As String
    Flags As Long
    SOA As DNS_SOA_DATA
    TEXT As DNS_TEXT_DATA
    MX As DNS_MX_DATA
    NS As DNS_NS_DATA
    PTR As DNS_PTR_DATA
End Type



' Deklaration Enums
Public Enum DNS_TYPES
    DNS_TYPE_A = &H1
    DNS_TYPE_NS = &H2
    DNS_TYPE_MD = &H3
    DNS_TYPE_MF = &H4
    DNS_TYPE_CNAME = &H5
    DNS_TYPE_SOA = &H6
    DNS_TYPE_MB = &H7
    DNS_TYPE_MG = &H8
    DNS_TYPE_MR = &H9
    DNS_TYPE_NULL = &HA
    DNS_TYPE_WKS = &HB
    DNS_TYPE_PTR = &HC
    DNS_TYPE_HINFO = &HD
    DNS_TYPE_MINFO = &HE
    DNS_TYPE_MX = &HF
    DNS_TYPE_TEXT = &H10
    DNS_TYPE_ALL = &HFF
End Enum

Public Enum DNS_QUERY_FLAG
    DNS_QUERY_STANDARD = &H0
    DNS_QUERY_ACCEPT_TRUNCATED_RESPONSE = &H1
    DNS_QUERY_USE_TCP_ONLY = &H2
    DNS_QUERY_NO_RECURSION = &H4
    DNS_QUERY_BYPASS_CACHE = &H8
    DNS_QUERY_CACHE_ONLY = &H10
    DNS_QUERY_SOCKET_KEEPALIVE = &H100
    DNS_QUERY_TREAT_AS_FQDN = &H1000
    DNS_QUERY_ALLOW_EMPTY_AUTH_RESP = &H10000
    DNS_QUERY_DONT_RESET_TTL_VALUES = &H100000
    DNS_QUERY_RESERVED = &HFF000000
End Enum

' Deklaration Konstanten
Private Const DnsFreeRecordListDeep As Long = 1&
Public Const ERROR_NOT_RR_EXIST As Long = -1&
Public Const ERROR_CHANGE_IP_IN_PTRSTRING As Long = -2&

Public Function GetDNSLookup(ByVal DNSEntry As String, _
    ByRef Records() As DNSRecord, Entries As Long, _
    Optional ByVal DNSType As DNS_TYPES = DNS_TYPE_ALL, _
    Optional ByVal lngQueryFlag As DNS_QUERY_FLAG = DNS_QUERY_STANDARD) As Long
    
    On Error Goto Fehler
    
    Dim x As Long
    Dim MyRecord As VBDnsRecord
    Dim strIP() As String
    Dim lngDNSRec As Long
    Dim lngDNSNext As Long
    Dim lngDNSRecordType As DNS_TYPES
    
    ' Umwandlung der IP Addresse wenn aus der IP der Hostname ermittelt
    ' werden soll. DNS_TYPE_PTR
    If DNSType = DNS_TYPE_PTR And InStr(1, DNSEntry, ".IN-ADDR.ARPA", _
        vbTextCompare) = 0 Then
        
        strIP = Split(DNSEntry, ".")
        
        DNSEntry = strIP(3) & "." & strIP(2) & "." & strIP(1) & "." & _
            strIP(0) & ".IN-ADDR.ARPA"
    End If
    
    On Error Goto 0
    
    ' DNS Server fragen
    x = DnsQuery(DNSEntry, DNSType, lngQueryFlag, ByVal 0, lngDNSRec, 0)
    GetDNSLookup = x
    
    ' hats funktioniert
    If x = 0 Then
        
        ' gibts eine RR Menge
        If lngDNSRec Then
            
            ' Pointer setzen
            lngDNSNext = lngDNSRec
            Do
                ReDim Preserve Records(Entries)
                
                ' Ergebnis in die Struktur übertragen
                CopyMem MyRecord, ByVal lngDNSNext, 64
                
                ' DNS Type übertragen
                Records(Entries).Type = MyRecord.wType
                
                ' RR Menge auslesen
                Select Case MyRecord.wType
                    Case DNS_TYPE_A
                        ' Type A ist eine IP Addresse die man erst in einen
                        ' String umwandeln muss
                        
                        MyRecord.prt = inet_ntoa(MyRecord.prt)
                        Records(Entries).RR = String$(StrLenA(MyRecord.prt), 0)
                        StrCopyA Records(Entries).RR, MyRecord.prt
                        
                    Case DNS_TYPE_TEXT
                        ' Der Pointer für den Text steht in Others(0)
                        Records(Entries).TEXT.DNSText = String$( _
                            StrLenA(MyRecord.others(0)), 0)
                        
                        StrCopyA Records(Entries).TEXT.DNSText, MyRecord.others(0)
                        
                    Case DNS_TYPE_SOA
                        ' Der SOA Record ist hier der größte Eintrag,
                        ' er beinhaltet 2 Stringpointer
                        ' und eine Reihe anderer Werte
                        
                        x = MyRecord.prt 'Pointer für den PrimaryServer
                        Records(Entries).SOA.pNamePrimaryServer = String$( _
                            StrLenA(x), 0)
                            
                        StrCopyA Records(Entries).SOA.pNamePrimaryServer, x
                        
                        ' Pointer für den Administrator
                        x = MyRecord.others(0)
                        
                        Records(Entries).SOA.pNameAdministrator = String$( _
                            StrLenA(x), 0)
                        
                        StrCopyA Records(Entries).SOA.pNameAdministrator, x
                        
                        ' Ergänzende Angaben
                        Records(Entries).SOA.dwSerialNo = MyRecord.others(1)
                        Records(Entries).SOA.dwRefresh = MyRecord.others(2)
                        Records(Entries).SOA.dwRetry = MyRecord.others(3)
                        Records(Entries).SOA.dwExpire = MyRecord.others(4)
                        Records(Entries).SOA.dwDefaultTtl = MyRecord.others(5)
                        
                    Case DNS_TYPE_MX
                        ' Pointer auf den Mailserver FQDN
                        x = MyRecord.prt
                        Records(Entries).MX.pNameExchange = String$(StrLenA(x), 0)
                        StrCopyA Records(Entries).MX.pNameExchange, x
                        
                    Case DNS_TYPE_NS
                        ' Pointer auf den NameServer FQDN
                        x = MyRecord.prt
                        Records(Entries).NS.pNameServer = String$(StrLenA(x), 0)
                        StrCopyA Records(Entries).NS.pNameServer, x
                        
                    Case DNS_TYPE_PTR
                        ' Pointer auf den Hostname FQDN
                        x = MyRecord.prt
                        Records(Entries).PTR.pHostName = String$(StrLenA(x), 0)
                        StrCopyA Records(Entries).PTR.pHostName, x
                        
                    Case Else
                        ' hier kann man noch erweitern auf andere Recordtypen
                        x = MyRecord.prt
                        If x <> 0 Then
                            Records(Entries).RR = String$(StrLenA(x), 0)
                            StrCopyA Records(Entries).RR, x
                        End If
                End Select
                
                ' Returend Name übertragen
                Records(Entries).Name = String$(StrLenA(MyRecord.pName), 0)
                StrCopyA Records(Entries).Name, MyRecord.pName
                
                ' Next Pointer ermitteln für den nächsten durchlauf
                lngDNSNext = MyRecord.pNext
                Entries = Entries + 1
            Loop While lngDNSNext > 0 And lngDNSNext <> lngDNSRec
            DnsRecordListFree lngDNSRec, DnsFreeRecordListDeep
        Else
        
            ' Fehlerwert: Keine RR_Menge
            GetDNSLookup = ERROR_NOT_RR_EXIST
        End If
    End If
    Exit Function
Fehler:
    ' Fehler bei der Umwandlung der IP Adresse in ein PTR-String.
    ' Kann nur bei Query DNS_TYPE_PTR vorkommen
    GetDNSLookup = ERROR_CHANGE_IP_IN_PTRSTRING
End Function
'---------- Ende Modul "Module1" alias Module1.bas ----------
'-------------- Ende Projektdatei Projekt1.vbp --------------

Archivierte Nutzerkommentare 

Klicken Sie diesen Text an, wenn Sie die 2 archivierten Kommentare ansehen möchten.
Diese stammen noch von der Zeit, als es noch keine direkte Forenunterstützung für Fragen und Kommentare zu einzelnen Artikeln gab.
Aus Gründen der Vollständigkeit können Sie sich die ausgeblendeten Kommentare zu diesem Artikel aber gerne weiterhin ansehen.