VisualBasic6(VB6)Format, IsDateの新元号対応

業務システムでは今でもVB6使っているのが残っています。きっとMSさんが対応してくれると思ってはいますが、心配なのでオーバーライド関数を作ってみました。
レジストリHKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Control\Nls\Calendars\Japanese\Eras
を反映するように作成してあります。

modFormatOverride.bas

Attribute VB_Name = "modFormatOverride"
Option Explicit

Private Const HKEY_LOCAL_MACHINE = &H80000002
Private varEnumEras As Variant

' 新元号対応IsDate関数
Public Function IsDate(expression As Variant) As Boolean

    If vba.IsDate(expression) Then
        IsDate = True
        Exit Function
    End If
    IsDate = vba.IsDate(ConvertAD(expression))

End Function

' 新元号対応Format関数
Public Function Format(expression As Variant, Optional fmtstr As Variant = "", Optional firstdayofweek As Variant = vbSunday, Optional firstweekofyear As Variant = vbUseSystem) As String

    Dim i As Integer, intYear As Integer
    Dim varDef As Variant, varExp As Variant, varTmpfmt As Variant
    
    If Not IsDate(expression) Then
        Format = vba.Format(expression, fmtstr, firstdayofweek, firstweekofyear)
        Exit Function
    End If

    varExp = ConvertAD(expression)

    varDef = Array("General Date", "Long Date", "Medium Date", "Short Date", "Long Time", "Medium Time", "Short Time")
    
    For i = 0 To UBound(varDef)
        If LCase(fmtstr) = LCase(varDef(i)) Then
            Format = vba.Format(varExp, fmtstr, firstdayofweek, firstweekofyear)
            Exit Function
        End If
    Next
    
    If InStr(LCase(fmtstr), "g") = 0 And InStr(LCase(fmtstr), "e") = 0 Then
        Format = vba.Format(varExp, fmtstr, firstdayofweek, firstweekofyear)
        Exit Function
    End If

    For i = 0 To UBound(varEnumEras)
        If CDate(varExp) < varEnumEras(i)(0) Then
            Exit For
        End If
    Next
    i = i - 1

    If i > 3 Then
        varTmpfmt = Replace(Replace(fmtstr, "g", "z"), "G", "z")
        varTmpfmt = Replace(Replace(varTmpfmt, "e", "x"), "E", "x")
        varTmpfmt = Replace(varTmpfmt, ".", "v")
        varTmpfmt = vba.Format(varExp, varTmpfmt, firstdayofweek, firstweekofyear)
        varTmpfmt = Replace(varTmpfmt, "v", ".")
        varTmpfmt = Replace(varTmpfmt, "zzz", varEnumEras(i)(1)(0))
        varTmpfmt = Replace(varTmpfmt, "zz", varEnumEras(i)(1)(1))
        varTmpfmt = Replace(varTmpfmt, "z", varEnumEras(i)(1)(3))
        intYear = Year(varExp) - Year(varEnumEras(i)(0)) + 1
        varTmpfmt = Replace(varTmpfmt, "xx", Right("0" & intYear, 2))
        Format = Replace(varTmpfmt, "x", intYear)
    Else
        Format = vba.Format(varExp, fmtstr, firstdayofweek, firstweekofyear)
    End If

End Function

' 新元号文字列を西暦文字列に変換
Private Function ConvertAD(expression As Variant) As Variant

    Dim i As Integer, j As Integer, k As Integer
    Dim objRegistry As Object
    Dim strKeyPath As String, strChar As String
    Dim varEras As Variant, varValue As Variant, varNum As Variant

    ConvertAD = expression
    
    If IsEmpty(varEnumEras) Then
        Set objRegistry = GetObject("winmgmts:\root\default:StdRegProv")
        strKeyPath = "SYSTEM\CurrentControlSet\Control\Nls\Calendars\Japanese\Eras"
        objRegistry.EnumValues HKEY_LOCAL_MACHINE, strKeyPath, varEras
        ReDim varValue(UBound(varEras))
        ReDim varEnumEras(UBound(varEras))
        For i = 0 To UBound(varEras)
            objRegistry.GetStringValue HKEY_LOCAL_MACHINE, strKeyPath, varEras(i), varValue(i)
            varEras(i) = CDate(Replace(varEras(i), " ", "/"))
            varValue(i) = Split(varValue(i), "_")
            varValue(i)(2) = LCase(varValue(i)(3))
            varValue(i)(3) = UCase(varValue(i)(3))
            varEnumEras(i) = Array(varEras(i), varValue(i))
        Next
        Set objRegistry = Nothing
    End If
    
    If Not vba.IsDate(expression) Then
        For i = 4 To UBound(varEnumEras)
            For j = 0 To UBound(varEnumEras(i)(1))
                If InStr(Trim(expression), varEnumEras(i)(1)(j)) = 1 Then
                    For k = InStr(expression, varEnumEras(i)(1)(j)) + Len(varEnumEras(i)(1)(j)) To Len(expression)
                        strChar = Mid(expression, k, 1)
                        If InStr("年/,-", strChar) > 0 Then
                            Exit For
                        Else
                            varNum = varNum & strChar
                        End If
                    Next
                    If IsNumeric(varNum) Then
                        ConvertAD = Replace(expression, varEnumEras(i)(1)(j) & varNum, Year(varEnumEras(i)(0)) + varNum - 1)
                        Exit Function
                    End If
                End If
            Next
        Next
    End If

End Function

まあ、CDate("新元号1年5月1日")みたいにCDateに直接新元号を入れられるとだめですけどね...