Save document as pdf and attach to new mail [Archive]

moosmahna

11-12-2020, 12:05 AM

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 & "" & strName & ", " & _
"text " & sMyString8 & " zu senden." & " " & _
"text" & " " & _
"Kind Regards" & " " & _
"Ttext" & " "

.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

Gasman

11-12-2020, 06:08 AM

https://www.thespreadsheetguru.com/the-code-vault/microsoft-word-vba-to-save-document-as-a-pdf-in-same-folder

https://docs.microsoft.com/en-us/office/vba/api/outlook.attachments.add

moosmahna

11-12-2020, 06:52 AM

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

moosmahna

11-12-2020, 07:01 AM

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

moosmahna

11-12-2020, 07:19 AM

I tried a lot of things but it still does not work. :banghead:
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 & "" & strName & ", " & _
"Ich erlaube mir, Ihnen die Rechnung " & sMyString8 & " zu senden." & " " & _
"Ich bitte um Überweisung auf das untenstehende Konto." & " " & _
"Mit freundlichen Grüßen" & " " & _
"Teresa Santer BA MA" & " "

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

Gasman

11-12-2020, 07:27 AM

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? :banghead:

gmayor

11-13-2020, 12:41 AM

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 (http://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