MS Word vba to save .docm to .docx WITHOUT converting active document - vba

I have an MS Word document with macros (.docm)
Based on many StackOverflow posts, I've written a macro to export as a pdf and save as a .docx
I open/edit the .docm document, that has an onSave macro that saves the document in .pdf format and .docx format which I distribute for other people to use. I will always be making my changes to the .docm document.
My issue is that doing so converts the active(open) document from .docm to .docx such that I'm no longer making my changes to the .docm.
Sub SaveActiveDocumentAsDocx()
On Error GoTo Errhandler
If InStrRev(ActiveDocument.FullName, ".") <> 0 Then
Dim strPath As String
strPath = Left(ActiveDocument.FullName, InStrRev(ActiveDocument.FullName, ".") - 1) & ".docx"
ActiveDocument.SaveAs2 FileName:=strPath, FileFormat:=wdFormatDocumentDefault
End If
On Error GoTo 0
Exit Sub
Errhandler:
MsgBox "There was an error saving a copy of this document as DOCX. " & _
"Ensure that the DOCX is not open for viewing and that the destination path is writable. Error code: " & Err
End Sub
I can find no parameter to prevent this conversion of the active document in either "saveas" or "saveas2"
Furthermore, after the "saveas" command, any additional lines in the original macro are not executed because the active document no longer contains macros. I tried adding lines to the macro to reopen the original .docm and then close the .docx but those commends never execute.
I'm hoping I'm just missing something simple?

Sub SaveAMacrolessCopyOfActiveDocument()
' Charles Kenyon 2 October 2020
' Save a copy of active document as a macrofree document
'
Dim oDocument As Document
Dim oNewDocument As Document
Dim iLength As Long
Dim strName As String
Set oDocument = ActiveDocument ' - saves a copy of the active document
' Set oDocument = ThisDocument '- saves copy of code container rather than ActiveDocument
Let iLength = Len(oDocument.Name) - 5
Let strName = Left(oDocument.Name, iLength)
Set oNewDocument = Documents.Add(Template:=oDocument.FullName, DocumentType:=wdNewBlankDocument, Visible:=False)
oNewDocument.SaveAs2 FileName:=strName & ".docx", FileFormat:= _
wdFormatXMLDocument, LockComments:=False, Password:="", AddToRecentFiles _
:=True, WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts _
:=False, SaveNativePictureFormat:=False, SaveFormsData:=False, _
SaveAsAOCELetter:=False, CompatibilityMode:=15
oNewDocument.Close SaveChanges:=False
' Clean up
Set oDocument = Nothing
Set oNewDocument = Nothing
End Sub
The above code creates and saves a copy of the ActiveDocument with the same name but as a .docx formatted document (macro-free). The visible property in the .Add command means that it will not appear on screen and it is closed by the procedure. The new document will appear in Recent documents.

Related

How can I manage the active document reference in word to save and close my newly created output?

I am trying to use VBA in an open .docm file to open a 2nd read only .docx file and then insert -> object -> text from file (a 3rd read only .docx stored within the same folder).
The below code correctly opens and merges the two files but when it comes to saving the output it returns a Run-Time 13 “mismatch” error. My limited understanding leads me to believe that at the point where I am saving, the active document reference is still the original .docm and it is the .docx designation that then causes the conflict.
I am really struggling to manage the active document reference to avoid this. Presumably I am missing something very simple, all assistance is very gratefully received.
Documents.Open ActiveDocument.Path & "\DocA.docx", Visible:=True
Selection.InsertFile FileName:=ActiveDocument.Path & "\DocB.docx", Range:="", _
ConfirmConversions:=False, Link:=False, Attachment:=False
ActiveDocument.SaveAs2 "C:\Users\" & Environ("UserName") & "\DocC" & ".docx", FileFormat:= _
wdFormatXMLDocument
ActiveWindow.Close
Putting flesh on John Korchok's comment:
Sub deleteme3()
Dim oldDoc As Document
Set oldDoc = Documents.Open(ActiveDocument.Path & "\DocA.docx", Visible:=True)
oldDoc.Activate
selection.Collapse Direction:=wdCollapseEnd 'to insert at end of document
selection.Range.InsertBreak Type:=wdPageBreak
Selection.EndKey Unit:=wdStory
Selection.InsertFile FileName:=ActiveDocument.Path & "\DocB.docx", range:="", _
ConfirmConversions:=False, Link:=False, Attachment:=False
oldDoc.SaveAs2 "C:\Users\" & Environ("UserName") & "\DocC" & ".docx", FileFormat:= _
wdFormatXMLDocument
oldDoc.Close
Set oldDoc = Nothing
End Sub
Note this puts the inserted document at the end of the original document. You may want to use a next-page section break instead if there is header/footer differentiation. If you need that, please comment and I will include it.
There are a number of break types. Here is the enumeration of all of them if you are interested. The following types create a page break of one sort or another:
wdPageBreak (the default)
wdSectionBreakNextPage
wdSectionBreakOddPage (starts section on next odd-numbered page - good for chapters)
wdSectionBreakEvenPage (starts section on next even-numbered page - rarely used)
If wanting to preserve headers and footers additional code would be needed.
(Every section in a Word document has three headers and three footers, even if they are not displayed or used.)
' Break Link to Previous in newly added section for all of the headers and footers
Dim oHeaderFooter As HeaderFooter
Dim iCounter As Long
Let iCounter = ActiveDocument.Sections.Count
' break link in headers
For Each oHeaderFooter In ActiveDocument.Sections(iCounter).Headers
Let oHeaderFooter.LinkToPrevious = False
Next oHeaderFooter
' repeat for footers
For Each oHeaderFooter In ActiveDocument.Sections(iCounter).Footers
Let oHeaderFooter.LinkToPrevious = False
Next oHeaderFooter

VBA Issues with Inserting Multiple PDF Objects Within a Loop

My set-up is that I have a bunch of blank templates in a folder. Inside each blank template is a fund code (it is the only thing in the template)
The below macro I created (in an external workbook) goes through the folder with the templates, opens each template, and "fills it out" via a loop.
Basically my macro opens each template, assigns the fund code to a variable and then uses that variable in combination with some text strings to pull in other worksheets/PDF objects related to that specific fund code.
My issue is that in a more meaty version of the below code, I added maybe four or five more PDF objects to insert. It'll go through some of the templates and then randomly stop on a random fund code at a random pdf object insert line saying either "object cannot be found" or "object cannot be inserted"
If I press debug and then press F8 to run that line again, it is able to insert the object no problem. So perhaps my code is running too fast for adobe to handle? I am unsure. Perhaps my code isn't doing things as efficiently as possible. This would save sooo much time for my team, I just can't be having it work half the time.
(also the file names have definitely been correct, so that is not an issue)
Public Sub test()
Set currentbook = ActiveWorkbook
Application.AskToUpdateLinks = False
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim wbk As Workbook
Dim filename1 As String
Dim Path As String
Dim a As Long
Path = "C:\Users\Bob\Desktop\Workbooks\"
filename1 = Dir(Path & "*.xlsm")
'--------------------------------------------
'OPEN EXCEL FILES
Do While Len(filename1) > 0 'IF NEXT FILE EXISTS THEN
Set wbk = Workbooks.Open(Path & filename1)
wbk.Activate
'Gets Fund Code
Sheets("Initialize").Select
Dim FdCode As String
FdCode = Worksheets("Initialize").Range("D8")
'--------------------------- PDF ADDS
'Add PDF TB----------------------------------------------------
Worksheets("F.a - Working TB").OLEObjects.Add filename:="C:\Users\Bob\Desktop\Raw Reports\R122 04.30.16 - 04.30.17\" & FdCode & " 04.30.16 TB.PDF", Link:=False, DisplayAsIcon:=False, Left:=40, Top:=40, Width:=150, Height:=10
On Error GoTo 0
'Add PDF Closed Options----------------------------------------------------'
Worksheets("T300.1 - Options (Closed)").OLEObjects.Add filename:="C:\Users\Bob\Raw Reports\Other Reports 04.30.16-04.30.17\Breakout\" & FdCode & " other 04.30.17_ CLOSED OPTIONS POSITION REPORT.PDF", Link:=False, DisplayAsIcon:=False, Left:=40, Top:=40, Width:=150, Height:=10
On Error GoTo 0
ActiveWorkbook.Save
wbk.Close False
filename1 = Dir
Loop
Application.ScreenUpdating = True
End Sub

I want functionality to a button in Access

I am having difficulties having a button perform what I want. I have an MS Access db which I input all of the information for a particular project. I also have a contract word document which is mail merged with this db.
So far with the help of some of you I've gotten this far (code below). It works, but if I have 120 records when the button is pressed it creates a long contract with all 120 records. I simply want to have just the current record (the record on my screen at the time) to only make a pdf.
I would also like to name the pdf which is created use a naming convention such as, "Name of product - Name of client". Both are fields in the record.
I want to add I am not a coder by no stretch of the imagination, kudos to you all that do this everyday....you are unsung heros.
Option Compare Database
Option Explicit
Private Sub Command205_Click()
Dim strWordDoc As String
'Path to the word document of the Mail Merge
'###-1 CHANGE THE FOLLOWING LINE TO POINT TO YOUR DOCUMENT!!
strWordDoc = "C:\Users\...\Google Drive\contract.docx"
' Call the code to merge the latest info
startMerge strWordDoc
End Sub
'----------------------------------------------------
' Auto Mail Merge With VBA and Access (Early Binding)
'----------------------------------------------------
' NOTE: To use this code, you must reference
' The Microsoft Word 14.0 (or current version)
' Object Library by clicking menu Tools > References
' Check the box for:
' Microsoft Word 14.0 Object Library in Word 2010
' Microsoft Word 15.0 Object Library in Word 2013
' Click OK
'----------------------------------------------------
Function startMerge(strDocPath As String)
Dim oWord As Word.Application
Dim oWdoc As Word.Document
Dim wdInputName As String
Dim wdOutputName As String
Dim outFileName As String
' Set Template Path
wdInputName = strDocPath ' was CurrentProject.Path & "\mail_merge.docx"
' Create unique save filename with minutes and seconds to prevent overwrite
outFileName = "[Product Name]_" & Format(Now(), "mmddyyyy")
' Output File Path w/outFileName
wdOutputName = CurrentProject.Path & "\" & outFileName
Set oWord = New Word.Application
Set oWdoc = oWord.Documents.Open(wdInputName)
' Start mail merge
'###-2 CHANGE THE SQLSTATEMENT AS NEEDED
With oWdoc.MailMerge
.MainDocumentType = wdFormLetters
.OpenDataSource _
Name:=CurrentProject.FullName, _
ReadOnly:=True, _
AddToRecentFiles:=False, _
LinkToSource:=True, _
Connection:="QUERY mailmerge", _
SQLStatement:="SELECT * FROM [Contract Information]" ' Change the table name or your query"
.Destination = wdSendToNewDocument
.Execute Pause:=False
End With
' Hide Word During Merge
oWord.Visible = False
' Save file as PDF
' Uncomment the line below and comment out
' the line below "Save file as Word Document"
'------------------------------------------------
oWord.ActiveDocument.SaveAs2 wdOutputName & ".pdf", 17
' Save file as Word Document
' ###-3 IF YOU DON'T WANT TO SAVE AS A NEW NAME, COMMENT OUT NEXT LINE
'oWord.ActiveDocument.SaveAs2 wdOutputName & ".docx", 16
' SHOW THE DOCUMENT
oWord.Visible = True
' Close the template file
If oWord.Documents(1).FullName = strDocPath Then
oWord.Documents(1).Close savechanges:=False
ElseIf oWord.Documents(2).FullName = strDocPath Then
oWord.Documents(2).Close savechanges:=False
Else
MsgBox "Well, this should never happen! Only expected two documents to be open"
End If
' Quit Word to Save Memory
'oWord.Quit savechanges:=False
' Clean up memory
'------------------------------------------------
Set oWord = Nothing
Set oWdoc = Nothing
End Function
Filter the SQL to return only the current Id:
SQLStatement:="SELECT * FROM [Contract Information] Where ProjectId = " & Me!ProjectId.Value & ""
and adjust outFileName to reflect "Name of product - Name of client":
outFileName = Me!ProductName.Value & " - " & Me!ClientName.Value

VBA Word : Error 5174 when Documents.Open with filename including pound sign #

In Microsoft Word 2010 VBA
I am getting a runtime error 5174, when trying to open a document which file name includes a pound sign "#", with a relative file path.
Sub openPoundedFilename()
Dim doc As Object
' Both files "C:\Temp\foo_bar.docx" and "C:\Temp\foo#bar.docx" exist
' With absolute file paths
Set doc = Documents.Open(fileName:="C:\Temp\foo_bar.docx") ' Works
doc.Close
Set doc = Documents.Open(fileName:="C:\Temp\foo#bar.docx") ' Works
doc.Close
' With relative file paths
ChDir "C:\Temp"
Set doc = Documents.Open(fileName:="foo_bar.docx") ' Works
doc.Close
Set doc = Documents.Open(fileName:="foo#bar.docx") ' Does not work !!!!
'Gives runtime error 5174 file not found (C:\Temp\foo)
doc.Close
End Sub
I did not find any explanation for why the last Documents.Open fails.
It probably has to do with some mismatch regarding the "#" sign used for URL.
(see https://support.microsoft.com/en-us/kb/202261)
Thanks in advance for answers
Edit 17/10/2016 13:37:17
The macro recording generates the following:
Sub Macro1()
'
' Macro1 Macro
'
'
ChangeFileOpenDirectory "C:\Temp\"
Documents.Open fileName:="foo#bar.docx", ConfirmConversions:=False, _
ReadOnly:=False, AddToRecentFiles:=False, PasswordDocument:="", _
PasswordTemplate:="", Revert:=False, WritePasswordDocument:="", _
WritePasswordTemplate:="", Format:=wdOpenFormatAuto, XMLTransform:=""
End Sub
This macro doesn't work (gives the same error 5174).
To open the file using a relative path you need to URLEncode the filename. There is no built-in support in VBA for doing so (besides in newer Excel versions), but you can use #Tomalak's URLEncode function, which should encode foo#bar.docx as foo%23bar.docx:
ChangeFileOpenDirectory "C:\Temp\"
Dim urlEncodedFilename as String
urlEncodedFilename = URLEncode("foo#bar.docx")
Set doc = Documents.Open(fileName:=urlEncodedFilename)
As the issue only occurred with relative path names, a work-around could be used:
convert paths to absolute.
Set fs = CreateObject("Scripting.FileSystemObject")
Set doc = Documents.Open(fileName:=fs.GetAbsolutePathName("foo#bar.docx"))
Maybe this work-around doesn't work in all cases, as Documents.Open performs unclear processing with the file name.

Not able to save PDFs from Excel/VBA on one computer

I recently received help here for an Excel spreadsheet we have that allows users to create quotations for customers. The spreadsheet uses VBA to allow the user to press a button which generates a PDF out from certain sheets, and attaches them to a new Outlook email.
Unfortunately this isn't working on one of the user's computers. The problem seems to be with the generating of the PDF. Initially when pressing the button, nothing happened. I suspected it was to do with the Microsoft Add-in to Save as PDF, so I made sure it was installed, which it was. After 'commenting out' the error message coming from the code to get to the real error message from Visual Basic, I found it to be this:
run-time error '-2147467261 (80004003)': Document not saved.
When clicking 'Debug' it highlights:
FileName = Create_PDF_Sheet_Level_Names(NamedRange:="addtopdf1", _
FixedFilePathName:=ThisWorkbook.Path & "\" & "Quotation - " & Range("G18") & ".pdf", _
OverwriteIfFileExist:=True, _
OpenPDFAfterPublish:=False)
Which relates to:
Function Create_PDF_Sheet_Level_Names(NamedRange As String, FixedFilePathName As String, _
OverwriteIfFileExist As Boolean, OpenPDFAfterPublish As Boolean) As String
'This function will create a PDF with every sheet with
'a sheet level name variable <NamedRange> in it
Dim FileFormatstr As String
Dim Fname As Variant
Dim Ash As Worksheet
Dim sh As Worksheet
Dim ShArr() As String
Dim s As Long
Dim SheetLevelName As Name
'Test If the Microsoft Add-in is installed
If Dir(Environ("commonprogramfiles") & "\Microsoft Shared\OFFICE" _
& Format(Val(Application.Version), "00") & "\EXP_PDF.DLL") <> "" Then
'We fill the Array with sheets with the sheet level name variable
For Each sh In ActiveWorkbook.Worksheets
If sh.Visible = -1 Then
Set SheetLevelName = Nothing
On Error Resume Next
Set SheetLevelName = sh.Names(NamedRange)
On Error GoTo 0
If Not SheetLevelName Is Nothing Then
s = s + 1
ReDim Preserve ShArr(1 To s)
ShArr(s) = sh.Name
End If
End If
Next sh
'We exit the function If there are no sheets with
'a sheet level name variable named <NamedRange>
If s = 0 Then Exit Function
If FixedFilePathName = "" Then
'Open the GetSaveAsFilename dialog to enter a file name for the pdf
FileFormatstr = "PDF Files (*.pdf), *.pdf"
Fname = Application.GetSaveAsFilename("", filefilter:=FileFormatstr, _
Title:="Create PDF")
'If you cancel this dialog Exit the function
If Fname = False Then Exit Function
Else
Fname = FixedFilePathName
End If
'If OverwriteIfFileExist = False we test if the PDF
'already exist in the folder and Exit the function if that is True
If OverwriteIfFileExist = False Then
If Dir(Fname) <> "" Then Exit Function
End If
Application.ScreenUpdating = False
Application.EnableEvents = False
'Remember the ActiveSheet
Set Ash = ActiveSheet
'Select the sheets with the sheet level name in it
Sheets(ShArr).Select
'Now the file name is correct we Publish to PDF
On Error Resume Next
ActiveSheet.ExportAsFixedFormat _
Type:=xlTypePDF, _
FileName:=Fname, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=OpenPDFAfterPublish
On Error GoTo 0
'If Publish is Ok the function will return the file name
If Dir(Fname) <> "" Then
Create_PDF_Sheet_Level_Names = Fname
End If
Ash.Select
Application.ScreenUpdating = True
Application.EnableEvents = True
End If
End Function
I'm really scratching my head here! Checked all settings side-by-side with my machine on Excel and Outlook, including Trust Centre settings. Also checked add-ins.
Please check if there is enough disk space where the user wants to save the PDF file to!
I would recommend to check the length of the PDF fullname (path, filename and file extension; in your example it is the variable "Fname") as well before calling "ActiveSheet.ExportAsFixedFormat(...)", because filenames (or rather fullnames) under Microsoft Windows regularly cannot exceed more than 255 characters (see: Naming Files, Paths, and Namespaces).