'*********** Código ***************
'
' CrearAccesoDirectoArgs
'
' Rutina que crea un acceso directo
' en el escritorio de una base de
' datos asociada a un grupo de tra-
' bajo. 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.
'
' Esta rutina tiene dos argumentos:
'
'   baseDatos: Ruta y nombre de la
'   base de datos. Ejemplo:
'   "c:\mis bases\miBase.mdb"
'
'   Argumentos: argumentos que tendrá
'   la base de datos cuando se abra.
'   Por ejemplo:
'   " /user usuario /wrkgrp " & _
'   "c:\grupos bases\miGrupo.mdw"
'
' Autor: Juan M. Afán de Ribera
' Fecha: Junio 2003
'
Sub crearAccesoDirectoArgs(baseDatos As String, _
                        Argumentos As String)
        
Dim WScript As Object 'New WshShell
Dim AccesoDirecto As Object 'WshShortCut
Dim Escritorio As String
Dim Enlace 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 & "\" & FileName(baseDatos) & ".lnk")
    'indicamos la ruta del programa Access
    Enlace = SysCmd(acSysCmdAccessDir) & "MSACCESS.EXE"
    AccesoDirecto.TargetPath = Enlace
    'indicamos los argumentos
    AccesoDirecto.Arguments = Argumentos
       
    On Error GoTo err_IconoAccesoDirecto
    AccesoDirecto.IconLocation = _
        CurrentDb.Properties("AppIcon")

    'indicamos el directorio de trabajo
    AccesoDirecto.WorkingDirectory = FilePath(baseDatos)
    '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
'********** Fin código ***********


'*********** Código ***************
'
' FileName
'
' Función que devuelve el nombre del
' archivo que se le pase como argumento
' (no comprueba si ese archivo existe).
'
' Por ejemplo:
'
'   Debug.Print FileName("c:\ruta\mibd.mdb")
'
' devolverá:
'
'   "mibd.mdb"
'
' Autor: Juan M. Afán de Ribera
' Fecha: Junio 2003
'
Function FileName(fName As String) As String
Dim fso As Object

    Set fso = CreateObject("Scripting.FileSystemObject")
    FileName = fso.GetFileName(fName)
    Set fso = Nothing
    
End Function
'********** Fin código ***********


'*********** Código ***************
'
' FilePath
'
' Función que devuelve la ruta del
' archivo que se le pase como argumento
' (no comprueba si ese archivo existe).
'
' Por ejemplo:
'
'   Debug.Print FilePath("c:\ruta\mibd.mdb")
'
' devolverá:
'
'   "c:\ruta"
'
' Autor: Juan M. Afán de Ribera
' Fecha: Junio 2003
'
Function FilePath(fName As String) As String
Dim fso As Object

    Set fso = CreateObject("Scripting.FileSystemObject")
    FilePath = fso.GetParentFolderName(fName)
    Set fso = Nothing
    
End Function
'********** Fin código ***********