'*********** Código ***************
'
' CrearAccesoDirecto
'
' Rutina que crea un acceso directo
' en el escritorio de la base de
' datos actual. Si la bd tiene
' asociado un icono se utilizará
' para el acceso directo, y si no,
' se le pondrá el predeterminado
' para BDs de Access
'
' Autor: Juan M. Afán de Ribera
' Fecha: Junio 2003
'
Sub crearAccesoDirecto()
Dim WScript As Object 'New WshShell
Dim AccesoDirecto As Object 'WshShortCut
Dim Escritorio As String

    Set WScript = CreateObject("WScript.Shell")
    'obtenemos la ruta del escritorio
    Escritorio = WScript.SpecialFolders("Desktop")
    'creamos el acceso directo a nuestra bd
    Set AccesoDirecto = WScript.CreateShortcut _
        (Escritorio & "\" & Dir(CurrentDb.Name) & ".lnk")
    'decimos donde está la bd
    AccesoDirecto.TargetPath = CurrentDb.Name
    
    On Error GoTo err_IconoAccesoDirecto
    AccesoDirecto.IconLocation = _
        CurrentDb.Properties("AppIcon")

    'indicamos el directorio de trabajo
    AccesoDirecto.WorkingDirectory = CurrentProjectPath
    'y grabamos el trabajo
    AccesoDirecto.Save
    
exit_CrearAccesoDirecto:

    Set AccesoDirecto = Nothing
    Set WScript = Nothing
    Exit Sub
    
err_IconoAccesoDirecto:

    If Err.Number = 3270 Then 'no existe la propiedad
        'asignamos el icono predeterminado para
        'bases de datos de Access
        AccesoDirecto.IconLocation = SysCmd( _
        acSysCmdAccessDir) & "\msaccess.exe, 1"
        Resume Next
    Else
        MsgBox Err.Description
        GoTo exit_CrearAccesoDirecto
    End If
    
End Sub


Function CurrentProjectPath() As String
Dim fso As Object
Dim archivo As File

    Set fso = CreateObject("Scripting.FileSystemObject")
    Set archivo = fso.GetFile(CurrentDb.Name)
    
    CurrentProjectPath = archivo.ParentFolder
    
    Set archivo = Nothing
    Set fso = Nothing
    
End Function
'********** Fin código ***********