Consulting

Results 1 to 7 of 7

Thread: Save document as pdf and attach to new mail

  1. #1

    Save document as pdf and attach to new mail

    Hy,
    I have a macro that creates a new mail which works. Here is the macro.

    Dim olApp      As Object
        Dim strAnrede  As String
        Dim strName    As String
        Dim strFntClr  As String
        Dim strFntNme  As String
        Dim strFntWht  As String
        Dim strFntSiz  As String
        Dim strFntStl  As String
        Dim strFntUdl  As String
        Dim sMyString1 As String     'T1
        Dim sMyString2 As String     'T2
        Dim sMyString3 As String     'T3
        Dim sMyString4 As String     'T4
        Dim sMyString5 As String     'T5
        Dim sMyString6 As String     'T6
        Dim sMyString7 As String     'T7
        Dim sMyString8 As String     'T8
        sMyString1 = ActiveDocument.Bookmarks("T1").Range.Text
        sMyString2 = ActiveDocument.Bookmarks("T2").Range.Text
        sMyString3 = ActiveDocument.Bookmarks("T3").Range.Text
        sMyString4 = ActiveDocument.Bookmarks("T4").Range.Text
        sMyString5 = ActiveDocument.Bookmarks("T5").Range.Text
        sMyString6 = ActiveDocument.Bookmarks("T6").Range.Text
        sMyString7 = ActiveDocument.Bookmarks("T7").Range.Text
        sMyString8 = ActiveDocument.Bookmarks("T8").Range.Text
               
            Set olApp = CreateObject("Outlook.Application")
                With olApp.CreateItem(0)
                    .To = sMyString1
                    .Subject = "text " & sMyString8
                    .HTMLBody = sMyString7 & " " & sMyString4 & "<span style='color:" & strFntClr & "; " & _
                                "font-family:" & strFntNme & "; font-size:" & strFntSiz & _
                                "pt; font-weight:" & strFntWht & "; font-style:" & strFntStl & _
                                ",'>" & strName & "</span>,<br><br>" & _
                                "text " & sMyString8 & " zu senden." & "<br><br>" & _
                                "text" & "<br><br>" & _
                                "Kind Regards" & "<br><br>" & _
                                "Ttext" & "<br>"
    
                        .Display
                    End With
                
    
    End Sub
    
    Public Function FarbeInHtml(ByVal lngRGB As Long) As String
    FarbeInHtml = Right$("000000" & Hex$(lngRGB), 6)
    FarbeInHtml = "#" & Right$(FarbeInHtml, 2) & Mid$(FarbeInHtml, 3, 2) & Left$(FarbeInHtml, 2)
    End Function

    The Word document has a macro that saves the .docm file as a .docx file. Here is the macro:


    Dim firstName, lastName As String
    firstName = ActiveDocument.Bookmarks("T7").Range.Text
    lastName = ActiveDocument.Bookmarks("T8").Range.Text
    
    Dim pfad As String
    pfad = ActiveDocument.Path & Application.PathSeparator & "Data" & Application.PathSeparator
    
        ChangeFileOpenDirectory pfad
        ActiveDocument.SaveAs2 FileName:= _
            "firstName.docx", FileFormat:= _
            wdFormatXMLDocument, LockComments:=False, Password:="", AddToRecentFiles _
            :=True, WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts _
            :=False, SaveNativePictureFormat:=False, SaveFormsData:=False, _
            SaveAsAOCELetter:=False, CompatibilityMode:=15
    End Sub
    This works also fine.
    Now I want to save the new .docx file as a PDF with the same name in the same folder as the .docx file and attach the PDF to the created mail.
    I searched and tried a lot, but I had no luck.

    Can you help me please?
    Thanks a lot.
    Kind Regards

  2. #2

  3. #3
    Thanks for your ansert.
    Creating a pdf works now.
    But the code with the Mail attachments does not work.


    Dim myItem As Outlook.MailItem
        Dim myAttachments As Outlook.Attachments
        
        Set myItem = Application.CreateItem(olApp)
        Set myAttachments = myItem.Attachments
        Set myItem = Application.CreateItem(olApp)
        Set myAttachments = myItem.Attachments
        
        Dim myPath As String
        Dim CurrentFolder As String
    I got an error: method or object not found

    Set myItem = Application.CreateItem(olApp)

    What made i wrong?
    Thanks

  4. #4
    This works now...

    Dim myItem As Outlook.MailItem
        
        Set myItem = Outlook.CreateItem(olMailItem)
        
        Dim myPath As String
        Dim CurrentFolder As String
    But there is an error on the following code:

    myItem.Add "CurrentFolder\File1.pdf"
    myItem.Display

  5. #5
    I tried a lot of things but it still does not work.
    I have this code now:

    Dim olApp      As Object
        Dim strAnrede  As String
        Dim strName    As String
        Dim strFntClr  As String
        Dim strFntNme  As String
        Dim strFntWht  As String
        Dim strFntSiz  As String
        Dim strFntStl  As String
        Dim strFntUdl  As String
        Dim sMyString1 As String     'T1
        Dim sMyString2 As String     'T2
        Dim sMyString3 As String     'T3
        Dim sMyString4 As String     'T4
        Dim sMyString5 As String     'T5
        Dim sMyString6 As String     'T6
        Dim sMyString7 As String     'T7
        Dim sMyString8 As String     'T8
        sMyString1 = ActiveDocument.Bookmarks("T1").Range.Text
        sMyString2 = ActiveDocument.Bookmarks("T2").Range.Text
        sMyString3 = ActiveDocument.Bookmarks("T3").Range.Text
        sMyString4 = ActiveDocument.Bookmarks("T4").Range.Text
        sMyString5 = ActiveDocument.Bookmarks("T5").Range.Text
        sMyString6 = ActiveDocument.Bookmarks("T6").Range.Text
        sMyString7 = ActiveDocument.Bookmarks("T7").Range.Text
        sMyString8 = ActiveDocument.Bookmarks("T8").Range.Text
        
        '*_*_* MAIL*_*_*_
        Dim myItem As Outlook.MailItem
        
        Set myItem = Outlook.CreateItem(olMailItem)
        
        Dim myPath As String
        Dim CurrentFolder As String
        
        myPath = ActiveDocument.FullName & Application.PathSeparator & "Rechnungen" & Application.PathSeparator
        CurrentFolder = ActiveDocument.Path & Application.PathSeparator & "Rechnungen" & Application.PathSeparator
        '*_*_* MAIL*_*_*_
            
            Set olApp = CreateObject("Outlook.Application")
                With olApp.CreateItem(0)
                    .To = sMyString1
                    .Subject = "Rechnung " & sMyString8
                    .HTMLBody = sMyString7 & " " & sMyString4 & "<span style='color:" & strFntClr & "; " & _
                                "font-family:" & strFntNme & "; font-size:" & strFntSiz & _
                                "pt; font-weight:" & strFntWht & "; font-style:" & strFntStl & _
                                ",'>" & strName & "</span>,<br><br>" & _
                                "Ich erlaube mir, Ihnen die Rechnung " & sMyString8 & " zu senden." & "<br><br>" & _
                                "Ich bitte um Überweisung auf das untenstehende Konto." & "<br><br>" & _
                                "Mit freundlichen Grüßen" & "<br><br>" & _
                                "Teresa Santer BA MA" & "<br>"
    
                     myItem.Attachments.Add CurrentFolder & Application.PathSeparator & "Rechnungen.pdf"
                     myItem.Display
                        
                .Display
            End With
    But now I get 2 Mails. The first contains all the informations (Adress, Text....)
    And the second Mail contains the pdf file only.
    Can you please help me again?

    Thanks a lot.
    Kind Regards

  6. #6
    VBAX Regular
    Joined
    Nov 2020
    Location
    Swansea,South Wales,UK
    Posts
    86
    Location
    I always create the objects in the correct order?
    Outlook object
    outlook email
    Any attachments
    Send or display

    So do not use myitem and use all the code within the With olApp.CreateItem block?

    However still better to get the logic in order correctly? and understand it as well. Too many people just cobble code together with little clue as to how it works?

  7. #7
    Where to begin? Your code has undeclared variables that don't appear to refer to anything and assorted declared variables that have no values assigned. Without the document it is not clear what the bookmarks refer to so it is not possible to establish for example what strName refers to. However we are where we are and the following should point the way.You may need to change the variables used in the message to ensure they refer to the correct bookmarks.

    Programming German text in English versions of Word creates some issues that are obvious from your reproduced code in order to produce the German special characters. That may not be so with the German interface of Windows and Office, but it is something to bear in mind.

    I would strongly recommend using the Outlook Word editor to edit the message (as in the code below) as it is so much easier to do so than juggle with Outlook's implementation of HTML. You just treat the message as a Word document. You do however have to start Outlook correctly or it won't work. To that end see the note at the top of the code which points to the function you can download that is called by the macro below.

    The code here also inserts the default signature associated with the sending account, so you may need to adjust the message body to accommodate that.

    Finally I would not recommend the use of bookmarks to set the variable texts. Bookmarks are notoriously easy for users to overwrite and that will cause problems. I strongly urge you to use content controls instead. These can be locked against deletion and can be given meaningful titles for ease of access. See https://www.gmayor.com/insert_content_control_addin.htm

    Option Explicit
    
    'Graham Mayor - http://www.gmayor.com - Last updated - 13/11/2020
    
    'Requires the code from - http://www.rondebruin.nl/win/s1/outlook/openclose.htm
    'to either retrieve an open instance of Outlook or open Outlook if it is closed.
    
    Private Sub Send_As_Mail()
    Dim olApp As Object
    Dim olInsp As Object
    Dim oItem As Object
    Dim wdDoc As Document
    Dim oRng As Range
    Dim bStarted As Boolean
    Dim oDoc As Document
    Dim strDocName As String
    Dim strPath As String
    Dim intPos As Integer
    Dim sMyString1 As String
    Dim sMyString2 As String
    Dim sMyString3 As String
    Dim sMyString4 As String
    Dim sMyString5 As String
    Dim sMyString6 As String
    Dim sMyString7 As String
    Dim sMyString8 As String
    
        Set oDoc = ActiveDocument
        oDoc.Save
        If oDoc.path = "" Then
            MsgBox "Das Dokument muss zuerst gespeichert werden"
            GoTo lbl_Exit
        End If
    
        sMyString1 = oDoc.Bookmarks("T1").Range.Text
        sMyString2 = oDoc.Bookmarks("T2").Range.Text
        sMyString3 = oDoc.Bookmarks("T3").Range.Text
        sMyString4 = oDoc.Bookmarks("T4").Range.Text
        sMyString5 = oDoc.Bookmarks("T5").Range.Text
        sMyString6 = oDoc.Bookmarks("T6").Range.Text
        sMyString7 = oDoc.Bookmarks("T7").Range.Text
        sMyString8 = oDoc.Bookmarks("T8").Range.Text
    
        strDocName = oDoc.Name
        strPath = oDoc.path & "\Rechnungen\"
        intPos = InStrRev(strDocName, ".")
        strDocName = Left(strDocName, intPos - 1)
        strDocName = strPath & strDocName & ".pdf"
        oDoc.ExportAsFixedFormat OutputFileName:=strDocName, _
                                 ExportFormat:=wdExportFormatPDF, _
                                 OpenAfterExport:=False, _
                                 OptimizeFor:=wdExportOptimizeForPrint, _
                                 Range:=wdExportAllDocument, from:=1, To:=1, _
                                 Item:=wdExportDocumentContent, _
                                 IncludeDocProps:=True, _
                                 KeepIRM:=True, _
                                 CreateBookmarks:=wdExportCreateHeadingBookmarks, _
                                 DocStructureTags:=True, _
                                 BitmapMissingFonts:=True, _
                                 UseISO19005_1:=False
        Set olApp = OutlookApp()
    
        'Create a new mailitem
        Set oItem = olApp.CreateItem(0)
    
        With oItem
            .To = sMyString1
            .Subject = "Rechnung " & sMyString8
            .Attachments.Add strDocName
            .BodyFormat = 2        'olFormatHTML
            Set olInsp = .GetInspector
            Set wdDoc = olInsp.WordEditor
            .Display 'do not remove
            Set oRng = wdDoc.Range
            oRng.Collapse 1
            oRng.Text = sMyString7 & " " & sMyString4 & sMyString5 & vbCr & vbCr & _
                        "Ich erlaube mir, Ihnen die Rechnung " & sMyString8 & " zu senden." & vbCr & vbCr & _
                        "Ich bitte um " & ChrW(220) & "berweisung auf das unten stehende Konto." & vbCr & vbCr & _
                        "Mit freundlichen Gr" & ChrW(252) & ChrW(223) & "en" & vbCr & vbCr & _
                        "Teresa Santer BA MA"
            With oRng.Paragraphs(1).Range
                .Font.Bold = True
                .Font.Size = 14
            End With
            '.Send        'restore after testing
        End With
        If bStarted Then olApp.Quit
    lbl_Exit:
        Set oItem = Nothing
        Set olApp = Nothing
        Set olInsp = Nothing
        Set wdDoc = Nothing
        Set oDoc = Nothing
        Set oRng = Nothing
        Exit Sub
    err_Handler:
        Err.Clear
        GoTo lbl_Exit
    End Sub
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

Posting Permissions

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