Palabras clave: crear acceso directo, shortccut, WSH
Autor: Juan M. Afán de Ribera (Happy) / Junio 2003
Extraído de: La web del Búho
Objetivo:
Rutina que crea un acceso directo a la base de datos actual en el escritorio. 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.
(Más abajo hay variantes)
'*********** 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 ***********
Variante
Rutina que crea un acceso directo en el escritorio de una base de datos asociada a un grupo de trabajo. 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.
'*********** 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 ***********
Nota: Las funciones FileName y FilePath de esta variante se pueden encontrar en este mismo subforo.
Variante 2
Autor: Buho / Junio 2003
Function OtroAccessoDirectoPaco()
'Crea un acceso directo del Explorador, en el Escritorio
'Buho Junio 2003
Dim ObjetoWSS As Object
Dim AccesoDirecto As Object
Dim Ruta As String
Set ObjetoWSS = CreateObject("WScript.Shell")
'En el escritorio
Ruta = ObjetoWSS.SpecialFolders("Desktop") & "\" & ObjetoWSS.ExpandEnvironmentstrings("MiAccesoDirecto") & ".lnk"
Set AccesoDirecto = ObjetoWSS.CreateShortcut(Ruta)
'Fichero a crear acceso directo. En este caso el Explorador de Windows
AccesoDirecto.TargetPath = ObjetoWSS.ExpandEnvironmentstrings("%windir%\explorer.exe")
'¿Que icono le pongo? Pues el mismo del explorer
AccesoDirecto.IconLocation = ObjetoWSS.ExpandEnvironmentstrings("%windir%\explorer.exe, 0")
AccesoDirecto.WindowStyle = 0
AccesoDirecto.Save
Set AccesoDirecto = Nothing
Set ObjetoWSS = Nothing
End Function
