Windowsをお使いの方。
下記をコピーして、メモ帳などに貼り付けて、適当なファイル名前で拡張子をvbsにして保存して
そのファイルをダブルクリックして下さい。３ヶ月分のカレンダーが表示されます。
'*==============================================================================*=============================*
'* 日付処理メイン
'*==============================================================================*=============================*
MsgBox ScriptEngine & ScriptEngineBuildVersion & "." & ScriptEngineMajorVersion & "." & ScriptEngineMinorVersion , vbOkOnly , CpyL
'*--------------------------------------------------------------------------*-----------------------------*
'* システム日付
'*--------------------------------------------------------------------------*-----------------------------*
Dim strYYYY '* 西暦年
Dim strMM '* 月
Dim strDD '* 日
Dim strWD '* 曜日
'*--------------------------------------------------------------------------*-----------------------------*
'* 指定日付
'*--------------------------------------------------------------------------*-----------------------------*
Dim strSYYYY '* 西暦年
Dim strSMM '* 月
Dim strSDD '* 日
Dim strSWD '* 曜日
'*--------------------------------------------------------------------------*-----------------------------*
'* 曜日テーブル
'*--------------------------------------------------------------------------*-----------------------------*
Dim WD(7) '* 曜日テーブル
Dim CLN(7) '* カレンダーテーブル
'*--------------------------------------------------------------------------*-----------------------------*
'* リテラル
'*--------------------------------------------------------------------------*-----------------------------*
Const CpyL = "Sapporo Cute Photo" '* タイトル（コピーライト）
Dim MsgMode '* メッセージボックスタイプ
MsgMode = vbOkOnly '* OKボタン＋情報アイコン
'*--------------------------------------------------------------------------*-----------------------------*
'* 表示用領域
'*--------------------------------------------------------------------------*-----------------------------*
Dim strSTART '* 当月日付
Dim strEND '* 指定日付
Dim strMSG '* カレンダー
Dim l '* カレンダー作成カウンタ
l = 0 '* カウンタ初期化
'*--------------------------------------------------------------------------*-----------------------------*
'* 主処理
'*--------------------------------------------------------------------------*-----------------------------*
'*----------------------------------------------------------------------*-----------------------------*
'* 曜日テーブル初期化
'*----------------------------------------------------------------------*-----------------------------*
call setDayName() '* 曜日テーブル設定
'*----------------------------------------------------------------------*-----------------------------*
'* 指定月設定（当月１日）
'*----------------------------------------------------------------------*-----------------------------*
strSYYYY = Year(Now) '* 指定年設定
strSMM = Month(Now) '* 指定月設定
strSDD = 1 '* 指定日設定
'*----------------------------------------------------------------------*-----------------------------*
'* 日付取得処理
'*----------------------------------------------------------------------*-----------------------------*
call getSDate(strSYYYY, strSMM, strSDD, strSWD) '* 指定日付取得（当月１日）
call getDate( strYYYY, strMM, strDD, strWD) '* システム日付取得（当日）
'*----------------------------------------------------------------------*-----------------------------*
'* 日付編集
'*----------------------------------------------------------------------*-----------------------------*
strSTART = EditMSG(strSYYYY , strSMM , strSDD , strSWD) '* 当月１日
strEND = EditMSG(strYYYY , strMM , strDD , strWD) '* 当日
'*----------------------------------------------------------------------*-----------------------------*
'* 当月カレンダー作成
'*----------------------------------------------------------------------*-----------------------------*
strMSG = "" '* カレンダー表示領域初期化
Call setCALEN() '* カレンダーテーブル設定
strMSG = strMSG & vbCrLf '* １行改行
'*----------------------------------------------------------------------*-----------------------------*
'* 翌月及び翌々月カレンダー作成
'*----------------------------------------------------------------------*-----------------------------*
For l=1 To 2 Step 1 '* 翌月カレンダー作成ループ
'*------------------------------------------------------------------*-----------------------------*
'* 翌月算出
'*------------------------------------------------------------------*-----------------------------*
strSMM = strSMM + 1 '* 当月に１加算
If strSMM > 12 Then '* １２月を超える場合
strSYYYY = strSYYYY + 1 '* 年に１を加算
strSMM = 1 '* １月に設定
End If '* 判定終了
strSDD = 1 '* １日に設定
'*------------------------------------------------------------------*-----------------------------*
'* カレンダー作成
'*------------------------------------------------------------------*-----------------------------*
call getSDate(strSYYYY,strSMM,strSDD,strSWD) '* 指定日付取得
strEND = EditMSG(strSYYYY , strSMM , strSDD , strSWD) '* 指定日表示編集
Call setCALEN() '* カレンダー作成
Next '* ループ終了
'*----------------------------------------------------------------------*-----------------------------*
'* カレンダー表示
'*----------------------------------------------------------------------*-----------------------------*
Call dsp(strMSG)
'*==============================================================================*=============================*
'* 日付取得
'*==============================================================================*=============================*
'* Arg(1) : Output 西暦年
'* Arg(2) : Output 月（２桁）
'* Arg(3) : Output 日（２桁）
'* Arg(4) : Output 曜日
'*==============================================================================*=============================*
sub getDate(gY,gM,gD,gW)
'*--------------------------------------------------------------------------*-----------------------------*
'* システム日付取得処理
'*--------------------------------------------------------------------------*-----------------------------*
Dim Dt '* システム日付領域
Dt = Now '* システム日付取得
'*--------------------------------------------------------------------------*-----------------------------*
'* 年月日取得
'*--------------------------------------------------------------------------*-----------------------------*
gY = Year(Dt) '* 西暦年取得を取得しパラメタへ
gM = Month(Dt) '* 月取得を取得しパラメタへ
gD = Day(Dt) '* 日取得を取得しパラメタへ
gW = WeekDay(Dt) '* 曜日取得を取得しパラメタへ
gM = edit2NUM(gM) '* 月２桁変換を取得しパラメタへ
gD = edit2NUM(gD) '* 日２桁変換を取得しパラメタへ
End Sub
'*==============================================================================*=============================*
'* 指定日付取得
'*==============================================================================*=============================*
'* Arg(1) : Input 西暦年
'* Arg(2) : I-O 月（２桁）
'* Arg(3) : I-O 日（２桁）
'* Arg(4) : Output 曜日
'*==============================================================================*=============================*
sub getSDate(gY,gM,gD,gW)
'*--------------------------------------------------------------------------*-----------------------------*
'* 指定日付／日付型変換
'*--------------------------------------------------------------------------*-----------------------------*
Dim Dt '* 日付変換領域
Dt = Cdate(gY & "/" & gM & "/" & gD) '* 日付型変換
'*--------------------------------------------------------------------------*-----------------------------*
'* 指定日付／日付取得
'*--------------------------------------------------------------------------*-----------------------------*
gW = WeekDay(Dt) '* 曜日取得
gm = edit2NUM(gM) '* 月２桁変換
gD = edit2NUM(gD) '* 日２桁変換
End Sub
'*==============================================================================*=============================*
'* メッセージ表示
'*==============================================================================*=============================*
'* Arg(1) : Input メッセージ
'*==============================================================================*=============================*
sub dsp(strDSPMSG)
'*--------------------------------------------------------------------------*-----------------------------*
'* メッセージ表示処理
'*--------------------------------------------------------------------------*-----------------------------*
MsgBox strDSPMSG, MsgMode, CpyL '* メッセージ表示
End SUb
'*==============================================================================*=============================*
'* 曜日テーブル設定
'*==============================================================================*=============================*
'* Arg(1) : Output 曜日テーブル
'*==============================================================================*=============================*
sub setDayName()
'*--------------------------------------------------------------------------*-----------------------------*
'* 曜日設定処理
'*--------------------------------------------------------------------------*-----------------------------*
WD(1)="日" '* 日曜日を設定
WD(2)="月" '* 月曜日を設定
WD(3)="火" '* 火曜日を設定
WD(4)="水" '* 水曜日を設定
WD(5)="木" '* 木曜日を設定
WD(6)="金" '* 金曜日を設定
WD(7)="土" '* 土曜日を設定
End Sub
'*==============================================================================*=============================*
'* 月日１桁を２桁へ変換
'*==============================================================================*=============================*
'* Arg(1) : Input 月／日
'* Return : ２桁の月／日
'*==============================================================================*=============================*
Function edit2NUM(strNUM)
'*--------------------------------------------------------------------------*-----------------------------*
'* １桁を２桁へ変換処理
'*--------------------------------------------------------------------------*-----------------------------*
edit2NUM = Right("0" & strNUM,2) '* 頭に０を付加し右から２桁取得
End Function
'*==============================================================================*=============================*
'* 日付表示編集
'*==============================================================================*=============================*
'* Arg(1) : Input 年
'* Arg(2) : Input 月
'* Arg(3) : Input 日
'* Arg(4) : Input 曜日
'* Return : yyyy年mm月dd日(曜日)形式の文字列
'*==============================================================================*=============================*
Function EditMSG(strSYYYY , strSMM , strSDD , strSWD)
'*--------------------------------------------------------------------------*-----------------------------*
'* 日付編集処理（yyyy年mm月dd日（曜日））
'*--------------------------------------------------------------------------*-----------------------------*
Dim rtn '* 編集領域
rtn = strSYYYY & "年" & strSMM & "月" & strSDD & "日" '* 年月日編集
rtn = rtn & "(" & WD(strSWD) & ")" '* 曜日編集
'rtn = rtn & "(" & WeekDayName(strSWD) & ")" '* 曜日編集
EditMSG = rtn '* 戻り値設定
End Function
'*==============================================================================*=============================*
'* カレンダーテーブル初期化
'*==============================================================================*=============================*
'* Return : カレンダーテーブル
'*==============================================================================*=============================*
Sub clrCLN()
'*--------------------------------------------------------------------------*-----------------------------*
'* カレンダーテーブル初期化
'*--------------------------------------------------------------------------*-----------------------------*
Dim i '* 初期化ループカウンタ
For i=1 To 7 '* 初期化ループ
CLN(i) = "" '* カレンダーテーブル初期値設定
Next '* ループ終了
End Sub
'*==============================================================================*=============================*
'* カレンダー設定
'*==============================================================================*=============================*
'* Arg(1) : Input カレンダーテーブル
'* Arg(2) : I-O カレンダー
'*==============================================================================*=============================*
Sub prtCLN()
'*--------------------------------------------------------------------------*-----------------------------*
'* カレンダー設定
'*--------------------------------------------------------------------------*-----------------------------*
Dim i '* カレンダー設定ループカウンタ
For i=1 To 7 Step 1 '* カレンダー設定ループ
strMSG = strMSG & CLN(i) & " " '* カレンダー設定
Next '* ループ終了
strMSG = strMSG & vbCrLf '* １行改行
End Sub
'*==============================================================================*=============================*
'* カレンダー作成
'*==============================================================================*=============================*
'* Arg(1) : Input 年
'* Arg(2) : Input 月
'* Arg(3) : Input 日
'*==============================================================================*=============================*
Sub setCALEN()
'*--------------------------------------------------------------------------*-----------------------------*
'* カレンダー作成処理
'*--------------------------------------------------------------------------*-----------------------------*
Dim Sw '* カレンダー作成スイッチ
Dim j '* 日付
Dim i '* カレンダー作成ループカウンタ
Dim k '* 翌月カレンダー作成カウンタ
Sw = 0 '* カレンダー作成スイッチ初期化
i = 0 '* 日付初期化
j = 0 '* カレンダー作成カウンタ初期化
k = 0 '* 翌月カレンダーカウンタ初期化
'*--------------------------------------------------------------------------*-----------------------------*
'* カレンダー作成処理
'*--------------------------------------------------------------------------*-----------------------------*
'*----------------------------------------------------------------------*-----------------------------*
'* 見出し作成
'*----------------------------------------------------------------------*-----------------------------*
strMSG = strMSG & "--------------------" & vbCrLf '* 見出し１行目 区切り線
strMSG = strMSG & strEND & vbCrLf '* 見出し２行目 年月日
strMSG = strMSG & "--------------------" & vbCrLf '* 見出し３行目 区切り線
strMSG = strMSG & "日 月 火 水 木 金 土" & vbCrLf '* 見出し４行目 曜日
'*----------------------------------------------------------------------*-----------------------------*
'* 第１週目作成（ループ：１＝日から７＝土まで）
'*----------------------------------------------------------------------*-----------------------------*
Call clrCLN() '* カレンダーテーブル初期化
For i=1 To 7 Step 1 '* 第１週目曜日ループ
If i = strSWD Then '* １日の曜日判定
Sw = 1 '* 該当曜日の場合
End If '* 判定終了
if Sw = 1 Then '* 該当曜日に到達していたら
j=j+1 '* 日付を加算
CLN(i) = edit2NUM(j) '* ２桁変換
Else '* 到達していない場合
CLN(i) = "**" '* **マークを日に設定
End If '* 判定終了
Next '* ループ終了
Call prtCLN()
'*----------------------------------------------------------------------*-----------------------------*
'* 第２週目から６週目まで作成（ループ：１＝２週目から５＝６週目まで）
'*----------------------------------------------------------------------*-----------------------------*
For k=1 To 5
Call clrCLN()
For i=1 To 7 Step 1
If (strSMM = 1) or (strSMM = 3) or (strSMM = 5) or (strSMM = 7) or (strSMM = 8) or (strSMM = 10) or (strSMM = 12) Then
If j >= 31 Then
Sw = 0
End If
End If
If (strSMM = 4) or (strSMM = 6) or (strSMM = 9) or (strSMM = 11) Then
If j >= 30 Then
Sw = 0
End If
End If
If (strSMM = 2) Then
If j >= 29 Then
Sw = 0
End If
End If
if Sw = 1 Then
j=j+1
CLN(i) = edit2NUM(j)
Else
CLN(i) = "**"
End If
Next
Call prtCLN()
If Sw = 0 Then
Exit For
End If
Next
End Sub