I want to separate my mail merge into separate PDF files (this part is working). But the file names are being saved as a counter i.e. numbers.
Sub AllSectionsToSubDoc()
Dim x As Long
Dim Sections As Long
Dim Doc As Document
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set Doc = ActiveDocument
Sections = Doc.Sections.Count
For x = Sections - 1 To 1 Step -1
Doc.Sections(x).Range.Copy
Documents.Add
ActiveDocument.Range.Paste
ActiveDocument.SaveAs (Doc.Path & "\" & x & ".pdf")
ActiveDocument.Close False
Next x
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
I want to extend this code so that it saves the files with file names which are NOT numbers, but are taken from one of the field codes that I specify.
For example if I specify field code «First_Name» as the file name in my VBA code, and there are 3 names - (John, Peter, Samuel) 3 files should be saved in my destination folder as John.pdf, Peter.pdf, Samuel.pdf
Get the value from the data source, Split between commas, loop through the returned array and save each document individually.
Something like this (I haven't been able to test it).
Dim Value As String
Dim Names As Variant
Dim idx As Long
Value = Doc.DataSource.DataFields("First_Name").Value
Names = Split(Value, ",")
For idx = LBound(Names) To UBound(Names)
ActiveDocument.SaveAs Doc.Path & "\" & Names(idx) & ".pdf"
Next
In the event where the value is a single name (no comma), the Split() function will return an array with a single element.
I managed to find a very simple solution to this. After creating the mail merge, I previewed the results and ran the following macro
ChangeFileOpenDirectory "C:\User\Documents\folder\"
ActiveDocument.ExportAsFixedFormat OutputFileName:= _
" C:\User\Documents\folder\" & ActiveDocument.MailMerge.DataSource.DataFields("Field") & ".pdf", _
ExportFormat:=wdExportFormatPDF, OpenAfterExport:=False, OptimizeFor:= _
wdExportOptimizeForOnScreen, Range:=wdExportAllDocument, From:=1, To:=1, _
Item:=wdExportDocumentContent, IncludeDocProps:=True, KeepIRM:=True, _
CreateBookmarks:=wdExportCreateNoBookmarks, DocStructureTags:=True, _
BitmapMissingFonts:=True, UseISO19005_1:=False
ActiveDocument.MailMerge.DataSource.ActiveRecord = wdNextRecord
and then just loop until the end
Related
I have a Word document with a Macro that is executed daily and converts all Word documents that had been updated within the last 24 hours to PDF. The problem is that it runs on the File Server, that the folder contains about 150'000 files and that the macro takes 7 minutes while occupying more than 45% of the CPU. Usually there won’t be more than 30-40 files that need that conversion to PDF. But off course the macro scans all the content
I noticed that the PDF’s are all created within the first minute so my guess is that “by nature” windows starts in its routines with the most recent files and proceeds towards the oldest.
Using this characteristics, I could probably run this loop 100 times and abort it then.
Any comment is apeciated.
This is the macro:
Sub Loop_through_files()
Dim cDocuments As New Collection
Dim sPath As String, sFilter As String
Dim sCurrentDocName As String, sFullname As String
Dim i As Long
Dim xNewName As String
Dim xIndex As Integer
Set WordObject = CreateObject("Scripting.FileSystemObject")
sPath = "\\XXXXXXXX\XXXXX\Certificates"
sFilter = "*.DOC*"
Set cDocuments = Nothing
sCurrentDocName = Dir(sPath & "\" & sFilter)
Do Until sCurrentDocName = ""
cDocuments.Add Item:=sCurrentDocName
sCurrentDocName = Dir
Loop
Application.DisplayAlerts = False
Application.ScreenUpdating = False
For i = cDocuments.Count To 1 Step -1 '
sFullname = sPath & "\" & cDocuments(i)
Set f = WordObject.GetFile(sFullname)
If f.DateLastModified > DateAdd("d", -1, Date) Then
xIndex = InStr(cDocuments(i), ".")
xNewName = Left(cDocuments(i), xIndex) + "pdf"
Documents.Open FileName:=sFullname, _
ConfirmConversions:=False, ReadOnly:=False, AddToRecentFiles:=False, _
PasswordDocument:="", PasswordTemplate:="", Revert:=False, _
WritePasswordDocument:="", WritePasswordTemplate:="", Format:= _
wdOpenFormatAuto, XMLTransform:=""
ActiveDocument.ExportAsFixedFormat OutputFileName:=sPath & "\" & xNewName, _
ExportFormat:=wdExportFormatPDF, OpenAfterExport:=False, OptimizeFor:= _
wdExportOptimizeForPrint, Range:=wdExportAllDocument, From:=1, To:=1, _
Item:=wdExportDocumentContent, IncludeDocProps:=True, KeepIRM:=True, _
CreateBookmarks:=wdExportCreateNoBookmarks, DocStructureTags:=True, _
BitmapMissingFonts:=True, UseISO19005_1:=False
ActiveDocument.Close SaveChanges:=wdDoNotSaveChanges, OriginalFormat:=wdOriginalDocumentFormat
End If
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
I am trying to set the name of my Word document as the contents of whats in the highlighted cell, given by code; ActiveDocument.Tables(1).Cell(1, 2)
I have to do this for 200+ documents and the name will be in the same spot for all the documents.
This macro selects the desired cell and copies it
ActiveDocument.Tables(1).Cell(1, 2).Select
Selection.Copy
And this one saves the word document as a pdf with the clipboard contents as its name.
Sub rename()
Dim strPath As String
Dim strFileName As String
'set pathname accordingly
strPath = "enter path"
'create the Filename with your selection in Document
strFileName = Trim(Selection.Text) & ".pdf"
ActiveDocument.SaveAs FileName:= _
strPath & strFileName _
, FileFormat:=wdFormatXMLDocument, LockComments:=False, Password:="", _
AddToRecentFiles:=True, WritePassword:="", ReadOnlyRecommended:=False, _
EmbedTrueTypeFonts:=False, SaveNativePictureFormat:=False, SaveFormsData _
:=False, SaveAsAOCELetter:=False
End Sub
The issue is that the second Macro does not work when I select the entire cell
Only when I select specific text, like below
Any solutions for this?
Many thanks again
Try replacing this line:
strFileName = Trim(Selection.Text) & ".pdf"
With this...
With ActiveDocument.Tables(1).Cell(1,2).Range
strFileName=ActiveDocument.Range(Start:=.Start, End:=.End-1) & ".pdf"
End With
In MS Word last character in a cell is always a special character with ASCII code 7 which mark the end of cell. You need to remove this character before using. There might be several way of doing it. You may replace this character as follows:
strFileName = Replace(ActiveDocument.Tables(1).Cell(1, 2).Range.Text, Chr(7), "") & ".pdf"
Or, you may exclude it as follows:
charCount = ActiveDocument.Tables(1).Cell(1, 2).Range.Characters.Count
strFileName = Left(ActiveDocument.Tables(1).Cell(1, 2).Range.Text, charCount - 1)
I am trying to split my word document by pages and save the splits as new files named from cells in various tables that are the same on each page. The error I am encountering is:
Run-time error '5941':
The requested member of the collection does not exist.
My code thus far is:
Sub splitter()
'
'
Dim Counter As Long, Source As Document, Target As Document
Set Source = ActiveDocument
Selection.HomeKey Unit:=wdStory
Pages = Source.BuiltInDocumentProperties(wdPropertyPages)
Counter = 0
While Counter < Pages
Counter = Counter + 1
DocName = "" _
& Left(ActiveDocument.Tables(3).Rows(1).Cells(2).Range.Text, _
Len(ActiveDocument.Tables(3).Rows(1).Cells(2).Range.Text)) _
& Left(ActiveDocument.Tables(5).Rows(1).Cells(2).Range.Text, _
Len(ActiveDocument.Tables(5).Rows(1).Cells(2).Range.Text)) _
& Left(ActiveDocument.Tables(6).Rows(1).Cells(2).Range.Text, _
Len(ActiveDocument.Tables(6).Rows(1).Cells(2).Range.Text))
Source.Bookmarks("\Page").Range.Cut
Set Target = Documents.Add
Target.Range.Paste
Target.SaveAs FileName:=DocName
Target.Close
Wend
End Sub
The error specified in the title occurs within these lines of the code:
DocName = "" _
& Left(ActiveDocument.Tables(3).Rows(1).Cells(2).Range.Text, _
Len(ActiveDocument.Tables(3).Rows(1).Cells(2).Range.Text)) _
& Left(ActiveDocument.Tables(5).Rows(1).Cells(2).Range.Text, _
Len(ActiveDocument.Tables(5).Rows(1).Cells(2).Range.Text)) _
& Left(ActiveDocument.Tables(6).Rows(1).Cells(2).Range.Text, _
Len(ActiveDocument.Tables(6).Rows(1).Cells(2).Range.Text))
I am not sure how to resolve this error.
A second question is where can I set the directory that the documents are saved to in this code?
At least part of the problem is that you're getting the end-of-cell characters for each cell. Try:
DocName = "" _
& Split(Source.Tables(3).Cell(1 ,2).Range.Text, vbCr)(0) _
& Split(Source.Tables(5).Cell(1, 2).Range.Text, vbCr)(0) _
& Split(Source.Tables(6).Cell(1, 2).Range.Text, vbCr)(0)
You also aren't supplying the file extension, format, etc. as part of the SaveAs.
You may also be interested in Split Merged Output to Separate Documents in the Mailmerge Tips and Tricks thread at: http://www.msofficeforums.com/mail-merge/21803-mailmerge-tips-tricks.html which, amongst other things, shows how to supply the required SaveAs parameters.
I've got a bit of a tricky one here. Attempting to simplify an existing process.
Existing Process:
Word Document ("Plan Doc Template") is entirely composed of INCLUDETEXT fields that pull Bookmarked sections from another Word Document ("Source Plan Doc" we'll call it) that includes merge-fields in its bookmarked sections which are from an Excel Workbook ("Mail Merge Workbook").
The current process involves the user copying a Plan Doc Template and a Mail Merge Workbook and pasting it into any folder they choose. The user then fills out the Mail Merge Workbook, saves and closes, and runs a Mail Merge through the Plan Doc Template Word Doc. This pulls in bookmarked sections from the Source Plan Doc depending on the Mail Merge Workbook fields selected. The user then removes all INCLUDETEXT fields with CTRL + SHIFT + F9 to turn fields of Plan Doc Template into workable text.
(Hopeful) Future Process:
The user copies a Mail Merge Workbook and pastes it into their
desired folder. Fills out the Mail Merge Workbook. (Manual Step)
Runs VBA Code.
VBA copies the Plan Doc Template and pastes in the Mail Merge Workbook's folder that just ran the VBA code.
VBA renames the Plan Doc Template Word Doc based on fields within the Mail Merge Workbook.
VBA runs a Mail Merge within the Plan Doc Template
VBA highlights entire document and CTRL + SHIFT + F9 to turn Field Codes into workable text.
Is it possible to do all this from an Excel VBA code or would I need a separate code after the Plan Doc has been created to run the mail merge and do the CTRL + SHIFT + F9 steps?
P.S. I use Excel Worksheets via DDE Selection to get the correct formatting from Mail Merge Workbook to Document. Hoping that can be included in the VBA code, as well.
Help would be greatly appreciated on this one, thanks,
Rich
It looks like you can have the whole thing run with one macro from Excel, without the user having to run a second one, using a For loop until wdApp.Documents.Count increases by 1. I did test the following, but with only a very small data set, so it ran very quickly.
Since the user might have more than just the main merge document open, it's important the code can identify and work with the resulting document. Usually, it will have become the ActiveDocument but relying on that is never certain. So I built in a couple of loops to 1) hold the currently open documents in an array then 2) compare those to the currently active document. If the currently active document is not in the array, then the fields are unlinked (that's the equivalent of Ctrl+Shift+F9).
Of course, if you really wanted to identify the new document from all the documents you'd need to loop each document and loop the array, making the comparison. But I've given you the starting point...
Sub MergeWithWord()
Dim wdApp As Object
Dim wdDoc As Object
Dim nrDocs As Long
Dim i As Long, d As Long
Dim aDocs() As Variant
Set wdApp = GetObject(, "Word.Application")
nrDocs = wdApp.documents.Count
'Get all opened documents so can compare whether a new one
ReDim Preserve aDocs(nrDocs - 1)
Set wdDoc = wdApp.activedocument
For i = 0 To nrDocs - 1
Set aDocs(i) = wdApp.documents(i + 1)
Next
If wdDoc.MailMerge.MainDocumentType <> -1 Then
wdDoc.MailMerge.Destination = 0
wdDoc.MailMerge.Execute False
Do Until wdApp.documents.Count > nrDocs Or i > 1000
i = i + 1
Loop
Set wdDoc = wdApp.activedocument
For d = 0 To UBound(aDocs)
If wdDoc Is aDocs(d) Then
Debug.Print "Not a new doc"
Else
Debug.Print wdDoc.FullName
wdDoc.Fields.Unlink
Exit For
End If
Next
End If
Debug.Print nrDocs, i
MsgBox "Done"
End Sub
May not be the most elegant code but here was what I wound up using to solve my question in case it helps anyone else.
Sub ButtonMerge()
Dim str1 As String
Dim PlanDocTemplate As String
Dim EDrive As String
Dim answer1 As Integer
Dim answer2 As Integer
answer1 = MsgBox("Is this IC Plan Workbook saved in the appropriate Client folder?", vbYesNo + vbQuestion)
If answer1 = vbNo Then
MsgBox ("Please save this IC Plan Workbook in the appropriate Client folder then run again.")
Exit Sub
Else
'do nothing
End If
str1 = "Q:\IC\New Structure\IC Toolkit\Templates\01 Plan Doc Template\16 Source\IC Plan Doc Template v1.0.docx"
PlanDocTemplate = Application.ActiveWorkbook.Path & "\" & Range("A1").Value & ".docx"
EDrive = "E:\" & Range("A1").Value & ".docx"
If Len(Dir(Application.ActiveWorkbook.Path & "\" & Range("A1").Value & ".docx")) = 0 Then
Call FileCopy(str1, PlanDocTemplate)
Else
MsgBox ("The Plan document already exists, please delete or rename the existing Plan Doc in folder " _
& Application.ActiveWorkbook.Path & "\ before creating a new one.")
Exit Sub
End If
strWorkbookName = ThisWorkbook.Path & "\" & ThisWorkbook.Name
Worksheets("Data").Activate
'Opens New Plan Doc Template
Set appWD = CreateObject("Word.Application")
appWD.Visible = True
appWD.Documents.Open Filename:=PlanDocTemplate
ActiveDocument.MailMerge.OpenDataSource Name:=strWorkbookName, _
Format:=wdMergeInfoFromExcelDDE, _
ConfirmConversions:=True, _
ReadOnly:=False, _
LinkToSource:=True, _
AddToRecentFiles:=False, _
PasswordDocument:="", _
PasswordTemplate:="", _
Revert:=False, _
Connection:="Entire Spreadsheet", _
SQLStatement:="SELECT * FROM `Data$`", _
SQLStatement1:="", _
SubType:=wdMergeSubTypeOther
appWD.Visible = True
appWD.Selection.WholeStory
appWD.Selection.Fields.Update
appWD.Selection.Fields.Unlink
ActiveDocument.MailMerge.MainDocumentType = wdNotAMergeDocument
appWD.ActiveDocument.Save
Worksheets("Form").Activate
MsgBox "Successfully Created " & Range("A1").Value & " in Location: " & Application.ActiveWorkbook.Path & "\"
answer2 = MsgBox("Do you want to save a draft in the E:\ drive as well?", vbYesNo + vbQuestion, "E: Drive Copy")
If answer2 = vbYes Then
If Dir("E:\") <> "" Then
ActiveDocument.SaveAs2 Filename:= _
"E:\" & Range("A1").Value & ".docx", _
FileFormat:=wdFormatXMLDocument, LockComments:=False, Password:="", _
AddToRecentFiles:=True, WritePassword:="", ReadOnlyRecommended:=False, _
EmbedTrueTypeFonts:=False, SaveNativePictureFormat:=False, SaveFormsData _
:=False, SaveAsAOCELetter:=False, CompatibilityMode:=14
MsgBox ("Successfully Created " & Range("A1").Value & " in E:\ Location.")
Exit Sub
Else
MsgBox ("Please open the E:\ drive and enter your username/password." & _
vbCrLf & vbCrLf & "Click Ok when E:\ drive is opened.")
If Len(Dir("E:\")) = 0 Then
MsgBox ("Error connecting to E:\ drive." & vbCrLf & vbCrLf & "Please ensure you're connected and try again.")
Exit Sub
Else
ActiveDocument.SaveAs2 Filename:= _
"E:\" & Range("A1").Value & ".docx", _
FileFormat:=wdFormatXMLDocument, LockComments:=False, Password:="", _
AddToRecentFiles:=True, WritePassword:="", ReadOnlyRecommended:=False, _
EmbedTrueTypeFonts:=False, SaveNativePictureFormat:=False, SaveFormsData _
:=False, SaveAsAOCELetter:=False, CompatibilityMode:=14
MsgBox ("Successfully Created " & Range("A1").Value & " in E:\ Location.")
Exit Sub
End If
End If
Else
Exit Sub
End If
End Sub
I have created a Userform where you can flag records as "In Progress", "Completed", and "Not Completed".
This will reflect on the sheet as below:
Records marked as "In Progress" will have the letter "P" in the status column.
Records marked as "Completed" will have the letter "Y" in the status column.
Records marked as "Not Completed" will have the letter "N" in the status column.
DataSheet http://im39.gulfup.com/VZVxr.png!
I want to run a mailmerge using the below buttons on the user form:
Userform http://im39.gulfup.com/98isU.png!
I have created this work template for the fields.
Document http://im39.gulfup.com/4WMLh.png!
This word template file called "MyTemplate" will be in the same directory as the excel file.
I am trying to figure out how:
(1) Select recepients by filtering the "Status" column, so if the user pressed the first button, it will run the mail merge only for records with "P" in the status column.
(2) Run mailmerge without displaying Microsoft Word and only displaying the "Save As" dialog where the user can select where to save the file.
(3) This file should be saved in PDF format.
I am running Office 2013 and so far I have the code in bits and pieces and had no luck when trying to run it.
I have uploaded the data I am trying to work on:
MyBook: https://db.tt/0rLUZGC0
MyTemplate: https://db.tt/qPuoZ0D6
Any help will be highly appreciated.
Thanks.
(1) What I use is the WHERE clause (on the OpenDataSource, you probably don't need all those options)
' setup the SQL
Dim sSQLModel As String, sSQLWhere As String
sSQLModel = " Where ( AssignLtrType = 'T1' or AssignLtrType = 'T2' ) ;"
' replace the appropriate value(s)
sSQLWhere = sSQLModel ' never replace in the model
sSQLWhere = Replace(sSQLWhere, "T1", mydatavariable)
' open the MERGE
doc.MailMerge.OpenDataSource Name:=sIn, _
ConfirmConversions:=False, readOnly:=False, LinkToSource:=True, _
AddToRecentFiles:=False, PasswordDocument:="", PasswordTemplate:="", _
WritePasswordDocument:="", WritePasswordTemplate:="", Revert:=False, _
Format:=wdOpenFormatAuto, Connection:= _
"Provider=Microsoft.Jet.OLEDB.4.0;Password="""";" & _
"User ID=Admin;" & _
"Data Source=" & sXLSPathFile & ";" & _
"Mode=Read;Extended Properties=" & _
"HDR=YES;IMEX=1;"";Jet OLEDB:System database="""";" _
, SQLStatement:="SELECT * FROM `Detail$`", _
SQLStatement1:=sSQLWhere, _
SubType:=wdMergeSubTypeAccess
' do the MERGE
With doc.MailMerge
.Destination = wdSendToPrinter
.SuppressBlankLines = True
With .DataSource
.FirstRecord = wdDefaultFirstRecord
.LastRecord = wdDefaultLastRecord
End With
.Execute Pause:=False
End With
(2) Prior to the above, make the doc Visible (or Invisible)
' setup the template document
Dim doc As Word.Document
Set doc = wrdApp.Documents.Add(sPathFileTemplate)
wrdApp.Visible = True ' you can say False
(3) I have Adobe PDF as a Printer (the registry routines were from the web--Google them). Put this prior to OpenDataSource.
' Get current default printer.
SetDefaultPrinter "Adobe PDF"
'Create the Registry Key where Acrobat looks for a file name
CreateNewRegistryKey HKEY_CURRENT_USER, _
"Software\Adobe\Acrobat Distiller\PrinterJobControl"
'Put the output filename where Acrobat could find it
SetRegistryValue HKEY_CURRENT_USER, _
"Software\Adobe\Acrobat Distiller\PrinterJobControl", _
wrdApp.Application.Path & "\WINWORD.EXE", sPathFilePDF
In the SQL, change the tab name from Detail$ to yourTab$ (needs trailing $)
added later--
Dim sIn As String
sIn = SelectAFile(sInitial:=sDriveSAO, sTitle:=" XLS file")
If (sIn = "" Or sIn = "False") Then Exit Sub
and Google for SelectAFile
added 1/22 aft
' ============= added ===========
Dim xls As Excel.Application ' for me, because I am running in MSAccess as mdb
Set xls = New Excel.Application
Dim wrdApp As Word.Application ' for you, to have WORD running
Set wrdApp = New Word.Application
Dim sPathFileTemplate As String
sPathFileTemplate = xls.GetOpenFilename(" docx file,*.docx", , "Template file")
' ============= added ===========
' changed you only need one variable
sSQLModel = " Where ( Status = 'T1' ) ;"
' changed replace, possibly with some screen value
sSQLWhere = Replace(sSQLWhere, "T1", "P")
' changed because your tab is named Sheet1
, SQLStatement:="SELECT * FROM `Sheet1$`", _
' ============= added ===========
doc.Close False
Set doc = Nothing
wrdApp.Quit False
Set wrdApp = Nothing
' ============= added ===========
OK so with a lot of help from #donPablo I finally got a working code which does exactly what I want.
BTW the "Status" in sSQLModel = " Where ( Status = 'T1' ) ;" can be change to any other column heading, but in my case I am filtering based on a value in the column F (Status).
The "P" in sSQLWhere = Replace(sSQLWhere, "T1", "P") can also be change to the value been filtered on, but in my case I want all the records containing "P" in the "Status" column.
The "Sheet1" in , SQLStatement:="SELECT * FROMSheet1$", _ can be changed to the name of the sheet containing the source data for the merge. (Don't forget to include the $ sign at the end of the sheet name.
Before proceeding make sure to load the Microsoft Word Object Library (VBA - Tools - References)
And here is the working code:
Private Sub CommandButton1_Click()
Dim xls As Excel.Application
Set xls = New Excel.Application
Dim wrdApp As Word.Application
Set wrdApp = New Word.Application
Dim sPathFileTemplate As String
sPathFileTemplate = ThisWorkbook.Path & "\MyTemplate.docx" 'This gets the file called MyTemplate from the same directory
'in which this excel file is running from
' setup the template document
Dim doc As Word.Document
Set doc = wrdApp.Documents.Add(sPathFileTemplate)
wrdApp.Visible = False ' Make MS Word Invisible
Dim sIn As String
sIn = ThisWorkbook.FullName 'This Workbook is set the merge data source
' setup the SQL
Dim sSQLModel As String, sSQLWhere As String
sSQLModel = " Where ( Status = 'T1' ) ;"
' replace the appropriate value(s)
sSQLWhere = sSQLModel
sSQLWhere = Replace(sSQLWhere, "T1", "P")
' open the MERGE
doc.MailMerge.OpenDataSource Name:=sIn, _
ConfirmConversions:=False, ReadOnly:=False, LinkToSource:=True, _
AddToRecentFiles:=False, PasswordDocument:="", PasswordTemplate:="", _
WritePasswordDocument:="", WritePasswordTemplate:="", Revert:=False, _
Format:=wdOpenFormatAuto, Connection:= _
"Provider=Microsoft.Jet.OLEDB.4.0;Password="""";" & _
"User ID=Admin;" & _
"Data Source=" & sXLSPathFile & ";" & _
"Mode=Read;Extended Properties=" & _
"HDR=YES;IMEX=1;"";Jet OLEDB:System database="""";" _
, SQLStatement:="SELECT * FROM `Sheet1$`", _
SQLStatement1:=sSQLWhere, _
SubType:=wdMergeSubTypeAccess
' do the MERGE
With doc.MailMerge
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
With .DataSource
.FirstRecord = wdDefaultFirstRecord
.LastRecord = wdDefaultLastRecord
End With
.Execute Pause:=False
End With
'If you want you can delete this part and proceed to diretly define the
'filename and path below in "OutputFileName"
On Error Resume Next
Dim FileSelected As String
FileSelected = Application.GetSaveAsFilename(InitialFileName:="Export", _
FileFilter:="PDF Files (*.pdf), *.pdf", _
Title:="Save PDF as")
If Not FileSelected <> "False" Then
MsgBox "You have cancelled"
doc.Close False
Set doc = Nothing
wrdApp.Quit False
Set wrdApp = Nothing
Exit Sub
End If
If FileSelected <> "False" Then
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
wrdApp.Application.Options.SaveInterval = False
'Saves Documents as PDF and does not open after saving, you can change OpenAfterExport:=False to True
wrdApp.Application.ActiveDocument.ExportAsFixedFormat OutputFileName:=FileSelected, _
ExportFormat:=wdExportFormatPDF, OpenAfterExport:=False, OptimizeFor:=wdExportOptimizeForPrint, _
Range:=wdExportAllDocument, FROM:=1, To:=1, Item:=wdExportDocumentContent, IncludeDocProps:=True, _
KeepIRM:=True, CreateBookmarks:=wdExportCreateNoBookmarks, DocStructureTags:=True, _
BitmapMissingFonts:=True, UseISO19005_1:=False
doc.Close False
Set doc = Nothing
wrdApp.Quit False
Set wrdApp = Nothing
MsgBox "Done"
End If ' this EndIf pretains to the SaveAs code above
End Sub
I cannot stress enough how much help was #donPablo, thanks again, you just made my weekend and I am selecting your answer as accepted :)