業務システムでは今でも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に直接新元号を入れられるとだめですけどね...
