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
Reply With Quote
