|
-
Sep 1st, 2000, 08:59 AM
#29
Thread Starter
Frenzied Member
I use this Function from the book SAMS Teach Yourself Internet Programming with Visual Basic 6 in 21 days so all credits go to them, they rule I don't and I really recommend this book. (Ok enough commercial brabbling)
Code:
Option Explicit
Public Function GetLinks(s As String, baseUrl As String)
Dim pos As Long, pos1 As Long, pos2 As Long
Dim buf As String, temp As String
Dim sq As String, dq As String
Dim qc As String, Start As Long
buf = ""
'Make sure a nonempty string has been passed.
If s = Null Or Len(s) = 0 Then
GetLinks = buf
Exit Function
End If
'Make sure there is at least one link
Start = InStr(1, s, "<a href=", vbTextCompare)
If Start = 0 Then
GetLinks = buf
Exit Function
End If
'Define the single
dq = Chr$(34)
sq = Chr$(39)
Do
'get the first Dq or Sq
pos = InStr(Start, s, dq, vbTextCompare)
pos2 = InStr(Start, s, sq, vbTextCompare)
If pos = 0 And pos2 = 0 Then Exit Do 'Nothing found
If pos > 0 And pos2 > 0 Then
If pos < pos2 Then 'It's a Dq
qc = dq
Else
qc = sq
pos = pos2
End If
ElseIf pos = 0 Then 'Only Signle
qc = sq
pos = pos2
ElseIf pos2 = 0 Then
qc = dq
End If
pos1 = InStr(pos + 1, s, qc, vbTextCompare)
If pos1 = 0 Then Exit Do
temp = Mid$(s, pos + 1, pos1 - pos - 1)
'Forget about FTP and Mailto links
If LCase(Left(temp, 7)) = "mailto:" Or LCase(Left(temp, 3)) = "ftp" Then
GoTo DoNotAdd
End If
'See if it's a full URL, if not add the base Url
If LCase(Left(temp, 7)) <> "http://" Then
temp = baseUrl & temp
End If
'Strip off anything following a # or ?
pos = InStr(1, temp, "#")
If pos > 0 Then
temp = Left(temp, pos - 1)
End If
pos = InStr(1, temp, "?")
If pos > 0 Then
temp = Left(temp, pos - 1)
End If
buf = buf & temp & "|"
DoNotAdd:
'Locate the next link
pos = InStr(pos1, s, "<a href=", vbTextCompare)
Start = pos
'If there a no more links then quit
If pos = 0 Then Exit Do
DoEvents
Loop While True
'Strip off the trailing |
GetLinks = Left(buf, Len(buf) - 1)
'MsgBox buf
End Function
Hope it's of use for someone.
Again, all respect, flowers, presents, money, kisses, pies and ofcourse the new ferrari goes to the great [/i]Peter Aitken[/i], the author of the book Sams Teach Yourself Internet Programming with VB6 in 21 days! BUY IT!!!
Jop - validweb.nl
Alcohol doesn't solve any problems, but then again, neither does milk.
Posting Permissions
- You may not post new threads
- You may not post replies
- You may not post attachments
- You may not edit your posts
-
Forum Rules
|
Click Here to Expand Forum to Full Width
|