Scanning for bad hyperlinks in Favorites folder

[BobK4UVT]

I have a bunch of hyperlinks in the Favorites folder in C"\Documents and Settings\. Via VBA, I would like to scan thru all the links and have it shell out to the link to test it. If the link is no good (dead, broken, 404, etc.), I'd like to populate a table with the bad URLs. That way I can find out which ones are bad & delete them without doing the search process manually. I tried doing a FileSearch on the Favorites folder, but I always get .FoundFiles = 0. Does anyone have any suggestions on how to do this (assuming it can be done) properly? I'm using Access 2003. Many thanks in advance!! -------- Bob

 

[PHV]

I tried doing a FileSearch on the Favorites folder, but I always get .FoundFiles = 0
Can you please post your actual code ?

Hope This Helps, PH.
Want to get great answers to your Tek-Tips questions? Have a look at FAQ219-2884 or FAQ222-2244

 

[BobK4UVT]

PH --- sorry for omitting the code --- too sleepy I guess :=)


Public Sub ScanFav()

Dim Jdx As Long
Dim NumFiles As Long
Dim DirName As String

Dim FullFileName As String

DirName = "C:\Documents and Settings\Daniel R. Dorsey Jr\Favorites\"

With Application.FileSearch

.LookIn = DirName
.FileName = "*.*"
.SearchSubFolders = True

If .Execute > 0 Then

NumFiles = .FoundFiles.Count

For Jdx = 1 To .FoundFiles.Count

FullFileName = .FoundFiles(Jdx)
'Add URL processing code here.......

Next Jdx

Else

MsgBox "No files were found in this directory", vbInformation

End If

End With

End Sub

It chugs thru the loop for a good while & then I get my MsgBox dialog, which meant .FoundFiles.Count = 0.

My plan was to get the filename and then from the file properties, get the URL associated with it. Then try to follow the hyperlink. If it is bad, then add that URL to a "bad links" table. But so far, the code above isn't finding the files at all. Perhaps the internet shortcuts in Favorites are a special type & I'm missing the boat somewhere. This is the first time I've attempted something like this, so there must be a key point I'm missing.

 

[BobK4UVT]

Hmmmmmmmmm ....... upon further tinkering, it looks like maybe FileSearch doesn't recognize internet shortcuts. So how does one handle that?? Am I perhaps barking up the wrong tree?

 

[PHV]

Just add this line before the .Execute:
.FileType = msoFileTypeAllFiles

Hope This Helps, PH.
Want to get great answers to your Tek-Tips questions? Have a look at FAQ219-2884 or FAQ222-2244

 

[BobK4UVT]

PH ------- That helped out great!!! Now I see the shortcut files as .url files. Now all I need to do is figure out how to follow the links best. The FollowHyperlink method opens the link in a window --- with 1500+ links, that could swamp me, so got to find a way to do that without a glut of windows.

Your tip did solve the problem of seeing the needed files --- thanks a million!!!!! I'll post the final code here once I have it working right, in case it is useful to someone else......

 

[Aqif]

Hi,

I worked with ur code n it worked perfect for me. Is there anyway I can get two additional info

1. Logical File name like: check yahoo mail (the link will be mail.yahoo.com)
2. Folder containing tht link like Graphics, Computer Programming etc

I want to create a form in which I can search for my links as they r getting out of hands now. I want to scan the links and save them in table to search. So I just need those above two additional info



Cheers!
ÙÇãá

It's important to learn the rules so that you know how to break them.

 

[BobK4UVT]

Hi, Aqif,

Thanks for your reply! Since my original post, I discovered that the code was failing to pick up over half of the links that were actually in my Favorites folder. Upon further tinkering, I finally arrived at a good solution. The key is the function GetURLFromShortcut() ---- that picks up all links. I have included the code for my main scan loop and the function below for you (and anyone else who may be interested. At least I think I've solved the original VBA problem, with help from the other replys to my post (thank you very much for tips!!).

In DirToScan, "XXXXXXXXX" is whatever username your system set up for you. The main proc populates the FavLinks table with the full pathname (datatype TEXT(255)) of the .url file and the corresponding URL (datatype Hyperlink). This could be tweaked however you like.

I also print the URL's to a .txt file, one link per line. I then wrote a PHP page to read this file and try to connect to each URL and return the status of the attempt. I don't have this quite right yet. It is returning a lot of false negatives --- i.e., it tells me a link failed when I know for sure the link is good. So I need to work on that some more --- to resolve that issue and also to return the results back into the FavLinks table, so that I can build a good form telling me the results of my scan. I'm still not sure what is the best way to test the links efficiently and so that the results are accurate.

For a test you could try these, which I know are good links:

Path = C:\Documents and Settings\XXXXXXX\Favorites\Computers and Internet\Microsoft\Microsoft Press.url
Logical File Name = Microsoft Press
URL =

http://www.microsoft.com/mspress/default.asp

Path = C:\Documents and Settings\XXXXXXX\Favorites\AmateurRadio\Digital and PSK31\NB6Z - Digital HF Ham Radio.url
Logical File Name = NB6Z - Digital HF Ham Radio
URL =

http://www.teleport.com/~nb6z/

With some more tweaking, I think I can get this into a very good, quick and efficient way to check the links in one's Favorite folders. Would appreciate any tips you might have. Also please let me know if you need any more assistance. Perhaps together we can come up with a super way to do this!!

Regards --- Bob

================= C O D E F O L L O W S ============================

Public Sub ScanFavDir(DirName As String)

Dim rstFS As New ADODB.Recordset

Dim cnn As ADODB.Connection

Dim Jdx As Long
Dim NumFiles As Long

Dim FullFileName As String
Dim URLName As String
Dim URLFile As String
Dim DirToScan As String

ClearRecSet "FavLinks"

Set cnn = CurrentProject.Connection

Set rstFS = New ADODB.Recordset
rstFS.Open "FavLinks", cnn, adOpenStatic, adLockOptimistic

DirToScan = "C:\Documents and Settings\XXXXXXXXX\Favorites\" & DirName
URLFile = "C:\BobD\ZScan\FavURL.txt"

Open URLFile For Output As #1

With Application.FileSearch

.LookIn = DirToScan
.FileName = "*.url"
.SearchSubFolders = True
.FileType = msoFileTypeAllFiles

If .Execute > 0 Then

NumFiles = .FoundFiles.Count

For Jdx = 1 To .FoundFiles.Count

FullFileName = .FoundFiles(Jdx)
URLName = GetURLFromShortcut(FullFileName)
rstFS.AddNew
rstFS!FavName = FullFileName
rstFS!FavURL = URLName
rstFS.Update
Debug.Print Jdx, FullFileName, URLName
Print #1, URLName

'------ Application.FollowHyperlink FullFileName, , True, False

Next Jdx

Else

MsgBox "No files were found in this directory", vbInformation

End If

End With

Close #1

rstFS.Close
cnn.Close

End Sub

Public Function GetURLFromShortcut(strShortcut As String) As String

Dim WSHShell As Object
Dim URLShortcut As Object

Set WSHShell = CreateObject("WScript.Shell")
Set URLShortcut = WSHShell.CreateShortcut(strShortcut)
GetURLFromShortcut = URLShortcut.TargetPath

End Function

 

[Aqif]

Dear Bob

It gives a error in ClearRecSet "FavLinks" with invalid procedure. Is tht some function which is missing in code?

I will be working to scan and store following info from my favorites in to an Access table

Logical name:
URL:
Folder name:

Then I plan to build a utility to search among my favorites and also to put the DB on my website and search it with ASP code. I will definitelty keep in touch with you and will be happy to share both my search database and ASP pages.



Cheers!
ÙÇãá

It's important to learn the rules so that you know how to break them.

 

[Aqif]

Dear Bob

How about this code

FUNCTION TO SCAN FILENAMES
--------------------------

Public Function SearchAndAppendFileNames(strFolder As String)

On Error GoTo ErrHandler

Dim objFSO
Dim objFolder
Dim objFiles
Dim strSubFolder

Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(strFolder)

Dim strFileName, strFolderName, strShortcut As String
Dim strCount As Integer




'To scan root files
'------------------

For Each objFiles In objFolder.Files

SysCmd acSysCmdSetStatus, "Scanning folder: " & objFolder.Path

DoCmd.SetWarnings False
strLoopCount = strLoopCount + 1

'Replace ' symbol with ~
strFileName = Replace(objFiles.Name, "'", "~", 1, , vbTextCompare)
strFolderName = objFolder.Name
strShortcut = GetURL(objFiles.Name, objFolder.Path)

'Debug.Print strFileName & " ||| " & strFolderName & " ||| " & strShortcut

DoCmd.RunSQL ("Insert Into TblHyperlinks (Id, Filename, Shortcut, Folder) Values(" & strLoopCount & ",'" & strFileName & "','" & strShortcut & "', '" & strFolderName & "');")
DoCmd.SetWarnings True
DoEvents


Next

SysCmd (acSysCmdClearStatus)


'To scan sub folders
'-------------------
For Each strSubFolder In objFolder.SubFolders
Call SearchAndAppendFileNames(strSubFolder.Path)
Next

ErrHandler:
If Err.Number > 0 Then
MsgBox Err.Number & " - " & Err.Description
Resume Next
End If

End Function

FUNCTION TO GET URL PATH (Thanks to you)
----------------------------------------

Public Function GetURL(strFile, DirToScan As String) As String
On Error GoTo ErrHandler

Dim strFileName As String

With Application.FileSearch

.LookIn = DirToScan
.FileName = "*" & strFile
.SearchSubFolders = False
' Debug.Print .FileName

If .Execute > 0 Then

NumFiles = .FoundFiles.Count

For Jdx = 1 To .FoundFiles.Count
strFileName = .FoundFiles(Jdx)
GetURL = strFileName
'Debug.Print GetURL
Next

End If

End With


ErrHandler:
If Err.Number > 0 Then
MsgBox Err.Number & " - " & Err.Description
Resume Next
End If

End Function

Usage: SearchAndAppendFileNames (strFolderPath)

I have developed an Access database for exactly what I wanted to do. You can give me your email if you want to have a copy.


Cheers!
ÙÇãá

It's important to learn the rules so that you know how to break them.

 

[BobK4UVT]

OOppsss ... sorry about that .... Clear RecSet is one of my functions too. Code be low .... Maybe not the best way, but it works OK if the recordset is not too large. I like to ensure all the old records are gone before I start doing AddNew. Hope this helps.....

Code for function:


Public Sub ClearRecSet(strRecSet As String)

Dim rstTbl As New ADODB.Recordset
Dim cnn As ADODB.Connection

Dim RecCount As Long
Dim Jdx As Long

Set cnn = CurrentProject.Connection

Set rstTbl = New ADODB.Recordset

rstTbl.Open strRecSet, cnn, adOpenStatic, adLockOptimistic
RecCount = rstTbl.RecordCount

For Jdx = 1 To RecCount
rstTbl.Delete adAffectCurrent
rstTbl.Update
rstTbl.MoveNext
Next Jdx

rstTbl.Close
cnn.Close

End Sub