No Outlook: Excel Sending mail with CDO.

countryfan_nt

Well-known Member
Joined
May 19, 2004
Messages
758
Hello friends, Hope all is well!

The code below does work. it sends a sheet as PDF via Outlook.
Please help me edit the code, so that it sends a sheet as PDF withOUT Outlook; but CDO.

Your kind is needed and really appreciated in advance!


Code:
Private Sub Email()
    
    Set OutApp = GetObject(, "Outlook.Application")
    Dim IsCreated As Boolean
    Dim i As Long
    Dim ab, ac, ad, emTo, emCC As String
    Dim PdfFile As String, Title As String
    Dim OutlApp As Object
    
    emTo = Worksheets("PDF").Range("BD4").Value
    emCC = Worksheets("PDF").Range("BD5").Value
    ab = Worksheets("PDF").Range("B1").Value
    GREET = Worksheets("PDF").Range("AZ4").Value
    AMPM = Worksheets("PDF").Range("AZ6").Value
    
    Set xSht = ThisWorkbook.Sheets("PDF")
   
   
   Title = AMPM & " - " & Sheets("PDF").Range("G1")
    TitleF = AMPM & " Period Update - " & Format(ab, "ddd dd-mmm-yyyy") & " - Medical Gas Inspection Summary."
    
    PdfFile = ActiveWorkbook.FullName
    i = InStrRev(PdfFile, ".")
    If i > 1 Then PdfFile = Left(PdfFile, i - 1)
    PdfFile = AMPM & " Period Update - " & Format(ab, "ddd dd-mmm-yyyy") & " - Medical Gas Inspection Summary" & ".pdf"
    
    
     Sheets("PDF").Visible = True
     
    xSht.ExportAsFixedFormat Type:=xlTypePDF, _
                                       Filename:=PdfFile, _
                                       Quality:=xlQualityStandard, _
                                       IncludeDocProperties:=True, _
                                       IgnorePrintAreas:=False, _
                                       OpenAfterPublish:=False
     
    On Error Resume Next
    Set OutlApp = GetObject(, "Outlook.Application")
    
    If Err Then
        Set OutlApp = CreateObject("Outlook.Application")
        IsCreated = True
    End If
    
    OutlApp.Visible = True
    On Error GoTo 0
    
    With OutlApp.CreateItem(0)
        ' Prepare e-mail
        .Subject = TitleF
        .to = emTo ' <-- Put email of the recipient here
        .CC = emCC ' <-- Put email of 'copy to' recipient here
        .HTMLBody = GREET & vbLf & vbLf _
                    & "<p> The attachment here displays the findings of the inspections of all the medical gasses (per location & Branch)." & vbLf _
                    & "<p> Whethere the they were actually inspected or not, and what what are the results are after a physical visit." & vbLf _
                    & "<p><i>Two emails will be sent on daily basis (weekends not included)</i>" & vbLf & vbLf _
                    & "<p><p>Best Regards,<br>" & vbLf _
                    & " " & vbLf & vbLf
                    .Attachments.Add PdfFile
        ' Try to send
        On Error Resume Next
        Set .SendUsingAccount = OutlApp.Session.Accounts.Item(1)   'Use 2nd Account in the  list
         
        .DISPLAY
        Application.Wait (Now + TimeValue("0:00:01"))
        Application.SendKeys "%s"
         
        Application.Visible = True
        
        On Error GoTo 0
    End With
    
    ' Delete PDF file
    Kill PdfFile
    
    ' Quit Outlook if it was created by this code
    If IsCreated Then OutlApp.Quit
    
    ' Release the memory of object variable
    Set OutlApp = Nothing
    
Sheets("PDF").Visible = False
End Sub
 

Excel Facts

Round to nearest half hour?
Use =MROUND(A2,"0:30") to round to nearest half hour. Use =CEILING(A2,"0:30") to round to next half hour.
Hello! OK I figured something out, but got stuck again. please help me fix the following bug:
Run time error 13: Type Mismatch

The highlighted line is: .Attachments.Add PdfFile

Thank you very much in advance!


Code:
Sub SendMail()
Dim filepath As String
 'TODO:change filepath for the temp pdf file
 'Exporting range of the excel contents which need to sent out
 Dim PdfFile As String, Title As String
 Dim IsCreated As Boolean
 Dim i As Long
 Dim ab, ac, ad, emTo, emCC As String
    
    
    emTo = Worksheets("PDF").Range("BD4").Value
    emCC = Worksheets("PDF").Range("BD5").Value
    ab = Worksheets("PDF").Range("B1").Value
    GREET = Worksheets("PDF").Range("AZ4").Value
    AMPM = Worksheets("PDF").Range("AZ6").Value
 
    
    Set xSht = ThisWorkbook.Sheets("PDF")
   
' Hide all sheets except PDF
'Sheets(Array("Khobar", "Qassim", "Takhassusi", "SWD", "RayyanMainBldg", "RayyanIVFRoom1Room2", "OlayaOSSHB1HMC3", "OlayaMatB1IVFB1")).Visible = False
   
    ' Not sure for what the Title is
   Title = AMPM & " - " & Sheets("PDF").Range("G1")
    TitleF = AMPM & " Period Update - " & Format(ab, "ddd dd-mmm-yyyy") & " - Medical Gas Inspection Summary."
    
    ' Title & " - " & ab
    ' Define PDF filename
    PdfFile = ActiveWorkbook.FullName
    i = InStrRev(PdfFile, ".")
    If i > 1 Then PdfFile = Left(PdfFile, i - 1)
    PdfFile = AMPM & " Period Update - " & Format(ab, "ddd dd-mmm-yyyy") & " - Medical Gas Inspection Summary" & ".pdf"
    
   ' PdfFile
   ' Export activesheet as PDF
    
     Sheets("PDF").Visible = True
     
    xSht.ExportAsFixedFormat Type:=xlTypePDF, _
                                       Filename:=PdfFile, _
                                       Quality:=xlQualityStandard, _
                                       IncludeDocProperties:=True, _
                                       IgnorePrintAreas:=False, _
                                       OpenAfterPublish:=False
     
    
 'Setting up CDOSYS configuration to send out the email
Set iMsg = CreateObject("CDO.Message")
    Set iConf = CreateObject("CDO.Configuration")
    Set Flds = iConf.Fields
    With Flds
        .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2 'send via port
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "ServerName" 'TODO:update the SMTP server name here
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
        .Update
    End With
 
    With iMsg
         Set .Configuration = iConf
        .From = "nwf@domain.com" 'TODO:change email address here
        .To = emTo  'TODO:change email address here
        .cc = emCC  'TODO:change email address here
                
        .Subject = TitleF
        
                   .HTMLBody = GREET & vbLf & vbLf _
                    & "<p> The attachment here displays the findings of the inspections of all the medical gasses (per location & Branch)." & vbLf _
                    & "<p> Whethere the they were actually inspected or not, and what what are the results are after a physical visit." & vbLf _
                    & "<p><i>Two emails will be sent on daily basis (weekends not included)</i>" & vbLf & vbLf _
                    & "<p><p>Best Regards,<br>" & vbLf _
                    & " " & vbLf & vbLf
        
            
'     .AddAttachment PdfFile
     'PdfFile
       .Attachments.Add PdfFile
        
        
        .DISPLAY
        Application.Wait (Now + TimeValue("0:00:01"))
        Application.SendKeys "%s"
         
        Application.Visible = True
        
              
    End With
 
    Set iMsg = Nothing
    Set iConf = Nothing
End Sub
 
Upvote 0

Forum statistics

Threads
1,213,563
Messages
6,114,332
Members
448,566
Latest member
Nickdozaj

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top