excel 2007 macro para guardar hoja activa como pdf y enviar por gmail también como pdf
publicado
Hola ; tendría que modificar esta macro para que me guarde la hoja activa como pdf y la envía como pdf a través de gmail. Esta macro esta armada para que haga esto pero me la esta guardando como xls y también me la envió como xls.
Por favor alguien la podria revisar y decirme que tengo mal
Sub GuardarEnviarGmailClientes7()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False
'PDFCLIENTES Macro
Dim sPEDIDOS_LAMA As String
Dim sHIS_CLIENT_LAMA As String
Dim sRutaEscritorio As String
Dim WScript As Object
Set WScript = CreateObject("WScript.Shell")
sRutaEscritorio = WScript.SpecialFolders("Desktop")
Set WScript = Nothing
sPEDIDOS_LAMA = sRutaEscritorio & "\PEDIDOS LAMA"
sHIS_CLIENT_LAMA = sRutaEscritorio & "\HISTORIAL CLIENTES LAMA"
If Len(Dir(sPEDIDOS_LAMA, vbDirectory)) = 0 Then
MkDir sPEDIDOS_LAMA
End If
If Len(Dir(sHIS_CLIENT_LAMA, vbDirectory)) = 0 Then
MkDir sHIS_CLIENT_LAMA
End If
'
ActiveSheet.Unprotect
'se impide que se ejecute la macro CHANGE de la hoja
Application.EnableEvents = False
Range("B3:U224").Select
ActiveSheet.PageSetup.PrintArea = "$B$3:$U$224"
ActiveSheet.Range("$F$20:$F$224").AutoFilter Field:=1, Criteria1:="<>"
ActiveWindow.SmallScroll Down:=-21
With ActiveSheet.PageSetup
.LeftHeader = "&""Arial Black,Normal""&11Hoja &P De &N"
.CenterHeader = "&""Arial Black,Normal""&11&A"
.RightHeader = "&""Arial Black,Normal""&11&D &T "
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(0.15748031496063)
.RightMargin = Application.InchesToPoints(0.15748031496063)
.TopMargin = Application.InchesToPoints(0.393700787401575)
.BottomMargin = Application.InchesToPoints(0.196850393700787)
.HeaderMargin = Application.InchesToPoints(0.118110236220472)
.FooterMargin = Application.InchesToPoints(0)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.CenterHorizontally = False
.CenterVertically = False
.Orientation = xlPortrait
.Draft = False
.PaperSize = xlPaperA4
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = 54
.PrintErrors = xlPrintErrorsDisplayed
.OddAndEvenPagesHeaderFooter = False
.DifferentFirstPageHeaderFooter = False
.ScaleWithDocHeaderFooter = True
.AlignMarginsHeaderFooter = False
.EvenPage.LeftHeader.Text = ""
.EvenPage.CenterHeader.Text = ""
.EvenPage.RightHeader.Text = ""
.EvenPage.LeftFooter.Text = ""
.EvenPage.CenterFooter.Text = ""
.EvenPage.RightFooter.Text = ""
.FirstPage.LeftHeader.Text = ""
.FirstPage.CenterHeader.Text = ""
.FirstPage.RightHeader.Text = ""
.FirstPage.LeftFooter.Text = ""
.FirstPage.CenterFooter.Text = ""
.FirstPage.RightFooter.Text = ""
End With
'Por.Dante Amor
' Macro para crear carpeta, guardar una hoja y enviar por Gmail
ActiveSheet.Range("$F$20:$F$224").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 = escritorio & "\Pedidos Lama\"
'ruta = "C:\trabajo\"
carp = "pedidos " & Format(Date, "dd-mm-yyyy")
nomb = h1.[G7] & " " & Format(h1.[F4], "dd-mm-yyyy-hhmmss")
'
rut2 = ruta & carp
If Dir(rut2, vbDirectory) = "" Then
MkDir rut2
End If
'
'h1.Copy
h1.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=rut2 & "\" & nomb & ".pdf", Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
'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(cdoSMTPServer) = "smtp.mail.yahoo.com"
'Email.Configuration.Fields(cdoSMTPServer) = "smtp.live.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/smtpserverport") = CLng(25) ' hotmail
.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 = h1.Range("F13").Value
.From = correo
.Subject = nomb
.TextBody = Range("G15").Value
.AddAttachment rut2 & "\" & nomb & ".pdf"
.Configuration.Fields.Update
dam.Send 'El correo se envía en automático
On Error Resume Next
.Send
End With
If Err.Number = 0 Then
MsgBox "Hoja Guardarda y enviada por Gmail al cliente", vbInformation, "CREAR CARPETA Y GUARDAR HOJA"
Else
MsgBox "Se produjo el siguiente error: " & Err.Number & " " & Err.Description
End If
Set Email = Nothing
'PDFCLIENTESFINAL Macro
'
ActiveSheet.Range("$F$20:$F$224").AutoFilter Field:=1
Range("B3:Q224").Select
ActiveSheet.PageSetup.PrintArea = "$B$3:$Q$224"
' PDFCLIENTECERRAR Macro
'
ActiveSheet.Range("$F$20:$F$224").AutoFilter Field:=1, Criteria1:="<>"
Range("F7").Select
With ActiveSheet.PageSetup
.LeftHeader = "&""Arial Black,Normal""&11Hoja &P De &N"
.CenterHeader = "&""Arial Black,Normal""&11&A"
.RightHeader = "&""Arial Black,Normal""&11&D &T "
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(0.15748031496063)
.RightMargin = Application.InchesToPoints(0.15748031496063)
.TopMargin = Application.InchesToPoints(0.393700787401575)
.BottomMargin = Application.InchesToPoints(0.196850393700787)
.HeaderMargin = Application.InchesToPoints(0.118110236220472)
.FooterMargin = Application.InchesToPoints(0)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.CenterHorizontally = False
.CenterVertically = False
.Orientation = xlPortrait
.Draft = False
.PaperSize = xlPaperA4
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = 70
.PrintErrors = xlPrintErrorsDisplayed
.OddAndEvenPagesHeaderFooter = False
.DifferentFirstPageHeaderFooter = False
.ScaleWithDocHeaderFooter = True
.AlignMarginsHeaderFooter = False
.EvenPage.LeftHeader.Text = ""
.EvenPage.CenterHeader.Text = ""
.EvenPage.RightHeader.Text = ""
.EvenPage.LeftFooter.Text = ""
.EvenPage.CenterFooter.Text = ""
.EvenPage.RightFooter.Text = ""
.FirstPage.LeftHeader.Text = ""
.FirstPage.CenterHeader.Text = ""
.FirstPage.RightHeader.Text = ""
.FirstPage.LeftFooter.Text = ""
.FirstPage.CenterFooter.Text = ""
.FirstPage.RightFooter.Text = ""
End With
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
, AllowSorting:=True, AllowFiltering:=True
'se vuelve a habilitar la macro CHANGE de la hoja
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
ActiveSheet.DisplayPageBreaks = True
Application.CutCopyMode = False
End Sub
Featured Replies
Archivado
Este tema está ahora archivado y está cerrado a más respuestas.
Hola ; tendría que modificar esta macro para que me guarde la hoja activa como pdf y la envía como pdf a través de gmail. Esta macro esta armada para que haga esto pero me la esta guardando como xls y también me la envió como xls.
Por favor alguien la podria revisar y decirme que tengo mal
Sub GuardarEnviarGmailClientes7() Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Application.EnableEvents = False ActiveSheet.DisplayPageBreaks = False 'PDFCLIENTES Macro Dim sPEDIDOS_LAMA As String Dim sHIS_CLIENT_LAMA As String Dim sRutaEscritorio As String Dim WScript As Object Set WScript = CreateObject("WScript.Shell") sRutaEscritorio = WScript.SpecialFolders("Desktop") Set WScript = Nothing sPEDIDOS_LAMA = sRutaEscritorio & "\PEDIDOS LAMA" sHIS_CLIENT_LAMA = sRutaEscritorio & "\HISTORIAL CLIENTES LAMA" If Len(Dir(sPEDIDOS_LAMA, vbDirectory)) = 0 Then MkDir sPEDIDOS_LAMA End If If Len(Dir(sHIS_CLIENT_LAMA, vbDirectory)) = 0 Then MkDir sHIS_CLIENT_LAMA End If ' ActiveSheet.Unprotect 'se impide que se ejecute la macro CHANGE de la hoja Application.EnableEvents = False Range("B3:U224").Select ActiveSheet.PageSetup.PrintArea = "$B$3:$U$224" ActiveSheet.Range("$F$20:$F$224").AutoFilter Field:=1, Criteria1:="<>" ActiveWindow.SmallScroll Down:=-21 With ActiveSheet.PageSetup .LeftHeader = "&""Arial Black,Normal""&11Hoja &P De &N" .CenterHeader = "&""Arial Black,Normal""&11&A" .RightHeader = "&""Arial Black,Normal""&11&D &T " .LeftFooter = "" .CenterFooter = "" .RightFooter = "" .LeftMargin = Application.InchesToPoints(0.15748031496063) .RightMargin = Application.InchesToPoints(0.15748031496063) .TopMargin = Application.InchesToPoints(0.393700787401575) .BottomMargin = Application.InchesToPoints(0.196850393700787) .HeaderMargin = Application.InchesToPoints(0.118110236220472) .FooterMargin = Application.InchesToPoints(0) .PrintHeadings = False .PrintGridlines = False .PrintComments = xlPrintNoComments .CenterHorizontally = False .CenterVertically = False .Orientation = xlPortrait .Draft = False .PaperSize = xlPaperA4 .FirstPageNumber = xlAutomatic .Order = xlDownThenOver .BlackAndWhite = False .Zoom = 54 .PrintErrors = xlPrintErrorsDisplayed .OddAndEvenPagesHeaderFooter = False .DifferentFirstPageHeaderFooter = False .ScaleWithDocHeaderFooter = True .AlignMarginsHeaderFooter = False .EvenPage.LeftHeader.Text = "" .EvenPage.CenterHeader.Text = "" .EvenPage.RightHeader.Text = "" .EvenPage.LeftFooter.Text = "" .EvenPage.CenterFooter.Text = "" .EvenPage.RightFooter.Text = "" .FirstPage.LeftHeader.Text = "" .FirstPage.CenterHeader.Text = "" .FirstPage.RightHeader.Text = "" .FirstPage.LeftFooter.Text = "" .FirstPage.CenterFooter.Text = "" .FirstPage.RightFooter.Text = "" End With 'Por.Dante Amor ' Macro para crear carpeta, guardar una hoja y enviar por Gmail ActiveSheet.Range("$F$20:$F$224").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 = escritorio & "\Pedidos Lama\" 'ruta = "C:\trabajo\" carp = "pedidos " & Format(Date, "dd-mm-yyyy") nomb = h1.[G7] & " " & Format(h1.[F4], "dd-mm-yyyy-hhmmss") ' rut2 = ruta & carp If Dir(rut2, vbDirectory) = "" Then MkDir rut2 End If ' 'h1.Copy h1.ExportAsFixedFormat Type:=xlTypePDF, _ Filename:=rut2 & "\" & nomb & ".pdf", Quality:=xlQualityStandard, _ IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False '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(cdoSMTPServer) = "smtp.mail.yahoo.com" 'Email.Configuration.Fields(cdoSMTPServer) = "smtp.live.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/smtpserverport") = CLng(25) ' hotmail .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 = h1.Range("F13").Value .From = correo .Subject = nomb .TextBody = Range("G15").Value .AddAttachment rut2 & "\" & nomb & ".pdf" .Configuration.Fields.Update dam.Send 'El correo se envía en automático On Error Resume Next .Send End With If Err.Number = 0 Then MsgBox "Hoja Guardarda y enviada por Gmail al cliente", vbInformation, "CREAR CARPETA Y GUARDAR HOJA" Else MsgBox "Se produjo el siguiente error: " & Err.Number & " " & Err.Description End If Set Email = Nothing 'PDFCLIENTESFINAL Macro ' ActiveSheet.Range("$F$20:$F$224").AutoFilter Field:=1 Range("B3:Q224").Select ActiveSheet.PageSetup.PrintArea = "$B$3:$Q$224" ' PDFCLIENTECERRAR Macro ' ActiveSheet.Range("$F$20:$F$224").AutoFilter Field:=1, Criteria1:="<>" Range("F7").Select With ActiveSheet.PageSetup .LeftHeader = "&""Arial Black,Normal""&11Hoja &P De &N" .CenterHeader = "&""Arial Black,Normal""&11&A" .RightHeader = "&""Arial Black,Normal""&11&D &T " .LeftFooter = "" .CenterFooter = "" .RightFooter = "" .LeftMargin = Application.InchesToPoints(0.15748031496063) .RightMargin = Application.InchesToPoints(0.15748031496063) .TopMargin = Application.InchesToPoints(0.393700787401575) .BottomMargin = Application.InchesToPoints(0.196850393700787) .HeaderMargin = Application.InchesToPoints(0.118110236220472) .FooterMargin = Application.InchesToPoints(0) .PrintHeadings = False .PrintGridlines = False .PrintComments = xlPrintNoComments .CenterHorizontally = False .CenterVertically = False .Orientation = xlPortrait .Draft = False .PaperSize = xlPaperA4 .FirstPageNumber = xlAutomatic .Order = xlDownThenOver .BlackAndWhite = False .Zoom = 70 .PrintErrors = xlPrintErrorsDisplayed .OddAndEvenPagesHeaderFooter = False .DifferentFirstPageHeaderFooter = False .ScaleWithDocHeaderFooter = True .AlignMarginsHeaderFooter = False .EvenPage.LeftHeader.Text = "" .EvenPage.CenterHeader.Text = "" .EvenPage.RightHeader.Text = "" .EvenPage.LeftFooter.Text = "" .EvenPage.CenterFooter.Text = "" .EvenPage.RightFooter.Text = "" .FirstPage.LeftHeader.Text = "" .FirstPage.CenterHeader.Text = "" .FirstPage.RightHeader.Text = "" .FirstPage.LeftFooter.Text = "" .FirstPage.CenterFooter.Text = "" .FirstPage.RightFooter.Text = "" End With ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _ , AllowSorting:=True, AllowFiltering:=True 'se vuelve a habilitar la macro CHANGE de la hoja Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic Application.EnableEvents = True ActiveSheet.DisplayPageBreaks = True Application.CutCopyMode = False End Sub