这是个不断的抓links 的例子-大家帮忙看！

Question

Option Explicit
Option Compare TextConst 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 BooleanPublic Function TrimPage(ByVal Address As String) As String
  Do While Right$(Address, 1) <> "/"
    Address = Left$(Address, Len(Address) - 1)
  Loop
  TrimPage = Address
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)
  End If
  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 FunctionResolveError:
  ResolvedSite = False
  MsgBox "Unable to resolve parent site!"
End Function
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
    frmSearching.lblCaption.Width = frmSearching.lblSite.Width
    frmSearching.Width = frmSearching.lblCaption.Width + 435
  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 Sub AddLink(LinktoAdd As String)
  Dim FoundPos As Integer
    
  FoundPos = 0
  FoundPos = frmWanderer.rtbLinkNames.Find(LinktoAdd, FoundPos)
  If FoundPos <> -1 Then                'the phrase was found.
    Exit Sub
  Else
    frmWanderer.rtbLinkNames.Text = frmWanderer.rtbLinkNames.Text & LinktoAdd & NewLine
  End If
End Sub
Public Function Parse() As Boolean
  Dim PositionInString As Long, Response As Integer, ThisLinkLength As Integer
  Dim End_Of_List As Boolean, NewFileName As String, GotFile As Boolean, Parent As String
  Dim Done As Boolean, Tag As String, lclTag As String, AddToFileString As String, RelativeAddress As Boolean
  Dim lclTag_Length As Integer, I As Integer, FirstQuote As Integer, SecondQuote As Integer
  
  End_Of_List = False
  PositionInString = 0
  Done = False
  If Not Initialize_OutputFile() Then Exit Function
  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 site!"
          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
    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 page. Moving on to next page. 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
'    frmWanderer.rtbLinkNames.Text = AddToFileString
  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) = "<" And 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
Public Function Initialize_OutputFile() As Boolean
  If Dir(App.Path & OUT_FILE) <> "" Then
    On Error Resume Next
    Kill App.Path & OUT_FILE
    If Err.Number <> 0 Then
      MsgBox "Unable to open output file.", vbCritical
      Initialize_OutputFile = False
      Exit Function
    End If
  End If
  Open App.Path & OUT_FILE For Append As #1
  Close #1
  Initialize_OutputFile = True
  Exit Function
End Function

Answer 1

* forwander.from 代码
Private Sub cmdExit_Click()
  Unload Me
End SubPrivate Sub cmdGoWander_Click()
  StopSearching = False
  rtbLinkNames.Text = ""
  On Error Resume Next
  Close #1
  On Error GoTo 0
  ' Open CurDir & "\HTTPFILE.TXT" For Append As #1
  Current_Pos = 1
  Me.MousePointer = vbArrowHourglass
  cmdGoWander.Enabled = False
  cmdStopWandering.Enabled = True
  If Get_File(txtSite.Text) Then
    If Not Parse Then
      Me.MousePointer = vbNormal
      cmdGoWander.Enabled = True
      cmdStopWandering.Enabled = False
      Exit Sub
    End If
  Else
    Me.MousePointer = vbNormal
    MsgBox "Unable to find the desired site."
  End If
  cmdGoWander.Enabled = True
  cmdStopWandering.Enabled = False
  Me.MousePointer = vbNormal
  StopSearching = True
End SubPrivate Sub cmdStopWandering_Click()
  StopSearching = True
End SubPrivate Sub Form_Load()
  txtSite.Text = "http://www.jamsa.com/jamsa1.htm"
  NewLine = Chr(13) & Chr(10)
  StopSearching = True
  cmdStopWandering.Enabled = False
End SubPrivate Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
  Dim Response As Integer
  
  If Not StopSearching Then
    Response = MsgBox("Stop search and lose updated file?", vbYesNo)
    If Response = vbNo Then
      Cancel = 1
      Exit Sub
    End If
  Else
    Response = MsgBox("Close program?", vbYesNo)
    If Response = vbNo Then
      Cancel = 1
      Exit Sub
    End If
  End If
  itcWander.Cancel
End SubPrivate Sub Form_Unload(Cancel As Integer)
  Unload frmSearching
  Unload frmParsing
End SubPrivate Sub itcWander_StateChanged(ByVal State As Integer)
  Dim strMess As String ' Message variable.
  
  DoEvents
  Select Case State
    Case 1                    'Resolving host
      Connected = False
  
    Case icConnected
      Connected = True
      
    Case State = icError
      strMess = "ErrorCode: " & itcWander.ResponseCode & " : " & itcSearch.ResponseInfo
      MsgBox strMess, vbOKOnly
      itcWanderSearchError = True
    End Select
End Sub

Answer 2

整个项目工程里面有3个frm :  frmparsing.frm; frmsearching.frm;frmwander.frm 一个模快: mblwanderer.basinternet control 6.0 & richtextbox control 有时候运行好用，有时候不好用输入地址时候必须是http 开始里面的连接如果长了或着带着多的? 就不会玩 再就是带有unicode 的地址连接就不行了大家帮忙看看-帮忙改改，需要的人还可以学习学习

Answer 3

能把源代码发一份给我吗 谢了
[email protected]