Vba code to save document as pdf using document property text and rename folder.

[staicumihai]

Hello everyone!

I am using Word 2010 and I have a document with following document property:

Author: Michael Staicu
Title: R6435
Company: ASIG-1234-EXP
Comments: BAAR/MGD/15/RO/03339
Publish date: 12.02.2015


I want to make a macro that automatically modifies the text from given document property fields and does the following:

1. Rename the folder that contains the document as:

R6435_BAAR.MGD.15.RO.03339 Michael Staicu ASIG1234EXP - 12.02.2015

(replacing "/" character from comments propery with "." character and removing "-" character from Company property).


2. Saves my word file with the following name:

R6435_BAAR.MGD.15.RO.03339 Michael Staicu ASIG1234EXP

(replacing "/" character from comments propery with "." character and removing "-" character from Company property).


3. Saves my word file as a pdf with following name:

R6435_BAAR.MGD.15.RO.03339 ASIG1234EXP

(replacing "/" character from comments propery with "." character and removing "-" character from Company property).


Any response I will gratefully appreciate as it saves me from a lot of work
Thanks and I wish you a good day.

[gmayor]

This is fairly straightforward apart from the Publish Date, which is not as readily accessible as the other property fields.
However the following will work. It takes no account of existing filenames of the same name nor illegal filename characters beyond those addressed in the particular examples.
There are code examples on my web site to cover both issues should you require them. http://www.gmayor.com/useful_vba_functions.htm

The code does not rename the folder, but creates a new one with the required name.


Option Explicit

Sub MySave()
Dim strFname As String
Dim strPDFName As String
Dim strPath As String
Const strDrive As String = "C:\"
strPath = Trim(ActiveDocument.BuiltInDocumentProperties("Title").Value) & "_"
strPath = strPath & Replace(Trim(ActiveDocument.BuiltInDocumentProperties("Comments").Value), "/", ".") & Chr(32)
strPDFName = strPath & Replace(Trim(ActiveDocument.BuiltInDocumentProperties("Company").Value), "-", "")
strPath = strPath & Trim(ActiveDocument.BuiltInDocumentProperties("Author").Value) & Chr(32)
strPath = strPath & Replace(Trim(ActiveDocument.BuiltInDocumentProperties("Company").Value), "-", "")
strFname = strPath
strPath = strDrive & strPath & " - " & GetPublishDate & "\"
'MsgBox strPath & vbCr & strFname & vbCr & strPDFName
CreateFolders strPath
ActiveDocument.SaveAs2 strPath & strFname & ".docx"
ActiveDocument.ExportAsFixedFormat OutputFilename:=strPath & strPDFName & ".pdf", _
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
lbl_Exit:
Exit Sub
End Sub

Private Function GetPublishDate() As String
'Graham Mayor
Dim oCustPart As CustomXMLPart
Dim oNode As CustomXMLNode
Dim pXPath As String
pXPath = "/ns0:CoverPageProperties[1]/ns0:PublishDate[1]"
Set oCustPart = ActiveDocument.CustomXMLParts(3)
Set oNode = oCustPart.SelectSingleNode(pXPath)
GetPublishDate = oNode.Text
Set oCustPart = Nothing
Set oNode = Nothing
lbl_Exit:
Exit Function
End Function

Private Function CreateFolders(strPath As String)
'Graham Mayor
'Create any missing folders in a named file path
Dim strTempPath As String
Dim lngPath As Long
Dim vPath As Variant
vPath = Split(strPath, "\")
strPath = vPath(0) & "\"
For lngPath = 1 To UBound(vPath)
strPath = strPath & vPath(lngPath) & "\"
If Not FolderExists(strPath) Then MkDir strPath
Next lngPath
lbl_Exit:
Exit Function
End Function

Private Function FolderExists(strFolderName As String) As Boolean
'Graham Mayor
'strFolderName is the name of folder to check
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
If (fso.FolderExists(strFolderName)) Then
FolderExists = True
Else
FolderExists = False
End If
lbl_Exit:
Exit Function
End Function

[Paul_Hossler]

@Graham -- can you expand on the pXPath part in your sub?

Is the .CustomXML... restricted to Word?




Private Function GetPublishDate() As String
'Graham Mayor
Dim oCustPart As CustomXMLPart
Dim oNode As CustomXMLNode
Dim pXPath As String
pXPath = "/ns0:CoverPageProperties[1]/ns0:PublishDate[1]"
Set oCustPart = ActiveDocument.CustomXMLParts(3)
Set oNode = oCustPart.SelectSingleNode(pXPath)
GetPublishDate = oNode.Text
Set oCustPart = Nothing
Set oNode = Nothing
lbl_Exit:
Exit Function
End Function

[gmayor]

See https://msdn.microsoft.com/en-us/library/office/ff863162.aspx and especially http://gregmaxey.mvps.org/word_tip_pages/customXML_helpful_help.html
CustomXLParts also apply to the Excel Workbook object

The function I supplied was developed from a much larger function developed by my colleague Greg Maxey for a joint project, for use in this specific application to obtain the Publish Date which is not otherwise exposed to VBA. See also http://www.gmayor.com/BookmarkandVariableEditor.htm.

There is a similarly conceived project on Greg's web site, with much greater emphasis on content controls.

[gmaxey]

Graham,

I am not trying to be critical and mentioning this only because I have had my head in XML entirely too much recently. Your whole function can be replaced with:

ActiveDocument.CustomXMLParts(3).SelectSingleNode("//ns0:PublishDate[1]").Text

Paul,

Excel has basically the same parts as Word:

Sub ScratchMacro()
'A basic Word macro coded by Greg Maxey
Dim oXMLPart As CustomXMLPart
Dim oNode As CustomXMLNode
MsgBox ActiveWorkbook.CustomXMLParts.Count
For Each oXMLPart In ActiveWorkbook.CustomXMLParts
For Each oNode In oXMLPart.DocumentElement.ChildNodes
Debug.Print oNode.BaseName & " " & oNode.Text
Next oNode
Next oXMLPart
lbl_Exit:
Exit Sub

End Sub

[staicumihai]

I cant get it to work, I think is my fault because I wasnt more specific about what I want. Here it is:









In this path: ”D:\MIHAI\DOSARE\BAAR” I have a folder named ”INTRO”
In ”INTRO” folder there are more documents and folders including a word 2010 document that has the properties:

Title: 6338
Company fax: 03218
Company: BZ-98-BNA
Comments: VW Lupo
Company Email: 12.02.2015
Keywords: BAAR/MGD/15/RO

I want to:

Rename ”INTRO” folder with: BAAR-Dosar6338_03218 BZ98BNA VW Lupo-12.02.2015

In the new folder I want to save the current word document with following name:
R6338_BAAR.MGD.15.RO.03218 BZ98BNA VW Lupo

In the new folder I want to save the current word document as pdf with following name: R6338_BAAR.MGD.15.RO.03218 BZ98BNA VW Lupo


Question:
If it is not possible to rename INTRO in BAAR-Dosar6338_03218 BZ98BNA VW Lupo-12.02.2015
can the code create a new folder in ”D:\MIHAI\DOSARE\BAAR” named
BAAR-Dosar6338_03218 BZ98BNA VW Lupo-12.02.2015 and copy all the files and folders
from ”INTRO” including the final word and pdf in the newly created folder?

Thanks a lot guys, it means a lot to me, saves me a lot of time at work.

[staicumihai]

Thanks a lot Gmayor, I tried this, and I got an error

Option Explicit

Sub MySave()
Dim strFname As String
Dim strPDFName As String
Dim strPath As String
Const strDrive As String = "C:\"
strPath = Trim(ActiveDocument.BuiltInDocumentProperties("Title").Value) & "_"
strPath = strPath & Replace(Trim(ActiveDocument.BuiltInDocumentProperties("Comments").Value), "/", ".") & Chr(32)
strPDFName = strPath & Replace(Trim(ActiveDocument.BuiltInDocumentProperties("Company").Value), "-", "")
strPath = strPath & Trim(ActiveDocument.BuiltInDocumentProperties("Author").Value) & Chr(32)
strPath = strPath & Replace(Trim(ActiveDocument.BuiltInDocumentProperties("Company").Value), "-", "")
strFname = strPath
strPath = strDrive & strPath & " - " & GetPublishDate & "\"
'MsgBox strPath & vbCr & strFname & vbCr & strPDFName
CreateFolders strPath
ActiveDocument.SaveAs2 strPath & strFname & ".docx"
ActiveDocument.ExportAsFixedFormat OutputFilename:=strPath & strPDFName & ".pdf", _
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
lbl_Exit:
Exit Sub
End Sub

Private Function GetPublishDate() As String
'Graham Mayor
Dim oCustPart As CustomXMLPart
Dim oNode As CustomXMLNode
Dim pXPath As String
pXPath = "/ns0:CoverPageProperties[1]/ns0:PublishDate[1]"
Set oCustPart = ActiveDocument.CustomXMLParts(3)
Set oNode = oCustPart.SelectSingleNode(pXPath)
GetPublishDate = oNode.Text
Set oCustPart = Nothing
Set oNode = Nothing
lbl_Exit:
Exit Function
End Function

Private Function CreateFolders(strPath As String)
'Graham Mayor
'Create any missing folders in a named file path
Dim strTempPath As String
Dim lngPath As Long
Dim vPath As Variant
vPath = Split(strPath, "\")
strPath = vPath(0) & "\"
For lngPath = 1 To UBound(vPath)
strPath = strPath & vPath(lngPath) & "\"
If Not FolderExists(strPath) Then MkDir strPath (on this line I get the run time error 76 path not found).
Next lngPath
lbl_Exit:
Exit Function
End Function

Private Function FolderExists(strFolderName As String) As Boolean
'Graham Mayor
'strFolderName is the name of folder to check
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
If (fso.FolderExists(strFolderName)) Then
FolderExists = True
Else
FolderExists = False
End If
lbl_Exit:
Exit Function
End Function

What am I doing wrong ?

[gmayor]

Frankly you are wasting my time if you request one thing, when what you want is something entirely different. The code I posted will not do what you require.
If you want to discuss rates for programming a revised version then you can contact me via my web site, with an explanation of how the different document is involved and selected.

[staicumihai]

Sorry man,

Anyway I managed to modify your code to fit my needs.
Thanks a lot.