Code that writes special date inside the document

[student123]

Dear colleagues,

This is a code for a special date format that was developed by Paul_Hossler and SamT (in thread: [SOLVED] Making Your Own Date Format).
It shows the date in special format in UserForm1.

Is there a way to make it like this that when you open this document it would write the the special date not in UserForm but in specific place (marked as yellow) in the Working Document.doc? Or maybe it's possible to assign it to {TIME \@ SpecialDateFormat} with auto update?

Option Explicit

'Developed by Paul_Hossler and SamT
Private Declare Function GetLocaleInfo Lib "kernel32" Alias "GetLocaleInfoA" (ByVal Locale As Long, _
    ByVal LCType As Long, _
        ByVal lpLCData As String, _
            ByVal cchData As Long) As Long
            

Public Const LOCALE_USER_DEFAULT As Long = &H400
Public Const LOCALE_SABBREVLANGNAME As Long = &H3


Public aMonthNames As Variant
Public MonthWord As String
Public aDayNumbers As Variant
Public DayWord As String

Public Const U_caron As Long = &H16B
Public Const Z_caron As Long = &H17E
Public Const E_caron As Long = &H117
Public Const S_caron As Long = &H161
Public Const C_caron As Long = &H10D



Sub driver()
    MsgBox SpecialDateFormat(DateSerial(2015, 11, 20)) 'use UserForm1
End Sub
    
Function SpecialDateFormat(Dt As Date)
    SetArrays
    SpecialDateFormat = _
        aMonthNames(Month(Dt) - 1) & _
        " " & MonthWord & _
        " " & aDayNumbers(Day(Dt) - 1) & _
        " " & DayWord
End Function
    
    
Private Function SetArrays()
    Dim sLang As String
    Dim i As Long

    sLang = GetInfo(LOCALE_SABBREVLANGNAME)
    
    Select Case sLang
        Case "LTH"
            aMonthNames = Array("sausio", "vasario", "kovo", "baland" & ChrW(Z_caron) & "io", "gegu" & ChrW(Z_caron) & ChrW(E_caron) & "s", "bir" & ChrW(Z_caron) & "elio", _
                "liepos", "rugpj" & ChrW(U_caron) & ChrW(C_caron) & "io", "rugs" & ChrW(E_caron) & "jo", "spalio", "lapkri" & ChrW(C_caron) & "io", "gruod" & ChrW(Z_caron) & "io")
            MonthWord = "m" & ChrW(E_caron) & "nesio"
            aDayNumbers = Array("pirma", "antra", "tre" & ChrW(C_caron) & "ia", "ketvirta", "penkta", ChrW(S_caron) & "e" & ChrW(S_caron) & "ta", "septinta", _
                "a" & ChrW(S_caron) & "tunta", "devinta", "de" & ChrW(S_caron) & "imta", "vienuolikta", "dvylikta", "trylikta", "keturiolikta", "penkiolikta", _
                ChrW(S_caron) & "e" & ChrW(S_caron) & "iolikta", "septyniolikta", "a" & ChrW(S_caron) & "tuoniolikta", "devyniolikta", "dvidešimta", "dvidešimt pirma", "dvidešimt antra", _
                "dvidešimt tre" & ChrW(C_caron) & "ia", "dvidešimt ketvirta", "dvidešimt penkta", "dvidešimt šešta", "dvidešimt septinta", _
                "dvidešimt aštunta", "dvidešimt devinta", "trisdešimta", "trisdešimt pirma")
            DayWord = "diena"
    
        Case "ENU"
            aMonthNames = Array("January", "February", "March", "April", "May", "June", _
                            "July", "Auguet", "September", "October", "November", "December")
            MonthWord = "month"
            aDayNumbers = Array("first", "second", "third", "fourth", "fifth", "sixth", "seventh", _
                "eighth", "ninth", "tenth", "eleventh", "twelfth", "thirteenth", "fourteenth", "fifteenth", _
                "sixteenth", "seventeenth", "eighteenth", "nineteenth", "twentieth", "twenty-first", "twenty-second", _
                "twenty-third", "twenty-fourth", "twenty-fifth", "twenty-sixth", "twenty-seventh", _
                "twenty-eighth", "twenty-ninth", "thirtieth", "thirty-first")
            DayWord = "day"
    
        Case Else
            MsgBox "Oops"
        End Select
End Function


Private Function GetInfo(ByVal lInfo As Long) As String
    Dim Buffer As String
    Dim ret As String
    Buffer = String$(256, 0)
    ret = GetLocaleInfo(LOCALE_USER_DEFAULT, lInfo, Buffer, Len(Buffer))
    If ret > 0 Then
        GetInfo = Left$(Buffer, ret - 1)
    Else
        GetInfo = vbNullString
    End If
lbl_Exit:
    Exit Function
End Function

The code of the UserForm1

Option Explicit

Private Sub Label1_Click()

End Sub

Private Sub UserForm_Initialize()

      Me.Label1.Caption = SpecialDateFormat(DateSerial(2015, 12, 31))
End Sub

M. Office 2013

[Paul_Hossler]

The easiest way I know is to

1. insert document variable fields where you want the special date to go,
2. in the document open generate the special string
3. update the fields

Option Explicit

Private Sub Document_Open()
    Dim s As String
    
    s = SpecialDateFormat(DateSerial(2016, 5, 14))
    
    With ActiveDocument.Variables
        On Error Resume Next
        .Item("SpecialFormattedDate").Delete
        On Error GoTo 0
        Call .Add("SpecialFormattedDate", s)
    End With
    Selection.WholeStory
    Selection.Fields.Update

End Sub

Alt-F9 toggles between view and hide field codes

[student123]

Hi Paul!
It works! Thank you!
I am so grateful for the people who created this forum and for the people who are keeping it alive!

Zygis