Using vba script for date formats in M$ Word 2016

[netwerkz]

    year_ = Format(DateAdd("m", 0, Date), "yyyy")    year_Month = Format(DateAdd("d", 0, Date), "yyyy Mmm")
    year_Month_Date = Format(DateAdd("d", 0, Date), "yyyy Mmm dd")
    Mnth = Format(Application.WorksheetFunction.EoMonth(Date, 1), "Mmm")

This code works great in M$ Excel. Now, I want to use it for M$ Word, but it doesn't.

After some digging around the net, I found this code to add a date in the format in the footer, that I want it in, but it doesn't work.

    If ActiveWindow.View.SplitSpecial <> wdPaneNone Then
        ActiveWindow.Panes(2).Close
    End If
    If ActiveWindow.ActivePane.View.Type = wdNormalView Or ActiveWindow. _
        ActivePane.View.Type = wdOutlineView Then
        ActiveWindow.ActivePane.View.Type = wdPrintView
    End If
    ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageFooter
    Application.Templates( _
        "C:\Users\JStewa11\AppData\Roaming\Microsoft\Document Building Blocks\1033\16\Built-In Building Blocks.dotx" _
        ).BuildingBlockEntries(" Blank (Three Columns)").Insert Where:=Selection. _
        Range, RichText:=True
    Selection.WholeStory
    Selection.Font.Name = "Times New Roman"
    Selection.Font.Size = 10
    Selection.HomeKey Unit:=wdLine
    Selection.MoveRight Unit:=wdWord, Count:=1, Extend:=wdExtend
    Selection.Delete Unit:=wdCharacter, Count:=1
    Selection.MoveRight Unit:=wdCharacter, Count:=1
    Selection.MoveRight Unit:=wdWord, Count:=1, Extend:=wdExtend
    Selection.TypeText Text:="CHS Bingham Cooperative Inc."
    Selection.MoveRight Unit:=wdCharacter, Count:=1
    Selection.MoveRight Unit:=wdWord, Count:=1, Extend:=wdExtend
    Selection.Delete Unit:=wdCharacter, Count:=1
    Selection.InsertDateTime DateTimeFormat:="yyyy mmm dd", InsertAsField:=True, DateLanguage:=wdEnglishUS, CalendarType:=wdCalendarWestern, InsertAsFullWidth:=False
    If ActiveWindow.View.SplitSpecial <> wdPaneNone Then
        ActiveWindow.Panes(2).Close
    End If
    If ActiveWindow.ActivePane.View.Type = wdNormalView Or ActiveWindow. _
        ActivePane.View.Type = wdOutlineView Then
        ActiveWindow.ActivePane.View.Type = wdPrintView
    End If
    ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
    Selection.EscapeKey

Please help.

[netwerkz]

The code above does work, but it does not add the date.

I save my documents in a hierarchical method as "H:\Projects\2018\Jul". The file should use the prefix of "2018 Jul 16 - Comments.docx". In addition, I changed my M$ Windows default date format to yyyy mmm dd, so in my system tray, I actually see the format I want. Now, I want to use the default format in my "saveAs" code, but my code doesn't use the format. Instead it deletes the date portion and saves the document in my "H:\Projects" folder, not in the folder I need.

ChangeFileOpenDirectory "H:\Projects\" & yyyy & "\" & yyyy & " " & mmm & "\"    ActiveDocument.SaveAs2 FileName:="H:\Projects\" & yyyy & "\" & yyyy & " " & mmm & " " & dd & " - Afternoon Comments.docx", _
        FileFormat:=wdFormatXMLDocument, LockComments:=False, Password:="", _
        AddToRecentFiles:=True, WritePassword:="", ReadOnlyRecommended:=False, _
        EmbedTrueTypeFonts:=False, SaveNativePictureFormat:=False, SaveFormsData _
        :=False, SaveAsAOCELetter:=False, CompatibilityMode:=15
    ActiveDocument.ExportAsFixedFormat OutputFileName:="H:\Projects\" & yyyy & "\" & yyyy & " " & mmm & " " & dd & " - Afternoon Comments.pdf" _
        , 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
End Sub

Any clues?

[gmayor]

This is fairly straightforward, but you cannot make up your own syntax and expect it to work - the first macro will add the date to all the footers and the second will create the folder (if not present) and save the document in it. Drive H: must be available and capable of being written to.

Option Explicit
'Graham Mayor - http://www.gmayor.com - Last updated - 17 Jul 2018 
Sub Macro1()
Dim strDate As String
Dim oFooter As HeaderFooter
Dim oSection As Section
Dim oRng As Range
    strDate = Format(Date, "yyyy mmm dd")
    For Each oSection In ActiveDocument.Sections
        For Each oFooter In oSection.Footers
            If oFooter.Exists Then
                Set oRng = oFooter.Range
                oRng.Collapse 1
                oRng.Text = strDate
            End If
        Next oFooter
    Next oSection
lbl_Exit:
    Set oRng = Nothing
    Set oFooter = Nothing
    Set oSection = Nothing
    Exit Sub
End Sub

Sub Macro2()
Dim strPath As String
    strPath = "H:\Projects\" & Format(Date, "yyyy") & "\"
    CreateFolders strPath
    ActiveDocument.SaveAs2 FileName:=strPath & Format(Date, "yyyy mmm dd") & " - Afternoon Comments.docx", _
                           FileFormat:=wdFormatXMLDocument, _
                           LockComments:=False, Password:="", _
                           AddToRecentFiles:=True, _
                           WritePassword:="", _
                           ReadOnlyRecommended:=False, _
                           EmbedTrueTypeFonts:=False, _
                           SaveNativePictureFormat:=False, _
                           SaveFormsData:=False, _
                           SaveAsAOCELetter:=False, _
                           CompatibilityMode:=15

    ActiveDocument.ExportAsFixedFormat OutputFileName:=strPath & Format(Date, "yyyy mmm dd") & " - Afternoon Comments.pdf", _
                                       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
lbl_Exit:
    Exit Sub
End Sub

Public Sub CreateFolders(strPath As String)
'A Graham Mayor/Greg Maxey AddIn Utility Macro
Dim oFSO As Object
Dim lng_PathSep As Long
Dim lng_PS As Long
    If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
    lng_PathSep = InStr(3, strPath, "\")
    If lng_PathSep = 0 Then GoTo lbl_Exit
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    Do
        lng_PS = lng_PathSep
        lng_PathSep = InStr(lng_PS + 1, strPath, "\")
        If lng_PathSep = 0 Then Exit Do
        If Len(Dir(Left(strPath, lng_PathSep), vbDirectory)) = 0 Then Exit Do
    Loop
    Do Until lng_PathSep = 0
        If Not oFSO.FolderExists(Left(strPath, lng_PathSep)) Then
            oFSO.CreateFolder Left(strPath, lng_PathSep)
        End If
        lng_PS = lng_PathSep
        lng_PathSep = InStr(lng_PS + 1, strPath, "\")
    Loop
lbl_Exit:
    Set oFSO = Nothing
    Exit Sub
End Sub