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