Svar: [AccessD] A2003:Test Voracity of URLS

MartyConnelly martyconnelly at shaw.ca
Wed Nov 17 17:33:39 CST 2004


Here is the rest of the basic routines takes a couple of minutes for 
10000 favourites
I was amazed I only had 100 duplicates.
I used to dump to an xml file of favourites that I could cart around.

Just create a table to hold all your favourite url's
with 3 text fields 255 long to hold directory path and filename
1 numeric field for file length
1 date field
1 memo field to hold http url, it will go longer than 255 characters for 
things like google addresses

'temporary database
Dim MyDb As DATABASE
Dim MyRs As Recordset

' findsub "C:\Documents and Settings\marty\Favorites\", "*url"
Sub testgrab()
Set MyDb = CurrentDb
Set MyRs = MyDb.OpenRecordset("TempURL")
 FindSub "C:\Documents and Settings\marty\Favorites\", "*url"
Set MyRs = Nothing
Set MyDb = Nothing
End Sub

Sub FindSub(strStart As String, strFindWhat As String)
Dim arrFindDir() As String
Dim strFind As String
Dim i As Long

ChDrive (Left(strStart, 3))
ChDir (strStart)

Call DirSub(strFindWhat, strStart)

strFind = Dir("*.*", vbDirectory)
i = 0

Do Until strFind = ""
ReDim Preserve arrFindDir(i)
   arrFindDir(i) = strFind
   i = i + 1
   strFind = Dir()
Loop

For i = 0 To UBound(arrFindDir)
  If Dir(arrFindDir(i), vbNormal) = "" And Left(arrFindDir(i), 1) <> "." 
Then

   ' Recursive call
   Call FindSub(strStart & arrFindDir(i) & "\", strFindWhat)
   ChDir (strStart)
  End If
Next
End Sub
Sub DirSub(strFindWhat, strStart)
Dim strFindfile As String
Dim strFullPathName As String
'temporary database
'Dim MyDb As DATABASE
'Dim MyRs As Recordset
'Set MyDb = CurrentDb
'Set MyRs = MyDb.OpenRecordset("TempURL")
strFindfile = Dir(strFindWhat, vbNormal)
Do While strFindfile <> ""
'Debug.Print strStart & " - " & strFindfile
  '.lstFiles.AddItem strStart & strFindfile
   '  colMyList.Add strStart & strFindfile
   strFullPathName = strStart & strFindfile
   Debug.Print Len(strFullPathName) & "-" & strFullPathName
     MyRs.AddNew
            MyRs!Dirnaam = strStart
            MyRs!FileNaam = strFullPathName
            MyRs!file = strFindfile
            On Error Resume Next 'Weird url filename problems here that 
are dos illegal because of  "?" characters
                                                 ' you can pick out of 
table as they will have no filelength.
            MyRs!FileLen = FileLen(strFullPathName)
            MyRs!datTime = FileDateTime(strFullPathName)
            MyRs!Http = GetHTTPfromURL(strFullPathName)
            On Error GoTo 0
     MyRs.Update
  
  strFindfile = Dir()
Loop
'Set MyRs = Nothing
'Set MyDb = Nothing
End Sub

MartyConnelly wrote:

> I have some really rough code written for Win 95, let me see if I can 
> upgraded it
> but just grab all the ".url"  files in the sub directories below that 
> contain your favourites in win xp or win 2000
> C:\Documents and Settings\usename\Favorites
> then pass your .url filename to this routine to drag out the http address
> Then pass http url string to xmlhttp or winhttp this will return a 404 
> if not valid or 500 if server gone etc.
>
> Public Function GetHTTPfromURL(FileNaam As String) As String
> Dim FSO As New Scripting.FileSystemObject
> Dim oFile As file
> Dim oText As TextStream
> Dim strLine As String
>
> 'grab the folder already so just get FileName
> 'Set oFolder = FSO.GetFolder(Path)
> Set oFile = FSO.GetFile(FileNaam)
>      Set oText = oFile.OpenAsTextStream
>      Do
>         strLine = oText.ReadLine 'contains [InternetShortcut]
>      Loop Until strLine = "[InternetShortcut]"
>      strLine = oText.ReadLine 'should contains URL=
>      oText.Close
>       ' Open "C:\Windows\Favorites\" & Text1.Text & ".url" For Binary 
> Access Write As #1 ' Save the file.
>   'Open FileNaam For Binary Access Read As #1 ' Read the file.
>   ' Put #1, , "[InternetShortcut]" & vbNewLine & "URL=" & Text1.Text
>   'Get #1, , VarBuf
>   Debug.Print "**" & strLine & "**"
>   ' Close #1
>   ' MsgBox "URL sucessfully added to Favorites!", vbInformation
>   GetHTTPfromURL = strLine
> End Function
>
> Erwin Craps - IT Helps wrote:
>
>> Seeing this, I wunder if there is someone who has some code (and wants
>> to share it) to check all hyperlinks in the favorites of IE to see if
>> the page/website still exists?
>>
>> Beeing on the internet for probably about 10 years now got me a lot of
>> favorites that are aged and no longer exists...
>>
>> I like to clean up (sometimes).
>>
>> Erwin
>>
>>
>>
>>
>> -----Original Message-----
>> From: accessd-bounces at databaseadvisors.com
>> [mailto:accessd-bounces at databaseadvisors.com] On Behalf Of Gustav Brock
>> Sent: Wednesday, November 17, 2004 10:36 AM
>> To: accessd at databaseadvisors.com
>> Subject: Svar: [AccessD] A2003:Test Voracity of URLS
>>
>> Hi Darren
>>
>> We use these functions:
>>
>> <code module>
>>
>> Private Declare Function URLDownloadToFile Lib "urlmon" Alias
>> "URLDownloadToFileA" ( _
>>  ByVal pCaller As Long, _
>>  ByVal szURL As String, _
>>  ByVal szFileName As String, _
>>  ByVal dwReserved As Long, _
>>  ByVal lpfnCB As Long) _
>>  As Long
>>
>> Public Function IsURL(ByVal strURL As String) As Boolean
>>
>> ' Usage: Check if URL strURL is alive and reachable.
>> '   booURL = IsURL("http://www.ibm.com")
>> '   booURL = IsURL("ftp://ftp.novell.com")
>> '
>> ' Note: Protocol header like "http://" must be provided.
>> '
>> ' 2001-12-09. Cactus Data ApS. CPH.
>>
>>  ' File found at most URLs.
>>  Const cstrFileIndex As String = "index.htm"
>>
>>  IsURL = (URLDownloadToFile(0, strURL, cstrFileIndex, 0, 0) = 0)
>>  
>> End Function
>>
>> </code module>
>>
>> If your URLs contains html document name you will have to modify the
>> code to use that and not append index.html.
>>
>> /gustav
>>
>>  
>>
>>>>> d.dick at uws.edu.au 17-11-2004 05:03:08 >>>
>>>>>       
>>>>
>>
>> I have an educational client who has a CD full of Education URL's
>> (Zillion's of 'em) Occasionally someone has to test to see if the links
>> are broken or not (Manually <yuk>)
>>
>> I thought this would be a perfect application for Access Set up a table
>> of URLs and loop through 'em and return TRUE or FALSE
>>
>> So...Is there a way I can type in
>> say...http://somewebsite.someserver.com.au
>> and return "true" if the site exists or "false" if the site does not
>> exist.
>>
>> -- 
>> _______________________________________________
>> AccessD mailing list
>> AccessD at databaseadvisors.com
>> http://databaseadvisors.com/mailman/listinfo/accessd
>> Website: http://www.databaseadvisors.com
>>  
>>
>

-- 
Marty Connelly
Victoria, B.C.
Canada






More information about the AccessD mailing list