Ver Mensaje Individual
  #1 (permalink)  
Antiguo 04/05/2003, 16:56
Avatar de yampoo
yampoo
 
Fecha de Ingreso: noviembre-2001
Ubicación: Vilanova i la Geltrú
Mensajes: 1.942
Antigüedad: 23 años, 4 meses
Puntos: 0
En vez de que busque href (enlaces) busque src (imágenes)

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 BooleanStopSearching As Boolean

Public Function TrimPage(ByVal Address As String) As String
  
Do While Right$(Address1) <> "/"
    
Address Left$(AddressLen(Address) - 1)
  
Loop
  TrimPage 
Address
End 
Function
Private Function 
ResolvedSite(FileAddr As StringParent As StringNewTag 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 LongResponse As IntegerThisLinkLength As Integer
  Dim End_Of_List 
As BooleanNewFileName As StringGotFile As BooleanParent As String
  Dim Done 
As BooleanTag As StringlclTag As StringAddToFileString As StringRelativeAddress As Boolean
  Dim lclTag_Length 
As IntegerAs IntegerFirstQuote As IntegerSecondQuote 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$(lclTag4) <> "href"
          
lclTag Right$(lclTagLen(lclTag) - 1)
        
Loop
        
If Not InStr(lclTag"::"Then
          RelativeAddress 
True
        
Else
          
RelativeAddress False
        End 
If
        For 
1 To lclTag_Length
          
If Mid$(lclTagI1) = Chr(34Then
            
If FirstQuote <> 0 Then
              SecondQuote 
I
              
Exit For
            Else
              
FirstQuote 1
            End 
If
          
End If
        
Next
        AddToFileString 
Mid$(lclTagFirstQuoteSecondQuote FirstQuote)
        If 
InStr(AddToFileString"://"Then
          AddLink 
(AddToFileString)
        Else
          If 
Not ResolvedSite(SiteParentAddToFileStringThen
              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_FILErtfText
      GotFile 
False
    
Else
      
Response MsgBox("Are you sure you want to stop search?"vbYesNo)
      If 
Response vbYes Then
        frmWanderer
.rtbLinkNames.SaveFile App.Path OUT_FILErtfText
        frmWanderer
.itcWander.Cancel
        Parse 
Not StopSearching
        
Exit Function
      
End If
    
End If
    
DoEvents
    
Do Until GotFile Or StopSearching
      
If PositionInString Len(frmWanderer.rtbLinkNames.TextThen
        ThisLinkLength 
0
        
If PositionInString 0 Then PositionInString 1
        
Do While Mid$(frmWanderer.rtbLinkNames.TextPositionInString ThisLinkLength1) <> Chr(10)
          
ThisLinkLength ThisLinkLength 1
          DoEvents
        Loop
        NewFileName 
Mid$(frmWanderer.rtbLinkNames.TextPositionInStringThisLinkLength 1)
        If 
Left$(NewFileName6) <> "mailto" Then
          PositionInString 
PositionInString ThisLinkLength 1
          ThisLinkLength 
0
          
If Not Get_File(NewFileNameThen
            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(SiteContentsCurrent_Pos1) = "<" And Mid(SiteContentsCurrent_Pos 11) = "A" Then
        Dim Local_I 
As Integer
        
        Local_I 
1
        
Do While Mid(SiteContentsCurrent_Pos Local_I1) <> ">"
          
If Local_I TAG_LENGTH Then
            ReturnTag 
ReturnTag Mid(SiteContentsCurrent_Pos Local_I1)
          
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.