2006 月曆(含農曆及自訂行事曆)
本範例可以製作出2006年1-12月的月曆(含農曆日期)，例假日的部份已加入行政院公告2006年的休假日期，使用者還可以自行加入[自定假日]或[行事曆]。
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
--------------------------------------------------------------------------------
Sub CreateCalendar()
Dim NewBookName As String
Dim Schedsht As Worksheet, Calensht As Worksheet
Dim CurrentYear As Integer
Dim i As Integer, rmonth As Integer
Dim DateRange As Range, rng As Range
Dim UserSheets As Integer
Dim rdate As Date
Dim DcPct As Double
Application.ScreenUpdating = False
Set Schedsht = ThisWorkbook.Sheets("Schedule")
Set Calensht = ThisWorkbook.Sheets("CalendarSheet")
Schedsht.Visible = xlSheetVisible
CurrentYear = 2006 '2006 年月曆
UserSheets = Application.SheetsInNewWorkbook
Application.SheetsInNewWorkbook = 1
Workbooks.Add
Application.SheetsInNewWorkbook = UserSheets
NewBookName = ActiveWorkbook.Name
Calensht.Range("m") = CurrentYear
PctForm.Show 0
For rmonth = 1 To 12
Calensht.Range("m") = rmonth
rdate = DateSerial(2006, rmonth, 1)
Schedsht.Range("A1").Value = "2006" & " " & _
Application.WorksheetFunction.Text(rdate, "m""月""") & _
" " & ChineCalenderA(rdate)
'第一個日期為星期日時使用 DateNumbers4 表格
If Weekday(rdate) = 1 Then
Set DateRange = Calensht.Range("DateNumbers4")
Else
Set DateRange = Calensht.Range("DateNumbers2")
End If
For i = 1 To 42
'國曆日期
Schedsht.DrawingObjects("DateB" & Format(i, "00")).Characters.Text = _
Format(DateRange.Cells(i).Value, "d")
Schedsht.DrawingObjects("DateB" & Format(i, "00")).Font.ColorIndex = 5
'農曆日期
Schedsht.DrawingObjects("Date" & Format(i, "00")).Characters.Text = _
ChineCalender(DateRange.Cells(i))
Schedsht.DrawingObjects("Date" & Format(i, "00")).Font.ColorIndex = 0
If Month(DateRange.Cells(i).Value) rmonth Then
'非當月日期字型灰色
Schedsht.DrawingObjects("Date" & Format(i, "00")).Font.ColorIndex = 15
Schedsht.DrawingObjects("DateB" & Format(i, "00")).Font.ColorIndex = 15
End If
'國定假日或自訂假日
With Schedsht.Shapes("DateB" & Format(i, "00")).TopLeftCell
If Weekday(DateRange.Cells(i).Value) = 1 Or _
Weekday(DateRange.Cells(i).Value) = 7 Then
.Interior.ColorIndex = 35
Else
.Interior.ColorIndex = xlNo
End If
'取得行政院公告假日的 Row
r = drow(1, CDate(DateRange.Cells(i)))
If r > 0 Then
.Interior.ColorIndex = 35
'在日期方塊中加入假日名稱
Schedsht.DrawingObjects("DateB" & Format(i, "00")).Characters.Text = _
ThisWorkbook.Sheets("holiday").Cells(r, 2) & _
" " & Format(DateRange.Cells(i).Value, "d")
End If
'取得自訂備忘錄的 Row
r = drow(3, CDate(DateRange.Cells(i)))
If r > 0 Then
.Font.ColorIndex = 3
.Font.Size = 12
'在儲存格中寫入備忘錄事項
.Value = ThisWorkbook.Sheets("holiday").Cells(r, 4)
Else
'先清空儲存格
.Value = ""
.Font.ColorIndex = 0
.Font.Size = 12
End If
End With
'更新進度條
PctForm.Label1 = "製作" & rmonth & "月份月曆中..."
'進度百分比
DcPct = (((rmonth - 1) * 42 + i) / (12 * 42)) * 100
Call UpdateProgress(DcPct) '更新進度條百分比
Next i
Schedsht.Protect DrawingObjects:=True, Contents:=False, Scenarios:=False
Schedsht.Copy After:=Workbooks(NewBookName).Sheets( _
Workbooks(NewBookName).Sheets.Count)
Schedsht.Unprotect
ActiveSheet.Name = rmonth & " " & 2006
Next rmonth
'關閉進度條
Sleep 500
Unload PctForm
Application.DisplayAlerts = False
'刪除第一張工作表
Workbooks(NewBookName).Sheets(1).Delete
Workbooks(NewBookName).Sheets(1).Activate
Application.DisplayAlerts = True
Schedsht.Visible = xlSheetHidden
Application.ScreenUpdating = True
End Sub
--------------------------------------------------------------------------------
Function drow(col As Integer, rdate As Date) As Integer
Dim c As Range
With ThisWorkbook.Sheets("holiday")
Set c = .Columns(col).Find(rdate, LookIn:=xlValues, LookAt:=xlWhole)
If Not c Is Nothing Then
drow = c.Row
Else
drow = 0
End If
End With
End Function
--------------------------------------------------------------------------------
Sub UpdateProgress(Pct)
With PctForm
Dim sngHeigh As Double
Dim sngOffset As Double
Dim intUnit As Double
Dim intTen As Double
Dim intHundred As Double
DoEvents
'百分比超過100的處裡
If Pct 100 >= 1 Then
intHundred = Pct 100
Pct = Pct - (100 * intHundred)
End If
'百分比超過十的處裡
If Pct 10 >= 1 Then
intTen = Pct 10
Pct = Pct - (10 * intTen)
End If
intUnit = Pct
sngOffset = -(.imgUnits.Height / 12) * 1
'如果起時數不是從0開始,以下sngHeight就會起作用
sngHeight = ((.imgUnits.Height / 12) * 10) / 10
'個位數
.imgUnits.Top = sngOffset - (sngHeight * intUnit)
'十位數
.imgTens.Top = sngOffset - (sngHeight * (intTen + (intUnit / 10)))
'百位數
.imgHundreds.Top = sngOffset - (sngHeight * _
(intHundred + (intTen / 10) + (intUnit / 100)))
End With
End Sub
農曆年函數因為資料過大不列出，請參考:
http://www.vba.com.tw/plog/post/1/43
目前農曆年含數只支援到2010年，所以無法做到萬年曆
等我有時間再加到 2050年吧!
修改了程式碼，可以自己輸入要輸出的年份
檔案請下載
http://www.vba.com.tw/file/H0052-1.rar