на этом сайте в библиотеке кодов в разделе интернета гдето был код как вытащить все емайлы и ссылки...

Ответить

Ответ на ваш вопрос был на http://sharig.webzone.ru/category/internet/inet19_getall_link_on_page.htm.

Но ссылка в данный момент на работает. Посему шлю сохраненную статью.
Как вытащить все ссылки из htm-страницы

В одном из многочисленных примеров по работе с компонентом WebBrowser я натолкнулся на пример, как можно вытащить все ссылки из любого *.htm файла, находящегося как в интернете, так и локально на жестком диске. Честно говоря, моя жизнь после нахождения данного примера очень облегчилась, поскольку я часто работаю с инетом, со ссылками.

Нажатие на первую кнопку покажет, как можно вытащить все ссылки из файла, а нажатие на вторую кнопку - как можно вытащить ссылки только определенного типа.

Но для начала вам надо установить через меню Project | References ссылку на Microsoft Internet Control.

Также вам необходимо расположить на форме 2 элемента CommandButton и элемент ListBox.

Private IEBroj1 As SHDocVw.InternetExplorer
Private Sub Form_Load()
Set IEBroj1 = New SHDocVw.InternetExplorer
End Sub
Private Sub Form_Unload(Cancel As Integer)
IEBroj1.Quit
Set IEBroj1 = Nothing
End
End Sub

Function Delay(Pause As Single)
Dim Start As Single
Start = Timer
Do While Timer < Start + Pause
DoEvents
Loop
End Function

Private Sub Command1_Click()
List1.Clear
Dim x
IEBroj1.Navigate "C:\1\index.htm"
Delay 3 'задержа необходима для загрузки страницы
'иногда требуется увеличить время загрузки до 30 секунд.
For i = 1 To IEBroj1.Document.links.length - 1
List1.AddItem IEBroj1.Document.links(i).href
Next
End Sub

Private Sub Command2_Click()
List1.Clear
Dim x
IEBroj1.Navigate "C:\1\index.htm"
Delay 3
For i = 1 To IEBroj1.Document.links.length - 1
If InStr(1, IEBroj1.Document.links(i).href, ".asp") <> 0 Or InStr(1, IEBroj1.Document.links(i).href, ".htm") <> 0 Then
List1.AddItem IEBroj1.Document.links(i).href
End If
Next
End Sub 
ПРИМЕР 2: Расположите на форме элемент CommandButton и элемент ListBox. 
Dim X, Y, St1, St2, tmpY As Integer

Private Sub Command1_Click()
StripEmail ("D:\vbcode\index.htm")
List1.AddItem "=============="
StripURL ("D:\vbcode\index.htm")
End Sub

Public Sub StripEmail(FilePath As String)
Dim tmpEmail1, tmpEmail2 As String
Open FilePath For Input As #1
Do Until EOF(1)
Input #1, tmpEmail1
For X = 1 To Len(tmpEmail1)
tmpEmail2 = Mid(tmpEmail1, X, 7)
If tmpEmail2 = "mailto:" Then
St1 = X
tmpY = X + 1
For Y = 1 To Len(tmpEmail1)
tmpEmail2 = Mid(tmpEmail1, tmpY, 1)
If tmpEmail2 = Chr(34) Then
St2 = tmpY
tmpEmail2 = Mid(tmpEmail1, St1 + 7, ((St2 - St1) - 7))
If (Left(tmpEmail2, 2) <> "//") And (Left(tmpEmail2, 1) <> " ") Then
List1.AddItem tmpEmail2
Exit For
End If
End If
tmpY = tmpY + 1
Next Y
End If
Next X
Loop
Close #1
End Sub

Public Sub StripURL(FilePath As String)
Dim tmpURL1, tmpURL2 As String
Open FilePath For Input As #1
Do Until EOF(1)
Input #1, tmpURL1
For X = 1 To Len(tmpURL1)
tmpURL2 = Mid(tmpURL1, X, 7)
If tmpURL2 = "http://" Then
St1 = X
tmpY = X
For Y = 1 To Len(tmpURL1)
tmpURL2 = Mid(tmpURL1, tmpY, 1)
If tmpURL2 = Chr(34) Then
St2 = tmpY
List1.AddItem Mid(tmpURL1, St1, ((St2 - St1)))
Exit For
Else
tmpY = tmpY + 1
End If
Next Y
End If
Next X
Loop
Close #1
End Sub

Ответить