'*********************************************************
'
' 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
    
    'usuarios de Access 97 han de utilizar esta línea
    'AccesoDirecto.WorkingDirectory = CurrentProjectPath
    
    'usuarios de Access 2000 o superior han de utilizar
    'esta línea 
    'AccesoDirecto.WorkingDirectory = CurrentProject.Path
    
    '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

' los usuarios de Access 97 necesitarán esta función
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
'*********************************************************