llenar los campos de una plantilla de word

Requerimiento previo, incluir en el menú Herramientas -> Referencias


la de "Microsoft Word X.X Object Library"



En la plantilla deberás insertar "marcadores" que serán sustituidos

cuando se ejecute el procedimiento por el contenido del campo en la

base de datos.



En el procedimiento se hace uso tanto del "nombre" del marcador, como

del nombre del cuadro de texto del formulario.



-------------Inicio de copia del

procedimiento-------------------------------



Private Sub CmdCombinar_Click()

On Error GoTo Err_cmdCombinar



Dim AppWord As Word.Application

Dim DocWord As Word.Document

Dim Resp As Long

'

' Variable con el nombre completo del fax a guardar.

'

Dim FileName As String

'

'Variable en la que se tiene u obtiene el nombre de la plantilla.

'

Dim Plantilla As String

'

' Variable en la que se tiene u obtiene el nombre del directorio de

los fax.

'

Dim DirFax As String



Plantilla = "C:\Plantillas\Plantilla.dot"

DirFax = "C:\Faxes\



'

' Abrir el Word utilizando la plantilla.

'

AppWord.Documents.Add Template:=Plantilla, NewTemplate:=False

Set DocWord = AppWord.ActiveDocument

'

' Comprobar existencia de un marcador llamado 'PersonaContacto', si

existe

' y el contenido del cuadro de texto del formulario no es nulo se

introduce

' en el documento.



If DocWord.Bookmarks.Exists("PersonaContacto") Then

If Not IsNull(PersonaContacto) Then

DocWord.Bookmarks("PersonaContacto").Select

Texto = PersonaContacto

DocWord.Application.Selection.TypeText Text:=Texto

End If

End If



If DocWord.Bookmarks.Exists("CabeceraFax") Then

If Not IsNull(CabeceraFax) Then

DocWord.Bookmarks("CabeceraFax").Select

Texto = CabeceraFax

DocWord.Application.Selection.TypeText Text:=Texto

End If

End If



If DocWord.Bookmarks.Exists("Fax") Then

If Not IsNull(Fax) Then

DocWord.Bookmarks("Fax").Select

Texto = Fax

DocWord.Application.Selection.TypeText Text:=Texto

End If

End If



If DocWord.Bookmarks.Exists("Remite") Then

If Not IsNull(Remite) Then

DocWord.Bookmarks("Remite").Select

Texto = Remite

DocWord.Application.Selection.TypeText Text:=Texto

End If

End If



If DocWord.Bookmarks.Exists("Remite2") Then

If Not IsNull(Remite) Then

DocWord.Bookmarks("Remite2").Select

Texto = Remite

DocWord.Application.Selection.TypeText Text:=Texto

End If

End If



If DocWord.Bookmarks.Exists("Direccion1") Then

If Not IsNull(Direccion1) Then

DocWord.Bookmarks("Direccion1").Select

Texto = Direccion1

DocWord.Application.Selection.TypeText Text:=Texto

End If

End If



If DocWord.Bookmarks.Exists("Direccion2") Then

If Not IsNull(Direccion2) Then

DocWord.Bookmarks("Direccion2").Select

Texto = Direccion2

DocWord.Application.Selection.TypeText Text:=Texto

End If

End If



If DocWord.Bookmarks.Exists("Tlf") Then

If Not IsNull(Rs!Tlf) Then

DocWord.Bookmarks("Tlf").Select

Texto = Rs!Tlf

DocWord.Application.Selection.TypeText Text:=Texto

End If

End If



If DocWord.Bookmarks.Exists("FechaFax") Then

DocWord.Bookmarks("FechaFax").Select

Texto = Format(Date, "dd/mm/yyyy")

DocWord.Application.Selection.TypeText Text:=Texto

End If



AppWord.Visible = True

AppWord.ActiveDocument.SaveAs FileName

AppWord.WindowState = wdWindowStateMaximize



Exit_cmdCombinar:

DoCmd.Hourglass False

Exit Sub



Err_cmdCombinar:



If Err = 91 Or Err = -2147023174 Then

Set AppWord = New Word.Application

Resume

End If



MsgBox Err & " " & Err.Description & Chr$(13) & Chr$(13) &

Plantilla

Resume Exit_cmdCombinar



End Sub



-------------------Fin del procedimiento

copiado-----------------------------



En este ejemplo el nombre que se puso a los marcadores en la plantilla

Word es el mismo que el que tenían los cuadros de texto en el

formulario pero pueden ser diferentes.



Si se necesita introducir la misma información en dos lugares

diferentes del fax, como ocurre en éste caso, debes definir dos

marcadores con dos nombres diferentes, aunque incluyas la misma

información.

Función para copiar el path de un archivo y utilizarlo en un formulario o en una varialble

Option Compare Database

Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias _
"GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long

Private Type OPENFILENAME
lStructSize As Long
hwndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type

Function LaunchCD(strform As Form) As String
Dim OpenFile As OPENFILENAME
Dim lReturn As Long
Dim sFilter As String
OpenFile.lStructSize = Len(OpenFile)
OpenFile.hwndOwner = strform.Hwnd
sFilter = "All Files (*.*)" & Chr(0) & "*.*" & Chr(0) & _
"JPEG Files (*.JPG)" & Chr(0) & "*.JPG" & Chr(0)
OpenFile.lpstrFilter = sFilter
OpenFile.nFilterIndex = 1
OpenFile.lpstrFile = String(257, 0)
OpenFile.nMaxFile = Len(OpenFile.lpstrFile) - 1
OpenFile.lpstrFileTitle = OpenFile.lpstrFile
OpenFile.nMaxFileTitle = OpenFile.nMaxFile
OpenFile.lpstrInitialDir = "C:\"
OpenFile.lpstrTitle = "Select a file using the Common Dialog DLL"
OpenFile.flags = 0
lReturn = GetOpenFileName(OpenFile)
If lReturn = 0 Then
MsgBox "A file was not selected!", vbInformation, _
"Select a file using the Common Dialog DLL"
Else
LaunchCD = Trim(Left(OpenFile.lpstrFile, InStr(1, OpenFile.lpstrFile, vbNullChar) - 1))
End If
End Function




En el odigo del botón:

Private Sub Comando0_Click()
Fichero = LaunchCD(Me)

Reiniciar campo autonumerico Access

Option Compare Database
Public strNombreTabla As String
Public strNombreCampo As String
Public ValorInicial As Integer


Function ReiniciarAutonumerico(strNombreTabla, strNombreCampo, ValorInicial)
Dim cat As Object
Dim t As Object
Dim col As Object
Dim p As Object


Set cat = CreateObject("ADOX.Catalog")
Set cat.ActiveConnection = CurrentProject.Connection

Set t = cat.Tables(strNombreTabla)
Set col = t.Columns(strNombreCampo)
Set p = col.Properties("Seed")

If IsMissing(ValorInicial) Then
p.Value = Nz(DMax(strNombreCampo, strNombreTabla), 1)
Else
p.Value = ValorInicial
End If

Set p = Nothing
Set col = Nothing
Set t = Nothing
Set cat = Nothing


End Function

Código del botón que llama función:

Private Sub Comando0_Click()
Dim strNombreTabla As String
Dim strNombreCampo As String
strNombreTabla = Me.strNombreTabla
strNombreCampo = Me.strNombreCampo

retorno = Módulo1.ReiniciarAutonumerico(strNombreTabla, strNombreCampo, 1)

End Sub

RV: Crear hojas Excel

'****** Crear Hoja Excel

'******************************

Dim H As Long

Dim V As Long

Dim MiBase As Database

Dim MiTabla As Recordset

Dim objExcel As Excel.Application

On Error GoTo ErrorExcel

'Set MiBase = OpenDatabase(CurrentProject.Path & "\db1.mdb")

'Esta linea anterior, por si deseamos abrir una tabla de cualquier

'otra MDB. En este ejemplo abrimos una tabla Local (Excel).

Set MiBase = CurrentDb

Set MiTabla = MiBase.OpenRecordset(SQL)

If MiTabla.RecordCount = 0 Then

MsgBox "La base de datos esta vacia", vbCritical + vbOKOnly, "AVISO"

Exit Sub

End If

Set objExcel = New Excel.Application

objExcel.Visible = False 'Ocultamos la aplicación excell

objExcel.SheetsInNewWorkbook = 1 'determina el numero de hojas

‘que se mostrara en el Excel

objExcel.Workbooks.Add 'Crea el Libro

With objExcel.ActiveSheet 'cogemos la hoja activa de Excel

'Definimos un rango y pintamos una linea alrededor

.Range(.Cells(1, 1), .Cells(1, 4)).Borders.LineStyle = xlContinuous

'Llenamos celdas con texto fijo

.Cells(3, 1) = "ANO"

.Range(.Cells(3, 1), .Cells(3, 13)).Font.Bold = True ' definimos un rango

‘y ponemos el texto en negrita

‘Definimos formato de columnas

.Columns("D").HorizontalAlignment = xlHAlignRight

.Columns("A").ColumnWidth = 30

.Columns("B").ColumnWidth = 30

.Columns("C").ColumnWidth = 30

.Columns("D").ColumnWidth = 15

.Columns("E").NumberFormat = "dd/mm/yyyy"

.Columns("M").NumberFormat = "dd/mm/yyyy"

End With

objExcel.ActiveSheet.Cells(1, 1) = "Titulo de Cabecera"

objExcel.ActiveSheet.Range(objExcel.ActiveSheet.Cells(1, 1), _

objExcel.ActiveSheet.Cells(1, 4)).HorizontalAlignment = xlHAlignCenterAcrossSelection

With objExcel.ActiveSheet.Cells(1, 1).Font

.Color = vbRed

.Size = 14

.Bold = True

End With

V = 4

H = 1

Do While Not MiTabla.EOF

DoEvents

objExcel.ActiveSheet.Cells(V, H) = MiTabla.Fields!ANO_PRESUP

objExcel.ActiveSheet.Cells(V, H + 1) = MiTabla.Fields!campo1

objExcel.ActiveSheet.Cells(V, H + 2) = MiTabla.Fields!campo2

‘……………………………………………………………………

objExcel.ActiveSheet.Cells(V, H + 11) = MiTabla.Fields!campoN

MiTabla.Edit

MiTabla.Fields![Fecha de asignación] = Date

MiTabla.Update

objExcel.ActiveSheet.Cells(V, H + 12) = MiTabla.Fields![Fecha de asignación]

V = V + 1

MiTabla.MoveNext

Loop

'V = V + 3

'objExcel.Range(objExcel.Cells(V, 1), objExcel.Cells(V, 4)).Borders.LineStyle = xlContinuous

'objExcel.ActiveSheet.Range(objExcel.ActiveSheet.Cells(V, 1), objExcel.ActiveSheet.Cells(V, 4)).HorizontalAlignment = xlHAlignCenterAcrossSelection

'objExcel.ActiveSheet.Cells(V, 1) = "Fec: Código Web del Programador"

objExcel.DisplayAlerts = False

Fecha = Replace(Date, "/", "_")

Filename = "Tareas_" & Fecha

objExcel.ActiveWorkbook.SaveAs Filename, , , , , , , xlLocalSessionChanges

objExcel.ActiveWorkbook.Close

MiBase.Close

objExcel.Quit

Set objExcel = Nothing

Me.Estado.Caption = "Se ha creado el fichero "

MsgBox ("Se ha creado el fichero ")

Me.Estado.Caption = ""

Exit Sub

ErrorExcel:

MsgBox "Ha ocurrido un error de conexión con Excel." _

& Chr(13) & Chr(13) & "Error : " & Err.Number _

& Chr(13) & "Info : " & Err.Description _

& Chr(13) & "Objeto : " & Err.Source _

& Chr(13) & Chr(13) & "Revisa las referencias y la ruta de la base de datos. ", vbCritical, "Paco Avisa: Error al conectar con Excel"

End Sub

Function Modificar Mayusculas Minusculas (texto)

Function ModificarMayusculasMinusculas(texto)


'Esta función devuelve la cadena (texto) convertida en palabras
'que empiezan con mayuscula

Dim CadenA As String
Dim ANSI As Variant
Dim Numero As Integer

CadenA = LCase(texto)
Mid(CadenA, 1, 1) = UCase(Left(CadenA, 1))
For Numero = 2 To Len(CadenA) - 1

ANSI = Asc(Mid(CadenA, Numero, 1))
If ANSI < 65 Or ANSI > 122 Or (ANSI > 90 And ANSI < 97) Then
If ANSI <> 241 Then

Mid(CadenA, Numero + 1, 1) = UCase(Mid(CadenA, Numero + 1, 1))

End If

End If

Next Numero

Mayusculas = CadenA
End Function

Control de errores para aplicaciones robustas

Cuando se trabaja en el control de errores de Access, éstas son las instrucciones que se pueden utilizar:

On Error
Resume
Exit

On Error:

permite especificar dónde se quiere exactamente que Access actúe cuando suceda un error.
La instrucción On Error tiene variables utilizadas para direccionar.

On Error Goto: tiene dos opciones :

Numero Línea, que puede ser un número situado en el procedimiento
Etiqueta Línea, que es una etiqueta que especifica el inicio de una sección de un procedimiento.

El código siguiente crea un controlador de errores muy simple.

Sub SimpleError(intNumerator As Integer, intDenominator As Integer)

On Error GoTo SimpleError_Error

Debug.Print intNumerator / intDenominator

SimpleError_Error:

MsgBox Err.Description, vbCritical, "Ha ocurrido un error"

Exit Sub

End Sub

Este procedimiento muestra un mensaje de error “Ha ocurrido un error” y sale del mismo. Es mejor que el presentado en la figura anterior. Después de recibir el usuario este mensaje, la ejecución del programa sale directamente debido al error producido.

La instrucción On Error Resume Next:

Se utiliza cuando el programa necesita continuar en la línea que sigue inmediatamente a la que originó el error. Un ejemplo sucede cuando se intenta eliminar una tabla que ya ha sido eliminada. El código para éste ejemplo es el siguiente:

Sub InlineResumeNextExample() 'Esta instrucción dice a Access que ignore los errores y '—salte a la siguiente línea.

On Error Resume Next

DoCmd.DeleteObject acTable, "UnaTabla"

End Sub

El siguiente código utiliza la instrucción Exit Sub para salir del procedimiento después de mostrar el error.

Sub SimpleError(intNumerator As Integer, intDenominator As Integer)

On Error GoTo SimpleError_Error

Debug.Print intNumerator / intDenominator

SimpleError_Error:

MsgBox Err.Description, vbCritical, "Ha ocurrido un error"

Exit Sub

End Sub

Las instrucciones Resume, Resume Next y Resume Etiqueta línea se utilizan dentro del controlador de errores para continuar con el procedimiento después de tratar el error.

La instrucción Resume devuelve la ejecución del procedimiento a la línea en la que ocurrió el error.

Sub ResumeExample(intNumerator As Integer, intDenominator As Integer)

On Error GoTo Error_ResumeExample

DoCmd.CopyDatabaseFile "C:\Mis BD\MiBD.mdb", True

Exit Sub

Error_ResumeExample:

Msgbox “ Compruebe que hay disco en la disquetera e intente de nuevo.“

Resume

End Sub

La instrucción Resume Next proporciona la capacidad de dar un mensaje, tratar el error y desplazarse a la siguiente línea de código posterior a la que originó el error.

Sub ResumeNextExample()

On Error GoTo Error_ResumeNextExample

DoCmd.DeleteObject acTable, "CualquierTabla"

Exit Sub Error_ResumeNextExample:

MsgBox Err.Description, vbCritical, "Error al intentar eliminar la tabla"

Resume Next

End Sub

La instrucción Resume Etiqueta línea permite continuar en la etiqueta de línea especificada. Esta instrucción se utiliza habitualmente para crear una salida del procedimiento.

Sub ResumeLineLabelExample()

On Error GoTo Error_ResumeLineLabelExample

DoCmd.DeleteObject acTable, "NoTable" '—Esta etiqueta inicia la salida del procedimiento Exit_ResumeLineLabelExample:

Exit Sub '—Esta etiqueta es para tartar el error
Error_ResumeLineLabelExample:

MsgBox Err.Description, vbCritical, "Error al eliminar la tabla" Resume Exit_ResumeLineLabelExample

End Sub