frmwebrobot.frm

vb写的网络蜘蛛程序

            Key             =   ""
         EndProperty
         BeginProperty ListImage5 {0713E8C3-850A-101B-AFC0-4210102A8DA7} 
            Picture         =   "frmWebRobot.frx":302E
            Key             =   ""
         EndProperty
         BeginProperty ListImage6 {0713E8C3-850A-101B-AFC0-4210102A8DA7} 
            Picture         =   "frmWebRobot.frx":3348
            Key             =   ""
         EndProperty
         BeginProperty ListImage7 {0713E8C3-850A-101B-AFC0-4210102A8DA7} 
            Picture         =   "frmWebRobot.frx":3662
            Key             =   ""
         EndProperty
         BeginProperty ListImage8 {0713E8C3-850A-101B-AFC0-4210102A8DA7} 
            Picture         =   "frmWebRobot.frx":397C
            Key             =   ""
         EndProperty
      EndProperty
   End
   Begin VB.Label lblURL 
      AutoSize        =   -1  'True
      BackStyle       =   0  'Transparent
      Caption         =   "输入查找地址"
      BeginProperty Font 
         Name            =   "楷体_GB2312"
         Size            =   12
         Charset         =   134
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      ForeColor       =   &H000000FF&
      Height          =   240
      Left            =   240
      TabIndex        =   1
      Top             =   600
      Width           =   1545
   End
   Begin VB.Menu mnuFile 
      Caption         =   "&文件"
      Begin VB.Menu mnuPerformSearch 
         Caption         =   "&开始查找"
      End
      Begin VB.Menu mnuStopSearch 
         Caption         =   "&停止查找"
         Enabled         =   0   'False
      End
      Begin VB.Menu mnuExit 
         Caption         =   "&退出"
      End
   End
End
Attribute VB_Name = "frmWebRobot"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Private Dummy As Variant
Private bPerformingRequest As Boolean
Private bPerformingSearch As Boolean
Private bRequestingHeaders As Boolean
Private BinaryFile As Boolean
Private RootWebNode As clsHTMLPageResourceNode
Private ActiveTreeNode As Node
Private bSearchCancelled
Private Analyst As clsDocumentAnalyst
Private TimeOfLastTransfer As Date

' Tree Icon Selectors for ImageList ilTreeIcons
Private Const icoHIT = 1
Private Const icoERROR = 2
Private Const icoSERVER = 3
Private Const icoDOCUMENT = 4
Private Const icoIMAGE = 5
Private Const icoROOT = 6

'Create HTTP Semaphore Flags
Private Type ProtocolTransferSemaphores
    Error As Boolean
    Timeout As Boolean
    Complete As Boolean
    Connected As Boolean
    ConnectionFailed As Boolean
    Cancelled As Boolean
    Disconnected As Boolean
    End Type

Private HTTPSemaphore As ProtocolTransferSemaphores

Private Sub Form_Load()
    Set RootWebNode = New clsHTMLPageResourceNode
    RootWebNode.URL = "WWW"
    RootWebNode.Path = "World Wide Web"
    AddNodeToTreeView RootWebNode, icoROOT
    End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    RootWebNode.RemoveLinks
    End Sub


Private Sub Form_Resize()
    If Me.WindowState = vbMinimized Then
        Exit Sub
      End If
    If Me.ScaleWidth < _
        (lblURL.Width + _
         picBusy.Width + _
         200 + 4 * 60) Then
        Me.Width = lblURL.Width + _
            picBusy.Width + _
            500 + 4 * 60 + 4
    End If
    If Me.ScaleHeight < _
        (txtOutput.Top + 500 + 60) Then
        Me.Height = txtOutput.Top + 500 + 60
    End If
    'lblURL.Left = 60
    txtURL.Left = lblURL.Left + lblURL.Width + 60
    txtURL.Width = Me.ScaleWidth - _
        (txtURL.Left + picBusy.Width + 2 * 60)
    picBusy.Left = Me.ScaleWidth - _
        (picBusy.Width + 60)
    lblSearch.Left = lblURL.Left + lblURL.Width - lblSearch.Width
    udSearchDepth.Left = txtURL.Left + txtURL.Width - udSearchDepth.Width
    txtSearchDepth.Left = udSearchDepth.Left - txtSearchDepth.Width
    lblSearchDepth.Left = txtSearchDepth.Left - lblSearchDepth.Width - 60
    txtSearchString.Left = txtURL.Left
    txtSearchString.Width = lblSearchDepth.Left - (txtSearchString.Left + 2 * 60)
    tvURLTreeView.Left = 60
    tvURLTreeView.Height = Me.ScaleHeight - _
        (sbHTTPStatus.Height + tvURLTreeView.Top + 60)
    txtOutput.Top = tvURLTreeView.Top
    txtOutput.Left = tvURLTreeView.Left + tvURLTreeView.Width + 60
    txtOutput.Width = Me.ScaleWidth - (txtOutput.Left + 60)
    txtOutput.Height = Me.ScaleHeight - _
        (sbHTTPStatus.Height + txtOutput.Top + 60)
    pbDivider.Top = tvURLTreeView.Top
    pbDivider.Height = tvURLTreeView.Height
    pbDivider.Left = tvURLTreeView.Left + tvURLTreeView.Width
    pbDivider.Width = 60
    End Sub

Private Sub Inet1_StateChanged(ByVal State As Integer)
    Dim Loc As Long
    Dim sHeaderValue As String
    Dim vtData As Variant
    Dim vtBinaryData As Variant
    Const BinaryFileNumber = 1
    
    Select Case State
      Case icNone
        sbHTTPStatus.Panels(1).Text = ""
      Case icResolvingHost
        sbHTTPStatus.Panels(1).Text = "Resolving Host"
      Case icHostResolved
        sbHTTPStatus.Panels(1).Text = "Host Resolved"
      Case icConnecting
        sbHTTPStatus.Panels(2).Text = ""
        sbHTTPStatus.Panels(1).Text = "Connecting"
      Case icConnected
        sbHTTPStatus.Panels(1).Text = "Connected"
        Loc = InStr(Inet1.URL, ":80")
        If Loc > 0 Then
            txtURL.Text = Left(Inet1.URL, Loc - 1) & Mid(Inet1.URL, Loc + 3)
          Else
            txtURL.Text = Inet1.URL
          End If
      Case icRequesting
        sbHTTPStatus.Panels(1).Text = "Requesting"
      Case icRequestSent
        sbHTTPStatus.Panels(1).Text = "Request Sent"
      Case icReceivingResponse
        sbHTTPStatus.Panels(1).Text = "Receiving Response"
      Case icResponseReceived
        sbHTTPStatus.Panels(1).Text = "Response Received"
      Case icDisconnecting
        sbHTTPStatus.Panels(1).Text = "Disconnecting"
      Case icDisconnected
        sbHTTPStatus.Panels(1).Text = "Disconnected"
        If bPerformingRequest And (Not HTTPSemaphore.Complete) Then
            HTTPSemaphore.ConnectionFailed = True
          End If
      Case icError
        sbHTTPStatus.Panels(1).Text = "Error"
        HTTPSemaphore.Error = True
        sbHTTPStatus.Panels(2).Text = "ErrorCode: " & _
            Inet1.ResponseCode & _
            " : " & Inet1.ResponseInfo
      Case icResponseCompleted
        sbHTTPStatus.Panels(1).Text = "Response Completed"
        sHeaderValue = Inet1.GetHeader("Content-type")
        If bRequestingHeaders Then
            vtData = Inet1.GetChunk(1024, icString)
            txtOutput.Text = sHeaderValue & vbCrLf & vbCrLf & vtData
          Else
            If (Not BinaryFile) And InStr(1, sHeaderValue, "text/", 1) Then
                'txtOutput.Text = sHeaderValue
                vtData = Inet1.GetChunk(1024, icString)
                Do While Len(vtData) > 0
                    txtOutput.Text = txtOutput.Text + vtData
                    vtData = Inet1.GetChunk(1024, icString)
                    Loop
                bPerformingRequest = False
                HTTPSemaphore.Complete = True
              Else
                ' Could add code here to handle binary files.
              End If
          End If
        HTTPSemaphore.Complete = True
      Case Else
      End Select

    End Sub

Private Sub mnuExit_Click()
    Unload Me
    End
    End Sub

Private Sub mnuPerformSearch_Click()
    PerformRequest
    End Sub

Private Sub mnuStopSearch_Click()
    bSearchCancelled = True
    mnuStopSearch.Enabled = False
    tbToolbar.Buttons("btnStop").Enabled = False
    End Sub

Private Sub pbDivider_MouseMove(Button As Integer, Shift As Integer, X As Single, y As Single)
    If Button = vbLeftButton Then
        pbDivider.Left = _
            MaxLong(200, _
                    MinLong((pbDivider.Left + X), _
                            (Me.ScaleWidth - 260)))
    End If

    End Sub


Private Sub pbDivider_MouseUp(Button As Integer, Shift As Integer, X As Single, y As Single)
    tvURLTreeView.Width = pbDivider.Left - tvURLTreeView.Left
    txtOutput.Left = pbDivider.Left + pbDivider.Width
    txtOutput.Width = Me.ScaleWidth - (txtOutput.Left + 60)
    End Sub


Private Sub tbToolbar_ButtonClick(ByVal Button As Button)
    Select Case Button.Key
      Case "btnSearch"
        PerformRequest
      Case "btnStop"
        Inet1.Cancel
        HTTPSemaphore.Cancelled = True
        bSearchCancelled = True
        mnuStopSearch.Enabled = False
        tbToolbar.Buttons("btnStop").Enabled = False
      End Select
      
    End Sub

Private Sub tmrBusy_Timer()
    Static Counter As Integer
    Counter = (Counter + 1) Mod (ilBusyIcons.ListImages.Count)
    picBusy.Picture = ilBusyIcons.ListImages(Counter + 1).Picture
    End Sub

Private Sub tvURLTreeView_NodeClick(ByVal Node As Node)
    If (Node.Key <> RootWebNode.URL) And _
       (Not bPerformingSearch) Then
        Set ActiveTreeNode = Node
        txtURL.Text = Node.Key
        PerformRequest
      End If
    End Sub


Private Sub txtURL_KeyPress(KeyAscii As Integer)
    If KeyAscii = 13 Then
        PerformRequest
      End If
    End Sub

Private Sub PerformRequest()
    Dim TempURL As String
    Dim FileExtension As String
    Dim TargetFilename As String
    Dim SearchDepth As Integer
    Dim NewWebNode As clsHTMLPageResourceNode
    Dim ExistingNode As clsHTMLPageResourceNode
    Dim Diplomat As clsDiplomat
    Dim vtBinaryData As Variant
    Dim BinaryData() As Byte
    Dim FilenameForBinaryData As String
    Const BinaryFileID = 1
    
    If Not ValidSearchDepth(SearchDepth) Then Exit Sub
    TempURL = txtURL.Text
    If Not URLNormalized(TempURL) Then
        MsgBox "Please enter a valid URL", vbCritical, "Invalid URL"
        Exit Sub
      Else
        txtURL.Text = TempURL
      End If
    
    If Not bPerformingRequest Then
        FileExtension = Trim(LCase(ExtractFilenameExtensionFromPath(txtURL.Text)))
        Select Case FileExtension
          Case "gif", "jpg"
            BinaryFile = True
            TargetFilename = App.Path & "\" & ExtractFilenameFromPath(txtURL.Text)
            cmnSaveAs.FileName = TargetFilename
            cmnSaveAs.DefaultExt = Right(TargetFilename, 4)
            cmnSaveAs.Filter = "Images(*.bmp;*.gif;*.jpg)"
            cmnSaveAs.CancelError = True
            On Error GoTo Skip
            cmnSaveAs.ShowSave
            bPerformingRequest = True
            txtURL.Enabled = False
            mnuPerformSearch.Enabled = False
            mnuStopSearch.Enabled = False
            tbToolbar.Buttons("btnSearch").Enabled = False
            tbToolbar.Buttons("btnStop").Enabled = False
            Me.MousePointer = vbHourglass
            tmrBusy.Enabled = True
            bPerformingSearch = True
            bSearchCancelled = False
            
            FilenameForBinaryData = cmnSaveAs.FileName
            
            BinaryData() = Inet1.OpenURL(txtURL.Text, icByteArray)
            Open FilenameForBinaryData For Binary As BinaryFileID
            Put BinaryFileID, , BinaryData()
            Close BinaryFileID
            
            txtURL.Enabled = True
            mnuPerformSearch.Enabled = True
            mnuStopSearch.Enabled = False
            tbToolbar.Buttons("btnSearch").Enabled = True
            tbToolbar.Buttons("btnStop").Enabled = False
            tmrBusy.Enabled = False
            Me.MousePointer = vbDefault
            bPerformingSearch = False
            bPerformingRequest = False

Skip:
          Case Else
            ' This case will handle any HTML document request,
            ' whether or not it includes a filename,
            ' because a URL with no filename will cause the
            ' web server to return its default HTML document
            ' file.
            
            bPerformingRequest = True
            tmrBusy.Enabled = True
            Me.MousePointer = vbArrowHourglass
            txtURL.Enabled = False
            mnuPerformSearch.Enabled = False
            mnuStopSearch.Enabled = True
            tbToolbar.Buttons("btnSearch").Enabled = False
            tbToolbar.Buttons("btnStop").Enabled = True
            bPerformingSearch = True
            bSearchCancelled = False
            BinaryFile = False