mdlWanderer.bas
资源名称:08.zip [点击查看]
上传用户:ynjin1970
上传日期:2014-10-13
资源大小:6438k
文件大小:7k
源码类别:
中间件编程
开发平台:
Visual C++
- 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