Excel 2007 macro para enviar hoja activa mediante gmail sacando la información de la hoja

Tengo la hoja activa de donde sacacar la información que seria:

Asunto: celda ""g7+f4" ( la celda f4 con formato de fecha)"

Cuerpo de mail celda "g15"

Ahora la información de los correo están en otra hoja del mismo libro que se llama "mail"

Mi correo de gmail en la celda "d9"

Mi contraseña en la celda "d11"

Destinatarios que son varios en "d16", "d18", "d20" y "d22"

1 Respuesta

Respuesta
1

H o l a:

Te anexo la macro

Sub GuardarEnviarGmail()
'Por.Dante Amor
' Macro para crear carpeta, guardar una hoja y enviar por Gmail
'
    ActiveSheet.Range("$F$19:$F$211").AutoFilter Field:=1, Criteria1:="<>"
    Range("F4:G5").Select
    ActiveCell.FormulaR1C1 = "=NOW()"
    Range("F4:G5").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Range("F7").Select
    Application.CutCopyMode = False
   'Por.Dante Amor
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Set l1 = ThisWorkbook
    Set h1 = l1.ActiveSheet
    ruta = "C:\Documents and Settings\Administrador\Escritorio\PEDIDOS LAMA\"
    'ruta = "C:\trabajo\"
    carp = "pedidos " & Format(Date, "dd-mm-yyyy")
    nomb = h1.[G7] & " " & Format(h1.[F4], "dd-mm-yyyy-hh-mm-ss")
    '
    rut2 = ruta & carp
    If Dir(rut2, vbDirectory) = "" Then
        MkDir rut2
    End If
    '
    h1.Copy
    Set l2 = ActiveWorkbook
    l2.SaveAs Filename:=rut2 & "\" & nomb & ".xls", _
        FileFormat:=xlExcel8, Password:="", WriteResPassword:="", _
        ReadOnlyRecommended:=False, CreateBackup:=False
    'l2.SaveAs rut2 & "\" & nomb & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    l2.Close
    '
    'Enviar por GMAIL
    Dim Email As CDO.Message
    '
    Set h2 = l1.Sheets("MAIL")
    correo = h2.Range("D9").Value
    passwd = h2.Range("D11").Value
    '
    Set Email = New CDO.Message
    Email.Configuration.Fields(cdoSMTPServer) = "smtp.gmail.com"
    Email.Configuration.Fields(cdoSendUsingMethod) = 2
    With Email.Configuration.Fields
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = CLng(465)
        .Item("http://schemas.microsoft.com/cdo/" & "configuration/smtpauthenticate") = Abs(1)
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = 30
        .Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = correo
        .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = passwd
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
    End With
    With Email
        .To = h2.Range("D16").Value & ";" & h2.Range("D18").Value
        .From = correo
        .Subject = nomb
        .TextBody = Range("G15").Value
        .AddAttachment rut2 & "\" & nomb & ".xls"
        .Configuration.Fields.Update
        On Error Resume Next
        .Send
    End With
    If Err.Number = 0 Then
        MsgBox "Hoja Guardarda y enviada por Outlook", vbInformation, "CREAR CARPETA Y GUARDAR HOJA"
    Else
        MsgBox "Se produjo el siguiente error: " & Err.Number & " " & Err.Description
    End If
    Set Email = Nothing
End Sub

' : )
'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias
' : )

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas