Windows
VBA
access

MS-ACCESS の新元号「元年表記」対応


目的

Office製品の新元号対応(改元対応)は Microsoft Update でパッチ提供されるらしいけれども、2019年の「元年表記」対応については自力で対応する必要がありそうです1。Excelの場合は比較的簡単に対応できますが、Access の場合はユーザ定義関数を作る必要があります。

2通りのアプローチで VBA の関数を作ってみました。

1つ目は、Format 関数に指定する書式文字列中の「e」や「ee」を「元」に置換する方法です。もう1つは、「1年」や「01年」を「元年」に置換する方法です。後者の方が簡単ですが、マイクロソフト社から新元号対応パッチがリリースされるまでテストができません(「平成1年」→「平成元年」で模擬試験を行なうことはできます)。

 

(2019.12.1 追記)こまごまと更新しているうちに「おまけ」の Format_ 関数(Format()の代替関数)の方がメインの様になってしまいました。


環境

Office 2013 で動作確認しました。他のバージョンでは修正が必要となる可能性があります。


使い方


1つ目:

Access のコントロールソースに次のように書きます(Format 関数を置き換える)2

 =Gannen1(DateSerial(2019,5,1),"ggge""年""m""月""d""日""")

書式中の「e」または「ee」の直後に「年」がある場合に「e」「ee」が「元」に置換されます。

注:上記の例の出力は、新元号対応パッチが適用される前は「平成元年5月1日」と表示されます(「ggg」 の処理が新元号に対応していないため 。)


2つ目:

Access のコントロールソースに次のように書きます3

 =Gannen2("新元号1年○月×日")

あるいは

 =Gannen2(Format(DateSerial(1989,1,8),"ggge""年""m""月""d""日"""))

入力文字列中の数字「1」または「01」の直後に「年」がある場合に「1」「01」が「元」に置換されます。半角数字だけでなく全角数字や漢数字(「1」,「一」)の場合も同様に「元」に置換されます。

注: 上記の2つ目の例の出力は、「平成元年1月8日」と表示されます。DateSerial(1989,1,8) の代わりに DateSerial(2019,5,1) を指定した場合、新元号対応パッチが適用される前は「平成31年5月1日」と表示されます。


コード

以下のコードを VBA の標準モジュールに追加してください。正規表現でクォートの有無を判定するために本来は肯定後読みを利用しますが、VBA の正規表現は後読みをサポートしていないため、Gannen1 関数では書式文字列を一旦逆順に並べ替えて肯定先読みを利用しています4

' by earthdiver1

Function Gannen1(ByVal DateArg As Date, ByVal FormatArg As String) As String
Static initialized As Boolean
Static re As Object
If (Not initialized) Then
initialized = True
Set re = CreateObject("VBScript.RegExp")
' 「e年」、「ee年」の正規表現パターンをセット(「e」と「年」の間のスペースは許容)
With re
.Pattern = "(年(?:[\s ]*""|\\?)(?:[\s ]\\?)*)e{1,2}(?=(?:[^""\\]|[\S\s]\\|""[^""]*"")*$)"
.IgnoreCase = True
.Global = True
End With
End If
' 2019年5月1日以降かつ2019年12月31日以前の場合、「e年」または「ee年」を「元年」に置換
If (43585 < DateArg And DateArg < 43831) Then FormatArg = StrReverse(re.Replace(StrReverse(FormatArg), "$1"""""))
Gannen1 = Format(DateArg, FormatArg)
End Function

Function Gannen2(ByVal DateString As String) As String
Static initialized As Boolean
Static re As Object
If (Not initialized) Then
initialized = True
Set re = CreateObject("VBScript.RegExp")
' 「1年」、「01年」等の正規表現パターンをセット(「1」と「年」の間のスペースは許容)
With re
.Pattern = "(?:(^|\D)0?1|(^|[^0-9])0?1|(^|[^〇一二三四五六七八九十百])一)(?=[\s ]*年)"
.Global = True
End With
End If
' 「1年」、「01年」等を「元年」に置換
Gannen2 = re.Replace(DateString, "$1$2$3元")
End Function


おまけ

マイクロソフト社からリリースされる予定の新元号対応パッチ適用後の Format 関数の(想定)動作をシミュレートする関数 Format_ です5 6。これを用いて、以下のいずれかの方法で新元号パッチがリリースされる前に元年表記を確認することができます。


  • Gannen1 関数の最終行の Format()Format_() に置き換える。

  • Gannen2 関数の入力に指定:=Gannen2(Format_(DateSerial(2019,5,1),"ggge""年""m""月""d""日"""))

  • Format_ 関数の下から 12 行目のコメントを外す(Format_ 関数自体が元年表記に対応します)。←2018.12.1 機能追加

新元号の情報は、レジストリ(HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Control\Nls\Calendars\Japanese\Eras キーの名前が "2019 05 01" の値)から取得します。

新元号を仮に「光文」とすると、上記レジストリの値は "2019 05 01" = "光文_光_Koubun_K" となり、

=format_("光文元年5月1日")

=format_(DateSerial(2019,5,1),"ggge""年""m""月""d""日""")

=format_(DateSerial(2019,5,1),"gee\.mm\.dd")

の出力はそれぞれ

2019/05/01

光文1年5月1日(元年表記が無効の場合)または 光文元年5月1日(元年表記が有効の場合)

K01.05.01

となります。

' by earthdiver1  V1.00

#If VBA7 Then
Declare PtrSafe Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" _
(ByVal hKey As LongPtr, ByVal lpSubKey As String, ByVal ulOptions As Long, _
ByVal samDesired As Long, phkResult As LongPtr) As Long
Declare PtrSafe Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" _
(ByVal hKey As LongPtr, ByVal lpValueName As String, ByVal lpReserved As LongPtr, _
lpType As Long, lpData As Any, lpcbData As Long) As Long
Declare PtrSafe Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As LongPtr) As Long
#Else
Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" _
(ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, _
ByVal samDesired As Long, phkResult As Long) As Long
Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" _
(ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, _
lpType As Long, lpData As Any, lpcbData As Long) As Long
Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
#End If

Const HKEY_LOCAL_MACHINE = &H80000002
Const KEY_QUERY_VALUE = &H1

Function Format_(ByVal Expression As Variant, _
Optional ByVal FormatString As Variant, _
Optional ByVal FirstDayOfWeek As VbDayOfWeek = vbSunday, _
Optional ByVal FirstWeekOfYear As VbFirstWeekOfYear = vbFirstJan1) As Variant
Static initialized As Boolean
Static newEra1 As String
Static newEra2 As String
Static newEra3 As String
Static initialYear As String
Static re1 As Object
Static re2 As Object
Static re3 As Object
Static re4 As Object
Static re5 As Object
Static re6 As Object
Static re7 As Object
Static re8 As Object
Static re9 As Object
Dim isDateOrNumeric As Boolean
Dim str As String
If (Not initialized) Then ' 初回のみ以下のブロックを実行
initialized = True
newEra1 = "??"
newEra2 = "?"
newEra3 = "?"
initialYear = "元年"
Set re1 = CreateObject("VBScript.RegExp")
Set re2 = CreateObject("VBScript.RegExp")
Set re3 = CreateObject("VBScript.RegExp")
Set re4 = CreateObject("VBScript.RegExp")
Set re5 = CreateObject("VBScript.RegExp")
Set re6 = CreateObject("VBScript.RegExp")
Set re7 = CreateObject("VBScript.RegExp")
Set re8 = CreateObject("VBScript.RegExp")
Set re9 = CreateObject("VBScript.RegExp")
' レジストリから新元号の情報を取得
Dim hWnd As LongPtr: hWnd = Application.hWndAccessApp ' Excelの場合は Application.hWnd を用いる
Dim result As Long
result = RegOpenKeyEx(HKEY_LOCAL_MACHINE, "SYSTEM\\CurrentControlSet\\Control\\Nls\\Calendars\\Japanese\\Eras", 0, KEY_QUERY_VALUE, hWnd)
If (result = 0) Then
str = String(255, " ")
result = RegQueryValueEx(hWnd, "2019 05 01", 0, 0, ByVal str, LenB(str))
If (result = 0) Then str = Left(str, InStr(str, vbNullChar) - 1)
RegCloseKey hWnd
If (Trim(str) <> "") Then ' レジストリに新元号の情報あり
Dim tokens() As String: tokens = Split(str, "_")
newEra1 = tokens(0)
newEra2 = tokens(1)
newEra3 = tokens(3)
End If
End If
' 環境変数に新元号の情報がある場合はそちらを優先
' If (Environ("SHINGENGOU1") <> "") Then newEra1 = Environ("SHINGENGOU1")
' If (Environ("SHINGENGOU2") <> "") Then newEra2 = Environ("SHINGENGOU2")
' If (Environ("SHINGENGOU3") <> "") Then newEra3 = Environ("SHINGENGOU3")
' レジストリから元年表記の設定を取得
result = RegOpenKeyEx(HKEY_LOCAL_MACHINE, "SYSTEM\\CurrentControlSet\\Control\\Nls\\Calendars\\Japanese", 0, KEY_QUERY_VALUE, hWnd)
If (result = 0) Then
str = String(255, " ")
result = RegQueryValueEx(hWnd, "InitialEraYear", 0, 0, ByVal str, LenB(str))
If (result = 0) Then str = Left(str, InStr(str, vbNullChar) - 1)
RegCloseKey hWnd
If (Trim(str) <> "") Then initialYear = str
End If
' 和暦年号(新元号+年号) の正規表現パターンをセット
With re1
.Pattern = "^(.*)((?:" & newEra1 & "|" & Left(newEra1, 1) & "|" & newEra2 & "|" & newEra3 & ")[\s ]*)([\d0-9]{1,3}|元(?=[\s ]*年))([\s ]*[年/-].*)$"
.IgnoreCase = True
End With
' 日付・時刻書式を判定する正規表現パターンをセット
With re2
.Pattern = "(?:[cdeghmnqswy:/]|aaa|ooo|mpma|ttttt)(?=(?:[^""\\!#&.0<>@]|[\S\s]\\|""[^""]*"")*$)"
.IgnoreCase = True
End With
' ggg, gg, g の正規表現パターンをセット
With re3
.Pattern = "ggg(?=(?:ggg)*(?!g))(?=(?:[^""\\]|[\S\s]\\|""[^""]*"")*$)"
.IgnoreCase = True
.Global = True
End With
With re4
.Pattern = "gg(?=(?:gg)*(?!g))(?=(?:[^""\\]|[\S\s]\\|""[^""]*"")*$)"
.IgnoreCase = True
.Global = True
End With
With re5
.Pattern = "g(?=(?:[^""\\]|[\S\s]\\|""[^""]*"")*$)"
.IgnoreCase = True
.Global = True
End With
' ee, e の正規表現パターンをセット(re6 は ee,e に「年」が続くパターン)
With re6
.Pattern = "(年(?:[\s ]*""|\\?)(?:[\s ]\\?)*)e{1,2}(?=(?:[^""\\]|[\S\s]\\|""[^""]*"")*$)"
.IgnoreCase = True
.Global = True
End With
With re7
.Pattern = "ee(?=(?:ee)*(?!e))(?=(?:[^""\\]|[\S\s]\\|""[^""]*"")*$)"
.IgnoreCase = True
.Global = True
End With
With re8
.Pattern = "e(?=(?:[^""\\]|[\S\s]\\|""[^""]*"")*$)"
.IgnoreCase = True
.Global = True
End With
' 数値・文字列書式に使用される文字の正規表現パターンをセット
With re9
.Pattern = "([!#&.0<>@])(?=(?:[^""\\]|[\S\s]\\|""[^""]*"")*$)"
.Global = True
End With
' 新元号の文字列を逆順に並び替え
newEra1 = StrReverse(newEra1)
End If
isDateOrNumeric = IsDate(Expression) Or IsNumeric(Expression)
' 第一引数が新元号を含む和暦の文字列の場合は和暦年号を西暦に置換
If (Not isDateOrNumeric) Then
Dim num As String
str = Expression
num = re1.Replace(str, "$3")
If num <> str Then
If num = "元" Then num = "1"
str = re1.Replace(str, "$1") & VBA.Format(CInt(num) + 2018) & re1.Replace(str, "$4")
If IsDate(str) Then
Expression = str
isDateOrNumeric = True
End If
End If
End If
If (IsMissing(FormatString)) Then ' FormatString が未指定の場合
Format_ = VBA.Format(Expression)
Exit Function
End If
Select Case LCase(FormatString)
Case "general date"
Case "long date"
Case "medium date"
Case "short date"
Case "long time"
Case "medium time"
Case "short time"
Case "general number"
Case "currency"
Case "fixed"
Case "standard"
Case "percent"
Case "scientific"
Case "yes/no"
Case "true/false"
Case "on/off"
Case Else
If (isDateOrNumeric And 43585 < Expression) Then ' 2019年5月1日以降の場合
Dim rFormatString As String
' 書式文字列を逆順に並び替え
rFormatString = StrReverse(FormatString)
If (re2.Test(rFormatString)) Then ' 書式が日付時刻の場合
' ggg, gg, g を新元号の文字列に置換
rFormatString = re3.Replace(rFormatString, """" & newEra1 & """")
rFormatString = re4.Replace(rFormatString, """" & newEra2 & """")
rFormatString = re5.Replace(rFormatString, """" & newEra3 & """")
'「e年」または「ee年」を「元年」に置換
' If (initialYear <> "1年" And Expression < 43831) Then rFormatString = re6.Replace(rFormatString, "$1""元""")
' ee, e を新年号に置換
rFormatString = re7.Replace(rFormatString, """" & StrReverse(VBA.Format(Year(Expression) - 2018, "0#")) & """")
rFormatString = re8.Replace(rFormatString, """" & StrReverse(VBA.Format(Year(Expression) - 2018, "##")) & """")
' 日付時刻書式と認識されない場合(数値・文字列書式の文字が先に現れる場合)は、!#&.0<>@ をエスケープ
If (Not re2.Test(rFormatString)) Then rFormatString = re9.Replace(rFormatString, "$1\")
' 書式文字列を元の並び順に戻す
FormatString = StrReverse(rFormatString)
End If
End If
End Select
Format_ = VBA.Format(Expression, FormatString, FirstDayOfWeek, FirstWeekOfYear)
End Function

 

 

最終更新(Format_ 関数の Format 関数との互換性向上、バージョン付与(V1.00))

 

クリエイティブ・コモンズ 表示 - 継承 4.0 国際





  1. MSの英語のブログによると、.NET では元年表記に対応されるようですので、もしかしたら Office製品でも同様に対応されるかも知れません。(2018.12.1追記)さらにこちらによると、少なくとも Windows 10 では OS レベルで元年表記がデフォルトになるようです。 



  2. Excelのセルに指定して使う場合は、DateSerial()DATE() に置き換えます。 



  3. Excelのセルに指定して使う場合は、Format()TEXT() に、DateSerial()DATE() にそれぞれ置き換えます。 



  4. 関連する内容の投稿があります。 



  5. Excelで使用する場合は、ソース中の Application.hWndAccessApp を Application.hWnd に置き換えます。 



  6. Format_ 関数の名前を Format に変更することで標準の Format 関数を置き換えることもできます(1,131,173行目)。