Public Sub CreateLink(ShortCutName As String, Database As String, _
WorkGroup As String, Optional Image As String, _
Optional ShortCutPath As String, Optional DeskTop As Boolean)
'Written by Keith Goff
'Parameter
'ShortcutName= Name of the shortcut to create
'Database=Path and file name of the db
'Workgroup=Path and file name of the workgroup file
'Image=Optional image to use for the shortcut
'ShortcutPath= Path to the shortcut
On Error GoTo Err_Handler
Dim WshShell As Object
Dim oShtCt As Object
Dim FSO As Object
Dim strDesktop As String
Dim sPath As String
Dim sName As String
Dim sDBFile As String
Dim sWrkGrp As String
Dim sImage As String
Dim sWindows As String
Dim sAccessExe As String
Dim blnDeskTop As Boolean
sDBFile = Database
'File System Object
Set FSO = CreateObject("Scripting.FileSystemObject")
'Check that DB File Exists
If FSO.FileExists(sDBFile) = False Then
MsgBox "The database file " & sDBFile _
& " does not exist!"
GoTo Clean_Up
End If
sWrkGrp = WorkGroup
'Check that Workgroup File Exists
If FSO.FileExists(sWrkGrp) = False Then
MsgBox " The Workgroup file " & sWrkGrp _
& " does not exist!"
GoTo Clean_Up
End If
'Check that path to new shortcut exists
If Len(ShortCutPath) > 2 Then
sPath = ShortCutPath
If FSO.FolderExists(sPath) = False Then
MsgBox "The directory " & sPath _
& " for the Shortcut does not exist!"
GoTo Clean_Up
End If
Else
blnDeskTop = True
End If
'Add File extension to the shortcut name
sName = ShortCutName & ".lnk"
'Check if user entered a custom image to use
If Len(Image) > 1 Then
sImage = Image
Else
sImage = "C:\Program Files\Microsoft Office\Office11\MSACCESS.EXE"
End If
'Check that the image file exists
If FSO.FileExists(sImage) = False Then
MsgBox "The image " & sImage _
& " choosen for the shortcut does not exist!"
GoTo Clean_Up
End If
'Windows Script Host
Set WshShell = CreateObject("WScript.Shell")
'Set reference to the Desktop if True
If blnDeskTop = True Then
sPath = WshShell.SpecialFolders("Desktop")
End If
If Right(sPath, 1) <> "\" Then
sPath = sPath & "\"
End If
'Working Directory
sWindows = "C:\Documents and Settings\" _
& Environ("UserName") & "\Local Settings\Temp\"
'MS Access Program
sAccessExe = "C:\Program Files\Microsoft Office\Office11\MSACCESS.EXE"
sDBFile = Chr(34) & sDBFile & Chr(34)
sWrkGrp = "/wrkgrp" & Chr(34) & sWrkGrp & Chr(34)
'Create New Shortcut
Set oShtCt = WshShell.CreateShortcut(sPath & sName)
oShtCt.TargetPath = sAccessExe
oShtCt.Arguments = sDBFile & sWrkGrp
If Len(sImage) > 1 Then
oShtCt.IconLocation = sImage & ", 0"
End If
oShtCt.WorkingDirectory = sWindows
oShtCt.Save
MsgBox "Shortcut " & sPath & sName _
& " has been created!"
Clean_Up:
Set FSO = Nothing
Set oShtCt = Nothing
Set WshShell = Nothing
Exit Sub
Err_Handler:
MsgBox Err.Number & Chr(32) & Err.Description
GoTo Clean_Up
End Sub
