Saltar al contenido

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

No hay posts para mostrar

Archivado

Este tema está ahora archivado y está cerrado a más respuestas.

Ir al listado de temas