mdlwanderer.bas

用VB5实现搜索功能

Attribute VB_Name = "mdlWanderer"
Option Explicit
Option Compare Text

Const TAG_LENGTH% = 1000
Const OUT_FILE = "\taglist.txt"
Public Current_pos As Long
Public Tag As String
Public Real_File_Name As String
Public File_Name As String
Public Site As String
Public Location As String
Public Site_Length As Integer
Public NewLine As String
Public SiteContents As String
Public inetSearchError As Boolean, stopSearching As Boolean
Public Function Get_File(ByVal txtURL As String) As Boolean
frmSearching.Hide
frmSearching.lblsite.Caption = txtURL
If Len(txtURL) > 40 Then
    frmSearching.lblsite.Width = Len(txtURL) * 73
End If
frmSearching.Show
DoEvents
Real_File_Name = txtURL
Site = Real_File_Name
Site_Length = Len(Site)
inetSearchError = False
frmWanderer.itcWander.RequestTimeout = 60
frmWanderer.itcWander.AccessType = icUseDefault
On Error Resume Next
SiteContents = frmWanderer.itcWander.OpenURL(txtURL, icString)
Unload frmSearching
DoEvents
If Err.Number <> 0 And Not inetSearchError Then
Get_File = False
Exit Function
End If
Get_File = True
End Function
Public Function parse() As Boolean
On Error Resume Next
Dim positionInString As Long, ResPonse As Integer, ThisLinklength As Integer
Dim End_of_List As Boolean, NewFileName As String, GotFile As Boolean
Dim Parent As String, Tag As String, lClTag As String, AddToFilestring As String
Dim Done As Boolean, RelativeAddress As Boolean
Dim lclTag_Length As Integer, I As Integer
Dim FirstQuote As Integer, SecondQuote As Integer
 
    End_of_List = False
    positionInString = 0
    Done = False
 Do While Not End_of_List And Not stopSearching
    Current_pos = 1
    Done = Get_Tag(Tag)
    Do While Not Done And Not stopSearching
        frmparsing.Show
        DoEvents
        lClTag = Tag
        lclTag_Length = Len(Tag)
        FirstQuote = 0
        SecondQuote = 0
        If InStr(lClTag, "href") Then
            Do While Left$(lClTag, 4) <> "href"
                lClTag = Right$(lClTag, Len(lClTag) - 1)
            Loop
            If Not InStr(lClTag, ": :") Then
                 RelativeAddress = True
            Else
                RelativeAddress = False
            End If
            For I = 1 To lclTag_Length
                If Mid$(lClTag, I, 1) = Chr(34) Then
                    If FirstQuote <> 0 Then
                        SecondQuote = I
                    Exit For
                    Else
                       FirstQuote = I + 1
                    End If
                End If
            Next
                 AddToFilestring = Mid$(lClTag, FirstQuote, (SecondQuote - FirstQuote))
            If InStr(AddToFilestring, "://") Then
                    AddLink (AddToFilestring)
            Else
                If Not Resolvedsite(Site, Parent, AddToFilestring) Then
                      frmparsing.Hide
                      MsgBox "unable to resolve sitel"
                Else
                      AddLink (Parent & AddToFilestring)
                End If
            End If
        End If
        Done = Get_Tag(Tag)
        DoEvents
    Loop
    frmparsing.Hide
    If Done Then
        If Len(frmWanderer.rtbLinkNames.Text) > 0 Then
            frmWanderer.rtbLinkNames.SaveFile App.Path & OUT_FILE, rtfText
            GotFile = False
        Else
            ResPonse = MsgBox("are you sure you want to stop search?", vbYesNo)
            If ResPonse = vbYes Then
                frmWanderer.rtbLinkNames.SaveFile App.Path & OUT_FILE, rtfText
                frmWanderer.itcWander.Cancel
                parse = Not stopSearching
            Exit Function
            End If
        End If
    End If
            DoEvents
        Do Until GotFile Or stopSearching
            If positionInString < Len(frmWanderer.rtbLinkNames.Text) Then
                ThisLinklength = 0
                If positionInString = 0 Then positionInString = 1
                    Do While Mid$(frmWanderer.rtbLinkNames.Text, positionInString + ThisLinklength, 1) <> Chr(10)
                        ThisLinklength = ThisLinklength + 1
                        DoEvents
                    Loop
                    NewFileName = Mid$(frmWanderer.rtbLinkNames.Text, positionInString, ThisLinklength - 1)
                        If Left$(NewFileName, 6) <> "mailto" Then
                            positionInString = positionInString + ThisLinklength + 1
                            ThisLinklength = 0
                            If Not Get_File(NewFileName) Then
                                MsgBox "error opening pags.moving on to next pag.bad page" & NewFileName
                                GotFile = False
                            Else
                                GotFile = True
                            End If
                        Else
                            GotFile = False
                        End If
                Else
                    GotFile = True
                    End_of_List = True
                End If
            
    
        DoEvents
     Loop
  Loop
    
    parse = Not stopSearching
End Function
Public Function Get_Tag(Returntag As String) As Boolean
Returntag = ""
Get_Tag = False
Do While Current_pos < Len(SiteContents)
   If Mid(SiteContents, Current_pos + 1, 1) = "A" Then
   Dim Local_I As Integer
   Local_I = 1
   Do While Mid(SiteContents, Current_pos + Local_I, 1) <> ">"
        If Local_I < TAG_LENGTH Then
            Returntag = Returntag & Mid(SiteContents, Current_pos + Local_I, 1)
        End If
        Local_I = Local_I + 1
    Loop
    Current_pos = Current_pos + Local_I
    Exit Function
  End If
  Current_pos = Current_pos + 1
  Loop
  Get_Tag = True
  End Function
Private Function Resolvedsite(FileAddr As String, Parent As String, NewTag As String) As Boolean
On Error GoTo resolveerror
Resolvedsite = True
Parent = FileAddr
If Right$(Parent, 1) <> "/" Then
Parent = TrimPage(Parent)
End If

If Left$(NewTag, 3) <> "../" And Left$(NewTag, 5) <> "http:" Then
Exit Function
End If

If Left$(NewTag, 6) <> "http:/" And Left$(NewTag, 7) <> "http://" Then
    NewTag = Right$(NewTag, Len(NewTag) - 6)
    Do While Left$(NewTag, 3) = "../"
     NewTag = Right$(NewTag, Len(NewTag) - 3)
     Parent = Left(Parent, Len(Parent) - 1)
     Do While Right$(Parent, 1) <> "/"
      Parent = Left$(Parent, Len(Parent) - 1)
     Loop
    Loop
Exit Function
End If
resolveerror:
    Resolvedsite = False
    MsgBox "unable to resolve parent site!"
     
End Function
Public Function TrimPage(ByVal Address As String) As String
Do While Right$(Address, 1) <> "/"
    Address = Left$(Address, Len(Address) - 1)
Loop
TrimPage = Address
End Function
Public Sub AddLink(LinktoAdd As String)
On Error Resume Next
Dim Foundpos, Foundpos1 As Integer
Dim STr, STr1 As String
STr = frmWanderer.Text1.Text
frmWanderer.itcWander.RequestTimeout = 6
frmWanderer.itcWander.AccessType = icUseDefault
STr1 = frmWanderer.itcWander.OpenURL(LinktoAdd, icString)
If InStr(STr1, STr) Then
        Foundpos1 = 0
        Foundpos1 = frmWanderer.RichTextSearch.Find(LinktoAdd, Foundpos1)
    If Foundpos1 = -1 Then
        frmWanderer.RichTextSearch.Text = frmWanderer.RichTextSearch.Text & LinktoAdd & NewLine
    End If
End If
       Foundpos = 0
       Foundpos = frmWanderer.rtbLinkNames.Find(LinktoAdd, Foundpos)
    If Foundpos <> -1 Then
         Exit Sub
    Else
        frmWanderer.rtbLinkNames.Text = frmWanderer.rtbLinkNames.Text & LinktoAdd & NewLine
    End If

End Sub