ClaseInformeWord.cls

  1. VERSION 1.0 CLASS
  2. BEGIN
  3. MultiUse = -1 'True
  4. END
  5. Attribute VB_Name = "ClaseInformeWord"
  6. Attribute VB_GlobalNameSpace = False
  7. Attribute VB_Creatable = False
  8. Attribute VB_PredeclaredId = False
  9. Attribute VB_Exposed = False
  10. Option Compare Database
  11. Option Explicit
  12.  
  13. 'REFERENCIAS NECESARIAS:
  14. 'Menú -> Herramientas -> Referencias -> Microsoft Word Object Library
  15.  
  16. 'Ejemplo:
  17. '' Dim informe As New ClaseInformeWord
  18. '' Dim filtro As String
  19. ''
  20. '' filtro = "cliente_id=" & Me.cliente_id
  21. ''
  22. '' Call informe.Abrir("informe_cliente_pedidos.dot")
  23. '' Call informe.Ejecutar("tabla_clientes", filtro)
  24. '' Call informe.EjecutarTablaDetalles(2, "consulta_pedidos", filtro)
  25. '' Call informe.Cerrar
  26. ''
  27. '' Set informe = Nothing
  28.  
  29. Private app_word As Word.Application
  30. Private documento_word As Word.Document
  31.  
  32. Private Sub Class_Initialize()
  33. 'Nada
  34. End Sub
  35.  
  36. Private Sub Class_Terminate()
  37. Call Cerrar
  38. End Sub
  39.  
  40. Public Function Abrir(ByVal plantilla_word As String)
  41. Dim ruta_actual As String
  42.  
  43. Set app_word = New Word.Application
  44. app_word.Visible = False
  45.  
  46. If plantilla_word = "" Then
  47. Set documento_word = app_word.Documents.Add()
  48. Else
  49. ruta_actual = Left(CurrentDb.Name, InStrRev(CurrentDb.Name, "\"))
  50. Set documento_word = app_word.Documents.Add(ruta_actual & plantilla_word)
  51. End If
  52. End Function
  53.  
  54. Public Function Cerrar()
  55. On Error Resume Next
  56. app_word.Visible = True
  57. Set app_word = Nothing
  58. Set documento_word = Nothing
  59. End Function
  60.  
  61. Public Function Ejecutar( _
  62. ByVal consulta As String, _
  63. Optional ByVal filtro As String = "" _
  64. ) As Boolean
  65. On Error GoTo Errores
  66. Call SysCmd(acSysCmdInitMeter, "Exportando a Word: " & consulta, 100)
  67. DoCmd.Hourglass True
  68.  
  69. Dim rs As DAO.Recordset
  70. Dim field As DAO.field
  71.  
  72. If filtro <> "" Then consulta = "SELECT * FROM " & consulta & " WHERE " & filtro
  73. Set rs = CurrentDb.OpenRecordset(consulta, dbOpenForwardOnly)
  74.  
  75. If rs.BOF And rs.EOF Then
  76. 'Nada
  77. Else
  78. For Each field In rs.Fields
  79. With app_word.Selection.Find
  80. .ClearFormatting
  81. .Text = "[" & UCase(field.Name) & "]"
  82. With .Replacement
  83. .ClearFormatting
  84. .Text = rs(field.Name) & ""
  85. End With
  86. Call .Execute(Replace:=Word.WdReplace.wdReplaceAll)
  87. End With
  88. Next
  89. End If
  90. Ejecutar = True
  91. Salida:
  92. Call SysCmd(acSysCmdRemoveMeter)
  93. DoCmd.Hourglass False
  94. Exit Function
  95. Errores:
  96. MsgBox Err.Description, vbCritical, "Ejecutar"
  97. Resume Salida
  98. End Function
  99.  
  100. Public Function EjecutarTablaDetalles( _
  101. ByVal num_tabla As Integer, _
  102. ByVal consulta As String, _
  103. Optional ByVal filtro As String = "" _
  104. ) As Boolean
  105. On Error GoTo Errores
  106. Call SysCmd(acSysCmdInitMeter, "Exportando a Word: " & consulta, 100)
  107. DoCmd.Hourglass True
  108.  
  109. Dim rs As DAO.Recordset
  110. Dim field As DAO.field
  111. Dim tabla As Word.Table
  112. Dim ultima_fila As Word.Row, nueva_fila As Word.Row
  113. Dim celda As Word.Cell
  114. Dim campo As String, valor As String
  115.  
  116. If filtro <> "" Then consulta = "SELECT * FROM " & consulta & " WHERE " & filtro
  117. Set rs = CurrentDb.OpenRecordset(consulta, dbOpenForwardOnly)
  118. Set tabla = documento_word.Tables(num_tabla)
  119.  
  120. If rs.BOF And rs.EOF Then
  121. 'Nada
  122. Else
  123. Do Until rs.EOF
  124. Set ultima_fila = tabla.Rows(tabla.Rows.Count)
  125. Set nueva_fila = tabla.Rows.Add
  126. For Each celda In ultima_fila.Cells
  127. 'Duplicar la última fila en la nueva
  128. campo = celda.Range.Text
  129. campo = Left(campo, Len(campo) - 2) 'Eliminar vbCrLf del final
  130. nueva_fila.Cells(celda.ColumnIndex).Range.Text = campo
  131.  
  132. 'Poner los valores
  133. For Each field In rs.Fields
  134. If 0 <> InStr(LCase(field.Name), "importe") Then
  135. valor = Format(Nz(rs(field.Name), 0), "#,##0.00")
  136. Else
  137. valor = rs(field.Name) & ""
  138. End If
  139. campo = Replace(campo, "[" & field.Name & "]", valor)
  140. Next
  141. celda.Range.Text = campo
  142. Next
  143.  
  144. 'Call SysCmd(acSysCmdUpdateMeter, rs.PercentPosition) 'Fallas porque es dbOpenForwardOnly
  145. rs.MoveNext
  146. Loop
  147. End If
  148.  
  149. 'Borrar la última fila
  150. tabla.Rows(tabla.Rows.Count).Delete
  151.  
  152. EjecutarTablaDetalles = True
  153. Salida:
  154. Call SysCmd(acSysCmdRemoveMeter)
  155. DoCmd.Hourglass False
  156. Exit Function
  157. Errores:
  158. MsgBox Err.Description, vbCritical, "EjecutarTablaDetalles"
  159. Resume Salida
  160. End Function
  161.  
  162.  
  163.  

Proinf.net