frmmain.frm

VB快速端口扫描器的源代码

    Me.Frame1(1).Enabled = False
    Me.framePortsToScan.Enabled = False
    Me.Frame1(2).Enabled = False
    Progbar True
    Me.cmdScan.Caption = "停止扫描(&S)"
    lngWinSocks = Val(Me.txtWinsocks)
    Me.MousePointer = vbArrowHourglass
    StatusBar "正在建立 " & lngWinSocks & " Winsocks..."
    Me.pgbrPorts.Min = 0
    Me.pgbrPorts.Max = lngWinSocks
    Me.pgbrPorts.Value = 0
    Do Until Me.tcpClient.Count = lngWinSocks
        Load Me.tcpClient(Me.tcpClient.Count)
        Me.tcpClient(Me.tcpClient.Count - 1).Tag = Timer
        Me.pgbrPorts.Value = Me.tcpClient.Count
        DoEvents
        If blStop Then Exit Do
    Loop
    lngCurrentWinsock = 0
    StatusBar "正在扫描开放的端口..."
    Me.pgbrPorts.Max = lngEndPort
    Me.pgbrPorts.Min = lngStartPort
    Me.pgbrPorts.Value = lngStartPort
    With Me.tvwScans.Nodes
        .Clear
        .Add , , "H", "打开的主机"
        .Add , , "P", "打开的端口"
        .Add , , "R", "可能存在问题的端口"
        .Add , , "T", "可能存在特洛伊木马/后门程序"
    End With
    'On Error GoTo Error_ScanPorts
    If Me.optPortOptions(2).Value = True Then   '手动
        lngStartTime = Timer()
        Me.pgbrPorts.Max = lngEndPort
        Me.pgbrPorts.Min = lngStartPort
        Me.pgbrPorts.Value = lngStartPort
        For lngPort = lngStartPort To lngEndPort
            Me.pgbrPorts.Value = lngPort
            If lngTime > 0 And lngTime < Timer Then Exit For
    
            For lngHex = lngStartHex To lngEndHex
                If lngTime > 0 And lngTime < Timer Then Exit For
                Do
                    DoEvents
                    If Me.tcpClient(lngCurrentWinsock).State = sckClosed Then
                        '2倍扫描时间.
                        'StatusBar "winsock(" & lngCurrentWinsock & ") " & strSub & lngHex & ":" & lngPort
                        Me.tcpClient(lngCurrentWinsock).RemoteHost = strSub & lngHex
                        Me.tcpClient(lngCurrentWinsock).RemotePort = lngPort
                        Me.tcpClient(lngCurrentWinsock).LocalPort = 0
                        Me.tcpClient(lngCurrentWinsock).Tag = "" & Timer + sngTimeOut
                        Me.tcpClient(lngCurrentWinsock).Connect
                        If iHex = 255 And lngPort = 200 Then blStop = True
                        Exit Do
                    End If
                    If tcpClient(lngCurrentWinsock).State = sckConnected Then
                        AddPortToTree Me.tcpClient(lngCurrentWinsock).RemoteHostIP, Me.tcpClient(lngCurrentWinsock).RemotePort
                        tcpClient(lngCurrentWinsock).Close
                    End If
                    If tcpClient(lngCurrentWinsock).State = sckError Then
                        tcpClient(lngCurrentWinsock).Close
                    End If
                    If tcpClient(lngCurrentWinsock).State >= sckResolvingHost And tcpClient(lngCurrentWinsock).State <= sckConnecting And tcpClient(lngCurrentWinsock).Tag < Timer Then
                        tcpClient(lngCurrentWinsock).Close
                    End If
                    lngCurrentWinsock = lngCurrentWinsock + 1
                    If lngCurrentWinsock = lngWinSocks Then lngCurrentWinsock = 0
                    If blStop Then
                        If lngTime = 0 Then lngTime = Timer + 2
                    End If
                    If lngTime > 0 And lngTime < Timer Then Exit Do
                Loop
            Next lngHex
        Next lngPort
        MsgBox "扫描用时 " & Timer() - lngStartTime & " 秒！", vbInformation, "扫描完成"
    Else
        Set rs = New ADODB.Recordset
        rs.CursorLocation = adUseClient
        rs.CursorType = adOpenDynamic
        If Me.optPortOptions(1).Value = True Then
            rs.Open "SELECT DISTINCT fldPort FROM tblTrojanPorts WHERE fldType = 'TCP' ORDER BY fldPort", cn, adOpenDynamic, adLockReadOnly
        Else
            rs.Open "SELECT DISTINCT fldPort FROM tblRegisteredPorts WHERE fldType = 'TCP' ORDER BY fldPort", cn, adOpenDynamic, adLockReadOnly
        End If
        If Not rs.EOF Then
            rs.MoveLast
            rs.MoveFirst
        End If
        Me.pgbrPorts.Max = rs.RecordCount
        Me.pgbrPorts.Min = 0
        lngStartTime = Timer
        Do Until rs.EOF
            Me.pgbrPorts.Value = rs.AbsolutePosition
            lngPort = rs.Fields("fldPort")
            If lngTime > 0 And lngTime < Timer Then Exit Do
    
            For lngHex = lngStartHex To lngEndHex
                If lngTime > 0 And lngTime < Timer Then Exit For
                Do
                    DoEvents
                    If Me.tcpClient(lngCurrentWinsock).State = sckClosed Then
                        '双倍扫描时间.
                        'StatusBar "winsock(" & lngCurrentWinsock & ") " & strSub & lngHex & ":" & lngPort
                        Me.tcpClient(lngCurrentWinsock).RemoteHost = strSub & lngHex
                        Me.tcpClient(lngCurrentWinsock).RemotePort = lngPort
                        Me.tcpClient(lngCurrentWinsock).LocalPort = 0
                        Me.tcpClient(lngCurrentWinsock).Tag = "" & Timer + sngTimeOut
                        Me.tcpClient(lngCurrentWinsock).Connect
                        If iHex = 255 And lngPort = 200 Then blStop = True
                        Exit Do
                    End If
                    If tcpClient(lngCurrentWinsock).State = sckConnected Then
                        AddPortToTree Me.tcpClient(lngCurrentWinsock).RemoteHostIP, Me.tcpClient(lngCurrentWinsock).RemotePort
                        tcpClient(lngCurrentWinsock).Close
                    End If
                    If tcpClient(lngCurrentWinsock).State = sckError Then
                        tcpClient(lngCurrentWinsock).Close
                    End If
                    If tcpClient(lngCurrentWinsock).State >= sckResolvingHost And tcpClient(lngCurrentWinsock).State <= sckConnecting And tcpClient(lngCurrentWinsock).Tag < Timer Then
                        tcpClient(lngCurrentWinsock).Close
                    End If
                    lngCurrentWinsock = lngCurrentWinsock + 1
                    If lngCurrentWinsock = lngWinSocks Then lngCurrentWinsock = 0
                    If blStop Then
                        If lngTime = 0 Then lngTime = Timer + 2
                    End If
                    If lngTime > 0 And lngTime < Timer Then Exit Do
                Loop
            Next lngHex
            rs.MoveNext
        Loop
        MsgBox "扫描用时 " & Timer() - lngStartTime & " 秒！", vbInformation, "扫描完成"
    End If
    StatusBar "Disolving " & lngWinSocks & " Winsocks..."
    Me.pgbrPorts.Min = 0
    Me.pgbrPorts.Max = Me.tcpClient.Count
    Me.pgbrPorts.Value = Me.tcpClient.Count
    Do Until Me.tcpClient.Count = 1
        Unload Me.tcpClient(Me.tcpClient.Count - 1)
        Me.pgbrPorts.Value = Me.tcpClient.Count
        DoEvents
    Loop
    blRefreshing = False
    blStop = False
    Me.Caption = "端口扫描工具"
    Me.MousePointer = vbNormal
    Me.Frame1(0).Enabled = True
    Me.Frame1(1).Enabled = True
    Me.Frame1(2).Enabled = True
    Me.framePortsToScan.Enabled = True
    Progbar False
    StatusBar "完毕"
    Me.cmdScan.Caption = "开始扫描"
    Exit Sub
    
Error_ScanPorts:
    blStop = True
    Debug.Print Err.Number; ":" & Err.Description
    Resume Next
End Sub

Private Sub AddPortToTree(strIP As String, lngOpenPort As Long)
    Dim strHost As String
    Dim strPartialKey As String
    Dim objNode As Node
    Dim objNodes As Nodes
    Dim objParentNode As Node
    Dim strTemp As String
    Dim objPort As clsPort
    Dim strTrojans As String
    Dim strRegistered As String
    
    strHost = strIP & " " & iphDNS.AddressToName(strIP)
    strPartialKey = strIP & ":" & lngOpenPort
    Set objPort = objPorts("" & lngOpenPort)    '在集合中查找端口, 若没有则创建.
    If objPort Is Nothing Then
        If rsReg.State = adStateOpen Then
            rsReg.Filter = "fldPort = " & lngOpenPort
            Do Until rsReg.EOF
                If strTemp <> rsReg.Fields("fldRegisterName") Then
                    
                    strRegistered = strRegistered & IIf(Len(strRegistered) > 0, ", ", "") & rsReg.Fields("fldRegisterName")
                    strTemp = rsReg.Fields("fldRegisterName")
                End If
    '            AddRegisteredToTree rsReg.Fields("fldID"), rsReg.Fields("fldRegisterName"), strHost, lngOpenPort
                rsReg.MoveNext
            Loop
        End If
        strTemp = ""
        If rsTroj.State = adStateOpen Then
            rsTroj.Filter = "fldPort = " & lngOpenPort
            Do Until rsTroj.EOF
                If strTemp <> rsTroj.Fields("fldTrojanName") Then
                    strTrojans = strTrojans & IIf(Len(strTrojans) > 0, ", ", "") & rsTroj.Fields("fldTrojanName")
                    strTemp = rsTroj.Fields("fldTrojanName")
                End If
    '            AddTrojanToTree rsTroj.Fields("fldID"), rsTroj.Fields("fldTrojanName"), strHost, lngOpenPort
                rsTroj.MoveNext
            Loop
        End If
        Set objPort = objPorts.Add(lngOpenPort, strTrojans, strRegistered, "" & lngOpenPort)
    End If
    Set objNodes = Me.tvwScans.Nodes
    
    Set objParentNode = AddNodeToParent(objNodes("H"), "H" & strIP, strHost & " (1 端口)")
    objParentNode.Tag = Val(objParentNode.Tag) + 1
    objParentNode.Text = Left(objParentNode.Text, InStr(1, objParentNode.Text, " (") - 1) & " (" & objParentNode.Tag & " 端口)"
    Set objNode = AddNodeToParent(objNodes("H" & strIP), strPartialKey, Format(objPort.PortNumber, "00000") & ":" & IIf(objPort.PossibleRegister <> "", "(Reg: " & objPort.PossibleRegister & ") ", "") & IIf(objPort.PossibleTrojans <> "", "(特洛伊: " & objPort.PossibleTrojans & ")", ""))
    
    Set objParentNode = AddNodeToParent(objNodes("P"), "P" & Format(lngOpenPort, "00000"), Format(objPort.PortNumber, "00000") & ":" & IIf(objPort.PossibleRegister <> "", "(登录: " & objPort.PossibleRegister & ") ", "") & IIf(objPort.PossibleTrojans <> "", "(特洛伊: " & objPort.PossibleTrojans & ")", ""))
    objParentNode.Tag = Val(objParentNode.Tag) + 1
    objParentNode.Text = Format(objPort.PortNumber, "00000") & ":" & IIf(objPort.PossibleRegister <> "", "(Reg: " & objPort.PossibleRegister & ") ", "") & IIf(objPort.PossibleTrojans <> "", "(特洛伊: " & objPort.PossibleTrojans & ")", "") & " (" & objParentNode.Tag & " 主机)"

    Set objNode = AddNodeToParent(objNodes("P" & Format(lngOpenPort, "00000")), "P" & Format(lngOpenPort, "00000") & strPartialKey, strHost)
    If objPort.PossibleRegister <> "" Then  '已登记的,添加到树型
        Set objParentNode = AddNodeToParent(objNodes("R"), "R" & Format(objPort.PortNumber, "00000"), Format(objPort.PortNumber, "00000") & ":" & objPort.PossibleRegister)
        objParentNode.Tag = Val(objParentNode.Tag) + 1
        objParentNode.Text = Format(objPort.PortNumber, "00000") & ":" & objPort.PossibleRegister & " (" & objParentNode.Tag & " 主机)"
        Set objNode = AddNodeToParent(objNodes("R" & Format(objPort.PortNumber, "00000")), "R" & Format(objPort.PortNumber, "00000") & strPartialKey, strHost)
    End If
    If objPort.PossibleTrojans <> "" Then '可能存在的特洛伊
        Set objParentNode = AddNodeToParent(objNodes("T"), "T" & Format(objPort.PortNumber, "00000"), Format(objPort.PortNumber, "00000") & ":" & objPort.PossibleTrojans)
        objParentNode.Tag = Val(objParentNode.Tag) + 1
        objParentNode.Text = Format(objPort.PortNumber, "00000") & ":" & objPort.PossibleTrojans & " (" & objParentNode.Tag & " 主机)"
        Set objNode = AddNodeToParent(objNodes("T" & Format(objPort.PortNumber, "00000")), "T" & Format(objPort.PortNumber, "00000") & strPartialKey, strHost)
    End If


End Sub

Private Function AddNodeToParent(objParentNode As Node, strKey As String, strText As String) As Node
    Dim nodeParent As Node
    On Error Resume Next
    Set nodeParent = Me.tvwScans.Nodes(strKey)
    If nodeParent Is Nothing Then
        Set AddNodeToParent = Me.tvwScans.Nodes.Add(objParentNode, tvwChild, strKey, strText)
    Else
        Set AddNodeToParent = Me.tvwScans.Nodes(strKey)
    End If
End Function

Private Sub AddTrojanToTree(lngKey As Long, strTrojan As String, strHost As String, lngOpenPort As Long)

End Sub

Private Sub AddRegisteredToTree(lngKey As Long, strRegistered As String, strHost As String, lngOpenPort As Long)

End Sub

Private Sub cmdScan_Click()
    If blRefreshing Then
        blStop = True
    Else
        ScanPorts
    End If
End Sub

Private Sub Form_Resize()
    If Me.WindowState = vbMinimized Then Exit Sub
    Me.tvwScans.Width = Me.ScaleWidth - Me.tvwScans.Left * 2
    Me.tvwScans.Height = Me.ScaleHeight - Me.framePortsToScan.Top - Me.framePortsToScan.Height - (Me.tvwScans.Top - Me.framePortsToScan.Top - Me.framePortsToScan.Height) * 2 - Me.sbMain.Height
    If Me.pgbrPorts.Visible Then Progbar True
'    Me.pgbrPorts.Width = Me.ScaleWidth - Me.pgbrPorts.Left * 2
End Sub

Private Sub Form_Unload(Cancel As Integer)
    If blRefreshing Then
        MsgBox "退出本程序需要停止扫描进程", vbCritical, "退出"
        Cancel = -1
        Exit Sub
    End If
    
    If rsPorts.State = adStateOpen Then rsPorts.Close
    Set rsPorts = Nothing
    
    If rsTroj.State = adStateOpen Then rsTroj.Close
    Set rsTroj = Nothing
    
    If rsReg.State = adStateOpen Then rsReg.Close
    Set rsReg = Nothing
    
    If cn.State = adStateOpen Then cn.Close
    Set cn = Nothing
End Sub

Private Function getRegisteredForPort(Port As Long) As String
    If rsReg.State <> adStateOpen Then Exit Function
    rsReg.Filter = "fldPort = " & Port
    Do Until rsReg.EOF
        getRegisteredForPort = getRegisteredForPort & IIf(getRegisteredForPort = "", "", ", ") & rsReg.Fields("fldRegisterName")
        rsReg.MoveNext
    Loop
End Function

Private Function getTrojansForPort(Port As Long) As String
    If rsTroj.State <> adStateOpen Then Exit Function
    rsTroj.Filter = "fldPort = " & Port
    Do Until rsTroj.EOF
        getTrojansForPort = getTrojansForPort & IIf(getTrojansForPort = "", "", ", ") & rsTroj.Fields("fldTrojanName")
        rsTroj.MoveNext
    Loop
End Function

Private Function GetConnectionString() As String
    GetConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & App.Path & "\scanner.mdb"
End Function

Private Function MakeConnection() As ADODB.Connection
    Dim cn As ADODB.Connection
    Dim strCon As String
    On Error GoTo Error_MakeConnection
    Set cn = New ADODB.Connection
    cn.CursorLocation = adUseClient
    strCon = GetConnectionString()
    cn.Open strCon
    Set MakeConnection = cn
    Exit Function

Error_MakeConnection:
    MsgBox Err.Number & ":" & Err.Description, vbCritical, "错误"
End Function

Private Sub optPortOptions_Click(Index As Integer)
    Me.txtFromPort.Enabled = Me.optPortOptions(2)
    Me.txtToPort.Enabled = Me.optPortOptions(2)
End Sub

Private Sub txtStartIP_Validate(Cancel As Boolean)
    Me.txtEndIP.Text = Left(Me.txtStartIP, InStrRev(Me.txtStartIP, ".")) & "254"
End Sub

Private Sub StatusBar(Info As String)
    Me.sbMain.Panels("Info").Text = Info
End Sub

Private Sub Progbar(ProgBarVisible As Boolean)
    If ProgBarVisible Then
        If lngX = 0 Then
            Me.pgbrPorts.Left = Me.sbMain.Left + Me.sbMain.Panels("Date").Left
            Me.pgbrPorts.Top = Me.sbMain.Top
            Me.pgbrPorts.Height = Me.sbMain.Height
            Me.pgbrPorts.Width = Me.sbMain.Panels("Time").Left + Me.sbMain.Panels("Time").Width - Me.sbMain.Panels("Date").Left
            lngX = Me.pgbrPorts.Left - Me.ScaleWidth
            lngY = Me.pgbrPorts.Top - Me.ScaleHeight
        Else
            Me.pgbrPorts.Move Me.ScaleWidth + lngX, Me.ScaleHeight + lngY
        End If
        Me.pgbrPorts.Visible = True
    Else
        Me.pgbrPorts.Visible = False
    End If
End Sub