mdlWanderer.bas
上传用户:ynjin1970
上传日期:2014-10-13
资源大小:6438k
文件大小:7k
源码类别:

中间件编程

开发平台:

Visual C++

  1. Attribute VB_Name = "mdlWanderer"
  2. Option Explicit
  3. Option Compare Text
  4. Const TAG_LENGTH% = 1000
  5. Const OUT_FILE = "taglist.txt"
  6. Public Current_pos As Long
  7. Public Tag As String
  8. Public Real_File_Name As String
  9. Public File_Name As String
  10. Public Site As String
  11. Public Location As String
  12. Public Site_Length As Integer
  13. Public NewLine As String
  14. Public SiteContents As String
  15. Public inetSearchError As Boolean, stopSearching As Boolean
  16. Public Function Get_File(ByVal txtURL As String) As Boolean
  17. frmSearching.Hide
  18. frmSearching.lblsite.Caption = txtURL
  19. If Len(txtURL) > 40 Then
  20.     frmSearching.lblsite.Width = Len(txtURL) * 73
  21. End If
  22. frmSearching.Show
  23. DoEvents
  24. Real_File_Name = txtURL
  25. Site = Real_File_Name
  26. Site_Length = Len(Site)
  27. inetSearchError = False
  28. frmWanderer.itcWander.RequestTimeout = 60
  29. frmWanderer.itcWander.AccessType = icUseDefault
  30. On Error Resume Next
  31. SiteContents = frmWanderer.itcWander.OpenURL(txtURL, icString)
  32. Unload frmSearching
  33. DoEvents
  34. If Err.Number <> 0 And Not inetSearchError Then
  35. Get_File = False
  36. Exit Function
  37. End If
  38. Get_File = True
  39. End Function
  40. Public Function parse() As Boolean
  41. On Error Resume Next
  42. Dim positionInString As Long, ResPonse As Integer, ThisLinklength As Integer
  43. Dim End_of_List As Boolean, NewFileName As String, GotFile As Boolean
  44. Dim Parent As String, Tag As String, lClTag As String, AddToFilestring As String
  45. Dim Done As Boolean, RelativeAddress As Boolean
  46. Dim lclTag_Length As Integer, I As Integer
  47. Dim FirstQuote As Integer, SecondQuote As Integer
  48.  
  49.     End_of_List = False
  50.     positionInString = 0
  51.     Done = False
  52.  Do While Not End_of_List And Not stopSearching
  53.     Current_pos = 1
  54.     Done = Get_Tag(Tag)
  55.     Do While Not Done And Not stopSearching
  56.         frmparsing.Show
  57.         DoEvents
  58.         lClTag = Tag
  59.         lclTag_Length = Len(Tag)
  60.         FirstQuote = 0
  61.         SecondQuote = 0
  62.         If InStr(lClTag, "href") Then
  63.             Do While Left$(lClTag, 4) <> "href"
  64.                 lClTag = Right$(lClTag, Len(lClTag) - 1)
  65.             Loop
  66.             If Not InStr(lClTag, ": :") Then
  67.                  RelativeAddress = True
  68.             Else
  69.                 RelativeAddress = False
  70.             End If
  71.             For I = 1 To lclTag_Length
  72.                 If Mid$(lClTag, I, 1) = Chr(34) Then
  73.                     If FirstQuote <> 0 Then
  74.                         SecondQuote = I
  75.                     Exit For
  76.                     Else
  77.                        FirstQuote = I + 1
  78.                     End If
  79.                 End If
  80.             Next
  81.                  AddToFilestring = Mid$(lClTag, FirstQuote, (SecondQuote - FirstQuote))
  82.             If InStr(AddToFilestring, "://") Then
  83.                     AddLink (AddToFilestring)
  84.             Else
  85.                 If Not Resolvedsite(Site, Parent, AddToFilestring) Then
  86.                       frmparsing.Hide
  87.                       MsgBox "unable to resolve sitel"
  88.                 Else
  89.                       AddLink (Parent & AddToFilestring)
  90.                 End If
  91.             End If
  92.         End If
  93.         Done = Get_Tag(Tag)
  94.         DoEvents
  95.     Loop
  96.     frmparsing.Hide
  97.     If Done Then
  98.         If Len(frmWanderer.rtbLinkNames.Text) > 0 Then
  99.             frmWanderer.rtbLinkNames.SaveFile App.Path & OUT_FILE, rtfText
  100.             GotFile = False
  101.         Else
  102.             ResPonse = MsgBox("are you sure you want to stop search?", vbYesNo)
  103.             If ResPonse = vbYes Then
  104.                 frmWanderer.rtbLinkNames.SaveFile App.Path & OUT_FILE, rtfText
  105.                 frmWanderer.itcWander.Cancel
  106.                 parse = Not stopSearching
  107.             Exit Function
  108.             End If
  109.         End If
  110.     End If
  111.             DoEvents
  112.         Do Until GotFile Or stopSearching
  113.             If positionInString < Len(frmWanderer.rtbLinkNames.Text) Then
  114.                 ThisLinklength = 0
  115.                 If positionInString = 0 Then positionInString = 1
  116.                     Do While Mid$(frmWanderer.rtbLinkNames.Text, positionInString + ThisLinklength, 1) <> Chr(10)
  117.                         ThisLinklength = ThisLinklength + 1
  118.                         DoEvents
  119.                     Loop
  120.                     NewFileName = Mid$(frmWanderer.rtbLinkNames.Text, positionInString, ThisLinklength - 1)
  121.                         If Left$(NewFileName, 6) <> "mailto" Then
  122.                             positionInString = positionInString + ThisLinklength + 1
  123.                             ThisLinklength = 0
  124.                             If Not Get_File(NewFileName) Then
  125.                                 MsgBox "error opening pags.moving on to next pag.bad page" & NewFileName
  126.                                 GotFile = False
  127.                             Else
  128.                                 GotFile = True
  129.                             End If
  130.                         Else
  131.                             GotFile = False
  132.                         End If
  133.                 Else
  134.                     GotFile = True
  135.                     End_of_List = True
  136.                 End If
  137.             
  138.     
  139.         DoEvents
  140.      Loop
  141.   Loop
  142.     
  143.     parse = Not stopSearching
  144. End Function
  145. Public Function Get_Tag(Returntag As String) As Boolean
  146. Returntag = ""
  147. Get_Tag = False
  148. Do While Current_pos < Len(SiteContents)
  149.    If Mid(SiteContents, Current_pos + 1, 1) = "A" Then
  150.    Dim Local_I As Integer
  151.    Local_I = 1
  152.    Do While Mid(SiteContents, Current_pos + Local_I, 1) <> ">"
  153.         If Local_I < TAG_LENGTH Then
  154.             Returntag = Returntag & Mid(SiteContents, Current_pos + Local_I, 1)
  155.         End If
  156.         Local_I = Local_I + 1
  157.     Loop
  158.     Current_pos = Current_pos + Local_I
  159.     Exit Function
  160.   End If
  161.   Current_pos = Current_pos + 1
  162.   Loop
  163.   Get_Tag = True
  164.   End Function
  165. Private Function Resolvedsite(FileAddr As String, Parent As String, NewTag As String) As Boolean
  166. On Error GoTo resolveerror
  167. Resolvedsite = True
  168. Parent = FileAddr
  169. If Right$(Parent, 1) <> "/" Then
  170. Parent = TrimPage(Parent)
  171. End If
  172. If Left$(NewTag, 3) <> "../" And Left$(NewTag, 5) <> "http:" Then
  173. Exit Function
  174. End If
  175. If Left$(NewTag, 6) <> "http:/" And Left$(NewTag, 7) <> "http://" Then
  176.     NewTag = Right$(NewTag, Len(NewTag) - 6)
  177.     Do While Left$(NewTag, 3) = "../"
  178.      NewTag = Right$(NewTag, Len(NewTag) - 3)
  179.      Parent = Left(Parent, Len(Parent) - 1)
  180.      Do While Right$(Parent, 1) <> "/"
  181.       Parent = Left$(Parent, Len(Parent) - 1)
  182.      Loop
  183.     Loop
  184. Exit Function
  185. End If
  186. resolveerror:
  187.     Resolvedsite = False
  188.     MsgBox "unable to resolve parent site!"
  189.      
  190. End Function
  191. Public Function TrimPage(ByVal Address As String) As String
  192. Do While Right$(Address, 1) <> "/"
  193.     Address = Left$(Address, Len(Address) - 1)
  194. Loop
  195. TrimPage = Address
  196. End Function
  197. Public Sub AddLink(LinktoAdd As String)
  198. On Error Resume Next
  199. Dim Foundpos, Foundpos1 As Integer
  200. Dim STr, STr1 As String
  201. STr = frmWanderer.Text1.Text
  202. frmWanderer.itcWander.RequestTimeout = 6
  203. frmWanderer.itcWander.AccessType = icUseDefault
  204. STr1 = frmWanderer.itcWander.OpenURL(LinktoAdd, icString)
  205. If InStr(STr1, STr) Then
  206.         Foundpos1 = 0
  207.         Foundpos1 = frmWanderer.RichTextSearch.Find(LinktoAdd, Foundpos1)
  208.     If Foundpos1 = -1 Then
  209.         frmWanderer.RichTextSearch.Text = frmWanderer.RichTextSearch.Text & LinktoAdd & NewLine
  210.     End If
  211. End If
  212.        Foundpos = 0
  213.        Foundpos = frmWanderer.rtbLinkNames.Find(LinktoAdd, Foundpos)
  214.     If Foundpos <> -1 Then
  215.          Exit Sub
  216.     Else
  217.         frmWanderer.rtbLinkNames.Text = frmWanderer.rtbLinkNames.Text & LinktoAdd & NewLine
  218.     End If
  219. End Sub