再送大家一个礼物!!
来源:岁月联盟
时间:2003-07-11
calendar.vbs
<%
'*************************************************************************************************
'VBScript 日历 组件
'
'赋值:
' Mnth 日历月份
' Yr 日历年份
' FontSize 字体大小
' Columns 月份显示列数
' FontFace 字体样式
' FontColour 字体颜色
' FillColour 星期背景颜色
' BorderColour 边框颜色
' BackgroundColour 日历背景颜色
' FullYearLink 全年月份连接
'
'取值:
' MonthCal 月份表格
' YearCal 年份表格
'方法:
' LoadMonthArray 私有方法
'*************************************************************************************************
%>
<Script LANGUAGE=JavaScript>
//定义整个年份查看连接函数
function showyearcal(link, year) {
if (link.indexOf('?') > 0)
link = link + '&year=' + year
else
link = link + '?year=' + year
calwin=window.open( link, 'calwin', 'toolbar=yes, scrollbars=yes, status=yes, width=680, height=480' )
if (typeof(calwin.focus) != "undefined") {
calwin.focus()
}
}
//定义月份查看连接函数
function changemonth(moveby) {
document.calform.calmonth.value = document.calform.calmonth.value - 0 + moveby;
document.calform.submit();
}
function changeyear(moveby) {
document.calform.calyear.value = document.calform.calyear.value - 0 + moveby;
document.calform.submit();
}
</script>
<style>
td.day {font-family:arial;font-size:8pt;color:black}
</style>
<%
'定义日历类
class calendar
private M, Y, D, WeekNo, MonthArray, FSize, FFace, FColour, BorderCol, FillCol, BGCol, BigCol, SingleMonth, FYLink, Cols, cStyleSheet
'声明私有变量
property let Mnth(Month)
if Month >= 1 and Month <= 12 then
M = Month
end if
end property
'给月份赋值
property let Yr(Year)
if Year > 1 and Year < 9999 then
Y = Int(Year)
end if
end property
'给年份赋值
property let FontSize(FS)
if FS >= 1 and FS <= 7 then
FSize = FS
end if
end property
'给字体大小赋值
property let Columns(C)
select case C
case 1,2,3,4,6,12
Cols = C
case else
Cols = 4
end select
end property
'给月份行数赋值
property let FontFace(FF)
if FF <> "" then
FFace = FF
end if
end property
'给字体样式赋值
property let FontColour(FC)
if FC <> "" then
FColour = FC
end if
end property
'给字体颜色赋值
property let FillColour(FC)
if FC <> "" then
FillCol = FC
end if
end property
'给星期背景色赋值
property let BorderColour(BC)
if BC <> "" then
BorderCol = BC
end if
end property
'给边框颜色赋值
property let BackgroundColour(BGC)
if BGC <> "" then
BgCol = BGC
end if
end property
'给日历背景色赋值
property let FullYearLink(FYL) FYLink = FYL end property
'给全年连接赋值
property let StyleSheet(SS) cStyleSheet = SS end property
'给样式赋值
'初始化日历类
private Sub Class_Initialize
Mnth = Month(Now)
Yr = Year(Now) '给年份赋值
FFace = "arial" '给字体样式赋值
FSize = 2 '给字体大小赋值
FColour = "black" '给字体颜色赋值
BorderCol = "lightgrey" '给边框颜色赋值
FillCol = "#3399FF" '给星期背景颜色赋值
BgCol = "darkgray" '给日历背景颜色赋值
SingleMonth = true '确定为当前月
FYLink = "" '整个年份连接
Cols = 4 '整个年份中显示月份的列数
StyleSheet = false '是否使用样式
End Sub
'定义LoadMonthArray方法
private Sub LoadMonthArray
Dim Dte, FirstDayNo
Redim MonthArray(6,7)
for D = 1 to 31
Dte = DateSerial(Y,M,D)
if D = 1 then
FirstDayNo = Weekday(Dte)
end if
if M = Month(Dte) and D = Day(Dte) then
WeekNo = Abs( Int( ( ( FirstDayNo + D -1 ) /7 )*-1) )
MonthArray( Weekno, Weekday(Dte) ) = D
end if
next
end sub
'取得月份
property get MonthCal
dim HTML, FontStr, Colour, ColSpan
'定义HTML、字体样式、颜色和表格跨度
if Request.Form("calmonth") <> "" then
M = Int( Request.Form("calmonth") ) '取得传送来的月份
Y = Int( Request.Form("calyear") ) '取得传送来的年份
if M > 12 then
M = 1
Y = Y + 1
end if
if M < 1 then
M = 12
Y = Y -1
end if
end if
LoadMonthArray
FontStr = "<font face=""" & FFace & """ size=" & FSize & " color=" & FColour & ">"
HTML = "<table cellspacing=3 cellpadding=0 bgcolor=" & BgCol & " bordercolor=" & BorderCol & " border=1 width=""100%"">"
'使用HTML制作日历的显示表格
HTML = HTML & "<tr>"
if SingleMonth then
HTML = HTML & "<form name=calform method=post>"
HTML = HTML & "<td align=center>" & FontStr & "<a href=javascript:changemonth(-1)><</a></td>"
HTML = HTML & "<td align=center colspan=5>" & FontStr & MonthName(M)
if FYLink <> "" then
HTML = HTML & " <a href=javascript:showyearcal('" & Server.URLEncode(FYLink) & "',"& Y & ")>" & Y & "</a>"
else
HTML = HTML & " " & Y
end if
HTML = HTML & "</font></td>"
HTML = HTML & "<td align=center>" & FontStr & "<a href=javascript:changemonth(1)>></a></td>"
else
HTML = HTML & "<td align=center colspan=7>" & FontStr & MonthName(M) & "</td>"
end if
HTML = HTML & "</tr>"
for D = 1 to 7
HTML = HTML & "<th width=""14%"" bgcolor=" & FillCol & ">" & FontStr & Right(WeekdayName(d),1) & "</font></th>"
'Right(WeekdayName(d),1)为中文星期格式,可以显示简单格式和完全格式
'英文系统简单格式为:Left(WeekdayName(d),1)
'完全显示格式为:WeekdayName(d)
next
for WeekNo = 1 to 6
HTML = HTML & "<tr>"
for D = 1 to 7
HTML = HTML & "<td align=""center"" "
if cStyleSheet then
HTML = HTML & "class=day "
end if
if MonthArray(WeekNo,D) = "" then
MonthArray(WeekNo,D) = " "
else
if Date = DateSerial(Y,M,MonthArray(WeekNo,D)) then
HTML = HTML & "bgcolor=" & BorderCol
end if
end if
if not cStyleSheet then
HTML = HTML & ">" & FontStr & MonthArray(WeekNo,D) & "</font></td>"
else
HTML = HTML & ">" & MonthArray(WeekNo,D) & "</td>"
end if
if IsNumeric( MonthArray(WeekNo,D) ) then
if Date = DateSerial(Y,M,MonthArray(WeekNo,D)) then
FontStr = Replace( FontStr, BgCol, FColour )
end if
'将当前日期的背景显示为边框颜色
end if
next
HTML = HTML & "</tr>"
next
if SingleMonth then
HTML = HTML & "<input type=hidden name=calmonth value=" & M & "></input>"
HTML = HTML & "<input type=hidden name=calyear value=" & Y & "></input>"
'如果是当前月则通过隐藏的表单传送年份和月份
HTML = HTML & "</form>"
end if
HTML = HTML & "</table>"
MonthCal = HTML
end property
'取得年份
property get YearCal
Dim HTML, Col, Row, MonthSave, Rows
MonthSave = M
SingleMonth = false
if Request.Form("calyear") <> "" then
Yr = Request.Form("calyear")
end if
Rows = 12/Cols
'定义全年月份显示行数
HTML = HTML & "<table border=0><form name=calform method=post>"
HTML = HTML & "<tr><td align=center colspan=" & Cols & ">"
HTML = HTML & "<font face=""" & FFace & """ size=6 color=" & FColour & ">"
if not CStyleSheet then
HTML = HTML & "<a href=javascript:changeyear(-1)><</a> " & Y & " <a href=javascript:changeyear(1)>></a>"
else
HTML = HTML & Y
end if
HTML = HTML & "</font></td></tr>"
for Row = 1 to Rows
HTML = HTML & "<tr>"
for Col = 1 to Cols
Mnth = Col + ((Row -1) * Cols)
HTML = HTML & "<td>" & MonthCal & "</td>"
next
HTML = HTML & "</tr>"
next
HTML = HTML & "<input type=hidden name=calyear value=" & Y & "></input></form></table>"
'通过隐藏表单来提交年份
Mnth = MonthSave
YearCal = HTML
end property
end class
%>
test.asp
<%
option explicit
response.expires = 0
response.buffer = true
%>
<HTML>
<head>
<%
if Request.QueryString("mode") = "year" then
%>
<TITLE> Year Calendar </TITLE>
<%
else
%>
<TITLE> Month Calendar </TITLE>
<%
end if
%>
</head>
<body>
<center>
<table border=0 cellspacing=0 cellpadding=0>
<tr>
<td>
<%
dim cal
set cal = new calendar
if Request.QueryString("mode") = "year" then
cal.yr = Request.QueryString("year")
Response.Write( Cal.YearCal )
else
cal.FullYearLink = "test.asp?mode=year"
Response.Write( Cal.MonthCal )
end if
set cal = nothing
%> </td>
</tr>
</table>
</center>
</body>
</html>
<!-- #INCLUDE FILE="calendar.vbs" -->
这个程序本来是用来投稿的,但是没有使用,我还是把他公布出来,没有什么特殊的,就是对学习VBS的CLASS有帮助。程序我做了详细的说明,大家可以很容易看懂的。
过断时间还会有好东西公布出来的,请大家期待。最为期待的估计就是VB的仿Office XP风格的按钮控件代码了。不过特别的大。呵呵。
上一篇:一个漂亮的互动式下拉菜单!