msgipscan.bas

vb做的数据库 客户管理系统

            End Select
            Debug.Print uNet(l).sRemoteName, uNet(l).sComment


            '将结果列出
            WhichToScan = uNet(l).dwDisplayType = RESOURCEDISPLAYTYPE_NETWORK& _
                Or uNet(l).dwDisplayType = RESOURCEDISPLAYTYPE_DOMAIN _
                Or uNet(l).dwDisplayType = RESOURCEDISPLAYTYPE_SERVER
            If isScanShare Then
                WhichToScan = WhichToScan _
                    Or uNet(l).dwDisplayType = RESOURCEDISPLAYTYPE_SHARE
            Else
                ShareNum = 0
            End If
            If WhichToScan Then
                tmp = uNet(l).sRemoteName & uNet(l).sComment
                tmp = Replace(tmp, "\\", "")

                ComputerName = tmp
                ComputerIP = ""
                MyTable = ""


                '对计算机名进行相应处理(获得 IP、添加计算机名和 IP 间的空格)
                If InStr(ComputerName, "\") = 0 Then

                    ComputerNameLen = Len(ComputerName)
                    If ComputerNameLen < 8 Then
                        MyTable = Chr$(9) & Chr$(9) & Chr$(9)
                    ElseIf ComputerNameLen >= 8 And ComputerNameLen < 16 Then
                        MyTable = Chr$(9) & Chr$(9)
                    ElseIf ComputerNameLen >= 16 And ComputerNameLen < 24 Then
                        MyTable = Chr$(9)
                    Else
                        MyTable = ""
                    End If

                    If isScanIP Then  '是否计算指定计算机对应的 IP 地址
                        ComputerIP = GetIPAddress(ComputerName)
                    Else
                        ComputerIP = ""
                    End If
                    
                    If ComputerIP = "" Then '工作组
                        If uNet(l).dwDisplayType = RESOURCEDISPLAYTYPE_DOMAIN Then
                            ComputerIP = "[WORKGROUP]"
                        End If
                    End If
                End If


                    ResultTxtRec = ResultTxtRec & ComputerName & MyTable & ComputerIP & vbNewLine
                    ResultTxt = ComputerName & MyTable & ComputerIP

                    '--- 保存计算机名、共享文件夹路径
                    MyList(l).ClkValue = "\\" & Trim(ComputerName)
                    '--- 如果是计算机名、共享文件夹路径则可以点击为真
                    If (isScanShare = True And uNet(l).dwDisplayType = RESOURCEDISPLAYTYPE_SHARE) Or _
                                    uNet(l).dwDisplayType = RESOURCEDISPLAYTYPE_SERVER Then
                            MyList(l).isEnabled = True
                    Else
                        MyList(l).isEnabled = False
                    End If

                    frmGetIP.result.AddItem ResultTxt
            End If
        Next l
    End If

    '这时候的 l 已经由于条件判断先加了 1，所以这里就不要 l = l + 1 了
    MyList(l).ClkValue = ""
    MyList(l).isEnabled = False
    frmGetIP.result.AddItem ""
    
    l = l + 1
    MyList(l).ClkValue = ""
    MyList(l).isEnabled = False
    frmGetIP.result.AddItem ""

    l = l + 1
    MyList(l).ClkValue = ""
    MyList(l).isEnabled = False
    frmGetIP.result.AddItem "Workgroup" & Chr$(9) & ": " & WorkGroupNum

    l = l + 1
    MyList(l).ClkValue = ""
    MyList(l).isEnabled = False
    frmGetIP.result.AddItem "Computer" & Chr$(9) & ": " & ComputerNum
    
    l = l + 1
    MyList(l).ClkValue = ""
    MyList(l).isEnabled = False
    frmGetIP.result.AddItem "Share" & Chr$(9) & Chr$(9) & ": " & ShareNum
    
    l = l + 1
    MyList(l).ClkValue = App.path & "\IpScan.txt"
    MyList(l).isEnabled = True
    frmGetIP.result.AddItem "Scanned on " & Now()
    


    frmGetIP.ScanFrame.Visible = False
    frmGetIP.result.Top = 435


    '为ListBox设置水平滚动条
    SetHScroll frmGetIP, frmGetIP.result
    

    If Trim(ResultTxtRec) = "" Then
            ResultTxtRec = "没有找到任何计算机，请检测网络连接状况。"
    End If


    '保存扫描结果到文件
    If frmGetIP.isSaveToFile.Value = 1 Then
        Dim iFile As Integer
        Dim RecInfo As String

        RecInfo = ResultTxtRec _
            & vbCrLf _
            & vbCrLf & "Workgroup" & Chr$(9) & ": " & WorkGroupNum _
            & vbCrLf & "Computer" & Chr$(9) & ": " & ComputerNum _
            & vbCrLf & "Share" & Chr$(9) & Chr$(9) & ": " & ShareNum _
            & vbCrLf _
            & "Scanned on " & Now() _
            & vbCrLf & vbCrLf & vbCrLf _
            & "============================================================" _
            & vbCrLf & vbCrLf & vbCrLf

        iFile = FreeFile
        Open App.path & "\IpScan.txt" For Append As iFile
             Print #iFile, RecInfo
        Close iFile
    End If

End Sub
'以下是获得指定计算机 IP 的函数
'----------------------------------------------------------------------------------------------------
Private Function GetIPAddress(Optional sHost As String) As String
        '返回给定机器名的Ip地址，机器名为空时返回本机Ip地址
    Dim sHostName   As String * 256
    Dim lpHost      As Long
    Dim HOST        As HOSTENT
    Dim dwIPAddr    As Long
    Dim tmpIPAddr() As Byte
    Dim i           As Integer
    Dim sIPAddr     As String
    Dim werr        As Long

    If Not SocketsInitialize() Then
        GetIPAddress = ""
        Exit Function
    End If

    If sHost = "" Then
        If gethostname(sHostName, 256) = SOCKET_ERROR Then
            werr = WSAGetLastError()
            GetIPAddress = ""
            SocketsCleanup
            Exit Function
        End If

        sHostName = Trim$(sHostName)
    Else
        sHostName = Trim$(sHost) & Chr$(0)
    End If

    lpHost = gethostbyname(sHostName)

    If lpHost = 0 Then
        werr = WSAGetLastError()
        GetIPAddress = ""
        SocketsCleanup
        Exit Function
    End If

    CopyMemory HOST, lpHost, Len(HOST)
    CopyMemory dwIPAddr, HOST.hAddrList, 4

    ReDim tmpIPAddr(1 To HOST.hLen)
    CopyMemory tmpIPAddr(1), dwIPAddr, HOST.hLen

    For i = 1 To HOST.hLen
            sIPAddr = sIPAddr & tmpIPAddr(i) & "."
    Next

    GetIPAddress = Mid$(sIPAddr, 1, Len(sIPAddr) - 1)
    SocketsCleanup
End Function



Private Function SocketsInitialize(Optional sErr As String) As Boolean
    Dim WSAD As WSADATA, sLoByte As String, sHiByte As String
    If WSAStartup(WS_VERSION_REQD, WSAD) <> ERROR_SUCCESS Then
        sErr = "The 32-bit Windows Socket is not responding."
        SocketsInitialize = False
        Exit Function
    End If

    If WSAD.wMaxSockets < MIN_SOCKETS_REQD Then
        sErr = "This application requires a minimum of " & _
                CStr(MIN_SOCKETS_REQD) & " supported sockets."

        SocketsInitialize = False
        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

        sHiByte = CStr(HiByte(WSAD.wVersion))
        sLoByte = CStr(LoByte(WSAD.wVersion))

        sErr = "Sockets version " & sLoByte & "." & sHiByte & _
                " is not supported by 32-bit Windows Sockets."

        SocketsInitialize = False
        Exit Function
    End If
    SocketsInitialize = True
End Function



Private Sub SocketsCleanup()
    If WSACleanup() <> ERROR_SUCCESS Then
        App.LogEvent "Socket error occurred in Cleanup.", vbLogEventTypeError
    End If
End Sub




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

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