clsnet.cls

扫描本地网络内的机器,包括ip和mac,vb代码

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "clsNet"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Private Declare Function IcmpCreateFile Lib "icmp.dll" () As Long
Private Declare Function IcmpCloseHandle Lib "icmp.dll" (ByVal IcmpHandle As Long) As Long
Private Declare Function IcmpSendEcho Lib "icmp.dll" (ByVal IcmpHandle As Long, ByVal DestinationAddress As Long, ByVal RequestData As String, ByVal RequestSize As Integer, ByVal RequestOptions As Long, ReplyBuffer As Icmp_Echo_Reply, ByVal ReplySize As Long, ByVal Timeout As Long) As Long
Private Declare Function WSAGetLastError Lib "WSOCK32.DLL" () As Long
Private Declare Function WSAStartup Lib "WSOCK32.DLL" (ByVal wVersionRequired As Long, lpWSAData As WsaData) As Long
Private Declare Function WSACleanup Lib "WSOCK32.DLL" () As Long
Private Declare Sub RtlMoveMemory Lib "KERNEL32" (hpvDest As Any, ByVal hpvSource As Long, ByVal cbCopy As Long)
Private Declare Function gethostname Lib "WSOCK32.DLL" (ByVal szHost As String, ByVal dwHostLen As Long) As Long
Private Declare Function gethostbyaddr Lib "WSOCK32.DLL" (addr As Long, addrLen As Long, addrType As Long) As Long
Private Declare Function inet_addr Lib "WSOCK32.DLL" (ByVal ipaddress$) As Long
Private Declare Function gethostbyname& Lib "WSOCK32.DLL" (ByVal hostname$)
Private Declare Sub CopyMemory Lib "KERNEL32" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)

Private Const WS_VERSION_REQD = &H101
Private Const WS_VERSION_MAJOR = WS_VERSION_REQD \ &H100 And &HFF&
Private Const WS_VERSION_MINOR = WS_VERSION_REQD And &HFF&
Private Const MIN_SOCKETS_REQD = 1
Private Const AF_INET As Integer = 2
Private Const MAX_WSADescription = 256
Private Const MAX_WSASYSStatus = 128
Private Const PING_TIMEOUT = 150

Private Type Inet_address
  Byte4 As Byte
  Byte3 As Byte
  Byte2 As Byte
  Byte1 As Byte
End Type

Private Type HostEnt
    hName As Long
    hAliases As Long
    hAddrType As Integer
    hLength As Integer
    hAddrList As Long
End Type

Private Type WsaData
    wversion As Integer
    wHighVersion As Integer
    szDescription(0 To MAX_WSADescription) As Byte
    szSystemStatus(0 To MAX_WSASYSStatus) As Byte
    wMaxSockets As Long
    wMaxUDPDG As Long
    dwVendorInfo As Long
End Type

Private Type Icmp_Options
    Ttl             As Byte
    Tos             As Byte
    Flags           As Byte
    OptionsSize     As Byte
    OptionsData     As Long
End Type

Private Type Icmp_Echo_Reply
    Address         As Long
    status          As Long
    RoundTripTime   As Long
    DataSize        As Integer
    Reserved        As Integer
    DataPointer     As Long
    Options         As Icmp_Options
    Data            As String * 250
End Type

Private IPLong As Inet_address
Private IcmPopt As Icmp_Options

Private Function HiByte(ByVal wParam As Integer)
    Let HiByte = wParam \ &H100 And &HFF&
End Function

Private Function LoByte(ByVal wParam As Integer)
    Let LoByte = wParam And &HFF&
End Function

Public Function Ping(szAddress As String) As Boolean
    Dim hPort As Long
    Dim dwAddress As Long
    Dim sDataToSend As String
    Dim Echo As Icmp_Echo_Reply
    Dim iOpt As Long
    Let sDataToSend = "Data"
    Call Me.SocketsInitialize
    Let dwAddress = AddressStringToLong(szAddress)
    Let hPort = IcmpCreateFile()
    Let Ping = False
    If (IcmpSendEcho(hPort, dwAddress, sDataToSend, Len(sDataToSend), 0, Echo, Len(Echo), PING_TIMEOUT)) Then
        Let Ping = (Echo.status = 0)
    End If
    Call Me.SocketsCleanup
    Call IcmpCloseHandle(hPort)
End Function
   
Private Function AddressStringToLong(ByVal tmp As String) As Long
    Dim i As Integer
    Dim parts(1 To 4) As String
    Let i = 0
    Let AddressStringToLong = 0
    While (InStr(tmp, ".") > 0)
        Let i = i + 1
        Let parts(i) = Mid(tmp, 1, InStr(tmp, ".") - 1)
        Let tmp = Mid(tmp, InStr(tmp, ".") + 1)
    Wend
    Let i = i + 1
    Let parts(i) = tmp
    If (i <> 4) Then
        Exit Function
    End If
    Let AddressStringToLong = Val("&H" & Right("00" & Hex(parts(4)), 2) & Right("00" & Hex(parts(3)), 2) & Right("00" & Hex(parts(2)), 2) & Right("00" & Hex(parts(1)), 2))
End Function

Public Function SocketsCleanup() As Boolean
    Dim X As Long
    Let X = WSACleanup()
    Let SocketsCleanup = True
    If (X <> 0) Then
        Call MsgBox("Windows Sockets error " & Trim$(Str$(X)) & " occurred in Cleanup.", vbExclamation)
        Let SocketsCleanup = False
    End If
End Function

Public Function SocketsInitialize() As Boolean
    Dim WSAD As WsaData
    Dim X As Integer
    Dim szLoByte As String, szHiByte As String, szBuf As String
    Let X = WSAStartup(WS_VERSION_REQD, WSAD)
    Let SocketsInitialize = False
    If (X <> 0) Then
        Call MsgBox("Windows Sockets for 32 bit Windows " & "environments is not successfully responding.")
        Exit Function
    End If
    If ((LoByte(WSAD.wversion) < WS_VERSION_MAJOR) Or (LoByte(WSAD.wversion) = WS_VERSION_MAJOR And HiByte(WSAD.wversion) < WS_VERSION_MINOR)) Then
        Let szHiByte = Trim$(Str$(HiByte(WSAD.wversion)))
        Let szLoByte = Trim$(Str$(LoByte(WSAD.wversion)))
        Let szBuf = "Windows Sockets Version " & szLoByte & "." & szHiByte
        Let szBuf = szBuf & " is not supported by Windows " & "Sockets for 32 bit Windows environments."
        Call MsgBox(szBuf, vbExclamation)
        Exit Function
    End If
    If (WSAD.wMaxSockets < MIN_SOCKETS_REQD) Then
        Let szBuf = "This application requires a minimum of " & Trim$(Str$(MIN_SOCKETS_REQD)) & " supported sockets."
        Call MsgBox(szBuf, vbExclamation)
        Exit Function
    End If
    Let SocketsInitialize = True
End Function

Public Function ResolveHostname(ByVal ipaddress As String) As String
    Dim hostip_addr As Long
    Dim hostent_addr As Long
    Dim newAddr As Long
    Dim host As HostEnt
    Dim strTemp As String
    Dim strHost As String * 255
    If (SocketsInitialize()) Then
        Let newAddr = inet_addr(ipaddress)
        Let hostent_addr = gethostbyaddr(newAddr, Len(newAddr), AF_INET)
        If (hostent_addr = 0) Then
            Call SocketsCleanup
            Exit Function
        End If
        Call RtlMoveMemory(host, hostent_addr, Len(host))
        Call RtlMoveMemory(ByVal strHost, host.hName, 255)
        Let strTemp = strHost
        If InStr(strTemp, Chr(0)) <> 0 Then strTemp = Left(strTemp, InStr(strTemp, Chr(0)) - 1)
        Let strTemp = Trim(strTemp)
        Let ResolveHostname = strTemp
        Call SocketsCleanup
    End If
End Function