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
' : )