SAK 図書館

SAK Streets メインストリート 図書館・カフェ 一覧 SAK Streets 検索
| VB | SQL | Perl | PHP | ASP | JSP | C | PC | HP | FAQ | フリーソフト |

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 ビジュアル編資料
| VB | SQL | Perl | PHP | ASP | JSP | C | PC | HP | FAQ | フリーソフト |

SAK Streets メインストリート 図書館・カフェ 一覧 SAK Streets 検索



Copyright (C) 1999-2017 Y.SAK