Attribute VB_Name = "modCombinarEnviar" Option Explicit ' ===================================================================== ' modCombinarEnviar - Word combinado -> un PDF por pagina -> correo Outlook ' ' QUE HACE ' Sirve para cualquier envio masivo de documentos personalizados: ' certificados, facturas, nominas, cartas, contratos... Partes de una ' combinacion de correspondencia de Word (UNA pagina por destinatario, ' en el mismo orden que las filas) y de la hoja Excel con sus datos. ' La macro exporta cada pagina a un PDF con el nombre de su fila, lo ' guarda en la carpeta de salida y (si quieres) crea un correo de ' Outlook por fila con el PDF adjunto. ' ' COMO USARLA ' 1. Importa modUtilidades.bas y este modulo (Alt+F11 > Importar). ' Guarda el libro como .xlsm. ' 2. Hoja "Config" (A = clave, B = valor): ' RutaWord C:\Envios\Cartas combinadas.docx (obligatoria) ' CarpetaPDF C:\Envios\Salida (obligatoria) ' HojaDatos Datos (obligatoria) ' ColumnaNombre1 A 1a parte del nombre del PDF (ej. codigo) ' ColumnaNombre2 B 2a parte del nombre del PDF (ej. nombre) ' ColumnaCorreo E (obligatoria) correo del destinatario ' ColumnaCC F opcional, copia ' ColumnaEstado G opcional; permite reanudar ' Asunto Factura {C} - {B} (obligatoria) ' Remitente facturacion@tuempresa.com opcional ' ModoEnvio MOSTRAR ENVIAR | MOSTRAR (abre sin enviar) | NINGUNO (solo PDF) ' PrimeraFila 2 UltimaFila (vacio = todas) ' SobrescribirPDF SI GuardarCada 25 EvitarAvisosOLE SI ' 3. Hoja "Plantilla": en la columna A, el cuerpo HTML del correo. ' Admite marcadores {A}, {B}, {AO}... con el valor de esa columna. ' 4. Ejecuta GenerarYEnviar, GenerarYMostrarCorreos o GenerarSoloPDF. ' ' LO QUE LA HACE SEGURA ' - Reanudable: escribe el estado en ColumnaEstado y salta las filas ya ' marcadas ENVIADO. Repetirla tras un fallo no reenvia nada. ' - Comprueba antes de empezar: paginas = filas, nombres repetidos, ' errores de Excel, rutas demasiado largas. ' - Usa su propia instancia de Word (no toca la que tengas abierta) y ' deja un registro TSV de cada PDF y cada correo. ' ' PARA ADAPTARLA (busca ">> ADAPTAR") ' - Anadir CCO, importancia o firma en EnviarUno. ' - Adjuntar un segundo archivo fijo (condiciones, folleto). ' - Cambiar el formato del nombre del PDF. ' Requiere: modUtilidades. Necesita Word y, para enviar, Outlook clasico ' con una cuenta configurada. ' ===================================================================== #If VBA7 Then Private Declare PtrSafe Function CoRegisterMessageFilter Lib "ole32.dll" ( _ ByVal filtroNuevo As LongPtr, ByRef filtroAnterior As LongPtr) As Long Private Declare PtrSafe Sub IUnknown_AtomicRelease Lib "shlwapi.dll" (ByRef interfaz As LongPtr) Private mFiltroOLEAnterior As LongPtr #Else Private Declare Function CoRegisterMessageFilter Lib "ole32.dll" ( _ ByVal filtroNuevo As Long, ByRef filtroAnterior As Long) As Long Private Declare Sub IUnknown_AtomicRelease Lib "shlwapi.dll" (ByRef interfaz As Long) Private mFiltroOLEAnterior As Long #End If Private mFiltroOLESuspendido As Boolean Private mEnCurso As Boolean Private Const PREFIJO_TEMPORAL As String = "CombinarEnviar_" Private Type Configuracion RutaWord As String CarpetaPDF As String HojaDatos As String ColNombre1 As Long ColNombre2 As Long ColCorreo As Long ColCC As Long ' 0 = sin copia ColEstado As Long ' 0 = sin reanudacion Remitente As String Asunto As String PrimeraFila As Long UltimaFila As Long ' 0 = hasta la ultima fila con datos Sobrescribir As Boolean ModoEnvio As String ' ENVIAR | MOSTRAR | NINGUNO GuardarCada As Long ' guardar el libro cada N correos (0 = solo al final) EvitarAvisosOLE As Boolean End Type ' ---------- Puntos de entrada ---------- Public Sub GenerarYEnviar() Ejecutar "" End Sub Public Sub GenerarSoloPDF() Ejecutar "NINGUNO" End Sub Public Sub GenerarYMostrarCorreos() Ejecutar "MOSTRAR" End Sub ' ---------- Motor ---------- Private Sub Ejecutar(ByVal forzarModo As String) Dim cfg As Configuracion, est As EstadoExcel Dim ws As Worksheet, fso As Object, nombresVistos As Object Dim wordApp As Object, wordDoc As Object, outlookApp As Object Dim datos As Variant, nombres() As String, correos() As String, copias() As String, pendientes() As Boolean Dim ultima As Long, total As Long, primero As Long, ultimo As Long, p As Long, paginas As Long, ancho As Long Dim copiados As Long, entregados As Long, sinCorreo As Long, saltados As Long, desdeGuardado As Long Dim temporal As String, dirPaginas As String, dirNombres As String, registro As String, registroDestino As String Dim origen As String, localNombrado As String, destino As String, html As String, asunto As String Dim fase As String, errorTexto As String, inicio As Date, completo As Boolean, mensaje As String, limpieza As String Dim opcionesWord() As Boolean, opcionesWordGuardadas As Boolean ReDim opcionesWord(0 To 2) Dim segPDF As Double, segCopia As Double, segCorreo As Double, marca As Double If mEnCurso Then Exit Sub mEnCurso = True On Error GoTo Fallo inicio = Now fase = "Leer configuracion" cfg = LeerConfiguracion() If Len(forzarModo) > 0 Then cfg.ModoEnvio = forzarModo Set ws = ThisWorkbook.Worksheets(cfg.HojaDatos) Set fso = CreateObject("Scripting.FileSystemObject") If Not fso.FolderExists(cfg.CarpetaPDF) Then Err.Raise vbObjectError + 100, , "No existe la carpeta de salida: " & cfg.CarpetaPDF If Not (LCase$(Left$(cfg.RutaWord, 4)) = "http") Then If Not fso.FileExists(cfg.RutaWord) Then Err.Raise vbObjectError + 101, , "No existe el Word combinado: " & cfg.RutaWord End If fase = "Validar datos" ultima = UltimaFila(ws, cfg.ColNombre1) If ultima < 2 Then Err.Raise vbObjectError + 102, , "No hay filas de datos." total = ultima - 1 primero = cfg.PrimeraFila - 1 ultimo = IIf(cfg.UltimaFila = 0, total, cfg.UltimaFila - 1) If primero < 1 Or ultimo < primero Or ultimo > total Then Err.Raise vbObjectError + 103, , "El intervalo de filas del lote no es valido." ReDim nombres(1 To total): ReDim correos(1 To total): ReDim copias(1 To total): ReDim pendientes(1 To total) Set nombresVistos = CreateObject("Scripting.Dictionary") nombresVistos.CompareMode = vbTextCompare For p = primero To ultimo If IsError(ws.Cells(p + 1, cfg.ColNombre1).Value) Or IsError(ws.Cells(p + 1, cfg.ColNombre2).Value) Or IsError(ws.Cells(p + 1, cfg.ColCorreo).Value) Then Err.Raise vbObjectError + 104, , "Hay un error de Excel en la fila " & p + 1 End If ' >> ADAPTAR: nombre del PDF = " .pdf". Para anadir una tercera parte o la ' fecha: NombreArchivoSeguro("pdf", ws.Cells(p + 1, cfg.ColNombre1).Value, Format$(Date, "yyyy-mm")) nombres(p) = NombreArchivoSeguro("pdf", ws.Cells(p + 1, cfg.ColNombre1).Value, ws.Cells(p + 1, cfg.ColNombre2).Value) correos(p) = Trim$(CStr(ws.Cells(p + 1, cfg.ColCorreo).Value)) If cfg.ColCC > 0 Then copias(p) = Trim$(CStr(ws.Cells(p + 1, cfg.ColCC).Value)) If nombresVistos.Exists(nombres(p)) Then Err.Raise vbObjectError + 105, , "Nombre PDF repetido en filas " & nombresVistos(nombres(p)) & " y " & p + 1 & ": " & nombres(p) End If nombresVistos.Add nombres(p), p + 1 destino = fso.BuildPath(cfg.CarpetaPDF, nombres(p)) If Len(destino) > 240 Then Err.Raise vbObjectError + 106, , "Ruta demasiado larga en fila " & p + 1 ' Reanudacion: una fila marcada ENVIADO no se vuelve a tocar. pendientes(p) = True If cfg.ColEstado > 0 Then If UCase$(Left$(Trim$(CStr(ws.Cells(p + 1, cfg.ColEstado).Value)), 7)) = "ENVIADO" Then pendientes(p) = False: saltados = saltados + 1 End If End If If pendientes(p) And Not cfg.Sobrescribir Then If fso.FileExists(destino) Then Err.Raise vbObjectError + 107, , "Ya existe: " & destino End If Next p p = 0 fase = "Preparar temporales" temporal = fso.BuildPath(fso.GetSpecialFolder(2).Path, PREFIJO_TEMPORAL & fso.GetTempName) fso.CreateFolder temporal dirPaginas = fso.BuildPath(temporal, "paginas"): fso.CreateFolder dirPaginas dirNombres = fso.BuildPath(temporal, "nombrados"): fso.CreateFolder dirNombres registro = fso.BuildPath(temporal, "registro.tsv") registroDestino = fso.BuildPath(cfg.CarpetaPDF, "registro_" & Format$(inicio, "yyyymmdd_hhnnss") & ".tsv") RegistroCrear fso, registro RegistroAnotar fso, registro, 0, "INICIO", "", "", "Word: " & cfg.RutaWord & " | modo: " & cfg.ModoEnvio & " | saltadas por ENVIADO: " & saltados GuardarEstado est html = LeerPlantillaHTML() fase = "Abrir y paginar Word" Application.StatusBar = fase If cfg.EvitarAvisosOLE Then SuspenderAvisosOLE Set wordApp = CreateObject("Word.Application") ' instancia propia, nunca la del usuario wordApp.Visible = False wordApp.ScreenUpdating = False opcionesWord(0) = wordApp.Options.Pagination opcionesWord(1) = wordApp.Options.CheckSpellingAsYouType opcionesWord(2) = wordApp.Options.CheckGrammarAsYouType opcionesWordGuardadas = True wordApp.Options.CheckSpellingAsYouType = False wordApp.Options.CheckGrammarAsYouType = False Set wordDoc = wordApp.Documents.Open(cfg.RutaWord, False, True, False) wordDoc.Repaginate paginas = wordDoc.ComputeStatistics(2) ' wdStatisticPages If paginas <> total Then Err.Raise vbObjectError + 108, , "Word tiene " & paginas & " paginas y Excel " & total & " filas de datos. Se requiere una pagina por fila y el mismo orden." End If ancho = Len(CStr(total)) On Error Resume Next wordApp.Options.Pagination = False On Error GoTo Fallo fase = "Exportar paginas a PDF" For p = primero To ultimo If pendientes(p) Then marca = CDbl(Timer) origen = fso.BuildPath(dirPaginas, "pagina-" & Format$(p, String$(ancho, "0")) & ".pdf") ' PDF=17, calidad impresion=0, wdExportFromTo=3. Pagina p = fila p+1. wordDoc.ExportAsFixedFormat origen, 17, False, 0, 3, p, p ComprobarArchivoExiste fso, origen segPDF = segPDF + SegundosDesde(marca) marca = CDbl(Timer) localNombrado = fso.BuildPath(dirNombres, nombres(p)) destino = fso.BuildPath(cfg.CarpetaPDF, nombres(p)) fso.MoveFile origen, localNombrado fso.CopyFile localNombrado, destino, cfg.Sobrescribir ComprobarArchivoExiste fso, destino If fso.GetFile(localNombrado).Size <> fso.GetFile(destino).Size Then Err.Raise vbObjectError + 111, , "La copia no tiene el tamano esperado: " & destino copiados = copiados + 1 If cfg.ColEstado > 0 Then ws.Cells(p + 1, cfg.ColEstado).Value = "PDF " & Format$(Now, "yyyy-mm-dd hh:nn") RegistroAnotar fso, registro, p + 1, "PDF_OK", correos(p), destino, "" segCopia = segCopia + SegundosDesde(marca) End If Progreso "PDF guardados", p - primero + 1, ultimo - primero + 1 Next p p = 0 fase = "Cerrar Word" wordDoc.Close False: Set wordDoc = Nothing RestaurarWord wordApp, opcionesWord: opcionesWordGuardadas = False wordApp.Quit False: Set wordApp = Nothing RestaurarAvisosOLE RegistroAnotar fso, registro, 0, "GENERACION_OK", "", "", Format$(segPDF, "0.0") & " s PDF; " & Format$(segCopia, "0.0") & " s copia" If cfg.ModoEnvio <> "NINGUNO" Then fase = "Conectar con Outlook" Set outlookApp = ObtenerOutlook() fase = "Correos" marca = CDbl(Timer) For p = primero To ultimo If pendientes(p) Then destino = fso.BuildPath(cfg.CarpetaPDF, nombres(p)) If Len(correos(p)) > 0 Then asunto = RellenarPlantilla(cfg.Asunto, ws, p + 1) RegistroAnotar fso, registro, p + 1, "INTENTO_" & cfg.ModoEnvio, correos(p), destino, "" EnviarUno outlookApp, correos(p), copias(p), cfg.Remitente, asunto, _ RellenarPlantilla(html, ws, p + 1), fso.BuildPath(dirNombres, nombres(p)), cfg.ModoEnvio entregados = entregados + 1 If cfg.ColEstado > 0 Then ws.Cells(p + 1, cfg.ColEstado).Value = IIf(cfg.ModoEnvio = "ENVIAR", "ENVIADO ", "MOSTRADO ") & Format$(Now, "yyyy-mm-dd hh:nn") desdeGuardado = desdeGuardado + 1 If cfg.GuardarCada > 0 And desdeGuardado >= cfg.GuardarCada Then ThisWorkbook.Save: desdeGuardado = 0 End If End If RegistroAnotar fso, registro, p + 1, "ENTREGADO_A_OUTLOOK", correos(p), destino, asunto Else sinCorreo = sinCorreo + 1 If cfg.ColEstado > 0 Then ws.Cells(p + 1, cfg.ColEstado).Value = "SIN CORREO" RegistroAnotar fso, registro, p + 1, "SIN_CORREO", "", destino, "" End If End If Progreso "Correos", p - primero + 1, ultimo - primero + 1 Next p p = 0 segCorreo = SegundosDesde(marca) RegistroAnotar fso, registro, 0, "CORREO_OK", "", "", Format$(segCorreo, "0.0") & " s" End If RegistroAnotar fso, registro, 0, "FIN", "", "", "Duracion total: " & DateDiff("s", inicio, Now) & " s" completo = True GoTo Salida Fallo: errorTexto = "Error " & Err.Number & " en '" & fase & "': " & Err.Description If p >= 1 And p <= total Then errorTexto = errorTexto & " (fila " & p + 1 & ")" On Error Resume Next RegistroAnotar fso, registro, IIf(p >= 1 And p <= total, p + 1, 0), "ERROR", "", "", errorTexto On Error GoTo 0 Salida: On Error Resume Next If Not wordDoc Is Nothing Then wordDoc.Close False If opcionesWordGuardadas Then RestaurarWord wordApp, opcionesWord If Not wordApp Is Nothing Then wordApp.Quit False Set wordDoc = Nothing: Set wordApp = Nothing: Set outlookApp = Nothing Err.Clear RestaurarAvisosOLE If Err.Number <> 0 Then completo = False errorTexto = errorTexto & vbCrLf & "No se pudo restaurar el filtro OLE: " & Err.Description & ". Guarda y reinicia Excel antes de otro lote." End If If cfg.ColEstado > 0 And entregados > 0 Then ThisWorkbook.Save RestaurarEstado est On Error GoTo 0 mEnCurso = False If Len(registro) > 0 Then On Error Resume Next Err.Clear fso.CopyFile registro, registroDestino, False If Err.Number = 0 Then registro = registroDestino Else errorTexto = errorTexto & vbCrLf & "El registro se conserva en: " & registro On Error GoTo 0 End If mensaje = "PDF guardados: " & copiados & vbCrLf & _ "Correos (" & cfg.ModoEnvio & "): " & entregados & vbCrLf & _ "Filas sin correo: " & sinCorreo & vbCrLf & _ "Filas saltadas por estar ya ENVIADAS: " & saltados & vbCrLf & _ "Tiempos: PDF " & Format$(segPDF, "0.0") & " s, copia " & Format$(segCopia, "0.0") & " s, Outlook " & Format$(segCorreo, "0.0") & " s" If completo Then limpieza = LimpiarTemporal(fso, temporal) mensaje = "Proceso terminado." & vbCrLf & mensaje & IIf(Len(limpieza) > 0, vbCrLf & limpieza, "") Else mensaje = errorTexto & vbCrLf & mensaje & vbCrLf & "Temporales conservados: " & temporal & vbCrLf & _ "Vuelve a ejecutar la macro: las filas marcadas ENVIADO no se repiten." End If If Len(registro) > 0 Then mensaje = mensaje & vbCrLf & "Registro: " & registro Aviso mensaje, IIf(completo, vbInformation, vbExclamation) End Sub ' ---------- Configuracion ---------- Private Function LeerConfiguracion() As Configuracion Dim c As Configuracion c.RutaWord = LeerConfig("RutaWord") c.CarpetaPDF = LeerConfig("CarpetaPDF") c.HojaDatos = LeerConfig("HojaDatos") c.ColNombre1 = ColumnaANumero(LeerConfig("ColumnaNombre1", False, "A")) c.ColNombre2 = ColumnaANumero(LeerConfig("ColumnaNombre2", False, "B")) c.ColCorreo = ColumnaANumero(LeerConfig("ColumnaCorreo")) If Len(LeerConfig("ColumnaCC", False)) > 0 Then c.ColCC = ColumnaANumero(LeerConfig("ColumnaCC", False)) If Len(LeerConfig("ColumnaEstado", False)) > 0 Then c.ColEstado = ColumnaANumero(LeerConfig("ColumnaEstado", False)) c.Remitente = LeerConfig("Remitente", False) c.Asunto = LeerConfig("Asunto") c.PrimeraFila = ConfigLong("PrimeraFila", 2) c.UltimaFila = ConfigLong("UltimaFila", 0) c.Sobrescribir = ConfigBool("SobrescribirPDF", True) c.ModoEnvio = UCase$(LeerConfig("ModoEnvio", False, "MOSTRAR")) If c.ModoEnvio <> "ENVIAR" And c.ModoEnvio <> "MOSTRAR" And c.ModoEnvio <> "NINGUNO" Then Err.Raise vbObjectError + 3, , "ModoEnvio debe ser ENVIAR, MOSTRAR o NINGUNO." End If c.GuardarCada = ConfigLong("GuardarCada", 25) c.EvitarAvisosOLE = ConfigBool("EvitarAvisosOLE", True) If c.PrimeraFila < 2 Then Err.Raise vbObjectError + 4, , "PrimeraFila debe ser 2 o mayor (la fila 1 son cabeceras)." LeerConfiguracion = c End Function Private Function LeerPlantillaHTML() As String Dim ws As Worksheet, r As Long, s As String On Error Resume Next Set ws = ThisWorkbook.Worksheets("Plantilla") On Error GoTo 0 If ws Is Nothing Then Err.Raise vbObjectError + 5, , "Falta la hoja 'Plantilla' con el cuerpo HTML del correo en la columna A." For r = 1 To UltimaFila(ws, 1) s = s & CStr(ws.Cells(r, 1).Value) & vbCrLf Next r If Len(Trim$(s)) = 0 Then Err.Raise vbObjectError + 6, , "La hoja 'Plantilla' esta vacia." LeerPlantillaHTML = s End Function ' ---------- Outlook ---------- Private Sub EnviarUno(ByVal app As Object, ByVal destinatario As String, ByVal cc As String, ByVal remitente As String, _ ByVal asunto As String, ByVal html As String, ByVal adjunto As String, ByVal modo As String) Dim mail As Object Set mail = app.CreateItem(0) With mail .To = destinatario If Len(cc) > 0 Then .CC = cc If Len(remitente) > 0 Then .SentOnBehalfOfName = remitente .Subject = asunto .HTMLBody = html .Attachments.Add adjunto ' >> ADAPTAR: aqui se personaliza el correo. Ejemplos: ' .BCC = "archivo@tuempresa.com" copia oculta fija ' .Importance = 2 alta (0 baja, 1 normal) ' .Attachments.Add "C:\Envios\Condiciones.pdf" segundo adjunto fijo ' .ReadReceiptRequested = True acuse de recibo ' Para la firma de Outlook: usa .Display antes de .HTMLBody y concatena ' html & .HTMLBody (la firma se inserta al mostrar el correo). If modo = "ENVIAR" Then .Send Else .Display End With Set mail = Nothing End Sub ' ---------- Word ---------- Private Sub RestaurarWord(ByVal app As Object, ByRef opciones() As Boolean) On Error Resume Next app.Options.Pagination = opciones(0) app.Options.CheckSpellingAsYouType = opciones(1) app.Options.CheckGrammarAsYouType = opciones(2) On Error GoTo 0 End Sub ' ---------- Filtro OLE ("Excel esta esperando a otra aplicacion") ---------- Private Sub SuspenderAvisosOLE() If mFiltroOLESuspendido Then Err.Raise vbObjectError + 130, , "El filtro OLE de una ejecucion anterior sigue suspendido. Reinicia Excel." If CoRegisterMessageFilter(0, mFiltroOLEAnterior) <> 0 Then Err.Raise vbObjectError + 131, , "No se pudo suspender el filtro OLE." mFiltroOLESuspendido = True End Sub Private Sub RestaurarAvisosOLE() #If VBA7 Then Dim retirado As LongPtr #Else Dim retirado As Long #End If If Not mFiltroOLESuspendido Then Exit Sub If CoRegisterMessageFilter(mFiltroOLEAnterior, retirado) <> 0 Then Err.Raise vbObjectError + 132, , "CoRegisterMessageFilter fallo al restaurar." mFiltroOLESuspendido = False IUnknown_AtomicRelease retirado IUnknown_AtomicRelease mFiltroOLEAnterior End Sub ' ---------- Temporales ---------- Private Function LimpiarTemporal(ByVal fso As Object, ByVal carpeta As String) As String Dim ruta As String On Error GoTo NoBorrado ruta = fso.GetAbsolutePathName(carpeta) If StrComp(fso.GetParentFolderName(ruta), fso.GetAbsolutePathName(fso.GetSpecialFolder(2).Path), vbTextCompare) <> 0 Then GoTo NoBorrado If Left$(fso.GetFileName(ruta), Len(PREFIJO_TEMPORAL)) <> PREFIJO_TEMPORAL Then GoTo NoBorrado fso.DeleteFolder ruta, True Exit Function NoBorrado: LimpiarTemporal = "No se elimino la carpeta temporal: " & carpeta End Function