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アップデートで、レジストリの値が全角合成文字(㍻)から先頭文字(平)に変更されています

配列から取得

view plainprint?

1. Dim Gengo()  
2. Dim I As Long  
3. Dim S As String  
4.   
5. Gengo = GetGengoDimFromReg()  
6. For I = UBound(Gengo, 2) To 0 Step -1  
7.     S = S & Gengo(0, I) & " = " & Gengo(1, I) & Chr(13) & Chr(10)  
8. Next I  
9.   
10. ' S  

    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関数

view plainprint?

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

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

---

モジュール本体

view plainprint?

1. Option Compare Database  
2. Option Explicit  
3.   
4. 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  
5. Private Declare Function RegCloseKey Lib "ADVAPI32" (ByVal hKey As Long) As Long  
6. Private Declare Function RegQueryValueExstr Lib "ADVAPI32" Alias "RegQueryValueExA" (ByVal hKey&, ByVal lpValueName$, ByVal lpReserved&, ByVal lpType&, ByVal lpData$, lpcbData&) As Long  
7. 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  
8.   
9. Private Const HKEY_LOCAL_MACHINE = &H80000002  
10.   
11. Private Const ERROR_SUCCESS = 0  
12.   
13. Private Const KEY_QUERY_VALUE = &H1  
14. Private Const KEY_ENUMERATE_SUB_KEYS = &H8  
15.   
16. Private GengoDimCache()  
17.   
18.   
19.   
20. Function FormatJ(ByVal iDate As Date, ByVal FormatStr As String)  
21.     Dim refGengo() As String  
22.     Dim refWareki As Long  
23.   
24.     If DateToWareki(iDate, refGengo, refWareki) Then  
25.         FormatStr = Replace(FormatStr, "ggg", """" & refGengo(2) & """") ' 平成  
26.         FormatStr = Replace(FormatStr, "gg", """" & refGengo(3) & """")  ' 平  
27.         FormatStr = Replace(FormatStr, "g", """" & refGengo(5) & """")   ' H  
28.           
29.         If refWareki = 1 Then  
30.             ' Format関数は eの後に年があると「元年」表示となる  
31.             FormatStr = Replace(FormatStr, "ee年", """元年""")  
32.             FormatStr = Replace(FormatStr, "ee\年", """元年""")  
33.             FormatStr = Replace(FormatStr, "e年", """元年""")  
34.             FormatStr = Replace(FormatStr, "e\年", """元年""")  
35.         End If  
36.           
37.         FormatStr = Replace(FormatStr, "ee", """" & Right("0" & Trim(Str(refWareki)), 2) & """")  
38.         FormatStr = Replace(FormatStr, "e", """" & Trim(Str(refWareki)) & """")  
39.     End If  
40.       
41.     FormatJ = Format(iDate, FormatStr)  
42. End Function  
43.   
44.   
45.   
46. Function DateToWareki(ByVal iDate As Date, ByRef refGengo() As String, ByRef refWareki As Long) As Boolean  
47.     Dim Gengo()  
48.     Dim I As Long  
49.     Dim J As Long  
50.     Dim S As String  
51.     Dim TempDate As Date  
52.   
53.     DateToWareki = False  
54.       
55.     Gengo = GetGengoDim()  
56.     If Sgn(Gengo) <> 0 Then  
57.         TempDate = 0  
58.         For I = 0 To UBound(Gengo, 2)  
59.             If (Gengo(0, I) > TempDate) And (iDate >= Gengo(0, I)) Then  
60.                 TempDate = Gengo(0, I)  
61.               
62.                 ReDim refGengo(UBound(Gengo, 1))  
63.                 For J = UBound(Gengo, 1) To 0 Step -1  
64.                     refGengo(J) = Gengo(J, I)  
65.                 Next J  
66.                 refWareki = Year(iDate) - Year(Gengo(0, I)) + 1  
67.                   
68.                 DateToWareki = True  
69.             End If  
70.         Next I  
71.     End If  
72. End Function  
73.   
74.   
75.   
76. ' レジストリから元号を取得して配列で返す  
77. Function GetGengoDimFromReg()  
78.     If Sgn(GengoDimCache) <> 0 Then  
79.         GetGengoDimFromReg = GengoDimCache ' キャッシュ  
80.         Exit Function  
81.     End If  
82.   
83.   
84.     Dim hKey As Long  
85.       
86.     Dim dwIndex As Long  
87.     Dim lpName As String  
88.     Dim lpcbName As Long  
89.       
90.     Dim lpType As Long  
91.     Dim lpData As String  
92.     Dim lpcbData As Long  
93.       
94.     Dim lpValue As String  
95.     Dim lpcbValue As Long  
96.       
97.     Dim DimLen As Long  
98.     Dim YMD() As String  
99.     Dim Gengo() As String  
100.     Dim Result()  
101.       
102.     If (RegOpenKeyEx(HKEY_LOCAL_MACHINE, "SYSTEM\CurrentControlSet\Control\Nls\Calendars\Japanese\Eras", 0, KEY_QUERY_VALUE + KEY_ENUMERATE_SUB_KEYS, hKey) = ERROR_SUCCESS) Then  
103.           
104.         dwIndex = 0  
105.         Do  
106.             lpType = 0  
107.             lpcbName = 256  
108.             lpName = String(lpcbName, Chr(0))  
109.               
110.             lpcbData = 256  
111.             lpData = String(lpcbData, Chr(0))  
112.               
113.             ' エントリ取得  
114.             If (RegEnumValue(hKey, dwIndex, lpName, lpcbName, 0, lpType, lpData, lpcbData) = ERROR_SUCCESS) Then  
115.                 lpName = Left(lpName, InStr(1, lpName, Chr(0)) - 1) ' "1989 01 08"  
116.                   
117.                 ' データ取得  
118.                 lpcbValue = 256  
119.                 lpValue = String(lpcbValue, Chr(0))  
120.                   
121.                 If (RegQueryValueExstr(hKey, lpName, 0, 0, lpValue, lpcbValue) = ERROR_SUCCESS) Then  
122.                     lpValue = Left(lpValue, InStr(1, lpValue, Chr(0)) - 1) ' "平成_㍻_Heisei_H" winUpdate→ "平成_平_Heisei_H"  
123.                       
124.                     ' 配列へ  
125.                     If Sgn(Result) = 0 Then  
126.                         ReDim Preserve Result(5, 0)  
127.                     Else  
128.                         ReDim Preserve Result(5, UBound(Result, 2) + 1)  
129.                     End If  
130.                     DimLen = UBound(Result, 2)  
131.                       
132.                     YMD = Split(lpName, " ", 3) ' "1989 01 08"  
133.                     Result(0, DimLen) = DateSerial(Int(YMD(0)), Int(YMD(1)), Int(YMD(2)))  
134.                       
135.                     Result(1, DimLen) = lpValue   ' 平成_平_Heisei_H  
136.                     Gengo = Split(lpValue, "_", 4)  
137.                     Result(2, DimLen) = Gengo(0) ' 平成  
138.                     Result(3, DimLen) = Gengo(1) ' 平  
139.                     Result(4, DimLen) = Gengo(2) ' Heisei  
140.                     Result(5, DimLen) = Gengo(3) ' H  
141.                 End If  
142.                   
143.                 dwIndex = dwIndex + 1  
144.             Else  
145.                 Exit Do  
146.               
147.             End If  
148.           
149.         Loop  
150.           
151.         Call RegCloseKey(hKey)  
152.     End If  
153.       
154.     GengoDimCache = Result  
155.     GetGengoDimFromReg = Result  
156. End Function  

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