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