frmdnssrv.frm

全面网络扫描器VB源代码 很实用

VERSION 5.00
Begin VB.Form frmdnssrv 
   BackColor       =   &H00000000&
   BorderStyle     =   1  'Fixed Single
   Caption         =   "DNS Server List"
   ClientHeight    =   2730
   ClientLeft      =   2340
   ClientTop       =   2025
   ClientWidth     =   4995
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   2730
   ScaleWidth      =   4995
   Begin VB.CommandButton Command1 
      Caption         =   "Command1"
      Height          =   495
      Left            =   3120
      TabIndex        =   0
      Top             =   240
      Width           =   1695
   End
   Begin VB.Label Label2 
      BackColor       =   &H80000003&
      Height          =   1575
      Left            =   120
      TabIndex        =   2
      Top             =   960
      Width           =   2655
   End
   Begin VB.Label Label1 
      BackColor       =   &H80000003&
      Height          =   495
      Left            =   120
      TabIndex        =   1
      Top             =   240
      Width           =   2655
   End
End
Attribute VB_Name = "frmdnssrv"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private Const MAX_HOSTNAME_LEN = 128
Private Const MAX_DOMAIN_NAME_LEN = 128
Private Const MAX_SCOPE_ID_LEN = 256
Private Const ERROR_SUCCESS As Long = 0

Private Type IP_ADDRESS_STRING
   IpAddr(0 To 15)     As Byte
End Type

Private Type IP_MASK_STRING
   IpMask(0 To 15)     As Byte
End Type

Private Type IP_ADDR_STRING
   dwNext               As Long
   IpAddress(0 To 15)   As Byte
   IpMask(0 To 15)      As Byte
   dwContext            As Long
End Type

Private Type FIXED_INFO
   HostName(0 To (MAX_HOSTNAME_LEN + 3))      As Byte
   DomainName(0 To (MAX_DOMAIN_NAME_LEN + 3)) As Byte
   CurrentDnsServer   As Long
   DnsServerList      As IP_ADDR_STRING
   NodeType           As Long
   ScopeId(0 To (MAX_SCOPE_ID_LEN + 3))       As Byte
   EnableRouting      As Long
   EnableProxy        As Long
   EnableDns          As Long
End Type

Private Declare Function GetNetworkParams Lib "iphlpapi.dll" _
  (pFixedInfo As Any, _
   pOutBufLen As Long) As Long

Private Declare Function lstrcpyA Lib "kernel32" _
  (ByVal RetVal As String, ByVal ptr As Long) As Long
                        
Private Declare Function lstrlenA Lib "kernel32" _
  (ByVal ptr As Any) As Long
   
Private Declare Function inet_ntoa Lib "wsock32.dll" _
   (ByVal addr As Long) As Long

Private Declare Sub CopyMemory Lib "kernel32" _
   Alias "RtlMoveMemory" _
  (Destination As Any, _
   Source As Any, _
   ByVal Length As Long)


Private Sub Form_Load()

   Command1.Caption = "Get DNS Servers"
   
End Sub


Private Sub Command1_Click()

   Dim cnt As Long
   Dim success As Long
   Dim currserver As String
   Dim dnsservers() As String
   
  'pass an empty string and string array
  'to the function. Return value is the
  'number of DNS servers found
   success = GetDNSServers(currserver, dnsservers())
   
  'show the current DNS server found
   Label1.Caption = "Current DNS Server: " & _
                     vbNewLine & _
                     currserver
                                      
   
  'show all servers found
   If success > 0 Then
   
      Label2.Caption = "DNS Server List: " & vbNewLine
   
      For cnt = 0 To success - 1
      
         Label2.Caption = Label2.Caption & _
                          dnsservers(cnt) & _
                          vbNewLine
         
      Next
   
   End If

End Sub


Private Function GetDNSServers(sCurrentDNSServer As String, _
                               dnssvr() As String) As Long

   Dim buff()        As Byte
   Dim cbRequired    As Long
   Dim nStructSize   As Long
   Dim ptr           As Long
   Dim fi            As FIXED_INFO
   Dim ipas          As IP_ADDR_STRING
   Dim cnt           As Long
   ReDim dnssvr(0) As String
   
   nStructSize = LenB(ipas)

  'call the api first to determine the
  'size required for the values to be returned
   Call GetNetworkParams(ByVal 0&, cbRequired)

   If cbRequired > 0 Then
    
      ReDim buff(0 To cbRequired - 1) As Byte
      
      If GetNetworkParams(buff(0), cbRequired) = ERROR_SUCCESS Then
              
         ptr = VarPtr(buff(0))
         
         CopyMemory fi, ByVal ptr, Len(fi)
         
         With fi
            
           'identify the current dns server
            CopyMemory ipas, _
                       ByVal VarPtr(.CurrentDnsServer) + 4, _
                       nStructSize
            
            sCurrentDNSServer = TrimNull(StrConv(ipas.IpAddress, vbUnicode))

           'obtain a pointer to the
           'DnsServerList array
            ptr = VarPtr(.DnsServerList)

           'the IP_ADDR_STRING dwNext member indicates
           'that more than one DNS server may be listed,
           'so a loop is needed
            Do While (ptr <> 0)

              'copy each into an IP_ADDR_STRING type
               CopyMemory ipas, ByVal ptr, nStructSize

               With ipas

                 'extract the server address and
                 'cast to the array
                  ReDim Preserve dnssvr(0 To cnt) As String
                  dnssvr(cnt) = TrimNull(StrConv(ipas.IpAddress, vbUnicode))
                  ptr = .dwNext
                  
               End With

               cnt = cnt + 1

            Loop
            
         End With
      
      End If  'If GetNetworkParams
    
    End If  'If cbRequired > 0
    
   'return number of servers found
    GetDNSServers = cnt
    
End Function


Private Function TrimNull(item As String)

    Dim pos As Integer
   
    pos = InStr(item, Chr$(0))
    If pos Then
       TrimNull = Left$(item, pos - 1)
    Else
       TrimNull = item
    End If
  
End Function


Private Function GetInetStrFromPtr(Address As Long) As String
  
   GetInetStrFromPtr = GetStrFromPtrA(inet_ntoa(Address))

End Function


Public Function GetStrFromPtrA(ByVal lpszA As Long) As String

   GetStrFromPtrA = String$(lstrlenA(ByVal lpszA), 0)
   Call lstrcpyA(ByVal GetStrFromPtrA, ByVal lpszA)
   
End Function