Option Compare Database
       Option Explicit

       ' Declare variables.
       Dim DesktopPath As String
       Dim StartMenuPath As String
       Dim WinPath As String
       Dim fNameOld As String
       Dim fNameNew As String

       ' Declare Public variables.
       Public Type ShortItemId
            cb As Long
            abID As Byte
       End Type

       Public Type ITEMIDLIST
            mkid As ShortItemId
       End Type

       ' Declare constants.
       Const CSIDL_TEMPLATES = &H15
       Const CSIDL_STARTMENU = &HB
       Const CSIDL_FAVORITES = &H6
       Const CSIDL_DESKTOPDIRECTORY = &H10

       ' Declare API functions.
       Public Declare Function SHGetPathFromIDList Lib "shell32.dll" _
          (ByVal pidl As Long, ByVal pszPath As String) As Long

       Public Declare Function SHGetSpecialFolderLocation Lib _
          "shell32.dll" (ByVal hwndOwner As Long, ByVal nFolder _
          As Long, pidl As ITEMIDLIST) As Long

       Function GetSpecialFolder(CSIDL As Long) As String

          Dim idlstr As Long
          Dim sPath As String
          Dim IDL As ITEMIDLIST

          Const NOERROR = 0
          Const MAX_LENGTH = 260

          On Error Goto Err_GetFolder

          ' Fill the idl structure with the specified folder item.
          idlstr = SHGetSpecialFolderLocation _
             (Application.hWndAccessApp, CSIDL, IDL)

          If idlstr = NOERROR Then

               ' Get the path from the idl list, and return
               ' the folder with a slash at the end.
               sPath = Space$(MAX_LENGTH)
               idlstr = SHGetPathFromIDList(ByVal IDL.mkid.cb, ByVal sPath)

                  If idlstr Then
                    GetSpecialFolder = Left$(sPath, InStr(sPath, Chr$(0)) _
                      - 1) & "\"
                  End If

          End If

        Exit_GetFolder:
           Exit Function
        Err_GetFolder:
           Msgbox err.description, vbCritical or VbokOnly
           Resume Exit_GetFolder

       End Function

       Function CopyAppShortcut()
          ' Turn off screen updating.
          Application.Echo False

          ' Call the GetSpecialFolder function to get the location
          ' of the Desktop, Start Menu, and Windows directories.

          DesktopPath = GetSpecialFolder(CSIDL_DESKTOPDIRECTORY)
          StartMenuPath = GetSpecialFolder(CSIDL_STARTMENU)
          WinPath = Left(GetSpecialFolder(CSIDL_TEMPLATES), _
             Len(GetSpecialFolder(CSIDL_TEMPLATES)) - 9)

          ' If there is a problem in getting the paths, then
          ' show an error message and exit.

          If DesktopPath = "" Or StartMenuPath = "" Or WinPath = "" Then
               Application.Echo True
               MsgBox "Error retrieving folder paths." & Chr(13) & _
                  "Unable to copy shortcut to desktop."
               Exit Function
          End If

          ' Copy the shortcut from its program group to the Desktop.

          FileCopy StartMenuPath & "Programs\Northwind\Northwind.lnk", _
             DesktopPath & "\Northwind.lnk"

          ' NOTE: It is necessary to modify the following lines of code to
          ' match your application's path and shortcut's name.
          '
          '   "Programs\Northwind\Northwind.lnk"
          '
          ' should be modified to read:
          '
          '   "Programs\Path To Your Application\Your Shortcut Name.lnk"
          '
          ' -and-
          '
          '   "\Northwind.lnk"
          '
          ' should be modified to read:
          '
          '   "\Your Shortcut Name.lnk"

          ' Create the batch file Cleanup.bat, which will
          ' run after CopyShortCut.mdb is closed.

          Open WinPath & "Cleanup.bat" For Output As #1
          Print #1, "del " & WinPath & "Script.bat"
          Print #1, "del " & WinPath & "CopyShortcut.mdb"
          Print #1, "Echo Northwind Setup is now complete."
          Print #1, "Echo Close this DOS window "
          Print #1, "Echo by clicking on the X"
          Print #1, "Echo at the top right..."
          Print #1, "Echo :)"
          Print #1, "Echo :)"
          Print #1, "Echo :)"
          Print #1, "Echo :)"
          Print #1, "Echo :)"
          Print #1, "Echo :)"
          Print #1, "Del " & WinPath & "Cleanup.bat"
          Close #1

          ' After Cleanup.bat is created, close
          ' Microsoft Access.

       Exit_CopyAppShortcut:
            Application.quit
       Err_GetFolder:
           Application.echo True
           Msgbox err.description, vbCritical or VbokOnly
           Resume Exit_CopyAppShortCut

      End Function