Consulting

Page 2 of 2 FirstFirst 1 2
Results 21 to 25 of 25

Thread: Add current worksheet as pdf to gmail

  1. #21
    VBAX Regular
    Joined
    Aug 2019
    Location
    Fortaleza
    Posts
    11
    Location
    Hello Leith,
    Sorry to bother with this one, despiet all the help!
    It's giving me an error 1004 - Application or Object Related
    Sub SendGmailPDF()
    
    
    
        Dim File        As String
        Dim Folder      As Variant
        Dim cdoNS       As String
        Dim cdoMsg      As Object
        Dim htmlMsg     As String
        Dim Password    As String
        Dim strBCC      As String
        Dim strCC       As String
        Dim strMsg      As String
        Dim strSubj     As String
        Dim ReplyTo     As String
        Dim strTo       As String
        Dim UserEmail   As String
        Dim RelatorioComissao As Worksheet
        Dim LastRowResults As Range
        Dim lastrow     As Long
        Dim Data        As Date
        
        Set RelatorioComissao = Worksheets("Relatório de Comissão")
        Data = RelatorioComissao.Range("B8").Value
    
    
        
        
            ' Email Information.
            strTo = RelatorioComissao.Range("B6").Value
            strSubj = "Relatório de Comissão" & "-" & RelatorioComissao.Range("B5").Value & "-" & Format(Data, "mmm/yy")
            strMsg = "Em anexo, segue o relatório de comissão. Sugerimos que revisem os detalhes."
            strCC = "Email"
            strBCC = ""
            ReplyTo = "Email"
            
            ' Gmail Account Information.
            UserEmail = RelatorioComissao.Range("B3").Value
            Password = RelatorioComissao.Range("B4").Value
            
            ' Save ActiveSheet as a PDF file to the user's Desktop and attach it to this email.
            If UserEmail = "" Or Password = "" Then
                MsgBox "Informe seu email e senha!"
                Exit Sub
            End If
                'Application.EnableEvents = False
                File = "Relatório de Comissão" & RelatorioComissao.Range("B5").Value & "-" & Format(Data, "mmm/yy") & ".pdf"
                If ActiveSheet.Range("A17").Value = "" Then
                    lastrow = 16
                    MsgBox "Não há comissão no período!"
                    Exit Sub
                Else
                    lastrow = Range("A17").End(xlDown).Row
                End If
                
                'Application.EnableEvents = True
               
                ActiveSheet.Range("A1:K" & lastrow).Select
                Selection.ExportAsFixedFormat Type:=xlTypePDF, Filename:=File, Quality:=xlQualityStandard, IgnorePrintAreas:=False
                'ActiveWorkbook.Close SaveChanges:=False
                 
              
            
            
               Set cdoMsg = CreateObject("CDO.Message")
    
    
    
    
                With cdoMsg
                    .To = strTo
                    .Subject = strSubj
                    .From = UserEmail
                    .ReplyTo = ReplyTo
                    .CC = strCC
                    .BCC = strBCC
                    
                    .TextBody = strMsg
                    .AddAttachment File
                
                     With .Configuration.Fields
                        .Item(cdoNS & "smtpusessl") = True              ' Any non zero value is True
                        .Item(cdoNS & "smtpauthenticate") = 1           ' basic clear text
                        .Item(cdoNS & "sendusername") = UserEmail
                        .Item(cdoNS & "sendpassword") = Password
                        .Item(cdoNS & "smtpserver") = "smtp.gmail.com"
                        .Item(cdoNS & "sendusing") = 2                  ' Using Port
                        .Item(cdoNS & "smtpserverport") = 465           ' Gmail SMTP Port
                        .Item(cdoNS & "smtpconnectiontimeout") = 60
                        .Update
                    End With
                
                    .Send
                                
                End With
            
    End Sub
    thanks a million!

  2. #22
    VBAX Regular
    Joined
    Aug 2019
    Location
    Fortaleza
    Posts
    11
    Location

    1004 Error unexplainable (to me)!

    Hello Leith,

    The error is within the piece below. It evens shows as it's publishing, but then the error window pops pup, saying that it's an object or application definition related error...
    Thanks in advance for your attention/help!

    Piece of Code reffered by the Debugger:
    RelatorioComissao.Range("A1:K" & lastrow).ExportAsFixedFormat _
    Type:=xlTypePDF, _
    Filename:=File, _
    Quality:=xlQualityStandard, _
    IgnorePrintAreas:=False


    Sub SendGmailPDF()
    
    
    
    
        Dim File        As String
        Dim Folder      As Variant
        Dim cdoNS       As String
        Dim cdoMsg      As Object
        Dim htmlMsg     As String
        Dim Password    As String
        Dim strBCC      As String
        Dim strCC       As String
        Dim strMsg      As String
        Dim strSubj     As String
        Dim strTo       As String
        Dim UserEmail   As String
        Dim RelatorioComissao As Worksheet
        Dim LastRowResults As Range
        Dim lastrow     As Long
        Dim Data        As Date
        Dim List        As String
        Dim Rng         As Range
        
        
        Set RelatorioComissao = ActiveWorkbook.Sheets("Relatório de Comissão")
        Data = RelatorioComissao.Range("B8").Value
        
           ' Email Information.
            strTo = RelatorioComissao.Range("B6").Value
            strSubj = "Relatório de Comissão" & "-" & RelatorioComissao.Range("B5").Value & "-" & Format(Data, "mmm/yy")
            strMsg = "Em anexo, segue o relatório de comissão. Sugerimos que revisem os detalhes."
            strCC = ""
            strBCC = ""
            ReplyTo = "Email"
            ' Gmail Account Information.
            UserEmail = RelatorioComissao.Range("B3").Value
            Password = RelatorioComissao.Range("B4").Value
            
            
            If UserEmail = "" Or Password = "" Then
                MsgBox "Informe seu email e senha!"
                Exit Sub
            End If
            
            File = "Relatório de Comissão" & RelatorioComissao.Range("B5").Value & "-" & Format(Data, "mmm/yy") & ".pdf"
                If RelatorioComissao.Range("A17").Value = "" Then
                    lastrow = 16
                    MsgBox "Não há comissão no período!"
                    Exit Sub
                Else
                    'lastrow = Cells(Rows.Count, "K").End(xlUp).Row
                    
                    lastrow = Range("A" & ActiveSheet.Rows.Count).End(xlDown).Row
                    'lastrow = RelatorioComissao.Cells(Rows.Count, 1).End(xlUp).Row
                End If
           
           
           MsgBox lastrow
           
           RelatorioComissao.Range("A1:K" & lastrow).ExportAsFixedFormat _
           Type:=xlTypePDF, _
           Filename:=File, _
           Quality:=xlQualityStandard, _
           IgnorePrintAreas:=False
           
           'ActiveSheet.Range("A1:K" & lastrow).Select
           'Selection.ExportAsFixedFormat Type:=xlTypePDF, Filename:=File, Quality:=xlQualityStandard, IgnorePrintAreas:=False
           
           
           
            
            
            
               Set cdoMsg = CreateObject("CDO.Message")
    
    
    
    
                With cdoMsg
                    .To = strTo
                    .Subject = strSubj
                    .From = UserEmail
                    .ReplyTo = ReplyTo
                    .CC = strCC
                    .BCC = strBCC
                    .TextBody = strMsg
                    .AddAttachment File
                
                     With .Configuration.Fields
                        .Item(cdoNS & "smtpusessl") = True              ' Any non zero value is True
                        .Item(cdoNS & "smtpauthenticate") = 1           ' basic clear text
                        .Item(cdoNS & "sendusername") = UserEmail
                        .Item(cdoNS & "sendpassword") = Password
                        .Item(cdoNS & "smtpserver") = "smtp.gmail.com"
                        .Item(cdoNS & "sendusing") = 2                  ' Using Port
                        .Item(cdoNS & "smtpserverport") = 465           ' Gmail SMTP Port
                        .Item(cdoNS & "smtpconnectiontimeout") = 60
                        .Update
                    End With
                
                    .Send
                End With
    End Sub

  3. #23
    VBAX Regular
    Joined
    Aug 2019
    Location
    Fortaleza
    Posts
    11
    Location

    Problem Solved!

    I got it to work basically using your instructions!
    Again, thanks a million!

    Cheers,
    Antonio
    PS: if you think that providing the solution here is of any help to others, let me know and I will do it with pleasure.

  4. #24
    VBAX Expert Leith Ross's Avatar
    Joined
    Oct 2012
    Location
    San Francisco, California
    Posts
    552
    Location
    Hello santosonit,

    I would like to know the what the problem was and what you did to fix it. I have never this error before. Thanks.
    Sincerely,
    Leith Ross

    "1N73LL1G3NC3 15 7H3 4B1L17Y 70 4D4P7 70 CH4NG3 - 573PH3N H4WK1NG"

  5. #25
    VBAX Regular
    Joined
    Aug 2019
    Location
    Fortaleza
    Posts
    11
    Location

    Solution.

    Quote Originally Posted by Leith Ross View Post
    Hello santosonit,

    I would like to know the what the problem was and what you did to fix it. I have never this error before. Thanks.

    Hello Leith,

    Here's how I've fixed it:

     If RelComissao.Range("A17").Value =""Then
            lastrow =16
            MsgBox "Não há comissão no período!"
            ExitSub
        Else
            lastrow = Range("A"& ActiveSheet.Rows.Count).End(xlUp).Row
        EndIf
    
        With CreateObject("Shell.Application")
            Folder =.Namespace(0).Self.Path &""
            File = Folder & ActiveWorkbook.Name
            File = File & RelComissao.Range("B5").Value &"-"& Format(Data,"mmm-yy")&".pdf"
            RelComissao.Range("A1:K"& lastrow).Select
            Selection.ExportAsFixedFormat Type:=xlTypePDF, Filename:=File
        EndWith 


    I think that because I hadn't specified a place where the file should be exported to, AddAttachment couldn't catch it and the code got stuck there. Also, I changed the way lastrow was detected.

    I'm sorry, I'm not a developer and can't go any deeper (concept wise) why this solution worked.

    Thank you!


    Last edited by santosonit; 09-16-2019 at 06:46 AM. Reason: Added CODE Styling

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •