Article ID: 182761
Article Last Modified on 1/22/2007
Function MakeShortcutTable(strTableName As String, _
strDirectoryPath As String)
Dim strGrab As String
Dim strFileName As String
Dim intFileNum As Integer
Dim dbs As Database
Dim Rst As Recordset
Dim tdf As TableDef
Dim fld As Field
Dim nextChar As String
' Return reference to current database.
Set dbs = CurrentDb
' Return TableDef object variable that points to new table.
Set tdf = dbs.CreateTableDef(strTableName)
' Define new field in table.
Set fld = tdf.CreateField("Link", dbMemo, 233)
' Append Field object to Fields collection of TableDef object.
fld.Attributes = dbHyperlinkField
tdf.Fields.Append fld
tdf.Fields.Refresh
' Append TableDef object to TableDefs collection of database.
dbs.TableDefs.Append tdf
dbs.TableDefs.Refresh
Set Rst = dbs.OpenRecordset(strTableName)
strFileName = Dir(strDirectoryPath & "*.url")
' Loop to open each matching file in the current folder.
Do While Len(strFileName) > 0
intFileNum = FreeFile
' Open the file.
Open strDirectoryPath & strFileName For Input As _
#intFileNum
' Get first 24 characters.
strGrab = Input(24, #intFileNum)
strGrab = ""
' Loop until end of file.
Do While Not EOF(intFileNum)
nextChar = Input(1, #intFileNum)
If nextChar = "[" Then Exit Do
strGrab = strGrab & nextChar
Loop
Close #intFileNum ' Close file.
MsgBox Left(strFileName, Len(strFileName) - 4) & _
"#" & Left(strGrab, Len(strGrab) - 2) & "x"
With Rst
.AddNew
!link = Left(strFileName, Len(strFileName) - 4) & _
"#" & Left(strGrab, Len(strGrab) - 2)
.Update
End With
strFileName = Dir()
' Repeat the loop for all matching files
' in the current folder.
Loop
Rst.Close
End Function
?MakeShortcutTable("tblHyperlinks","c:\MyShortcuts\")
Note that after you run the procedure, a new table called tblHyperlinks
appears in the database. Its data consists of hyperlinks that correspond
to the Internet shortcuts in the folder C:\MyShortcuts.Additional query words: inf favorite browser
Keywords: kbdtacode kbhowto kbprogramming KB182761