[green]'********************
'* §lamKeys §oftware 2005® (VBSlammer)
'*
'* @CREATED : 1/29/2005 1:21:55 PM
'* @PARAMS : strFile - path and filename of "bookmark.htm"
'* @RETURNS : N/A
'* @NOTES : Assumes table "InternetFavorites" exists
'* @CALL : ImportBookmarkFile("C:\..\..\bookmark.htm")
'* @MODIFIED :
'********************[/green]
Sub ImportBookmarkFile(ByVal strFile As String)
On Error GoTo ErrHandler
Dim rst As Recordset
Dim fso As FileSystemObject
Dim tsMyFile As TextStream
Dim re As RegExp
Dim strIn As String
Dim intDepth As Integer
Dim dicFolders As New Scripting.Dictionary
Dim strFolder As String
Dim i As Integer
Set fso = New FileSystemObject
Set tsMyFile = fso.OpenTextFile(strFile, ForReading)
Set re = New RegExp
Set rst = CurrentDb.OpenRecordset("InternetFavorites")
With re
[green]'set attributes[/green]
.Global = True
.MultiLine = True
.IgnoreCase = True
Do Until tsMyFile.AtEndOfStream
[green]'read a line[/green]
strIn = tsMyFile.ReadLine
[green]'check for nesting up (new folder)[/green]
.Pattern = "<DT><H3 FOLDED ADD_DATE=""(.*)"">(.*)</H3>"
If .Test(strIn) = True Then
[green]'new list, bump up level[/green]
intDepth = intDepth + 1
dicFolders.Add intDepth, Trim(.Replace(strIn, "$2"))
GoTo NextLine
End If
[green]'check for nesting down.[/green]
.Pattern = "</DL><P>"
If .Test(strIn) = True Then
[green]'end of current list, bump down level[/green]
If intDepth > 0 Then
dicFolders.Remove intDepth
intDepth = intDepth - 1
End If
GoTo NextLine
End If
[green]'build a folder path string[/green]
strFolder = "..\"
For i = 1 To intDepth
strFolder = strFolder & dicFolders(i)
If i < intDepth Then
strFolder = strFolder & "\"
End If
Next i
[green]'write the favorite info to a table[/green]
.Pattern = "<DT><A HREF=""(.*)"" ADD_DATE=""(.*)"" LAST_VISIT=""(.*)"" LAST_MODIFIED=""(.*)"">(.*)</A>"
If .Test(strIn) = True Then
rst.AddNew
rst.Fields("Folder") = strFolder
rst.Fields("Link") = Trim(.Replace(strIn, "$1"))
rst.Fields("Added") = Trim(.Replace(strIn, "$2"))
rst.Fields("Visited") = Trim(.Replace(strIn, "$3"))
rst.Fields("Modified") = Trim(.Replace(strIn, "$4"))
rst.Fields("Title") = Trim(.Replace(strIn, "$5"))
rst.Update
End If
NextLine:
Loop
End With
ExitHere:
On Error Resume Next
tsMyFile.Close
Set tsMyFile = Nothing
Set fso = Nothing
Set re = Nothing
rst.Close
Set rst = Nothing
Exit Sub
ErrHandler:
Debug.Print Err, Err.Description
Resume ExitHere
End Sub