SAK 図書館
SAK 図書館
VB テクニック編5 - カレンダー計算、通算日、月末日、うるう年、曜日
■SAK 関数利用規程
・テクニック編で紹介する関数は、私こと Y.SAK の開発関数である。
・著作権明示部分の改編は認めない。
・個人、企業がこれらの関数を使用したり、一部を使用して新たなシステムや
プログラムを開発することは自由です。
・但し、これらの関数を一部でも使用しているソフトウェアをシェアウェア、
その他有償プロダクトとして配布・販売するには、私の許可が必要です。
(無償のフリーソフトウェアなら、自由に配布しても良い。)
・これらの関数を使用して発生した、いかなる形での損害も私こと Y.SAK は
賠償しません。
■カレンダー計算(通算日、月末日、曜日)
(日付計算、日数計算、カレンダー計算、経過日付、万年カレンダー)
(うるう年計算、曜日算出、月の最終日)
【使い方】
dim dt as string
dim ybnm as string
dim days as long
dt = "2001.06.00"
days = CalcDate(dt, 0, ybnm, "")
if days = 0 then msgbox "エラー"
msgbox "月末日= " & dt
dt = "2001.06.22"
days = CalcDate(dt, 0, ybnm, "")
if days = 0 then msgbox "エラー"
msgbox "通算日= " & days & chr(10) & "日付= " & dt & chr(10) & "曜日= " & ybnm
'=======================================================================
' カレンダー計算(通算日、月末日、曜日)
'=======================================================================
'【引数】
' dt = 【入出力】西暦年月日("0000.00.00")
' yb = 【戻り値】曜日コード(0 = SUN 〜 6 = SAT)
' ybnm = 【戻り値】ANK 曜日 (Sun 〜 Sat)
' ybjp = 【戻り値】日本語曜日(日曜日 〜 土曜日)
'【戻り値】
' long = 西暦 1 年 1 月 1 日からの通算日
' 0 = 西暦年月日エラー
'【処理】
' ・西暦年月日に対する通算日、月末日、曜日を求める。
' ・dt の日が "00" か、その月の月末日をオーバーしていると、月末日を dt
' の 日の部分に返す。
' ・西暦年月日がエラーのとき、通算日を 0 として返す。
'【著作権】
' CalcDate() ver 1.00 Copyright (C) 1999 Y.SAK
'【履歴】
' 1999.04.17 sak ver 1.00 新規作成
'=======================================================================
Public Function CalcDate(dt As String, yb As Integer, ybnm As String, ybjp As String) As Long
Static ybnx(6) As String
Static ybjx(6) As String
Static init As Boolean
ReDim ddmx(12) As Integer
Dim yy As Long
Dim mm As Integer
Dim dd As Integer
Dim y1 As Integer
Dim y2 As Integer
Dim y3 As Integer
Dim ur As Integer
Dim dy As Long
Dim i As Integer
Dim rcd As Long
'** 初期化
If init = False Then
ybnx(0) = "Sun"
ybnx(1) = "Mon"
ybnx(2) = "Tue"
ybnx(3) = "Wed"
ybnx(4) = "Thu"
ybnx(5) = "Fri"
ybnx(6) = "Sat"
ybjx(0) = "日曜日"
ybjx(1) = "月曜日"
ybjx(2) = "火曜日"
ybjx(3) = "水曜日"
ybjx(4) = "木曜日"
ybjx(5) = "金曜日"
ybjx(6) = "土曜日"
init = True
End If
ddmx(1) = 31
ddmx(2) = 28
ddmx(3) = 31
ddmx(4) = 30
ddmx(5) = 31
ddmx(6) = 30
ddmx(7) = 31
ddmx(8) = 31
ddmx(9) = 30
ddmx(10) = 31
ddmx(11) = 30
ddmx(12) = 31
'** 日付分割
On Local Error Resume Next
yy = Val(Left(dt, 4))
If Err <> 0 Then rcd = Err
mm = Val(Mid(dt, 6, 2))
If Err <> 0 Then rcd = Err
dd = Val(Right(dt, 2))
If Err <> 0 Then rcd = Err
On Local Error GoTo 0
If rcd <> 0 Or yy < 1 Or mm < 1 Or mm > 12 Then
yb = 0
ybnm = ""
ybjp = ""
CalcDate = 0
Exit Function
End If
'** 月末日算出
If ((yy Mod 4) = 0 And (yy Mod 100) <> 0) Or (yy Mod 400) = 0 Then
ddmx(2) = 29
Else
ddmx(2) = 28
End If
'** 月末日セット
If dd > ddmx(mm) Or dd = 0 Then
dd = ddmx(mm)
dt = Left(dt, 8) + Right("00" + LTrim(Str(dd)), 2)
End If
'** 日付計算
y1 = (yy - 1) \ 4
y2 = (yy - 1) \ 100
y3 = (yy - 1) \ 400
ur = y1 - y2 + y3
'** 通算日計算
dy = (yy - 1) * 365 + ur + dd
For i = 1 To mm - 1
dy = dy + ddmx(i)
Next
'** 曜日計算
yb = dy Mod 7
'** 曜日セット
ybnm = ybnx(yb)
ybjp = ybjx(yb)
'** 通算日セット
CalcDate = dy
End Function
■カレンダー計算(西暦年月日、曜日)
(日付計算、日数計算、カレンダー計算、経過日付)
【使い方】
dim dt as string
dim ybnm as string
dim days as long
dt = "2001.06.22"
days = CalcDate(dt, 0, ybnm, "")
if days = 0 then msgbox "エラー"
days = days + 14
dt = CalcDays(days, 0, ybnm, "")
msgbox "2 週間後= " & dt & chr(10) & "曜日= " & ybnm
'=======================================================================
' カレンダー計算(西暦年月日、曜日)
'=======================================================================
'【引数】
' days = 西暦 1 年 1 月 1 日からの通算日
' yb = 【戻り値】曜日コード(0 = SUN 〜 6 = SAT)
' ybnm = 【戻り値】ANK 曜日 (Sun 〜 Sat)
' ybjp = 【戻り値】日本語曜日(日曜日 〜 土曜日)
'【戻り値】
' string = 西暦年月日("0000.00.00")
' "" = 通算日エラー
'【処理】
' ・通算日に対する西暦年月日、曜日を求める。
' ・通算日が西暦範囲外のとき、"" を返す。
'【著作権】
' CalcDays() ver 1.00 Copyright (C) 1999 Y.SAK
'【履歴】
' 1999.04.17 sak ver 1.00 新規作成
'=======================================================================
Public Function CalcDays(days As Variant, yb As Integer, ybnm As String, ybjp As String) As String
Static ybnx(6) As String
Static ybjx(6) As String
Static init As Boolean
ReDim ddmx(12) As Integer
Dim yy As Long
Dim mm As Integer
Dim dd As Integer
Dim y1 As Integer
Dim y2 As Integer
Dim y3 As Integer
Dim ur As Integer
Dim dy As Long
Dim i As Long
Dim j As Integer
'** 初期化
If init = False Then
ybnx(0) = "Sun"
ybnx(1) = "Mon"
ybnx(2) = "Tue"
ybnx(3) = "Wed"
ybnx(4) = "Thu"
ybnx(5) = "Fri"
ybnx(6) = "Sat"
ybjx(0) = "日曜日"
ybjx(1) = "月曜日"
ybjx(2) = "火曜日"
ybjx(3) = "水曜日"
ybjx(4) = "木曜日"
ybjx(5) = "金曜日"
ybjx(6) = "土曜日"
init = True
End If
ddmx(1) = 31
ddmx(2) = 28
ddmx(3) = 31
ddmx(4) = 30
ddmx(5) = 31
ddmx(6) = 30
ddmx(7) = 31
ddmx(8) = 31
ddmx(9) = 30
ddmx(10) = 31
ddmx(11) = 30
ddmx(12) = 31
'** 通算日チェック
If days < 1 Or days > 3652059 Then
yb = 0
ybnm = ""
ybjp = ""
CalcDays = ""
Exit Function
End If
'** 西暦年計算
i = days \ 365
dy = days Mod 365
i = i + 1
y1 = (i - 1) \ 4
y2 = (i - 1) \ 100
y3 = (i - 1) \ 400
ur = y1 - y2 + y3
Do Until dy > ur
i = i - 1
dy = dy + 365
y1 = (i - 1) \ 4
y2 = (i - 1) \ 100
y3 = (i - 1) \ 400
ur = y1 - y2 + y3
Loop
yy = i
dy = dy - ur
'** 月末日算出
If ((yy Mod 4) = 0 And (yy Mod 100) <> 0) Or (yy Mod 400) = 0 Then
ddmx(2) = 29
Else
ddmx(2) = 28
End If
'** 西暦月日計算
i = 1
j = 1
Do Until ddmx(j) >= dy
dy = dy - ddmx(j)
i = i + 1
j = j + 1
Loop
mm = i
dd = dy
'** 曜日計算
yb = days Mod 7
'** 曜日セット
ybnm = ybnx(yb)
ybjp = ybjx(yb)
'** 西暦年月日セット
CalcDays = Format(yy, "0000") + "." + Format(mm, "00") + "." + Format(dd, "00")
End Function
■日計算
【使い方】
dim dt as string
dt = CalcDD("2001.06.22", -14)
msgbox "2 週間前= " & dt
'=======================================================================
' 日計算
'=======================================================================
'【引数】
' dt = 日付("0000.00.00")
' days = プラスまたは、マイナス日数
'【戻り値】
' string = 日付
' "" = エラー
'【処理】
' ・日計算の結果を返す。
' ・計算エラーのとき、"" を返す。
'【著作権】
' CalcDD() ver 1.00 Copyright (C) 1999 Y.SAK
'【履歴】
' 1999.04.17 sak ver 1.00 新規作成
'=======================================================================
Public Function CalcDD(dt As Variant, days As Variant) As String
Dim s As String
Dim yb As Integer
Dim ybnm As String
Dim ybjp As String
'** 日付計算
s = dt
CalcDD = CalcDays(CalcDate(s, yb, ybnm, ybjp) + days, yb, ybnm, ybjp)
End Function
■月計算
【使い方】
dim dt as string
dt = CalcMM("2001.06.22", -12)
msgbox "12 ヶ月前= " & dt
'=======================================================================
' 月計算
'=======================================================================
'【引数】
' dt = 日付("0000.00.00")
' mms = プラスまたは、マイナス月数
'【戻り値】
' string = 日付
' "" = エラー
'【処理】
' ・月計算の結果を返す。
' ・計算エラーのとき、"" を返す。
'【著作権】
' CalcMM() ver 1.00 Copyright (C) 1999 Y.SAK
'【履歴】
' 1999.04.17 sak ver 1.00 新規作成
'=======================================================================
Public Function CalcMM(dt As Variant, mms As Variant) As String
Dim s As String
Dim yy As Integer
Dim mm As Integer
'** 月計算
s = dt
yy = Val(Left(s, 4))
mm = Val(Mid(s, 6, 2))
If yy < 1 Or mm < 1 Or mm > 12 Then
CalcMM = ""
Exit Function
End If
mm = mm + mms
If mm > 12 Then
yy = yy + (mm - 1) \ 12
mm = (mm - 1) Mod 12 + 1
End If
If mm < 1 Then
yy = yy + mm \ 12 - 1
mm = 12 + mm Mod 12
End If
If yy < 1 Then yy = 1
If yy > 9999 Then yy = 9999
CalcMM = Format(yy, "0000") + "." + Format(mm, "00") + Right(dt, 3)
End Function
■年計算
【使い方】
dim dt as string
dt = CalcYY("2001.06.22", 2)
msgbox "2 年後= " & dt
'=======================================================================
' 年計算
'=======================================================================
'【引数】
' dt = 日付("0000.00.00")
' yys = プラスまたは、マイナス年数
'【戻り値】
' string = 日付
' "" = エラー
'【処理】
' ・年計算の結果を返す。
' ・計算エラーのとき、"" を返す。
'【著作権】
' CalcYY() ver 1.00 Copyright (C) 1999 Y.SAK
'【履歴】
' 1999.04.17 sak ver 1.00 新規作成
'=======================================================================
Public Function CalcYY(dt As Variant, yys As Variant) As String
Dim s As String
Dim yy As Integer
'** 年計算
s = dt
If Val(Left(s, 4)) < 1 Then
CalcYY = ""
Exit Function
End If
yy = Val(Left(s, 4)) + yys
If yy < 1 Then yy = 1
If yy > 9999 Then yy = 9999
CalcYY = Format(yy, "0000") + Right(dt, 6)
End Function
■VB テクニック編資料
■VB 入門編資料
■VB 基礎編資料
■VB ビジュアル編資料
Copyright (C) 1999-2018 Y.SAK