ACC2000: How to Create Shortcuts from a Field of Hyperlinks

Sub ProcessHyperlinkTable(strTableName As String, _
   strFieldName As String)

   ' Declare variables.
   Dim DBS As DAO.Database
   Dim RST As DAO.Recordset
   Dim strSQL As String
   Dim strAddress As String
   Dim strDisplayText As String
   Dim strDirectoryPath As String
   Dim varLink As Variant

   ' Set error trapping.
   On Error GoTo Error_handler

   ' Assign the current database to the database variable.
   Set DBS = CurrentDb

   ' Set the path to the existing directory
   ' where the shortcuts will be created.
   ' Note: the path should end with a backslash ("\").
   strDirectoryPath = "c:\MyShortcuts\"

   ' Set the SQL string to return the field
   ' containing the hyperlinks from the
   ' table you have specified.
   strSQL = "SELECT " & strFieldName _
      & " FROM " & strTableName

   ' Open the Recordset.
   Set RST = DBS.OpenRecordset(strSQL)

   ' Move to the first record.
   RST.MoveFirst

   ' Loop until reaching the end of the table.
   Do Until RST.EOF
      ' Check to see if the HomePage field contains a link.
      If Not IsNull(RST!fldLink) Then

         ' Set varLink equal to the current Hypertext link field.
         varLink = RST!fldLink

         ' Pull the Address from varLink.
         strAddress = HyperlinkPart(varLink, acAddress)

         ' Pull the display text, if any, from varLink.
         strDisplayText = HyperlinkPart(varLink, acDisplayText)

         ' If there is no display text, set strDisplayText to
         ' be the same as the URL.
         If strDisplayText = "" Then

            ' If strAddress starts with "Http://",
            ' or "Ftp://", leave that out of strDisplayText.
            If Left(strAddress, 7) = "Http://" Or _
               Left(strAddress, 6) = "Ftp://" Then

                  strDisplayText = Right(strAddress, _
                     Len(strAddress) _
                     - (InStr(1, strAddress, "/") + 1))
            Else
            ' Otherwise, simply set strDisplayText
            ' equal to strAddress.
               strDisplayText = strAddress
            End If

         End If

         ' Pass the URL, the link name, and the directory path to
         ' the function.
         Create_Hyperlink_Shortcut strAddress, strDisplayText, _
            strDirectoryPath

      End If

      ' Move to the next record.
      RST.MoveNext

   Loop

' Error handling section

ProcessHyperlinkTable_Exit:

   DBS.Close

   ' Exit the Procedure.
   Exit Sub

Error_handler:
   MsgBox Err.Description
   Resume ProcessHyperlinkTable_Exit

End Sub

Function Create_Hyperlink_Shortcut(strAddress As String, _
   LinkFileName As String, LinkFilePath As String)

   ' Declare output file variable.
   Dim fileNum As Integer
   ' Declare counter variable.
   Dim i As Integer

   ' Set error trapping.
   On Error GoTo Error_handler

   ' Set fileNum to the next available file number.
   fileNum = FreeFile

   ' Create the new shortcut file.
   Open LinkFilePath & LinkFileName & ".url" For Output _
      As #fileNum
   Print #fileNum, "[InternetShortcut]"
   Print #fileNum, "URL=" & strAddress
   Close #fileNum

   ' Exit the function when done.
   Exit Function

   ' Error handling section
Error_handler:

   ' Trap for errors caused by a bad file name
   ' and prompt the user to correct it.
   Select Case Err
      ' "Bad file name or number" error caused by
      ' invalid characters in file name.
      Case 52
         LinkFileName = InputBox("Cannot create file for " _
            & strAddress & Chr(13) _
            & "The Internet Shortcut Name shown below is invalid." _
            & Chr(13) & Chr(13) _
            & "It contains one or more of the following: " _
            & "\ / : * ? " & """" & " < > |" & Chr(13) & Chr(13) _
            & Chr(13) & "Please enter a valid Shortcut name.", _
            "Invalid Shortcut Name", LinkFileName)

      ' "Path not found" error caused by slashes
      ' in the file name.
      Case 76
         LinkFileName = InputBox("Cannot create file for " _
            & strAddress & Chr(13) & Chr(13) _
            & "The shortcut name shown below is invalid. " _
            & "It may contain one or more slashes." _
            & Chr(13) & Chr(13) _
            & "Please remove any slashes from the Shortcut name.", _
            "Path not found", LinkFileName)

      ' If it is any other error, exit the function
      ' without creating the shortcut file.
      Case Else
         MsgBox "Error Number: " & Err & " while attempting to " _
            & "create" & "shortcut for " & strAddress
         Exit Function
   End Select

   ' If the user entered a blank shortcut name in the error dialog,
   ' prompt for a correct one, allowing for three tries.
   For i = 1 To 3
      If Len(LinkFileName) = 0 Then
         LinkFileName = InputBox("Cannot create file for " _
            & strAddress & Chr(13) _
            & "The Internet Shortcut Name is blank" _
            & Chr(13) & Chr(13) _
            & "Please enter a valid Shortcut name.", _
            "Invalid Shortcut Name", LinkFileName)
      End If
   Next i

   ' If the user has still left the name blank, let the user know
   ' the shortcut will not be created and then exit the function.
   If Len(LinkFileName) = 0 Then
      MsgBox ("A shortcut will not be created for " _
         & strAddress & ".")
      Exit Function
   End If

   ' Resume at the line that generated the error.
   Resume

End Function
					

ProcessHyperLinkTable "tblHyperlinks", "fldLink"