StoreURL

Sub Main
 
   Const HTMLbufferfile As String = "C:\MijnTelefoonnummer.htm"
   Const Titel = "Checking number via internet"
 
   Dim MyURL As String, TelZoek As String
   Dim Hnd As Long, Buffer As String
   Dim TelNr As String, Naam As String
   Dim Adres As String, PCode As String, Plaats As String
   Dim Info As String, Fax As String
 
'Step 1: enter the phone number to be searched for
   Restart: TelZoek = ""
   Do While Not IsNumeric(TelZoek)
      TelZoek = InputBox$("Enter phone number:", Titel) 
      If Len(TelZoek) = 0 Then End
      If Len(TelZoek)<10 Then
         MsgBox "Telnr must be at least 10 digits!",vbExclamation, Titel
      End If
   Loop
 
 
 
'Step 2: valid number is entered, process in URL of website
   MyURL= "http://zoekopnummer.ath.cx/index.php?nummer=" & TelZoek
 
'Step 3: Run the URL and save the output to a file
   Internet.StoreURL MyURL, HTMLbufferfile
   DoEvents
 
'Step 4: read the file and place the contents In a buffer
   Hnd = FreeFile
   Open HTMLbufferfile For Binary Access Read As #Hnd
   Buffer = Space$(LOF(Hnd)) 
   Get #Hnd, , Buffer
   Close #Hnd
 
'Step 5: filter fields from the Buffer (are stored in TDs)
'        and repeat this until no more numbers are found
'        (as there can be multiple naw's attached to 1 number) 
   TelNr = FilterTD(Buffer, "telnr")
 
Volgende:
   Naam = FilterTD(Buffer, "naam", True) 
   Adres = FilterTD(Buffer, "adres", True)
   PCode = FilterTD(Buffer, "postcode", True) 
   Plaats = FilterTD(Buffer, "plaats", True)
   Info = FilterTD(Buffer, "info", True)
   Fax = FilterTD(Buffer, "fax", True)
 
   If Len(TelNr) >0 Then
      'found, then add the buffer
       MsgBox "Telefoon: " & TelNr & vbCrLf _
         & "Naam: " & Naam & vbCrLf _
         & "Adres: " & Adres & vbCrLf _
         & "Postcode: " & PCode & vbCrLf _
         & "Plaats: " & Plaats & vbCrLf _
         & "Info: " & Info & vbCrLf _
         & "Fax: " & Fax & vbCrLf & vbCrLf _
         & "(gedownload via internet)" , vbInformation _
         ,"Informatie gevonden!" 
 
      TelNr = FilterTD(Buffer, "telnr", True)
      If Len(TelNr) > 0 Then
         GoTo Volgende
      ElseIf MsgBox("Wilt u opnieuw zoeken?",vbQuestion + vbYesNo _
                     + vbDefaultButton2, Titel) = vbYes Then
         GoTo Restart
      End If
   Else
      If MsgBox("Er zijn geen telefoonnummers gevonden" & vbCrLf _
                & "Wilt u opnieuw zoeken?",vbExclamation + vbYesNo _
                + vbDefaultButton2, Titel) = vbYes Then
 
         GoTo Restart
      End If
   End If
 
 
End Sub
 
 
Function FilterTD(Buffer As String, FieldName As String _
                 , Optional Repeated As Boolean = False) As String
 
   Static Offset As Long
   Dim x As Long, y As Long, z As Long
 
   If Repeated= False Then Offset = 1
   FilterTD = ""
 
   'look up title field in the table definition of the web page
   x = InStr(Offset, LCase$(Buffer), "<td>" & LCase$(FieldName) & ":</td>")
   If x > 0 Then
      'found, search for the next column in the table
      y = InStr(x + 10, LCase$(Buffer), "<td>") 
      If y > 0 Then
        'found, then look up the end of the column 
        y = y + 4
        z = InStr(y, LCase$(Buffer), "</td>") 
        If z > 0 Then
           'gevonden, dan de data uit deze kolom filteren
           FilterTD = Mid$(Buffer$, y, z - y) 
           Offset = z + 5
        End If
      End If
    End If
 
End Function