查看單個文章
舊 2006-09-21, 08:01 AM   #44 (permalink)
psac
榮譽會員
 
psac 的頭像
榮譽勳章
UID - 3662
在線等級: 級別:30 | 在線時長:1048小時 | 升級還需:37小時級別:30 | 在線時長:1048小時 | 升級還需:37小時級別:30 | 在線時長:1048小時 | 升級還需:37小時級別:30 | 在線時長:1048小時 | 升級還需:37小時級別:30 | 在線時長:1048小時 | 升級還需:37小時
註冊日期: 2002-12-07
住址: 木柵市立動物園
文章: 17381
現金: 5253 金幣
資產: 33853 金幣
預設

2006 月曆(含農曆及自訂行事曆)
本範例可以製作出2006年1-12月的月曆(含農曆日期),例假日的部份已加入行政院公告2006年的休假日期,使用者還可以自行加入[自定假日]或[行事曆]。
http://vba.com.tw/VBAFILE/general/H0052.1.jpg

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
__________________
http://bbsimg.qianlong.com/upload/01/08/29/68/1082968_1136014649812.gif
psac 目前離線  
送花文章: 3, 收花文章: 1625 篇, 收花: 3196 次