Create a shortcut via code in Access

[fun4me]

Does anyone know how to create a shortcut on the desktop in code when you are in Access?

Any help would be appreciated

 

[psemianonymous]

I think there actually is code to do it, but I'd recommend you just create a shortcut file, then do a "CopyFile" in code to the Desktop.

Also, consider putting the shortcut in the All Users\Desktop folder, so that your users can't accidentally delete the desktop shortcut, thereby "uninstalling" your application.

I have a lot of nasty-but-working code that removed the shortcut from the local user's desktop, then copied a new shortcut to the All Users\Desktop folder. It works for NT4\Win2000\WinXP users. If you want me to paste it, let me know.

 

[fun4me]

foolio12
Thanks for the recommendation. I would like to look at your "nasty-but-working" code. If possible could you post it?

 

[psemianonymous]

Yeah. I'll post it in the next message.

This is a form with a single (large) textbox named "txt". I put all updates echoed onto this textbox.

I have changed some names of filenames, etc.

The nastiness isn't necessarily the code, but the extensive use of environment variables. For NT4 machines, I hardcoded the "all users" desktop directory in there. For Win2K machines, I used %ALLUSERSPROFILE%\Desktop , which is just as nasty.

But it will work.


Pete

 

[psemianonymous]

Option Compare Database
Option Explicit

Private Sub Form_Load()
    Me.Visible = True
    Me.Repaint
    DoEvents
    
    '1. identify files to delete
    '2. delete files
    '3. copy shortcut over to All Users directory
    '4. make note of userid so that I can know who has copied their shortcut over.
    '5. open new shortcut link
    '6. close this database
    
    RunShortcutUpdates
End Sub

Private Sub RunShortcutUpdates()
    Dim str As String
    Dim strUserDesktopShortcut As String
    Dim fNT4 As Boolean
    
    Const strShortcutFilename As String = "YOUR_SHORTCUT_FILE.LNK"
    Const strSourceFilename As String = "FULL_DRIVE_AND_PATHNAME_AND_FILENAME_OF_SOURCE.LNK"
    
    str = fOSName()
    
    
    If Left(str, Len("Windows 2000")) = "Windows 2000" Then
        fNT4 = False
        WriteLn "Windows 2000 machine"
    Else 'only other option is NT4 at this point
        fNT4 = True
        WriteLn "Windows NT 4 machine"
    End If
    
    '1
    str = Environ("USERPROFILE") & "\Desktop\" & strShortcutFilename
    strUserDesktopShortcut = str
    WriteLn "File to remove is " & str
    '2
    If Dir(str) <> &quot;&quot; Then
        WriteLn &quot;Deleting file (&quot; & str & &quot;)...&quot;
        FileSystem.Kill str
        WriteLn &quot;Deleted&quot;
    End If
    
    '3
    WriteLn &quot;Finding All Users directory...&quot;
    If fNT4 = True Then
        str = &quot;C:\WINNT\Profiles\All Users&quot;
    Else
        '2000 machines should have all usersprofile set
        str = Environ(&quot;ALLUSERSPROFILE&quot;)
        '...but if it's not set, set it to this
        If str = &quot;&quot; Then
            str = &quot;C:\Documents And Settings\All Users&quot;
        End If
    End If
    WriteLn &quot;All Users dir: &quot; & str
    str = str & &quot;\Desktop\&quot; & strShortcutFilename
    
    WriteLn &quot;Copying shortcut to All Users desktop directory&quot;
    FileSystem.FileCopy strSourceFilename, str
    WriteLn &quot;Copying shortcut to user desktop&quot;
    FileSystem.FileCopy strSourceFilename, strUserDesktopShortcut
    
    '4
    WriteLn &quot;Logging completed file transfers.  User '&quot; & Environ(&quot;USERNAME&quot;) & &quot;' has updated shortcuts.&quot;
    FileSystem.FileCopy strSourceFilename, strSourceFilename & &quot;.&quot; & Environ(&quot;COMPUTERNAME&quot;) & &quot;.&quot; & Environ(&quot;USERNAME&quot;) & &quot;.&quot; & CurrentUser
    
    '5
    WriteLn &quot;Opening the new database&quot;
    apiHandleFile str, WIN_MAX
    
    '6
    WriteLn &quot;Closing this window&quot;
    DoCmd.Quit acQuitSaveNone
End Sub

Private Sub WriteLn(str As String)
    Dim dat As Date
    txt.Value = txt.Value & str & vbCrLf
    dat = Now()
    
    Me.Repaint
    DoEvents
    
    Do While (CDbl(Now()) - CDbl(dat)) * 24 * 60 * 60 < 0.4
        DoEvents
    Loop
End Sub

'from a different module
Option Explicit
Option Compare Database


'************ Code Start **********
' This code was originally written by Dev Ashish.
' It is not to be altered or distributed,
' except as part of an application.
' You are free to use it in any application,
' provided the copyright notice is left unchanged.
'
' Code Courtesy of
' Dev Ashish
'
Private Declare Function apiShellExecute Lib "shell32.dll" _
    Alias "ShellExecuteA" _
    (ByVal hwnd As Long, _
    ByVal lpOperation As String, _
    ByVal lpFile As String, _
    ByVal lpParameters As String, _
    ByVal lpDirectory As String, _
    ByVal nShowCmd As Long) _
    As Long

'***App Window Constants***
Public Const WIN_NORMAL = 1         'Open Normal
Public Const WIN_MAX = 3            'Open Maximized
Public Const WIN_MIN = 2            'Open Minimized

'***Error Codes***
Private Const ERROR_SUCCESS = 32&
Private Const ERROR_NO_ASSOC = 31&
Private Const ERROR_OUT_OF_MEM = 0&
Private Const ERROR_FILE_NOT_FOUND = 2&
Private Const ERROR_PATH_NOT_FOUND = 3&
Private Const ERROR_BAD_FORMAT = 11&

'***************Usage Examples***********************
'Open a folder:     ?fHandleFile("C:\TEMP\",WIN_NORMAL)
'Call Email app:    ?fHandleFile("mailto:dash10@hotmail.com",WIN_NORMAL)
'Open URL:          ?fHandleFile("[URL unfurl="true"]http://home.att.net/~dashish",[/URL] WIN_NORMAL)
'Handle Unknown extensions (call Open With Dialog):
'                   ?fHandleFile("C:\TEMP\TestThis",Win_Normal)
'Start Access instance:
'                   ?fHandleFile("I:\mdbs\CodeNStuff.mdb", Win_NORMAL)
'****************************************************

Function apiHandleFile(stFile As String, lShowHow As Long)
    Dim lRet As Long, varTaskID As Variant
    Dim stRet As String
    'First try ShellExecute
    lRet = apiShellExecute(hWndAccessApp, vbNullString, _
            stFile, vbNullString, vbNullString, lShowHow)
            
    If lRet > ERROR_SUCCESS Then
        stRet = vbNullString
        lRet = -1
    Else
        Select Case lRet
            Case ERROR_NO_ASSOC:
                'Try the OpenWith dialog
                varTaskID = Shell("rundll32.exe shell32.dll,OpenAs_RunDLL " _
                        & stFile, WIN_NORMAL)
                lRet = (varTaskID <> 0)
            Case ERROR_OUT_OF_MEM:
                stRet = &quot;Error: Out of Memory/Resources. Couldn't Execute!&quot;
            Case ERROR_FILE_NOT_FOUND:
                stRet = &quot;Error: File not found.  Couldn't Execute!&quot;
            Case ERROR_PATH_NOT_FOUND:
                stRet = &quot;Error: Path not found. Couldn't Execute!&quot;
            Case ERROR_BAD_FORMAT:
                stRet = &quot;Error:  Bad File Format. Couldn't Execute!&quot;
            Case Else:
        End Select
    End If
    apiHandleFile = lRet & _
                IIf(stRet = &quot;&quot;, vbNullString, &quot;, &quot; & stRet)
End Function
'************ Code End **********

'another code module


Option Compare Database
Option Explicit

' ******** Code Start ********
 'This code was originally written by Dev Ashish.
 'It is not to be altered or distributed,
 'except as part of an application.
 'You are free to use it in any application,
 'provided the copyright notice is left unchanged.
 '
 'Code Courtesy of
 'Dev Ashish
 '

Private Type OSVERSIONINFO
    dwOSVersionInfoSize As Long
    dwMajorVersion As Long
    dwMinorVersion As Long
    dwBuildNumber As Long
    dwPlatformId As Long
    szCSDVersion As String * 128
End Type
 
Private Declare Function apiGetVersionEx Lib "kernel32" _
    Alias "GetVersionExA" _
    (lpVersionInformation As Any) _
    As Long
 
Private Const VER_PLATFORM_WIN32_WINDOWS = 1
Private Const VER_PLATFORM_WIN32_NT = 2
 
Function fOSName() As String
Dim osvi As OSVERSIONINFO
Dim strOut As String
 
    osvi.dwOSVersionInfoSize = Len(osvi)
    If CBool(apiGetVersionEx(osvi)) Then
        With osvi
            ' XP
            If .dwPlatformId = VER_PLATFORM_WIN32_NT And _
                .dwMajorVersion = 5 And _
                .dwMinorVersion = 1 Then
                    strOut = "Windows XP (Version " & _
                        .dwMajorVersion & "." & .dwMinorVersion & _
                        ") Build " & .dwBuildNumber
                    If (Len(.szCSDVersion)) Then
                        strOut = strOut & " (" & _
                                    fTrimNull(.szCSDVersion) & ")"
                    End If
            End If
            ' .Net Server
            If .dwPlatformId = VER_PLATFORM_WIN32_NT And _
                .dwMajorVersion = 5 And _
                .dwMinorVersion = 2 Then
                    strOut = "Windows .NET Server (Version " & _
                        .dwMajorVersion & "." & .dwMinorVersion & _
                        ") Build " & .dwBuildNumber
                    If (Len(.szCSDVersion)) Then
                        strOut = strOut & " (" & _
                                    fTrimNull(.szCSDVersion) & ")"
                    End If
            End If
            ' Win 2000
            If .dwPlatformId = VER_PLATFORM_WIN32_NT And _
                .dwMajorVersion = 5 Then
                    strOut = "Windows 2000 (Version " & _
                        .dwMajorVersion & "." & .dwMinorVersion & _
                        ") Build " & .dwBuildNumber
                    If (Len(.szCSDVersion)) Then
                        strOut = strOut & " (" & _
                                    fTrimNull(.szCSDVersion) & ")"
                    End If
            End If
            ' Win ME
            If (.dwMajorVersion = 4 And _
                (.dwPlatformId = VER_PLATFORM_WIN32_WINDOWS And _
                .dwMinorVersion = 90)) Then
                    strOut = "Windows Millenium"
            End If
            ' Win 98
            If (.dwMajorVersion = 4 And _
                (.dwPlatformId = VER_PLATFORM_WIN32_WINDOWS And _
                .dwMinorVersion = 10)) Then
                    strOut = "Windows 98"
            End If
            ' Win 95
            If (.dwPlatformId = VER_PLATFORM_WIN32_WINDOWS And _
                .dwMinorVersion = 0) Then
                    strOut = "Windows 95"
            End If
            ' Win NT
            If (.dwPlatformId = VER_PLATFORM_WIN32_NT And _
                .dwMajorVersion <= 4) Then
                strOut = &quot;Windows NT &quot; & _
                        .dwMajorVersion & &quot;.&quot; & .dwMinorVersion & _
                        &quot; Build &quot; & .dwBuildNumber
                If (Len(.szCSDVersion)) Then
                        strOut = strOut & &quot; (&quot; & _
                                    fTrimNull(.szCSDVersion) & &quot;)&quot;
                End If
            End If
        End With
    End If
    fOSName = strOut
End Function

Private Function fTrimNull(strIn As String) As String
Dim intPos As Integer
    intPos = InStr(1, strIn, vbNullChar)
    If intPos Then
        fTrimNull = Mid$(strIn, 1, intPos - 1)
    Else
        fTrimNull = strIn
    End If
End Function
'   ********** Code End **********

 

[psemianonymous]

One last thing: it absolutely won't work for Win98/WinME, as they don't have the %USERNAME% profile set, so you'll have to handle that yourself.

The last two modules were directly ripped from

http://www.mvps.org/access/

- I usually don't directly post the contents of these modules and instead link to them when a question arises. And I probably should have done so in this case as well.