ModuloEnvioInformesPersonalizados.bas

  1. Attribute VB_Name = "ModuloEnvioInformesPersonalizados"
  2. Option Explicit
  3. Option Compare Database
  4.  
  5. '
  6. 'Envía por correo un informe personalizado a cada persona
  7. '
  8. 'Proinf.net, junio 2008, julio 2017
  9. 'GNU General Public License: http://creativecommons.org/licenses/GPL/2.0/deed.es
  10. '
  11. 'Parámetros:
  12. ' - nombreInforme...........Nombre del informe que se va enviar como archivo adjunto del correo electrónico
  13. ' - consultaDestinatarios...Lista de las personas con tres campos
  14. ' - Primer campo.....El nombre del campo identificador de la persona tal y como aparece en el informe
  15. ' - Segundo campo....Nombre y apellidos
  16. ' - Tercer campo.....Dirección de correo electrónico
  17. ' - Cuarto campo.....Asunto del correo (Opcional)
  18. ' - correoAsunto............Título del correo. Sino se indica se crea uno automático
  19. ' - correoMensaje...........Texto del cuerpo del correo.
  20. ' - revisarCorreo...........Revisa uno a uno los correos antes de enviarlos.
  21. ' - simulacion..............No envía los informes sino que los muestra en pantalla de uno en uno
  22. '
  23. 'Importante:
  24. ' El informe debe incluir el siguiente filtro por el campo identificador del destinatario
  25. ' GetProperty("nombreCampo")
  26. '
  27. 'Ejemplo:
  28. ' Se quiere enviar un informe a cada cliente sobre los pedidos que ha realizado
  29. '
  30. ' Call EnviarInformesPersonalizados( _
  31. ' nombreInforme := "InformePedidosAnual", _
  32. ' consultaDestinatarios := "SELECT cliente_id, contacto, correo, asunto FROM clientes")
  33. '
  34. ' En el informe habrá un filtro en el campo "cliente_id" así:
  35. ' GetProperty("cliente_id")
  36. '
  37.  
  38. Public Function EnviarInformesPersonalizados( _
  39. ByVal nombreInforme As String, _
  40. ByVal consultaDestinatarios As String, _
  41. Optional ByVal correoAsunto As String = "", _
  42. Optional ByVal correoMensaje As String = "", _
  43. Optional ByVal revisarCorreo As Boolean = True, _
  44. Optional ByVal simulacion As Boolean = False _
  45. ) As Boolean
  46.  
  47.  
  48. On Error GoTo Errores
  49. Const CANCELED_SENDOBJECT = 2501
  50. Const CAMPO_FILTRO = 0
  51. Const CAMPO_NOMBRE = 1
  52. Const CAMPO_CORREO = 2
  53. Const CAMPO_ASUNTO = 3
  54.  
  55. Dim db As DAO.Database
  56. Dim rs As DAO.Recordset
  57. Dim nombreFiltro As String
  58. Dim valorFiltro As String
  59. Dim destinatario As String
  60.  
  61. If revisarCorreo Then
  62. Select Case MsgBox("¿Revisar los correos antes de enviarlos?", vbYesNoCancel + vbQuestion)
  63. Case vbYes: revisarCorreo = True
  64. Case vbNo: revisarCorreo = False
  65. Case vbCancel: Exit Function
  66. End Select
  67. End If
  68.  
  69. If Trim(correoAsunto) = "" Then
  70. correoAsunto = nombreInforme
  71. End If
  72.  
  73. Set db = CurrentDb
  74. Set rs = db.OpenRecordset(consultaDestinatarios, dbOpenForwardOnly)
  75. nombreFiltro = rs.Fields(CAMPO_FILTRO).name
  76.  
  77. Do Until rs.EOF
  78.  
  79. destinatario = rs(CAMPO_NOMBRE) & "<" & rs(CAMPO_CORREO) & ">"
  80. If rs.Fields.Count >= 4 Then correoAsunto = rs(CAMPO_ASUNTO)
  81.  
  82. valorFiltro = rs(CAMPO_FILTRO)
  83. Call SetProperty(nombreFiltro, valorFiltro)
  84.  
  85. If simulacion Then
  86. DoCmd.OpenReport nombreInforme, acViewPreview
  87. If MsgBox("Pulsa Sí para continuar", vbYesNo, correoAsunto) = vbNo Then Exit Do
  88. DoCmd.Close acReport, nombreInforme
  89. Else
  90. DoCmd.SendObject ObjectType:=acSendReport, _
  91. ObjectName:=nombreInforme, _
  92. OutputFormat:=acFormatSNP, _
  93. To:=destinatario, _
  94. Subject:=correoAsunto, _
  95. MessageText:=correoMensaje, _
  96. EditMessage:=revisarCorreo
  97. End If
  98.  
  99. rs.MoveNext
  100. Loop
  101.  
  102. Salida:
  103. On Error Resume Next
  104. rs.Close: Set rs = Nothing
  105. db.Close: Set db = Nothing
  106. Exit Function
  107. Errores:
  108. If Err.Number = CANCELED_SENDOBJECT Then
  109. Resume Next
  110. Else
  111. MsgBox Err.Description, vbExclamation, "Error nº" & Err.Number & " en la función EnviarInformesPersonalizados "
  112. Resume Salida
  113. End If
  114. End Function
  115.  
  116. 'Private Function existsField(name As String, rs As DAO.Recordset) As Boolean
  117. ' Dim fld As DAO.Field
  118. ' For Each fld In rs.Fields
  119. ' If fld.name = name Then
  120. ' existsField = True
  121. ' Exit Function
  122. ' End If
  123. ' Next
  124. ' existsField = False
  125. 'End Function
  126.  
  127. Function SetProperty(ByVal nombrePropiedad As String, ByVal valor As Variant)
  128. On Error GoTo Errores
  129. Const PROPERTY_NOT_FOUND = 3270
  130. Dim db As DAO.Database
  131. Dim p As DAO.Property
  132.  
  133. Set db = CurrentDb
  134. db.Properties(nombrePropiedad) = valor
  135. db.Properties.Refresh
  136. Salida:
  137. On Error Resume Next
  138. db.Close: Set db = Nothing
  139. Exit Function
  140. Errores:
  141. If Err.Number = PROPERTY_NOT_FOUND Then
  142. Set p = db.CreateProperty(nombrePropiedad, dbText, valor)
  143. db.Properties.Append p
  144. Else
  145. MsgBox Err.Description, vbExclamation, "Error nº" & Err.Number & " en la función SetProperty"
  146. End If
  147. Resume Salida
  148. End Function
  149.  
  150. Function GetProperty(ByVal nombrePropiedad As String) As Variant
  151. On Error GoTo Errores
  152. Const PROPERTY_NOT_FOUND = 3270
  153. Dim p As Property
  154. GetProperty = CurrentDb.Properties(nombrePropiedad)
  155. Salida:
  156. Exit Function
  157. Errores:
  158. If Err.Number = PROPERTY_NOT_FOUND Then
  159. Resume Salida
  160. Else
  161. Resume Salida
  162. End If
  163. End Function
  164.  

Proinf.net