LoginSignup
11
12

More than 5 years have passed since last update.

@earthdiver1

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

Last updated at Posted at 2018-11-18

目的

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

2通りのアプローチで VBA の関数を作ってみました。
1つ目は、Format 関数に指定する書式文字列中の「e」や「ee」を「元」に置換する方法です。もう１つは、「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」が「元」に置換されます。半角数字だけでなく全角数字や漢数字（「１」,「一」）の場合も同様に「元」に置換されます。

注： 上記の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|(^|[^０-９])０?１|(^|[^〇一二三四五六七八九十百])一)(?=[\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　]*)([\d０-９]{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行目）。 ↩

11
12
0

Register as a new user and use Qiita more conveniently

  1. You get articles that match your needs
  2. You can efficiently read back useful information
  3. You can use dark theme
What you can do with signing up
Sign upLogin
11
12