I wish to mail merge and email from an Access query and pre setup word doc. It appears to work fine, as a the merged data document appears along with a new merged document that I have (for now) save. BUT what I really want it to do is send the actual email, rather than having to manually go to 'Finish & Merge" from MsWord. Simply it just doesn't actually send the email(s).
Function runMerge()
Dim StrFullDocPath As String
Dim oApp As Object
'Path to the word document
StrFullDocPath = "merge.docx" 'have removed the full path
'to save file name
outFileName = "Renewals_" & Format(Now(), "dd-mm-yyyy")
If Dir(StrFullDocPath) = "" Then
MsgBox "Document not found"
Else
'Create an instance of MS Word
Set oApp = CreateObject("Word.Application")
oApp.Visible = True
'Open the Document
oApp.Documents.Open FileName:=StrFullDocPath
End If
With oApp
With .ActiveDocument.MailMerge
.MainDocumentType = wdEMail
.OpenDataSource _
Name:="myDB.accdb", _
LinkToSource:=True, _
AddToRecentFiles:=False, _
Connection:="QUERY qryCheckRenews", _
SQLStatement:="SELECT * FROM [qryCheckRenews]"
.Destination = wdSendToEmail
.MailAddressFieldName = "EmailAddress"
.MailFormat = wdMailFormatHTML
.MailAsAttachment = False
.MailSubject = "testing testing 1, 2, 3"
.SuppressBlankLines = True
.Execute Pause:=False
MsgBox "Mail Merge Complete ", vbOKOnly, "myDB"
End With
oApp.ActiveDocument.SaveAs2 FileName:="Renewal" & outFileName & ".docx"
'oApp.Documents.Close savechanges:=False
Set oApp = Nothing
End With
'Exit Sub
'ErrTrap:
' MsgBox Err.Description, vbCritical
End Function
Any help gratefully received
Related
So I have been trying to use a the below macro to split a mail-merged document into individual documents. When I run the macro, I receive "Runtime Error '5852' Requested object is not available." The issue is highlighted as .Destination = wdSendToNewDocumentwhen using the debug action.
I though that perhaps the issue was with the file being located on my OneDrive but after moving the files to a local drive, I recieved the same issue. Any insight into how to resolve this error would be helpful.
If more info is necessary, please let me know and I would be happy to answer as best I could.
Code for reference:
Sub MailMergeToDoc()
'
' MailMergeToDoc Macro
' Collects the results of the mail merge in a document
'
' Sourced from: https://www.msofficeforums.com/mail-merge/21803-mailmerge-tips-tricks.html
Application.ScreenUpdating = False
Dim StrFolder As String, StrName As String, MainDoc As Document, i As Long, j As Long
Const StrNoChr As String = """*./\:?|"
Set MainDoc = ActiveDocument
With MainDoc
StrFolder = .Path & "\"
With .MailMerge
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
On Error Resume Next
For i = 1 To .DataSource.RecordCount
With .DataSource
.FirstRecord = i
.LastRecord = i
.ActiveRecord = i
If Trim(.DataFields("Last_Name")) = "" Then Exit For
'StrFolder = .DataFields("Folder") & "\"
StrName = .DataFields("Last_Name") & "_" & .DataFields("First_Name")
End With
On Error GoTo NextRecord
.Execute Pause:=False
For j = 1 To Len(StrNoChr)
StrName = Replace(StrName, Mid(StrNoChr, j, 1), "_")
Next
StrName = Trim(StrName)
With ActiveDocument
'Add the name to the footer
'.Sections(1).Footers(wdHeaderFooterPrimary).Range.InsertBefore StrName
.SaveAs FileName:=StrFolder & StrName & ".docx", FileFormat:=wdFormatXMLDocument, AddToRecentFiles:=False
' and/or:
.SaveAs2 FileName:=StrFolder & StrName & ".pdf", FileFormat:=wdFormatPDF, AddToRecentFiles:=False
.Close SaveChanges:=False
End With
NextRecord:
Next i
End With
End With
Application.ScreenUpdating = True
End Sub
This is pretty basic troubleshooting. You can't just copy code without understanding what it's doing.
Your MailMerge object does not exist when you're trying to run the mail merge.
You need to create a Mail Merge first in your Word doc - just use the Wizard - and that object will be magically filled. Then you'll have to progress to your next error.
Generated Word Document does not convert to PDF
I generate a Word Document populating the bookmarks within it from excel and then tried exporting to PDF. Constantly getting error even after adding Microsoft Word Library 16.0. What am I doing wrong here?
Option Explicit
Sub GenerateTerminationLetter()
Dim objWord As Object, docWord As Object
Dim wb As Workbook
Dim xlName As Name
Dim Path, SavePath, TempPath, FileName3 As String
Dim EmpFileName As String
Set wb = ThisWorkbook
' ******************************* Primary Letter Template Location ***********************
Sheets("FilePath").Select
TempPath = Sheets("FilePath").Range("C16").Value
If Right(TempPath, 1) <> "\" Then
TempPath = TempPath & "\"
Else
End If
Path = TempPath & "Termination Letter (Redundancy A023 FPP) (NEW - With Whistle Blowing Statement).docx"
'*******************************Populate Bookmarks ***************************************
On Error GoTo ErrorHandler
'Create a new Word Session
Set objWord = CreateObject("Word.Application")
'Open document in word
Set docWord = objWord.Documents.Add(Path)
'Loop through names in the activeworkbook
For Each xlName In wb.Names
'if xlName's name exists in the document then put the value at the bookmark
If docWord.Bookmarks.Exists(xlName.Name) Then
docWord.Bookmarks(xlName.Name).Range.Text = Range(xlName.Value)
End If
Next xlName
Sheets("Temp").Visible = xlVeryHidden
'******************************* Activate word and display document **********************
With objWord
.Visible = True
.Activate
End With
'Save Termination Letter
FileName3 = Sheets("R-Copy").Range("D7").Value
'******************************* Export as PDF ********************************************
docWord.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=EmpFolder & "\" & "Termination Letter_" & FileName3, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
ExportFormat:=wdExportFormatPDF
objWord.Quit
'Release the Word object to save memory and exit macro
ErrorExit:
Set objWord = Nothing
Exit Sub
'Error Handling routine
ErrorHandler:
If Err Then
MsgBox "Error No: " & Err.Number & "; There is a problem. Contact Administrator"
If Not objWord Is Nothing Then objWord.Quit False
Resume ErrorExit
End If
End Sub
Error No. 448: Contact Administrator
Which line is triggering the error? I'm assuming its the exportAsFixedFormat line. Error 448 is Named argument not found, and it looks like Type isn't one of the allowed arguments. You problably want ExportFormat:=wdExportFormatPDF, which it looks like you've included, but Type isn't an allowed argument, and will cause an error. Here's the docs on that method: https://learn.microsoft.com/en-us/office/vba/api/word.document.exportasfixedformat
It looks like some of the other arguments you're using aren't quite right, too, since they're referencing xl instead of wd types and the property names don't quite line up. Try:
docWord.ExportAsFixedFormat _
OutputFileName:=EmpFolder & "\" & "Termination Letter_" & FileName3, _
IncludeDocProps:=True, _
ExportFormat:=wdExportFormatPDF
Also, I don't believe you are setting EmpFolder anywhere, so it's an empty variable, which is probably either going to make the method fail or cause it to save the file in the wrong place.
Let me know if that works for you.
Sub BatchConvertDocxToPDF()
Dim objDoc1, objWord1 As Object
Dim strFile As String, strFolder, fp As String
'Initialization
strFolder = EmpFolder & "\"
strFile = Dir(strFolder & "*.docx", vbNormal)
xp = strFolder & strFile
'Process each file in the file folder and convert them to pdf.
Dim objWord As Object
Dim objDoc As Object
Set objWord = CreateObject("Word.Application")
objWord.Visible = True
While strFile <> ""
Set objDoc1 = objWord.Documents.Open(Filename:=strFolder & strFile)
objDoc1.ExportAsFixedFormat _
OutputFileName:=Replace(objDoc1.FullName, ".docx", ".pdf"), _
ExportFormat:=wdExportFormatPDF, OpenAfterExport:=False,
OptimizeFor:=wdExportOptimizeForPrint, _
Range:=wdExportAllDocument, Item:=wdExportDocumentContent
objDoc1.Close
strFile = Dir()
Wend
objWord.Visible = False
Set objDoc1 = Nothing
Set objWord = Nothing
End Sub
I am currently trying to use the code below in VBA to bring data in a table into a mailmerge word document which then saves the individual merges as a pdf. The code almost does this but when I run the macro on my excel sheet the pdf's saved only bring through the mergefield names from the word document and not the data itself.
Any ideas on where I can go from here? I am currently using Office 2016.
Sub RunMailMerge()
Dim objWord
Dim objDoc
Dim StrFolder As String, StrName As String, i As Long, j As Long
Dim strWorkbookName As String: strWorkbookName = ThisWorkbook.FullName
Const StrNoChr As String = """*./\:?|": StrName = "Easy.docx"
StrFolder = ThisWorkbook.Path & Application.PathSeparator
If Dir(StrFolder & strDocNm) = "" Then Exit Sub
Set objWord = CreateObject("Word.Application")
Set objDoc = objWord.Documents.Add
With objWord
'Disable alerts to prevent an SQL prompt
.DisplayAlerts = wdAlertsNone
'Display Word - change this to False once the code is running correctly
.Visible = False
'Open the mailmerge main document - set Visible:=True for testing
Set objWord = .Documents.Open(Filename:=StrFolder & StrName, ReadOnly:=True,
AddToRecentFiles:=False, Visible:=False)
With objWord
With .MailMerge
'Define the mailmerge type
.MainDocumentType = wdFormLetters
'Define the output
.Destination = wdSendToNewDocument
.SuppressBlankLines = False
'Connect to the data source
.OpenDataSource Name:=strWorkbookName, _
ReadOnly:=True, _
LinkToSource:=False, _
AddToRecentFiles:=False, _
Format:=wdOpenFormatAuto, _
Connection:="User ID=Admin;DataSource=strWorkbookName;" & _
"Mode=Read;Extended Properties=""HDR=YES;IMEX=1"";", _
SQLStatement:="SELECT * FROM `Sheet1 SQLStatement:=", _
SubType:=wdMergeSubTypeAccess
'Process all eligible records
For i = 1 To .DataSource.RecordCount
With .DataSource
.FirstRecord = i
.LastRecord = i
.ActiveRecord = i
'Exit if the field to be used for the filename is empty
If Trim(.DataFields("Tenant")) = "" Then Exit For
'StrFolder = .DataFields("Folder") & Application.PathSeparator
StrName = .DataFields("Tenant")
End With
.Execute Pause:=True
'Clean up the filename
For j = 1 To Len(StrNoChr)
StrName = Replace(StrName, Mid(StrNoChr, j, 1), "_")
Next
StrName = "Letter - " & Trim(StrName)
'Save as a PDF
objWord.SaveAs Filename:=StrFolder & StrName & ".pdf", _
FileFormat:=wdFormatPDF, AddToRecentFiles:=False
Next i
'Disconnect from the data source
.MainDocumentType = wdNotAMergeDocument
End With
'Close the mailmerge main document
.Close False
End With
Call CloseAll
Set wdDoc = Nothing: Set wdApp = Nothing
End With
End Sub
Sub CloseAll()
Dim objWord
Dim objDoc
Set objWord = CreateObject("Word.Application")
Set objDoc = objWord.Documents.Add
objWord.ActiveDocument.Close SaveChanges:=wdDoNotSaveChanges
End Sub
That code is essentially a copy of code I've posted elsewhere (e.g. https://www.mrexcel.com/forum/general-excel-discussion-other-questions/713478-word-2007-2010-mail-merge-save-individual-pdf-files-post4796480.html#post4796480), but why you'd add your call to CloseAll is a mystery.
Nonetheless, it's also clear you've also partially modified the code for use with late binding, by replacing:
Dim wdApp As New Word.Application, wdDoc As Word.Document
with:
Dim objWord
Dim objDoc
...
Set objWord = CreateObject("Word.Application")
Set objDoc = objWord.Documents.Add
Had you stuck with early binding throughout, the code would work. Right now, though, your modified code employs a mix of late binding with named Word constants, which are really only applicable to early binding. You need to fully adapt the code to late binding or revert to code that is entirely early binding.
Why are you trying to drive a mail merge via VBA code? You should be able to A) set up the data in Excel or Access, B) set up the template in Word & connect it to the data source, C) run the mail merge. Unless you're doing something really, really fancy, there should be no need for VBA.
Since it seems some sadist has forced you to do things the hard way, it looks like your error is most likely here:
Connection:="User ID=Admin;DataSource=strWorkbookName;" & _
"Mode=Read;Extended Properties=""HDR=YES;IMEX=1"";", _
SQLStatement:="SELECT * FROM `Sheet1
SQLStatement:=", _
SubType:=wdMergeSubTypeAccess
First of all:
Connection:="User ID=Admin;DataSource=strWorkbookName;" & _
should be
Connection:="User ID=Admin;DataSource=" & strWorkbookName & ";" & _
Second, your SQLStatement parameter is unterminated, and I'm pretty sure that "Sheet1" (not sure why you have an extra backtick in there) isn't the way to reference the "table" (i.e. worksheet) when selecting from an Excel workbook. IIRC, it should be "WorkBook$WorkSheet", so this:
SQLStatement:="SELECT * FROM `Sheet1
should be something like:
SQLStatement:="SELECT * FROM " & strWorkbookName & "$Sheet1", _
That line is followed by the end of the string
SQLStatement:=", _
which was part of the actual SQL string being sent to the database engine in Excel. That ain't gonna work.
The way I read it, that line should be:
Connection:="User ID=Admin;DataSource=" & strWorkbookName & ";" & _
"Mode=Read;Extended Properties=""HDR=YES;IMEX=1"";", _
SQLStatement:="SELECT * FROM " & strWorkbookName & "$Sheet1", _
SubType:=wdMergeSubTypeAccess
You may have to tweak it a bit, but I think that'll get you on the right track.
I using a macro VBA script in excel that allows me to email the active range to a recipient as a pdf.
here's the code
Sub AttachActiveSheetPDF()
Dim IsCreated As Boolean
Dim i As Long
Dim PdfFile As String, Title As String
Dim OutlApp As Object
' Not sure for what the Title is
Title = Range("A1")
' Define PDF filename
PdfFile = ActiveWorkbook.FullName
i = InStrRev(PdfFile, ".")
If i > 1 Then PdfFile = Left(PdfFile, i - 1)
PdfFile = PdfFile & "_" & ActiveSheet.Name & ".pdf"
' Export activesheet as PDF
With ActiveSheet
.ExportAsFixedFormat Type:=xlTypePDF, Filename:=PdfFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
End With
' Use already open Outlook if possible
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
' Prepare e-mail with PDF attachment
With OutlApp.CreateItem(0)
' Prepare e-mail
.Subject = Title
.To = "email#email.com" ' <-- Put email of the recipient here
.CC = "" ' <-- Put email of 'copy to' recipient here
.Body = "ùìåí øá," & vbLf & vbLf _
& "øö''á ãå''ç òìåéåú îùìçú (îùåòø) ìàéùåø éåúí." & vbLf & vbLf _
& "ááøëä," & vbLf _
& Application.UserName & vbLf & vbLf
.Attachments.Add PdfFile
' Try to send
On Error Resume Next
.Send
Application.Visible = True
If Err Then
MsgBox "E-mail was not sent", vbExclamation
Else
MsgBox "E-mail successfully sent", vbInformation
End If
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
End Sub
now I need this code to do the same and convert the active range to PDf but I also need to allow me to select and add other file as attachments to the email as well, my VBA and excel macro skills are not that great and I have no idea how to do that. could you please help me and rewrite the the code to do want I need.
Thanks,
Dan.
You should change this section:
On Error Resume Next
.Send
Application.Visible = True
If Err Then
MsgBox "E-mail was not sent", vbExclamation
Else
MsgBox "E-mail successfully sent", vbInformation
End If
To:
.Save
.Close olPromptForSave
Application.Visible = True
This will save the email in your drafts folder so you can add more attachments
I am trying to convert excel tabs to PDF and send each tab as a single attachment on different emails in outlook with different email recipients.
For example, Tab A would correspond to a "Vendor Emails" Tab with a To, Cc, and Bcc for each tab. Same would go for Tab B but a different set of recipients.
My Code:
Option Explicit
Sub create_and_email_pdf()
Dim EmailSubject As String, EmailSignature As String
Dim CurrentMonth As String, DestFolder As String, PDFFile As String
Dim Email_To As String, Email_CC As String, Email_BCC As String
Dim OpenPDFAfterCreating As Boolean, AlwaysOverwritePDF As Boolean, DisplayEmail As Boolean
Dim OverwritePDF As VbMsgBoxResult
Dim OutlookApp As Object, OutlookMail As Object
CurrentMonth = ""
EmailSubject = "Invoice Attached for "
OpenPDFAfterCreating = True
AlwaysOverwritePDF = False
DisplayEmail = True
Email_To = ThisWorkbook.Sheets("Vendor Emails").Range("B2").Value
Email_CC = ""
Email_BCC = ""
'Prompt for file destination
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = True Then
DestFolder = .SelectedItems(1)
Else
MsgBox "You must specify a folder to save the PDF into." & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Must Specify Destination Folder"
Exit Sub
End If
End With
'Current month/year
CurrentMonth = Mid(ThisWorkbook.Sheets("Vendor Emails").Range("E1").Value, InStr(1, ThisWorkbook.Sheets("Vendor Emails").Range("E1").Value, " ") + 1)
'Create new PDF file name including path and file extension
PDFFile = DestFolder & Application.PathSeparator & ActiveSheet.Name _
& "-" & CurrentMonth & ".pdf"
'If the PDF already exists
If Len(Dir(PDFFile)) > 0 Then
If AlwaysOverwritePDF = False Then
OverwritePDF = MsgBox(PDFFile & " already exists." & vbCrLf & vbCrLf & "Do you want to overwrite it?", vbYesNo + vbQuestion, "File Exists")
On Error Resume Next
'If you want to overwrite the file then delete the current one
If OverwritePDF = vbYes Then
Kill PDFFile
Else
MsgBox "OK then, if you don't overwrite the existing PDF, I can't continue." _
& vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Exiting Macro"
Exit Sub
End If
Else
On Error Resume Next
Kill PDFFile
End If
If Err.Number <> 0 Then
MsgBox "Unable to delete existing file. Please make sure the file is not open or write protected." _
& vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Unable to Delete File"
Exit Sub
End If
End If
'Create the PDF
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=PDFFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
:=False, OpenAfterPublish:=OpenPDFAfterCreating
'Create an Outlook object and new mail message
Set OutlookApp = CreateObject("Outlook.Application")
Set OutlookMail = OutlookApp.CreateItem(0)
'Display email and specify To, Subject, etc
With OutlookMail
.Display
.To = Email_To
.CC = Email_CC
.BCC = Email_BCC
.Subject = EmailSubject & CurrentMonth
.Attachments.Add PDFFile
If DisplayEmail = False Then
.Send
End If
End With
End Sub
I keep having an issue with this line, I keep getting a run-time 1004 and that the file may be open/error while saving:
'Create the PDF
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=PDFFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
:=False, OpenAfterPublish:=OpenPDFAfterCreating
If I don't use the reference ThisWookbook.Sheets(), I dont get an issue, but it only sends out the tab that I'm currently active on, not sure how to specify which tabs to convert.
For more context these tabs I'm converting would be part of a bigger worksheet with additional backup tabs that would not get sent as they are for internal purposes.
Thanks.