ModuloInformeWord.bas

  1. Attribute VB_Name = "ModuloInformeWord"
  2. Option Compare Database
  3. Option Explicit
  4.  
  5. 'REFERENCIAS NECESARIAS:
  6. 'Menú -> Herramientas -> Referencias -> Microsoft Word Object Library
  7.  
  8. Public Function InformeWord( _
  9. ByVal plantilla_word As String, _
  10. ByVal consulta As String, _
  11. Optional ByVal filtro As String = "" _
  12. ) As Boolean
  13. On Error GoTo Errores
  14. 'Ejemplo de uso (evento al hacer clic de un botón de comando):
  15. '=InformeWord("informe_cliente.dot";"tabla_clientes";"cliente_id=" & cliente_id)
  16.  
  17. Dim rs As DAO.Recordset
  18. Dim campo As DAO.field
  19. Dim appWord As Word.Application
  20. Dim documento_word As Word.Document
  21. Dim ruta_actual As String
  22.  
  23. If filtro <> "" Then
  24. consulta = "SELECT * FROM " & consulta & " WHERE " & filtro
  25. End If
  26. Set rs = CurrentDb.OpenRecordset(consulta, dbOpenForwardOnly)
  27.  
  28. If rs.BOF And rs.EOF Then
  29. 'Nada
  30. Else
  31.  
  32. Set appWord = New Word.Application
  33. appWord.Visible = False
  34. Call SysCmd(acSysCmdInitMeter, "Exportando a Word", 100)
  35. DoCmd.Hourglass True
  36.  
  37. If plantilla_word = "" Then
  38. Set documento_word = appWord.Documents.Add()
  39. Else
  40. ruta_actual = Left(CurrentDb.Name, InStrRev(CurrentDb.Name, "\"))
  41. Set documento_word = appWord.Documents.Add(ruta_actual & plantilla_word)
  42. End If
  43.  
  44. For Each campo In rs.Fields
  45.  
  46. With appWord.Selection.Find
  47. .ClearFormatting
  48. .Text = "[" & UCase(campo.Name) & "]"
  49. With .Replacement
  50. .ClearFormatting
  51. .Text = rs(campo.Name) & ""
  52. End With
  53. Call .Execute(Replace:=Word.WdReplace.wdReplaceAll)
  54. End With
  55.  
  56. Next
  57.  
  58. End If
  59. InformeWord = True
  60. Salida:
  61. On Error Resume Next
  62. appWord.Visible = True
  63. Call SysCmd(acSysCmdRemoveMeter)
  64. DoCmd.Hourglass False
  65. Set appWord = Nothing
  66. Set documento_word = Nothing
  67. rs.Close: Set rs = Nothing
  68. Set campo = Nothing
  69. Exit Function
  70. Errores:
  71. MsgBox Err.Description, vbCritical, "InformeWord"
  72. Resume Salida
  73. End Function
  74.  
  75.  
  76.  

Proinf.net