Cria atalho do projeto no Desktop do usuário atual

Este código (subCriaAtalho) cria um atalho do aplicativo na área de trabalho (desktop) do usuário.

Poderá ser chamada na abertura do formulário inicial ou na macro autoexec
(ou onde julgar necessário).

Se quiser definir um ícone personalizado para o atalho, basta por no diretório raiz da
aplicação um ícone com nome icon do tipo .ico.

Caso não informe nenhum ícone, o atalho terá o ícone do Access.

A subCriaAtalho tem um parâmetro opcional que é a descrição do atalho, ou seja,
ao passar o mouse sobre o atalho, será exibido a descrição informada. Se não escrever
nada na descrição, será mostrado apenas o caminho do aplicativo.

Eis o código abaixo e um exemplo em anexo.

Código:

Public Sub subCriaAtalho(Optional strDescricao As String)
'Autor: Marcelo David
'Data: 04/08/2020
'Propósito: criar ícone do aplicativo na área de trabalho do usuário ao executar o programa
Dim wsc As Object
Dim lnk
Dim strPathDesktop As String, strNomeApp As String

On Error GoTo TrataErro

    'Instancio o Windows Scripting Host
    Set wsc = CreateObject("wscript.shell")
    
    'Obtendo o path do desktop do usuário atual
    strPathDesktop = wsc.SpecialFolders("Desktop")
    
    'Extraindo o nome do aplicativo sem a extenção
    strNomeApp = Mid(CurrentProject.Name, 1, InStr(CurrentProject.Name, ".") - 1)
    
    'Instanciando um objeto do tipo atalho (lnk) e já definindo o desktop do usuário atual
    Set lnk = wsc.CreateShortcut(strPathDesktop & "\" & strNomeApp & ".lnk")
    
    'Verificando se já existe atalho e caso sim, apaga para criar o novo
    If Dir(strPathDesktop & "\" & strNomeApp & ".lnk") <> "" Then
        Kill strPathDesktop & "\" & strNomeApp & ".lnk"
    End If
    
    'Difinindo o aplicativo a ser executado ao clicar no link
    lnk.TargetPath = CurrentProject.FullName
    
    'Definindo a propriedade de "Iniciar em" do atalho (diretório de trabalho)
    lnk.WorkingDirectory = CurrentProject.Path
    
    'Caso tenha definido uma descrição (dica ao passar o mouse sobre o atalho)
    lnk.Description = strDescricao
    
    'Verifico se há o ícone do atalho para assim definir
    'Caso não haja ícone, o ícone do Access que será definido por padrão
    If Dir(CurrentProject.Path & "\icon.ico") <> "" Then
        lnk.IconLocation = CurrentProject.Path & "\icon.ico ,0"
    Else
        lnk.IconLocation = SysCmd(acSysCmdAccessDir) & "MSACCESS.EXE, 0"
    End If
    'Salvando o link
    lnk.Save
    
    'Apagando da memória o objeto Windows Scripting Host e o link
    Set lnk = Nothing 'Nem precisava apagar esse, já que é filho de wsc, mas para manter o bom hábito de apagar variávais de objetos
    Set wsc = Nothing
    
Exit Sub
    
TrataErro:
    MsgBox Err.Description, vbExclamation, "Erro " & Err.Number & " ao criar atalho"
End Sub

Espero que lhes seja útil.

Olá Marcelo David,

Parabéns! Está excelentemente comentado todo o código.

Obrigado pela partilha.

Abraço

Obrigado Teixeira