He hecho muchos cambios pero no me aclaro... os dejo el código.
Código PHP:
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 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 Function
ResolveError:
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
Donde pone href he puesto src pero... haber si me podéis ayudar.