如果將 NowDate = Date 改為 NowDate = DateSerial(某年, 某月, 某日) 會得到某年某月某日的月曆
以下是用VB寫的在表單載入的時候會在即時運算視窗印出月曆
語法:
Private Sub Form_Load()
Dim NowDate As Date, L_Date As Date, N_Date As Date
Dim NowYear As Integer, NowMonth As Integer, NowDay As Integer
NowDate = Date '取得目前的日期資訊
NowYear = year(NowDate) '取出年份
NowMonth = Month(NowDate) '取出月份
NowDay = Day(NowDate) '取出日
L_Date = getLFirstDate(NowYear, NowMonth) '傳入目前的年月取得上個月的第一天
N_Date = getNFirstDate(NowYear, NowMonth) '傳入目前的年月取得下個月的第一天
Debug.Print CalendarTable(L_Date) '印出上個月的月曆
Debug.Print CalendarTable(DateSerial(NowYear, NowMonth, 1)) '印出這個月的月曆
Debug.Print CalendarTable(N_Date) '印出下個月的月曆
End Sub
Private Function CalendarTable(MonthFirstDay As Date) As String '產生月曆的表單
Dim DayAmount As Integer, DayOfWeek As VbDayOfWeek
Dim C_Year As Integer, C_Month As Integer, C_Day As Integer
Dim i As Integer
Dim TableBuff As String
C_Year = year(MonthFirstDay) '取得月曆年份
C_Month = Month(MonthFirstDay) '取得月曆月份
C_Day = 1 '設定起始日期為 1 日
Rem 月曆表頭
TableBuff = " ---------------------------- " & vbCrLf
TableBuff = TableBuff & "| 西元 " & C_Year & " 年 "
If C_Month < 10 Then TableBuff = TableBuff & " "
TableBuff = TableBuff & C_Month & " 月 |" & vbCrLf
TableBuff = TableBuff & " ---------------------------- " & vbCrLf
TableBuff = TableBuff & "| 日 一 二 三 四 五 六 |" & vbCrLf
TableBuff = TableBuff & " ---------------------------- " & vbCrLf
TableBuff = TableBuff & "|"
DayOfWeek = Weekday(MonthFirstDay) '取得此月第一天為星期幾
Rem 填充上一月份的空白日期
i = vbSunday
While i < DayOfWeek
TableBuff = TableBuff & " "
i = i + 1
Wend
DayAmount = getDayAmount(C_Year, C_Month) '取得此月份的日期數
Rem 將表單填入全部日期
While (C_Day <= DayAmount)
If DayOfWeek = vbSunday Then TableBuff = TableBuff & "|" '每星期行的最前面加上 | 當外框
If C_Day < 10 Then TableBuff = TableBuff & " " '當日期小於10時最前面填充一個空白
TableBuff = TableBuff & " " & C_Day & " " '填入日期
C_Day = C_Day + 1
DayOfWeek = DayOfWeek + 1
Rem 每星期行的結尾加上 | 當外框
If DayOfWeek > vbSaturday Then
DayOfWeek = vbSunday
TableBuff = TableBuff & "|" & vbCrLf
End If
Wend
Rem 填充下一月份的空白日期
If DayOfWeek > vbSunday Then '當最後一天不為星期六時填充至星期六
For i = DayOfWeek To vbSaturday
TableBuff = TableBuff & " "
Next
TableBuff = TableBuff & "|" & vbCrLf '加上最後的外框
End If
TableBuff = TableBuff & " ---------------------------- " & vbCrLf '加上底框
Rem 回傳產生的表單
CalendarTable = TableBuff
End Function
Private Function getLFirstDate(NowYear As Integer, NowMonth As Integer) As Date '取得上個月第一天的日期
Dim L_Year As Integer, L_Month As Integer
L_Year = NowYear '年份設為與這個月同年
L_Month = NowMonth - 1 '月份設為這個月減一個月
Rem 當月份為上一年的時候要調整月份為 12 月且年份要減 1
If L_Month < 1 Then
L_Month = 12
L_Year = L_Year - 1
End If
getLFirstDate = DateSerial(L_Year, L_Month, 1)
End Function
Private Function getNFirstDate(NowYear As Integer, NowMonth As Integer) As Date '取得下個月第一天的日期
Dim N_Year As Integer, N_Month As Integer
N_Year = NowYear '年份設為與這個月同年
N_Month = NowMonth + 1 '月份設為這個月加一個月
Rem 當月份為下一年的時候要調整月份為 1 月且年份要加 1
If N_Month > 12 Then
N_Month = 1
N_Year = N_Year + 1
End If
getNFirstDate = DateSerial(N_Year, N_Month, 1)
End Function
Private Function getDayAmount(YearVal As Integer, MonthVal As Integer) As Integer '取得某年某月的天數
If MonthVal = 2 Then
getDayAmount = 28 + ((((YearVal Mod 4) = 0) And ((YearVal Mod 100) <> 0)) Or ((YearVal Mod 400) = 0) And &H1) '月份為 2 檢查是否為閏年並做調整
Else
getDayAmount = 30 + ((((MonthVal And &H1) = &H1) Xor (MonthVal > 7)) And &H1) '不為 2 月則天數在 7 月前奇數月為 31 天，在 7 月後偶數月為 31 天
End If
End Function
輸出結果大概像下面那樣
語法:
----------------------------
| 西元 2007 年 1 月 |
----------------------------
| 日 一 二 三 四 五 六 |
----------------------------
| 1 2 3 4 5 6 |
| 7 8 9 10 11 12 13 |
| 14 15 16 17 18 19 20 |
| 21 22 23 24 25 26 27 |
| 28 29 30 31 |
----------------------------
----------------------------
| 西元 2007 年 2 月 |
----------------------------
| 日 一 二 三 四 五 六 |
----------------------------
| 1 2 3 |
| 4 5 6 7 8 9 10 |
| 11 12 13 14 15 16 17 |
| 18 19 20 21 22 23 24 |
| 25 26 27 28 |
----------------------------
----------------------------
| 西元 2007 年 3 月 |
----------------------------
| 日 一 二 三 四 五 六 |
----------------------------
| 1 2 3 |
| 4 5 6 7 8 9 10 |
| 11 12 13 14 15 16 17 |
| 18 19 20 21 22 23 24 |
| 25 26 27 28 29 30 31 |
----------------------------