現在の用紙を1024*768と仮定して、下に帯状のカレンダーを作成します。作例は、1024*768で作業してから480*360にリサイズしたものです。
カレンダーは3行(3ヶ月分)で、実行した日の属する月が中央の行に16ptでその他の月は14ptで、日曜・祝日が赤、土曜が青、その他が黒で表示されます。
"CurrD.SaveAs"はコメントアウトしてありますが、この行を有効にすると指定したファイルネーム(フルパスで指定します。)でbmp形式でエクスポートを実行します。
当然ですが、春分の日、秋分の日はあらかじめ予測することが出来ませんので、適宜修正をして使用してください。
平成15年からのハッピーマンデー第二弾、海の日と敬老の日はコメントアウトで準備してあります。
Attribute VB_Name = "Main"
Sub MkCal()
Attribute MkCal.VB_Description = "カレンダー作成"
'Original Script
'2000/06/20 Ver 1.00
'2000/06/20 Ver 1.01 祝日判定
'2000/06/21 Ver 1.02 振り替え休日対応
'2000/06/21 Ver 1.03 可変サイズ
'2001/04/27 VBA Convert
'2001/05/02 more VBA
'2001/07/01 could save as file
'2001/11/17 HappyMonday
Dim DH As Long, DW As Long, DP As Long
Dim px As Long, py As Long, cx As Long, cy As Long
Dim TDa As Date, YTDa As Date
Dim ty As Long, tm As Long, td As Long, wd As Long, oy As Long, om As Long
Dim cm As Long, cyr As Long, fsr As Double
Dim dc As String, ds As Double
Dim CurrD As Document
Dim ppcs As Object
Set ppcs = PHOTOPAINT.CorelScript
Const ndp As Integer = 96
TDa = Date
om = month(TDa)
oy = year(TDa)
Set CurrD = ActiveDocument
DH = CurrD.SizeHeight
DW = CurrD.SizeWidth
DP = CurrD.DpiX
If CurrD.DpiY <> DP Then
Exit Sub
End If
CurrD.DpiX = ndp
CurrD.DpiY = ndp
CurrD.Resample DW, DH, True
fsr = DH / 768
CurrD.VirtualHeight = 768
CurrD.VirtualWidth = 1024
With ppcs
.RectangleTool 0, 50, 0, 0, True, True, True
.FillSolid 5, 0, 255, 0, 0
.Rectangle 0, 605, 1024, 730
.ObjectOpacity 50
.ObjectSelect 1, True
End With
For cy = 1 To 3
py = 600 + cy * 40
cm = om - 2 + cy
If cm > 12 Then
cyr = oy + 1
cm = cm - 12
ElseIf cm < 1 Then
cyr = oy - 1
cm = cm + 12
Else
cyr = oy
End If
PutStr 5, py - 20, CStr(cyr), "Arial Black", 8 * fsr, "y"
PutStr 5, py, ms(cm), "Arial Black", 16 * fsr, "r"
If cy = 2 Then
ds = 16
Else
ds = 14
End If
dc = "b"
For cx = 1 To 31
TDa = DateSerial(cyr, cm, cx)
If month(TDa) <> cm Then Exit For
YDa = TDa - 1
Select Case Weekday(TDa, vbSunday)
Case 1
dc = "r"
Case 2
If ish(YDa) = True Then
dc = "r"
Else
dc = "b"
End If
Case 7
dc = "bl"
Case Else
dc = "b"
End Select
If ish(TDa) = True Then
dc = "r"
End If
px = 40 + cx * 30
PutStr px, py, CStr(cx), "Arial Black", ds * fsr, dc
Next cx
Next cy
' CurrD.SaveAs "c:\windows\calendar.bmp", cdrBMP, True
Exit Sub
End Sub
Private Sub PutStr(x As Long, y As Long, ps As String, fn As String, fs As Double, fc As String)
With PHOTOPAINT.CorelScript
.TextTool x, y, False, True, 0
Select Case fc
Case "y"
.TextSetting "Fill", "255,255,0"
Case "r"
.TextSetting "Fill", "255,0,0"
Case "w"
.TextSetting "Fill", "255,255,255"
Case "bl"
.TextSetting "Fill", "0,0,255"
Case Else
.TextSetting "Fill", "0,0,0"
End Select
.TextSetting "Font", fn
.TextSetting "TypeSize", fs
.TextSetting "Justify", "1"
.TextSetting "InterCharSpacing", "0"
.TextSetting "InterLineSpacing", "1000000"
.TextSetting "Direction", "0"
.TextAppend ps
.TextRender
End With
End Sub
Private Function ms(cm As Long) As String
Select Case cm
Case 1
ms = "Jan."
Case 2
ms = "Feb."
Case 3
ms = "Mar."
Case 4
ms = "Apr."
Case 5
ms = "May"
Case 6
ms = "Jun."
Case 7
ms = "Jul."
Case 8
ms = "Aug."
Case 9
ms = "Sep."
Case 10
ms = "Oct."
Case 11
ms = "Nov."
Case 12
ms = "Dec."
End Select
End Function
Private Function ish(ByVal YDa As Date) As Boolean
'1月、10月は平成12年から
'7月、9月は平成15年から
Dim ty As Integer
Dim tm As Integer
Dim td As Integer
Dim wd As Integer
ty = year(YDa)
tm = month(YDa)
td = Day(YDa)
wd = Weekday(YDa, vbSunday)
ish = False
Select Case tm
Case 1
If td = 1 Then
ish = True
ElseIf td = HappyMonday(ty, tm, 2) Then
ish = True
End If
Case 2
If td = 11 Then
ish = True
End If
Case 3
'春分の日
If td = 20 Then
ish = True
End If
Case 4
If td = 29 Then
ish = True
End If
Case 5
If td > 2 And td < 6 Then
ish = True
End If
Case 7
' If td = HappyMonday(ty, tm, 3) Then
If td = 20 Then
ish = True
End If
Case 9
' If td = HappyMonday(ty, tm, 3) Then
If td = 15 Then
ish = True
'秋分の日
ElseIf td = 23 Then
ish = True
End If
Case 10
If td = HappyMonday(ty, tm, 2) Then
ish = True
End If
Case 11
If td = 3 Or td = 23 Then
ish = True
End If
Case 12
If td = 23 Then
ish = True
End If
End Select
End Function
Function HappyMonday(year As Integer, month As Integer, week As Integer) As Integer
Dim fdw As Integer, fdm As Date, fd As Date
fd = DateSerial(year, month, 1)
fdw = Weekday(fd, vbSunday)
fdm = fd - fdw + 2
If fdw > 2 Then
fdm = fdm + 7
End If
HappyMonday = Day(fdm + (week - 1) * 7)
End Function
ハッピーマンデー判定法について
ハッピーマンデー判定法について、2つのアイデアがあります。
- If td < 15 And td > 7 And wd = 2 Then
- If td = HappyMonday(ty, tm, 2) Then
前者は、第2月曜の取りうる日が分かっていることから、その期間の曜日を判定する方法です。後者は、ハッピーマンデーとなる日を直接求める関数を使用して判定する方法です。
とりうる日付と比較する方式はコードが簡単で良いのですが、第n月曜というのが変わるとちょっと考えないといけません。(実際ハッピーマンデー第一弾は第2月曜、第二弾は第3月曜です。)
その点ハッピーマンデー関数を使えば何も考えずに引数を変えるだけでOKです。処理の効率や速度のことを考えたら、処理の冒頭でハッピーマンデーとなる日を直接求めておいて、実際の描画の段階で予め求めておいた日と比較するのが一番良いと思いますが、たった3ヶ月分で、そう極端に遅いわけではないので、該当月は毎日ハッピーマンデー関数を呼び出すという一番単純な方式にしました。