Dim sitioweb As String
Dim done As Integer 'sites scanned
Dim halt As Boolean, restart As Boolean
Sub Startspider()
'funcion principal del programa
Dim i As Integer 'index
Dim siteanalisis As String 'string containig the site analisis of adsenses
MsgBox "sites to scan " & List1.ListCount
For i = done To List1.ListCount
DoEvents 'le puse este doevents pa q no c trabe
sitioweb = List1.List(i - 1) 'obtengo un sitio web de la lista cargada
Text2.Text = sitioweb
rtf.Text = OpenURL(sitioweb) 'obtengo el codigo html del sitio web
If halt = True Then 'maneja el pausa de la aplicacion
done = i 'guarda el estado donde queda n pausa
Exit Sub
End If
siteanalisis = analizepage(rtf.Text, i) 'mando ha buscar el numeroc pub del google adsense
If siteanalisis <> "" Then Print #2, siteanalisis
siteanalisis = ""
Label3.Caption = CStr(Format$(i / List1.ListCount * 100, "###.##")) & "%"
'Call SlowDown(1000)
Next i
Close #2
Text2.Text = "C:\spiderN.txt"
MsgBox "Pub numbers Seaarch finish!", vbInformation
End Sub
Function analizepage(ByVal html As String, ByVal i As Integer) As String
Dim s, e As Variant 'position
Dim pub As String 'pub of google adsense
If InStr(html, "google_ad_client = ") > 0 Then
s = InStr(InStr(html, "google_ad_client = "), html, "pub-")
e = InStr(s + 4, html, ";") - 3
pub = "G,"
pub = pub & Mid(html, s + 4, e - s - 2)
pub = pub & "," & List1.List(i - 1)
analizepage = pub
End If
If InStr("yahoo_ad_client = """"pub-", html) Then 'yahhoo
End If
End Function
Private Function OpenURL(ByVal sUrl As String) As String
'****************************************************
'PURPOSE: Returns Contents (including all HTML) from
' a web page
'PARAMETER: sURL (e.g., http://www33.websamba.com/iglesiadc)
'RETURN VALUE: Contents of requested page, or
' empty string if sURL is not available
'COMMENTS: This is an alternative to using the Internet Transfer
' Control 's OpenURL method. That control has a bug
' Whereby not all the contents of the page will be
' returned in certain circumstances
'*****************************************************
Dim hOpen As Long
Dim hOpenUrl As Long
Dim bDoLoop As Boolean
Dim bRet As Boolean
Dim sReadBuffer As String * 2048
Dim lNumberOfBytesRead As Long
Dim sBuffer As String
hOpen = InternetOpen(scUserAgent, INTERNET_OPEN_TYPE_PRECONFIG, _
vbNullString, vbNullString, 0)
hOpenUrl = InternetOpenUrl(hOpen, sUrl, vbNullString, 0, _
INTERNET_FLAG_RELOAD, 0)
bDoLoop = True
While bDoLoop
DoEvents 'le puse este doevents pa q no c trabe
sReadBuffer = vbNullString
bRet = InternetReadFile(hOpenUrl, sReadBuffer, _
Len(sReadBuffer), lNumberOfBytesRead)
sBuffer = sBuffer & Left$(sReadBuffer, _
lNumberOfBytesRead)
If Not CBool(lNumberOfBytesRead) Then bDoLoop = False
Wend
If hOpenUrl <> 0 Then InternetCloseHandle (hOpenUrl)
If hOpen <> 0 Then InternetCloseHandle (hOpen)
OpenURL = sBuffer
End Function
