Macro para enviar correos desde un archivo Excel

Yo hace un tiempo puse un post referente a esto y creo que hay alguna cosa más por el foro.

Intenta buscar el post y adecuarlo a lo que necesites.

Has de saber que con el lenguaje VBA solo puedes enviar correos planos (sin negritas, ni subrayados...), para darle formato al texto lo has de hacer con HTML. Aparte tampoco aplica la firma.

Te adjunto mi macro para correo que hay lenguaje VBA y HTML pero la has de entender y adaptar como lo necesites.

Como veras en mi ejemplo le doy formato al texto y soluciono el problema de la firma.

Pude hacer esta macro gracias a la ayuda de muchos de los compañeros de este foro.

En Sub_adjuntar la diferencia que hay es que se te abre el outlook con el mensaje y los archivos adjuntos y puedes adjuntar más archivos y has de pulsar tu el botón de enviar.

En Sub_enviar directamente envía el correo con los datos adjuntos sin abrir outlook y te lo confirma mediante un MSGBOX.

Hay cosas que están en Catalán si crees que te van ayudar a entender el código usa el traductor aunque creo que se puede entender bien.

No soy un experto ni nada por el estilo, no se si la programación es la mejor pero a mi me funciona

Private Sub adjuntar_Click()
        Application.ScreenUpdating = False
        Application.CutCopyMode = False
hoja_1 = "Buscador"
    Set l1 = ThisWorkbook
    Set h1 = l1.Sheets(hoja_1) '
ruta = "z:\DIGITALITZACIONS\Expedients tramitats\signatures\"
logo = "logotip.jpg"
    libro2 = "dades.xlsm"
    hoja_2 = "Registres enviats"
    ruta2 = ThisWorkbook.Path & "\"
Dim OutlookApp As outlook.Application
Dim MItem As outlook.MailItem
Dim Correo As String
Dim adjunt As Variant
Dim registre As String
Dim Msg As String
Const olFormatHTML As Integer = 2
Const ForReading As Integer = 1
Const TristateUseDefault As Integer = -2
If generica.Value = True Then
ElseIf Alicia.Value = True Then
ElseIf Pol.Value = True Then
ElseIf Silvia.Value = True Then
ElseIf jmaria.Value = True Then
ElseIf teresa.Value = True Then
ElseIf anna.Value = True Then
ElseIf lorea.Value = True Then
ElseIf merce.Value = True Then
ElseIf Pere.Value = True Then
 Else
            MsgBox "Selecciona una signatura"
Exit Sub
End If
If generica.Value = True Then
Set MiPc = CreateObject("Scripting.FileSystemObject")
Set Cadena = MiPc.GetFile("z:\DIGITALITZACIONS\Expedients tramitats\signatures\firma generica.htm").OpenAsTextStream(ForReading, TristateUseDefault)
firma = Cadena.ReadAll
ElseIf Alicia.Value = True Then
Set MiPc = CreateObject("Scripting.FileSystemObject")
Set Cadena = MiPc.GetFile("z:\DIGITALITZACIONS\Expedients tramitats\signatures\firma alicia.htm").OpenAsTextStream(ForReading, TristateUseDefault)
firma = Cadena.ReadAll
ElseIf Pol.Value = True Then
Set MiPc = CreateObject("Scripting.FileSystemObject")
Set Cadena = MiPc.GetFile("z:\DIGITALITZACIONS\Expedients tramitats\signatures\firma pol.htm").OpenAsTextStream(ForReading, TristateUseDefault)
firma = Cadena.ReadAll
ElseIf Silvia.Value = True Then
Set MiPc = CreateObject("Scripting.FileSystemObject")
Set Cadena = MiPc.GetFile("z:\DIGITALITZACIONS\Expedients tramitats\signatures\firma silvia.htm").OpenAsTextStream(ForReading, TristateUseDefault)
firma = Cadena.ReadAll
ElseIf jmaria.Value = True Then
Set MiPc = CreateObject("Scripting.FileSystemObject")
Set Cadena = MiPc.GetFile("z:\DIGITALITZACIONS\Expedients tramitats\signatures\firma josep maria.htm").OpenAsTextStream(ForReading, TristateUseDefault)
firma = Cadena.ReadAll
ElseIf teresa.Value = True Then
Set MiPc = CreateObject("Scripting.FileSystemObject")
Set Cadena = MiPc.GetFile("z:\DIGITALITZACIONS\Expedients tramitats\signatures\firma teresa.htm").OpenAsTextStream(ForReading, TristateUseDefault)
firma = Cadena.ReadAll
ElseIf anna.Value = True Then
Set MiPc = CreateObject("Scripting.FileSystemObject")
Set Cadena = MiPc.GetFile("z:\DIGITALITZACIONS\Expedients tramitats\signatures\firma anna.htm").OpenAsTextStream(ForReading, TristateUseDefault)
firma = Cadena.ReadAll
ElseIf lorea.Value = True Then
Set MiPc = CreateObject("Scripting.FileSystemObject")
Set Cadena = MiPc.GetFile("z:\DIGITALITZACIONS\Expedients tramitats\signatures\firma lorea.htm").OpenAsTextStream(ForReading, TristateUseDefault)
firma = Cadena.ReadAll
ElseIf merce.Value = True Then
Set MiPc = CreateObject("Scripting.FileSystemObject")
Set Cadena = MiPc.GetFile("z:\DIGITALITZACIONS\Expedients tramitats\signatures\firma merce.htm").OpenAsTextStream(ForReading, TristateUseDefault)
firma = Cadena.ReadAll
ElseIf Pere.Value = True Then
Set MiPc = CreateObject("Scripting.FileSystemObject")
Set Cadena = MiPc.GetFile("z:\DIGITALITZACIONS\Expedients tramitats\signatures\firma pere.htm").OpenAsTextStream(ForReading, TristateUseDefault)
firma = Cadena.ReadAll
End If
Set OutlookApp = New outlook.Application
        adjunt = "z:\DIGITALITZACIONS\Expedients tramitats\Registres tramitats a les oficines" & "\" & h1.registre_oficina.Value & "\" & h1.registre_oficina.Value & "-" & h1.registre_numero.Value & "-" & h1.registre_any.Value & "\" & h1.registre_oficina.Value & "-" & h1.registre_numero.Value & "-" & h1.registre_any.Value & " RR.pdf"
        registre = h1.registre_oficina.Value & "/" & h1.registre_numero.Value & "/" & h1.registre_any.Value
        'Cuerpo del mensaje
        '
        Cuerpo = "Benvolgut/da, " & _
        "<p>Adjunt us fem arribar el comprovant d'enviament a través de la plataforma EACAT, de l'expedient amb número<b> " & registre & "</b>.</p>
" & _
        "<p>Podeu facilitar aquest resguard a la persona interessada si així us ho demanen.</p>
" & _
        "<p>Salutacions,</p>
" & _
        "<br> <br> <br>"
        Set MItem = OutlookApp.CreateItem(olMailItem)
        Set b = h1.Columns("N").Find(h1.registre_oficina.Value, LookIn:=xlValues, lookat:=xlWhole)
    If Not b Is Nothing Then
        With MItem
            .To = h1.Cells(b.Row, "P")
            .Subject = "Rebut del registre " & registre & " mitjançant EACAT"
            .Attachments.Add (adjunt)
            .Attachments.Add ruta & logo
            .BodyFormat = olFormatHTML
            .HTMLBody = _
                "<HTML> " & _
                    "<BODY>" & _
                        Cuerpo & _
                        "<img src=cid:" & logo & " height=35 width=172>" & _
                    firma & _
                    "</BODY> " & _
                "</HTML>"
            '
          .Display
        End With
   Dim Carpeta As String
hoja_1 = "Buscador"
    Set l1 = ThisWorkbook
    Set h1 = l1.Sheets("buscador")
   Carpeta = "z:\DIGITALITZACIONS\Expedients tramitats\Registres tramitats a les oficines" & "\" & h1.registre_oficina.Value & "\" & h1.registre_oficina.Value & "-" & h1.registre_numero.Value & "-" & h1.registre_any.Value
     Call Shell("explorer.exe " & Carpeta, vbNormalFocus)
    End If
   correu2.Hide
End Sub
Private Sub enviar_Click()
        Application.ScreenUpdating = False
hoja_1 = "Buscador"
    Set l1 = ThisWorkbook
    Set h1 = l1.Sheets(hoja_1) '
ruta = "z:\DIGITALITZACIONS\Expedients tramitats\signatures\"
logo = "logotip.jpg"
    libro2 = "dades.xlsm"
    hoja_2 = "Registres enviats"
    ruta2 = ThisWorkbook.Path & "\"
Dim OutlookApp As outlook.Application
Dim MItem As outlook.MailItem
Dim Correo As String
Dim adjunt As Variant
Dim registre As String
Dim Msg As String
Const olFormatHTML As Integer = 2
Const ForReading As Integer = 1
Const TristateUseDefault As Integer = -2
If generica.Value = True Then
ElseIf Alicia.Value = True Then
ElseIf Pol.Value = True Then
ElseIf Silvia.Value = True Then
ElseIf jmaria.Value = True Then
ElseIf teresa.Value = True Then
ElseIf anna.Value = True Then
ElseIf lorea.Value = True Then
ElseIf merce.Value = True Then
ElseIf Pere.Value = True Then
Else
            MsgBox "Selecciona una signatura"
Exit Sub
End If
If generica.Value = True Then
Set MiPc = CreateObject("Scripting.FileSystemObject")
Set Cadena = MiPc.GetFile("z:\DIGITALITZACIONS\Expedients tramitats\signatures\firma generica.htm").OpenAsTextStream(ForReading, TristateUseDefault)
firma = Cadena.ReadAll
ElseIf Alicia.Value = True Then
Set MiPc = CreateObject("Scripting.FileSystemObject")
Set Cadena = MiPc.GetFile("z:\DIGITALITZACIONS\Expedients tramitats\signatures\firma alicia.htm").OpenAsTextStream(ForReading, TristateUseDefault)
firma = Cadena.ReadAll
ElseIf Pol.Value = True Then
Set MiPc = CreateObject("Scripting.FileSystemObject")
Set Cadena = MiPc.GetFile("z:\DIGITALITZACIONS\Expedients tramitats\signatures\firma pol.htm").OpenAsTextStream(ForReading, TristateUseDefault)
firma = Cadena.ReadAll
ElseIf Silvia.Value = True Then
Set MiPc = CreateObject("Scripting.FileSystemObject")
Set Cadena = MiPc.GetFile("z:\DIGITALITZACIONS\Expedients tramitats\signatures\firma silvia.htm").OpenAsTextStream(ForReading, TristateUseDefault)
firma = Cadena.ReadAll
ElseIf jmaria.Value = True Then
Set MiPc = CreateObject("Scripting.FileSystemObject")
Set Cadena = MiPc.GetFile("z:\DIGITALITZACIONS\Expedients tramitats\signatures\firma josep maria.htm").OpenAsTextStream(ForReading, TristateUseDefault)
firma = Cadena.ReadAll
ElseIf teresa.Value = True Then
Set MiPc = CreateObject("Scripting.FileSystemObject")
Set Cadena = MiPc.GetFile("z:\DIGITALITZACIONS\Expedients tramitats\signatures\firma teresa.htm").OpenAsTextStream(ForReading, TristateUseDefault)
firma = Cadena.ReadAll
ElseIf anna.Value = True Then
Set MiPc = CreateObject("Scripting.FileSystemObject")
Set Cadena = MiPc.GetFile("z:\DIGITALITZACIONS\Expedients tramitats\signatures\firma anna.htm").OpenAsTextStream(ForReading, TristateUseDefault)
firma = Cadena.ReadAll
ElseIf lorea.Value = True Then
Set MiPc = CreateObject("Scripting.FileSystemObject")
Set Cadena = MiPc.GetFile("z:\DIGITALITZACIONS\Expedients tramitats\signatures\firma lorea.htm").OpenAsTextStream(ForReading, TristateUseDefault)
firma = Cadena.ReadAll
ElseIf merce.Value = True Then
Set MiPc = CreateObject("Scripting.FileSystemObject")
Set Cadena = MiPc.GetFile("z:\DIGITALITZACIONS\Expedients tramitats\signatures\firma merce.htm").OpenAsTextStream(ForReading, TristateUseDefault)
firma = Cadena.ReadAll
ElseIf Pere.Value = True Then
Set MiPc = CreateObject("Scripting.FileSystemObject")
Set Cadena = MiPc.GetFile("z:\DIGITALITZACIONS\Expedients tramitats\signatures\firma pere.htm").OpenAsTextStream(ForReading, TristateUseDefault)
firma = Cadena.ReadAll
End If
Set OutlookApp = New outlook.Application
        adjunt = "z:\DIGITALITZACIONS\Expedients tramitats\Registres tramitats a les oficines" & "\" & h1.registre_oficina.Value & "\" & h1.registre_oficina.Value & "-" & h1.registre_numero.Value & "-" & h1.registre_any.Value & "\" & h1.registre_oficina.Value & "-" & h1.registre_numero.Value & "-" & h1.registre_any.Value & " RR.pdf"
        registre = h1.registre_oficina.Value & "/" & h1.registre_numero.Value & "/" & h1.registre_any.Value
        'Cuerpo del mensaje
        '
        Cuerpo = "Benvolgut/da, " & _
        "<p>Adjunt us fem arribar el comprovant d'enviament a través de la plataforma EACAT, de l'expedient amb número<b> " & registre & "</b>.</p>
" & _
        "<p>Podeu facilitar aquest resguard a la persona interessada si així us ho demanen.</p>
" & _
        "<p>Salutacions,</p>
" & _
        "<br> <br> <br>"
        Set MItem = OutlookApp.CreateItem(olMailItem)
        Set b = h1.Columns("N").Find(h1.registre_oficina.Value, LookIn:=xlValues, lookat:=xlWhole)
    If Not b Is Nothing Then
        With MItem
            .To = h1.Cells(b.Row, "P")
            .Subject = "Rebut del registre " & registre & " mitjançant EACAT"
            .Attachments.Add (adjunt)
            .Attachments.Add ruta & logo
            .BodyFormat = olFormatHTML
            .HTMLBody = _
                "<HTML> " & _
                    "<BODY>" & _
                        Cuerpo & _
                        "<img src=cid:" & logo & " height=35 width=172>" & _
                    firma & _
                    "</BODY> " & _
                "</HTML>"
            '
          .Send
        End With
    End If
    CreateObject("wscript.shell").Popup _
    "El correu ha estat enviat correctament ", 1, "Missatge temporal"
Correu2. Hide
End Sub