FollowHyperlink en access para ubicar cualquier ruta

Tengo un formulario que posee un control de lista de texto al cual voy agregando nombres de archivos de word en tipo plantilla "dot".

Los archivos están ubicados en una carpeta en el directorio que se encuentra la base de datos.

Lo que se necesita es abrir el archivo de word en cualquier ubicación del disco duro y a "la vez guardarlo"

Utilizo el código

FollowHyperlink CurrentProject.Path & "\Plantillas\" & Lista0.Column(3) & ".dot"

1 respuesta

Respuesta
1

A ver si esto te sirve:

Un botón que al pulsarlo abra una ventana en la que puedas seleccionar cualquier plantilla de word, y que una vez seleccionada, la copie a la carpeta Plantillas del directorio donde está tu BD y añada el nombre del archivo a la lista.

Paso 1: creas un nuevo módulo en tu BD (llámalo, por ejemplo mdlArchivos) y le pones este código:

'------------------------------------------------------------------------------------------------
' Función para abrir ventana de diálogo y buscar archivos
'------------------------------------------------------------------------------------------------
Public Function fncBuscaArchivo() As String
On Error GoTo sol_err

Dim fDialog As Office.FileDialog<br class="scayt-misspell" data-scayt_word="Dim" data-scaytid="426" />Set fDialog = Application.FileDialog(msoFileDialogFilePicker)
With fDialog
.AllowMultiSelect = False
.ButtonName = "Seleccionar"
.Title = "Seleccionar el archivo"
.InitialFileName = Application.CurrentProject.Path
.InitialView = msoFileDialogViewDetails
.Filters.Clear
.Filters.Add "Plantillas de Word", "*.dot"
If .Show = True Then
fncBuscaArchivo = .SelectedItems(1)
Else
'No hacemos nada
End If
End With
Salida:
Exit Function
sol_err:
Call MsgBox "Se ha producido el error: " & Err.Number & " - " & Err.Description, vbInformation + vbOkOnly,"ERROR"
Resume Salida
End Function

Para que esta función te funcione, tienes que registrar la librería "Microsoft Office 12.0 Object Library". Para ello, en el editor de vba vas a Herramientas->Referencias y allí la buscas y le marcas la casilla para registrarla (si no la tienes ya registrada)

Paso 2: Creas un botón en tu formulario, junto al cuadro de lista, y le pones este código, en el evento al hacer click:

On Error GoTo sol_err

Dim miRuta As String
Dim miArchivo As String<br class="scayt-misspell" data-scayt_word="Dim" data-scaytid="614" />Dim fso As Scripting.FileSystemObject
Dim arch As Scripting.File 'arch = archivo
miRuta = Application.CurrentProject.Path & "\Plantillas"
'Creamos la carpeta de la raza
MkDir miRuta
'Asignamos el valor de la variable al archivo que seleccionemos al navegar.
'Para ello utilizamos la llamada a la función buscaArchivo
miArchivo = fncBuscaArchivo()
'Si no seleccionamos ningún archivo, salimos
If IsNull(miArchivo) Or miArchivo = "" Then Exit Sub
'Creamos el objeto fso
Set fso = CreateObject("Scripting.FileSystemObject")
'Obtenemos el archivo de trabajo. Si no existe obtenemos el error 53.
Set arch = fso.GetFile(miArchivo)
'Copiamos el documento a la carpeta "Plantillas"
arch.Copy (miRuta & "\" & arch.Name)
Salida:
'Actualizamos el cuadro de lista (supondré que se llama lstPlantllas)<br class="scayt-misspell" data-scayt_word="Dim" data-scaytid="1423" />Dim misAdjuntos As String
miAdjuntos=Me.lstPlantillas.RowSource & ";" & arch.Name

Me.lstPlantilas.Requery

Exit Sub
sol_err:
Select Case Err.Number
Case 53
Call miMsg("El archivo " & miArchivo & " no existe.", 1)
Case 75
Resume Next
Case Else
Call miMsg("Se ha producido el error " & Err.Number & " - " & Err.Description, 1)
End Select
Resume Salida

Para que este código funcione, tendrás que registrar la biblioteca "Microsoft Scripting Runtime"

El código no lo probé, lo escribí "de cabeza" a partir de un código similar que uso en una de mis BDs. Si hay cualquier error, coméntamelo y miramos de solucionarlo.

Perdón, hay una cosa que no te va a funcionar: cambia desde sol_err: por esto otro:

sol_err:
Select Case Err.Number
Case 53
MsgBox "El archivo " & miArchivo & " no existe.", vbInformation + vbOkOnly,"ERROR"
Case 75
Resume Next
Case Else
MsgBox "Se ha producido el error " & Err.Number & " - " & Err.Description,vbInformation + vbOkOnly,"ERROR"
End Select

Se agradece...

Si no necesitas nada más, y ya quedó resuelta tu pregunta.

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas