カレンダー計算（3）万年カレンダー
万年カレンダー
MJDか日付を入力すると、その月のカレンダーの形状を表示する。
入力した日は★で表す。曜日と日干支も表示する。
日付は1582年10月15日以降はグレゴリオ暦、それより前はユリウス暦で表示する。
'MJDや日付を指定すると、カレンダーを表示する
Dim cal '自作のオブジェクト
Dim ret
Dim mjd '修正ユリウス日
Dim dat '日付
Dim wk '曜日
Dim eto '日干支
Dim tbl 'カレンダーを表す文字列
Set cal = New C_Calender
cal.Mode = 0 'グレゴリオ暦かユリウス暦かを自動で判断
ret = Date() 'デフォルト値として本日の日付
Do
ret = InputBox("MJDまたは日付を入力してください。", "万年カレンダー", ret)
If ret = "" Then Exit Do 'キャンセルボタンが押された場合は終了
If IsNumeric(ret) Then 'MJDが入力された場合
mjd = CDbl(ret)
dat = cal.GetDate(mjd)
wk = cal.GetJWeek(mjd)
eto = cal.GetEto(mjd)
tbl = cal.GetCalender(dat)
Call ShowCalender(dat, mjd, wk, eto, tbl)
ElseIf UBound(Split(ret, "/")) = 2 Then '日付が入力された場合
dat = ret '年月日の配列
mjd = cal.GetMJD(dat)
wk = cal.GetJWeek(mjd)
eto = cal.GetEto(mjd)
tbl = cal.GetCalender(dat)
Call ShowCalender(dat, mjd, wk, eto, tbl)
Else
ret = Date()
End If
Loop
Function ShowCalender(dat, mjd, wk, eto, tbl)
Dim buf
Dim title
Dim msg
buf = Split(dat, "/")
title = buf(1) & "月" & buf(2) & "日(" & wk & ")"
msg = "MJD=" & mjd & vbCr & eto & vbCr & vbCr & tbl
Msgbox msg, , title
End Function
Class C_Calender
Private m_mode
Public Property Let Mode(val)
m_mode = val
End Property
Public Function GetMJD(dt)
'引数の日付のMJDを返す
Dim buf, y, m, d, reki
buf = Split(dt, "/") '年,月,日の配列
y = CDbl(buf(0)) '年, 数値へ変換
m = CDbl(buf(1)) '月, 数値へ変換
d = CDbl(buf(2)) '日, 数値へ変換
Select Case m_mode
Case 1, 2
reki = m_mode
Case 0 'グレゴリオ暦かユリウス暦かを自動判断
If 10000*y + 100*m + d >= 15821015 Then
reki = 1
Else
reki = 2
End If
End Select
'1,2月を前年の13,14月にする
If m < 3 Then
y = y - 1
m = m + 12
End If
Select Case reki
Case 1
'グレゴリオ暦の日付から修正ユリウス日を算出
GetMJD = - 678882 + 365 * y + MonthDay(m - 1) + d + Int(y / 4) _
- Int(y / 100) + Int(y / 400)
Case 2
'ユリウス暦の日付から修正ユリウス日を算出
GetMJD = - 678884 + 365 * y + MonthDay(m - 1) + d + Int(y / 4)
End Select
End Function
Public Function GetDate(mjd)
'MJDに対応する日付を返す
Dim y, m, d, a, reki
Dim arrYears, arrDays, zeroDay
'グレゴリオ暦かユリウス暦かを自動判断
If mjd >= -100840 Then
reki = 1
Else
reki = 2
End If
arrYears = Array(0, 1, 4, 100, 400)
If reki = 1 Then 'グレゴリオ暦の場合
arrDays = Array(1,365,1461,36524,146097)
zeroDay = -678882 '西暦0年(紀元前1年)2月29日のMJD
ElseIf reki = 2 Then 'ユリウス暦の場合
arrDays = Array(1,365,1461)
zeroDay = -678884 '西暦0年(紀元前1年)2月29日のMJD
End If
'MJDをそれぞれの暦の西暦0年(紀元前1年)2月29日を第0日とした日数へ変換
d = mjd - zeroDay
y = 0
m = 3
'年の計算
a = Div(d, arrDays)
y = y + Mul(a, arrYears)
d = a(0)
'月の計算
If d < 1 Then 'dは小数点以下で時刻を表していることに注意
'2月末日の場合
m = 2 '2月
If LeapYear(a) Then
d = 29 + d
Else
d = 28 + d
End If
Else '2月末日以外の場合
Do While MonthDay(m) < d
m = m + 1
Loop
d = d - MonthDay(m - 1)
If m > 12 Then
y = y + 1
m = m - 12
End If
End If
GetDate = Join(Array(y,m,Round(d, 5)), "/") '日は小数点以下5桁まで
End Function
Private Function LeapYear(a)
'うるう年ならTrue、そうでなければFalseを返す
'aは配列
LeapYear = False
If UBound(a) = 4 Then 'グレゴリオ暦の場合
If a(2) = 0 And a(3) <> 0 Then
Exit Function
End If
End If
If a(1) = 0 Then
LeapYear = True
End If
End Function
Private Function MonthDay(M)
'2月末日を第0日としてM月末日までの日数を返す(M=2～13)
MonthDay = Int(30.59 * (M - 1)) - 30
End Function
Public Function GetCalender(dt)
'その月のカレンダーを返す
Dim buf, y, m, d
buf = Split(dt, "/") '年,月,日の配列
y = CDbl(buf(0)) '年, 数値へ変換
m = CDbl(buf(1)) '月, 数値へ変換
d = CInt(buf(2)) '日, 数値へ変換
Dim mjd1, mjd2, mjd, days
mjd1 = GetMJD(y & "/" & m & "/" & 1) '当月1日の修正ユリウス日
mjd2 = GetMJD(y & "/" & m + 1 & "/" & 1) '翌月1日の修正ユリウス日
mjd = GetMJD(y & "/" & m & "/" & d)
days = mjd2 - mjd1
Dim cale(41) 'カレンダーの6週×7日を表す配列
Dim i, j
j = GetWeek(mjd1) '当月1日の曜日
For i = 0 To j - 1
cale(i) = "□"
Next
For i = j To j - 1 + days
cale(i) = "■"
Next
cale(j + mjd -mjd1) = "★"
'カレンダーの6週目を表示するかどうか
If j + days - 1 > 34 Then
For i = j + days To 41
cale(i) = "□"
Next
Else
For i = j + days To 34
cale(i) = "□"
Next
End If
Dim buf2
buf2 = y & "年" & m & "月"
For i = 0 To 41
If i Mod 7 = 0 Then
buf2 = buf2 & vbCr
End If
buf2 = buf2 + cale(i)
Next
'結果を返す
GetCalender = buf2
End Function
Public Function GetWeek(mjd)
'曜日を返す(0～6の数値)
GetWeek = (mjd + 3) - Int((mjd + 3) / 7) * 7
End Function
Public Function GetJWeek(mjd)
'日本語の曜日を返す
GetJWeek = Mid("日月火水木金土", GetWeek(mjd) + 1, 1)
End Function
Public Function GetEto(mjd)
Dim p1, p2
p1 = mjd Mod 10
If p1 < 0 Then p1 = p1 + 10
p2 = (mjd + 2) Mod 12
If p2 < 0 Then p2 = p2 + 12
GetEto = Mid("甲乙丙丁戊己庚辛壬癸", p1+1, 1) _
& Mid("子丑寅卯辰巳午未申酉戌亥", p2+1, 1)
End Function
End Class
Function Div(val, arr)
'例えばarr=[1,365,1461]の場合、a(0)+365*a(1)+1461*a(2)=valとなる配列aを返す
Dim i, iMax
Dim a '戻り値となる配列
iMax = UBound(arr)
ReDim a(iMax)
a(0) = val
For i = iMax To 1 Step -1
a(i) = Int(a(0) / arr(i)) '商の整数部
a(0) = a(0) - arr(i) * a(i) '余り(>0)
Next
Div = a
End Function
Function Mul(arr1, arr2)
'2つの配列の「内積」を返す
Dim i, iMax
Dim a '戻り値となる配列
If UBound(arr1) < UBound(arr2) Then
iMax = UBound(arr1)
Else
iMax = UBound(arr2)
End If
For i = 0 To iMax
a = a + arr1(i) * arr2(i)
Next
Mul = a
End Function
表示例
1月1日(水)
MJD=60676
庚午
2025年1月
□□□★■■■
■■■■■■■
■■■■■■■
■■■■■■■
■■■■■■□