日付で困ったような投稿が時々あるので、和暦対応で書式を指定できるスクリプトを組んでみました。

先日投稿のあった、本日日付の年４桁＋月２桁＋００　も、基準日：本日　書式：YYYYMM00　と指定すれば得られます。

もっと、こういう機能を追加して欲しいなど、ご要望、お待ちしております。

タイトル：日付取得（和暦対応書式指定）

【注釈】

基準日：本日,前月月初,前月末,当月月初,当月末,翌月月初,翌月末,指定日　から選択
指定日：基準日で指定日を選択した場合、ここで指定した日を基準日とします。
加算日数：基準日に加算する日数（マイナス指定可）省略時は0日として計算。
書式：日付の書式を指定します。
　YYYY：西暦年（西暦４桁)
　YY：西暦年下２桁
　GGG：和暦元号（令和、平成、昭和、大正、明治）
　GG：和暦元号略（令、平、昭、大、明）
　G：和暦元号アルファベット略（R、H、S、T、M）
　EE:和暦年２桁
　E:和暦年
　MM:月２桁
　M:月
　DD:日２桁
　D:日
　AAA:曜日（日、月、火、水、木、金、土）
例）
基準日：本日 （2023/4/15として）　　加算日数：-5　　書式：GGGEE年MM月DD日（AAA)
結果：令和05年04月10日（月）

基準日：指定日　　指定日：1964/8/4　　加算日数：0　　書式：yyyy/mm/dd(aaa)（ggge年）
結果：1964/08/04(火)（昭和39年）

【スクリプト】(2023/2/20 16:22修正）

Option Explicit

Dim Dt, AddDt, SDt , FMT, Ret

Dt = !基準日|本日,前月月初,前月末,当月月初,当月末,翌月月初,翌月末,指定日!
SDt = !指定日!
AddDt = !加算日数!
FMT = !書式!

If AddDt = "" Then
AddDt = 0
End If
Dt = GetKijyunbi(Dt, AddDt , SDt)
Ret = SetFormat(Dt, FMT)
SetUMSVariable $結果格納先$, Ret

Function GetKijyunbi(Dt, AddDt , SDt)
Dim K, Y, M, S

K = Date
Y = Year(K)
M = Month(K)
S = CDate(Y & "/" & M & "/1") '今月月初

Select Case Dt
Case "前月月初": K = DateAdd("M", -1, S)
Case "前月末": K = DateAdd("D", -1, S)
Case "当月月初": K = S
Case "当月末": K = DateAdd("D", -1, DateAdd("M", 1, S))
Case "翌月月初": K = DateAdd("M", 1, S)
Case "翌月末": K = DateAdd("D", -1, DateAdd("M", 2, S))
Case "指定日": K = CDate(SDt)
End Select
GetKijyunbi = DateAdd("D", CInt(AddDt), K)
End Function

Function SetFormat(Dt, FMT)
Const HKEY_LOCAL_MACHINE = &H80000002
Const SYSTEM_CurrentControlSet = "SYSTEM\CurrentControlSet\Control\Nls\Calendars\Japanese\Eras"
Dim YYYY, YY, GGG, GG, G, EE, E, MM, M, DD, D, AAA
Dim objLocator, objService, objClass, objRegName, objRegType, i, objSubKey, strRet
Dim strSeireki, strGengo, intdate

YYYY = Year(Dt)
YY = Right(YYYY, 2)
M = Month(Dt)
MM = Right("0" & M, 2)
D = Day(Dt)
DD = Right("0" & D, 2)
AAA = Mid("日月火水木金土", Weekday(Dt), 1)

'和暦の取得
'ローカルコンピュータに接続する。
Set objLocator = CreateObject("WbemScripting.SWbemLocator")
Set objService = objLocator.ConnectServer(, "root\default")
'クエリー条件を WQL にて指定する。
Set objClass = objService.Get("StdRegProv")

objClass.EnumValues HKEY_LOCAL_MACHINE, SYSTEM_CurrentControlSet, objRegName, objRegType

i = 0
ReDim strGengo(UBound(objRegName), 1)
For Each objSubKey In objRegName
objClass.GetStringValue HKEY_LOCAL_MACHINE, SYSTEM_CurrentControlSet, objSubKey, strRet
strGengo(i, 0) = Replace(objRegName(i), " ", "/")
strGengo(i, 1) = strRet
i = i + 1
Next

Set objClass = Nothing
Set objService = Nothing
Set objLocator = Nothing

For i = UBound(objRegName) To 0 Step -1
intdate = DateDiff("d", strGengo(i, 0), Dt)
If intdate >= 0 Then Exit For
Next
E = Year(Dt) - Year(strGengo(i, 0)) + 1
EE = Right("0" & E, 2)

GGG = Split(strGengo(i, 1), "_")(0)
GG = Split(strGengo(i, 1), "_")(1)
G = Split(strGengo(i, 1), "_")(3)

'置換
FMT = UCase(FMT)
FMT = Replace(FMT, "EE", EE)
FMT = Replace(FMT, "E", E)
FMT = Replace(FMT, "YYYY", YYYY)
FMT = Replace(FMT, "YY", YY)
FMT = Replace(FMT, "MM", MM)
FMT = Replace(FMT, "M", M)
FMT = Replace(FMT, "DD", DD)
FMT = Replace(FMT, "D", D)
FMT = Replace(FMT, "AAA", AAA)
FMT = Replace(FMT, "GGG", GGG)
FMT = Replace(FMT, "GG", GG)
FMT = Replace(FMT, "G", G)
SetFormat = FMT
End Function