VB6, VBA でレジストリから元号を取得

VB6, VBA でレジストリから元号(和暦情報)を配列で取り出す関数をベタなAPIのみで構成
format関数って、ee年 のように eの直後に年が続くと 1年ではなく元年と表記されるんですね～

得られる配列は今の所、下記の形

第１引数→	0	1	2	3	4	5
0	1868/01/01	明治_明_Meiji_M	明治	明	Meiji	M
1	1912/07/30	大正_大_Taisho_T	大正	大	Taisho	T
2	1926/12/25	昭和_昭_Showa_S	昭和	昭	Showa	S
3	1989/01/08	平成_平_Heisei_H	平成	平	Heisei	H
第２引数↑

※古い順である保証はありません
※2019/3/13頃のOSアップデートで、レジストリの値が全角合成文字(㍻)から先頭文字(平)に変更されています

配列から取得

    Dim Gengo()
    Dim I As Long
    Dim S As String

    Gengo = GetGengoDimFromReg()
    For I = UBound(Gengo, 2) To 0 Step -1
        S = S & Gengo(0, I) & " = " & Gengo(1, I) & Chr(13) & Chr(10)
    Next I

    ' S

FormatJ関数

s = FormatJ(Now, "g gg ggg e ee yyyy-mm-dd hh:nn")

---

モジュール本体

Option Compare Database
Option Explicit

Private Declare Function RegOpenKeyEx Lib "ADVAPI32" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long
Private Declare Function RegCloseKey Lib "ADVAPI32" (ByVal hKey As Long) As Long
Private Declare Function RegQueryValueExstr Lib "ADVAPI32" Alias "RegQueryValueExA" (ByVal hKey&, ByVal lpValueName$, ByVal lpReserved&, ByVal lpType&, ByVal lpData$, lpcbData&) As Long
Private Declare Function RegEnumValue Lib "ADVAPI32" Alias "RegEnumValueA" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpValueName As String, lpcbValueName As Long, ByVal lpReserved As Long, lpType As Long, ByVal lpData As String, lpcbData As Long) As Long

Private Const HKEY_LOCAL_MACHINE = &H80000002

Private Const ERROR_SUCCESS = 0

Private Const KEY_QUERY_VALUE = &H1
Private Const KEY_ENUMERATE_SUB_KEYS = &H8

Private GengoDimCache()



Function FormatJ(ByVal iDate As Date, ByVal FormatStr As String)
    Dim refGengo() As String
    Dim refWareki As Long

    If DateToWareki(iDate, refGengo, refWareki) Then
        FormatStr = Replace(FormatStr, "ggg", """" & refGengo(2) & """") ' 平成
        FormatStr = Replace(FormatStr, "gg", """" & refGengo(3) & """")  ' 平
        FormatStr = Replace(FormatStr, "g", """" & refGengo(5) & """")   ' H
        
        If refWareki = 1 Then
            ' Format関数は eの後に年があると「元年」表示となる
            FormatStr = Replace(FormatStr, "ee年", """元年""")
            FormatStr = Replace(FormatStr, "ee\年", """元年""")
            FormatStr = Replace(FormatStr, "e年", """元年""")
            FormatStr = Replace(FormatStr, "e\年", """元年""")
        End If
        
        FormatStr = Replace(FormatStr, "ee", """" & Right("0" & Trim(Str(refWareki)), 2) & """")
        FormatStr = Replace(FormatStr, "e", """" & Trim(Str(refWareki)) & """")
    End If
    
    FormatJ = Format(iDate, FormatStr)
End Function



Function DateToWareki(ByVal iDate As Date, ByRef refGengo() As String, ByRef refWareki As Long) As Boolean
    Dim Gengo()
    Dim I As Long
    Dim J As Long
    Dim S As String
    Dim TempDate As Date

    DateToWareki = False
    
    Gengo = GetGengoDim()
    If Sgn(Gengo) <> 0 Then
        TempDate = 0
        For I = 0 To UBound(Gengo, 2)
            If (Gengo(0, I) > TempDate) And (iDate >= Gengo(0, I)) Then
                TempDate = Gengo(0, I)
            
                ReDim refGengo(UBound(Gengo, 1))
                For J = UBound(Gengo, 1) To 0 Step -1
                    refGengo(J) = Gengo(J, I)
                Next J
                refWareki = Year(iDate) - Year(Gengo(0, I)) + 1
                
                DateToWareki = True
            End If
        Next I
    End If
End Function



' レジストリから元号を取得して配列で返す
Function GetGengoDimFromReg()
    If Sgn(GengoDimCache) <> 0 Then
        GetGengoDimFromReg = GengoDimCache ' キャッシュ
        Exit Function
    End If


    Dim hKey As Long
    
    Dim dwIndex As Long
    Dim lpName As String
    Dim lpcbName As Long
    
    Dim lpType As Long
    Dim lpData As String
    Dim lpcbData As Long
    
    Dim lpValue As String
    Dim lpcbValue As Long
    
    Dim DimLen As Long
    Dim YMD() As String
    Dim Gengo() As String
    Dim Result()
    
    If (RegOpenKeyEx(HKEY_LOCAL_MACHINE, "SYSTEM\CurrentControlSet\Control\Nls\Calendars\Japanese\Eras", 0, KEY_QUERY_VALUE + KEY_ENUMERATE_SUB_KEYS, hKey) = ERROR_SUCCESS) Then
        
        dwIndex = 0
        Do
            lpType = 0
            lpcbName = 256
            lpName = String(lpcbName, Chr(0))
            
            lpcbData = 256
            lpData = String(lpcbData, Chr(0))
            
            ' エントリ取得
            If (RegEnumValue(hKey, dwIndex, lpName, lpcbName, 0, lpType, lpData, lpcbData) = ERROR_SUCCESS) Then
                lpName = Left(lpName, InStr(1, lpName, Chr(0)) - 1) ' "1989 01 08"
                
                ' データ取得
                lpcbValue = 256
                lpValue = String(lpcbValue, Chr(0))
                
                If (RegQueryValueExstr(hKey, lpName, 0, 0, lpValue, lpcbValue) = ERROR_SUCCESS) Then
                    lpValue = Left(lpValue, InStr(1, lpValue, Chr(0)) - 1) ' "平成_㍻_Heisei_H" winUpdate→ "平成_平_Heisei_H"
                    
                    ' 配列へ
                    If Sgn(Result) = 0 Then
                        ReDim Preserve Result(5, 0)
                    Else
                        ReDim Preserve Result(5, UBound(Result, 2) + 1)
                    End If
                    DimLen = UBound(Result, 2)
                    
                    YMD = Split(lpName, " ", 3) ' "1989 01 08"
                    Result(0, DimLen) = DateSerial(Int(YMD(0)), Int(YMD(1)), Int(YMD(2)))
                    
                    Result(1, DimLen) = lpValue   ' 平成_平_Heisei_H
                    Gengo = Split(lpValue, "_", 4)
                    Result(2, DimLen) = Gengo(0) ' 平成
                    Result(3, DimLen) = Gengo(1) ' 平
                    Result(4, DimLen) = Gengo(2) ' Heisei
                    Result(5, DimLen) = Gengo(3) ' H
                End If
                
                dwIndex = dwIndex + 1
            Else
                Exit Do
            
            End If
        
        Loop
        
        Call RegCloseKey(hKey)
    End If
    
    GengoDimCache = Result
    GetGengoDimFromReg = Result
End Function