VB电子台历代码课程设计.docx

VB电子台历代码课程设计.docx

《VB电子台历代码课程设计.docx》由会员分享，可在线阅读，更多相关《VB电子台历代码课程设计.docx（14页珍藏版）》请在冰点文库上搜索。

VB电子台历代码课程设计

'模块部分代码：

保存有各种函数声明段、对配置文件的操作以及部分常用变量和数组的定义

OptionExplicit

'窗体设置区域

PublicDeclareFunctionSetWindowRgnLib"user32"（ByValhWndAsLong,ByValhRgnAsLong,ByValbRedrawAsBoolean）AsLong

'SetWindowRgn函数声明段

PublicDeclareFunctionCreateRoundRectRgnLib"gdi32"（ByValX1AsLong,ByValY1AsLong,ByValX2AsLong,ByValY2AsLong,ByValX3AsLong,ByValY3AsLong）AsLong'CreateRoundRectRgn函数声明段

PublicDeclareFunctionGetSystemMetricsLib"user32"（ByValnIndexAsLong）AsLong'GetSystemMetrics函数声明段

PublicConstSM_CYCAPTION=4'标题栏高度

PublicConstSM_CYFRAME=33'上下边框高度

PublicConstSM_CXFRAME=32'左右边框宽度'配置文件操作

PublicDeclareFunctionWritePrivateProfileStringLib"kernel32"Alias"WritePrivateProfileStringA"（ByVallpApplicationNameAsString,ByVallpKeyNameAsAny,ByVallpStringAsAny,ByVallpFileNameAsString）AsLong

'WritePrivateProfileString函数声明段

PublicDeclareFunctionGetPrivateProfileStringLib"kernel32"Alias"GetPrivateProfileStringA"（ByVallpApplicationNameAsString,ByVallpKeyNameAsAny,ByVallpDefaultAsString,ByVallpReturnedStringAsString,ByValnSizeAsLong,ByVallpFileNameAsString）AsLong'GetPrivateProfileString函数声明段

PublicConstCALLEFTAsInteger=30

PublicConstCALTOPAsInteger=120

PublicConstCALHGRIDAsInteger=40

PublicConstCALVGRIDAsInteger=40

PublicSetColor（6）AsLong'定义颜色数组

PublicSetFont（4）AsString'定义字体数组

PublicCurYearAsInteger

PublicCurMonthAsInteger

PublicNotes（）AsString'定义记事内容为动态数组

PublicNotesdate（）AsString'定义记事日期为动态数组

PublicNotesnumAsInteger

PublicpicAsInteger

PublicFestivals（）AsString'定义节日动态数组

PublicFestivalsdate（）AsString'定义节日日期动态数组

PublicFestivalsnumAsInteger

PublicSubReadSet（）'读取配置文件

DimsAsString*100

DimiAsInteger

DimnAsInteger'读取颜色配置信息

Fori=1To6n=GetPrivateProfileString（"SetColor","颜色"&i,"0",s,15,App.Path&"\cal.set"）SetColor（i）=CLng（s）

Next

'读取字体配置信息

Fori=1To4n=GetPrivateProfileString（"SetFont","字体"&i,"0",s,15,App.Path&"\cal.set"）SetFont（i）=s

Next

'读取节日配置信息

i=1

Do

n=GetPrivateProfileString（"Festival","节日"&i,"",s,95,App.Path&"\cal.set"）Ifn=0ThenExitDo

s=Left（s,InStr（s,Chr（0））-1）Festivalsnum=Festivalsnum+1ReDimPreserveFestivals（Festivalsnum）ReDimPreserveFestivalsdate（Festivalsnum）n=InStr（s,":

"）

Festivalsdate（Festivalsnum）=Left（s,n-1）Festivals（Festivalsnum）=Right（s,Len（s）-n）i=i+1

Loop

'读取记事配置信息

i=1

Don=GetPrivateProfileString（"Note","记事"&i,"",s,95,App.Path&"\cal.set"）Ifn=0ThenExitDos=Left（s,InStr（s,Chr（0））-1）Notesnum=Notesnum+1ReDimPreserveNotes（Notesnum）

ReDimPreserveNotesdate（Notesnum）n=InStr（s,":

"）

Notesdate（Notesnum）=Left（s,n-1）Notes（Notesnum）=Right（s,Len（s）-n）i=i+1

Loop'读取背景图片配置信息n=GetPrivateProfileString（"Pic","图片","",s,5,App.Path&"\cal.set"）Ifn>0Then

i=CInt（Mid（s,2,1））Else

i=1EndIffrmMain.mnuPict（i-1）.Checked=TruefrmMain.Picture=LoadPicture（App.Path&"\pics\p"&i&".bmp"）

EndSub

'主窗体代码：

包括形成日历数据的自定义Sub过程、具体鼠标事件和用户对配置的修改及

配置文件的保存等

OptionExplicit

DimoldxAsInteger,oldyAsInteger

DiminmovingAsBoolean'inmoving用来判断鼠标左键按下或抬起，按下时值为True，抬

起时值为False

'自定义Sub过程

PublicSubShowCal（cYearAsInteger,cMonthAsInteger）

DimiAsInteger,jAsInteger

DimnAsInteger,mAsInteger

DimsAsString

DimrAsInteger,cAsInteger

j=lblCal1.Count

Fori=1Toj-1

UnloadlblCal1（i）

UnloadlblCal2（i）

Next

'显示标题****年**月lblYear1.Caption=cYear&"年"

lblYear2.Caption=cYear&"年"lblMonth1.Caption=cMonth&"月"lblMonth2.Caption=cMonth&"月"'设置标题字体和颜色lblYear1.ForeColor=SetColor（5）lblMonth2.ForeColor=SetColor（5）lblYear1.FontName=SetFont（3）lblYear2.FontName=SetFont（3）lblMonth1.FontName=SetFont（3）lblMonth2.FontName=SetFont（3）

'显示今日

lblDay1.Caption="今天是：

"&Year（Date）&"年"&Month（Date）&"月"&Day（Date）&"日"

lblDay2.Caption=lblDay1.Caption'设置今日字体和颜色lblDay2.ForeColor=SetColor（4）lblDay2.FontName=SetFont

（2）lblDay1.FontName=SetFont

（2）

'显示星期的标头

Fori=0To6

lblWeek1（i）.Left=CALLEFT+i*CALHGRID+1lblWeek2（i）.Left=CALLEFT+i*CALHGRIDlblWeek1（i）.Top=CALTOP-40+1lblWeek2（i）.Top=CALTOP-40lblWeek2（i）.ForeColor=SetColor（5）lblWeek2（i）.FontName=SetFont（3）lblWeek1（i）.FontName=SetFont（3）

Next

'显示日期n=Weekday（DateSerial（cYear,cMonth,1））m=DateDiff（"d",DateSerial（cYear,cMonth,1）,DateSerial（cYear,cMonth+1,1））Fori=1Tom-1

LoadlblCal2（i）

LoadlblCal1（i）

Ifi<9Thens=""&（i+1）Elses=（i+1）lblCal1（i）.Caption=slblCal2（i）.Caption=s

'设置颜色

'设置字体

'计算位置

Fori=0Tom-1

If（i+n-2）Mod7<5ThenlblCal2（i）.ForeColor=SetColor

（1）

ElseIf（i+n-2）Mod7=5ThenlblCal2（i）.ForeColor=SetColor

（2）

ElseIf（i+n-2）Mod7=6Then

lblCal2（i）.ForeColor=SetColor（3）

EndIflblCal1（i）.FontName=SetFont

（1）

lblCal2（i）.FontName=SetFont

（1）

Ifi=0Then

Ifn-2<0Then

c=6

r=0

Else

c=（i+n-2）Mod7

r=（i+n-2）\7

EndIf

Else

c=c+1

Ifc>6Then

c=0

r=r+1

EndIf

EndIflblCal1（i）.Left=CALLEFT+c*CALHGRIDlblCal2（i）.Left=CALLEFT+c*CALHGRID-1lblCal1（i）.Top=CALTOP+r*CALVGRIDlblCal2（i）.Top=CALTOP+r*CALVGRID-1

Ifi+1=Day（Date）AndCurYear=Year（Date）AndCurMonth=Month（Date）ThenlblCal2（i）.ForeColor=SetColor（4）

EndIflblCal1（i）.Visible=True

lblCal2（i）.Visible=True

EndSub

PrivateSubForm_Load（）

DimiAsInteger

CurYear=Year（Date）'读取系统年份

CurMonth=Month（Date）'读取系统月份

'载入星期标签，使用标签控件数组（两个标签同时显示以形成文字立体感）Fori=1To6

LoadlblWeek2（i）lblWeek2（i）.Visible=TrueLoadlblWeek1（i）lblWeek1（i）.Visible=True

Next

lblWeek1（0）.Caption="一"lblWeek2（0）.Caption="一"lblWeek1

（1）.Caption="二"lblWeek2

（1）.Caption="二"lblWeek1

（2）.Caption="三"lblWeek2

（2）.Caption="三"lblWeek1（3）.Caption="四"lblWeek2（3）.Caption="四"lblWeek1（4）.Caption="五"lblWeek2（4）.Caption="五"lblWeek1（5）.Caption="六"lblWeek2（5）.Caption="六"lblWeek1（6）.Caption="日"lblWeek2（6）.Caption="日"

lblNote1.Caption=""

lblNote2.Caption=""

lblNote2.Font=SetFont（4）

lblNote1.Font=SetFont（4）lblNote2.ForeColor=SetColor（6）

CallShowCal（CurYear,CurMonth）'调用Sub过程ShowCal（）

DimrgnAsLong

DimBorderWidthAsInteger,BorderHeightAsInteger

DimCaptionHeightAsInteger

BorderWidth=GetSystemMetrics（SM_CXFRAME）

BorderHeight=GetSystemMetrics（SM_CYFRAME）

CaptionHeight=GetSystemMetrics（SM_CYCAPTION）

rgn=CreateRoundRectRgn（0+BorderWidth,0+BorderHeight+CaptionHeight,570+BorderWidth,400+BorderHeight+CaptionHeight,100,100）'创建椭圆形区域

CallSetWindowRgn（Me.hWnd,rgn,True）'调用SetWindowRgn函数改变窗口形状

EndSub

'显示节日及记事

PrivateSublblCal2_Click（IndexAsInteger）DimiAsInteger,nAsIntegerDimsAsString,strAsString'读取节日s=CurMonth&"-"&（Index+1）Fori=1ToFestivalsnum

Ifs=Festivalsdate（i）Then

n=n+1str=Trim（str）&Chr（13）&Chr（10）&n&"：

"&Festivals（i）

EndIf

Next

'读取记事

s=CurYear&"-"&CurMonth&"-"&（Index+1）Fori=1ToNotesnum

Ifs=Notesdate（i）Then

n=n+1

str=Trim（str）&Chr（13）&Chr（10）&n&"：

"&Notes（i）EndIf

Next

'显示

IfTrim（str）<>""Then

str=CurYear&"-"&CurMonth&"-"&（Index+1）&str

str=Left（str,InStr（str,""））

Else

str=CurYear&"-"&CurMonth&"-"&（Index+1）&Chr（13）&Chr（10）&"无记事"

EndIf

lblNote2.Caption=str

lblNote1.Caption=str

EndSub

'鼠标事件设置

PrivateSubForm_MouseDown（ButtonAsInteger,ShiftAsInteger,XAsSingle,YAsSingle）'鼠标单击事件热点区域

IfButton=1Then

IfButton=1Theninmoving=True'左键按下inmoving值为True

oldx=Xoldy=Y

EndIf

EndIf'鼠标右击弹出弹出式菜单

IfButton=2Then

Me.PopupMenumnuFile

EndIf

EndSub

'鼠标双击左下角当天日期时刷新并立即显示当月日历

PrivateSublblDay2_DblClick（）

CurYear=Year（Date）

CurMonth=Month（Date）

CallShowCal（CurYear,CurMonth）lblNote1.Caption=""lblNote2.Caption=""

EndSub

'鼠标月份事件

PrivateSublblMonth2_MouseDown（ButtonAsInteger,ShiftAsInteger,XAsSingle,YAsSingle）

IfButton=1Then'鼠标单击左上角月份时月份增大

CurMonth=CurMonth+1

IfCurMonth=13ThenCurMonth=1:

CurYear=CurYear+1

Else'鼠标右击左上角月份时月份减小

CurMonth=CurMonth-1

IfCurMonth=0ThenCurMonth=12:

CurYear=CurYear-1EndIf

CallShowCal（CurYear,CurMonth）lblNote1.Caption=""lblNote2.Caption=""

EndSub

'鼠标年份事件

PrivateSublblYear1_MouseDown（ButtonAsInteger,ShiftAsInteger,XAsSingle,YAsSingle）IfButton=1Then'鼠标单击左上角年份时年份增大

CurYear=CurYear+1

Else'鼠标右击左上角年份时年份减小

CurYear=CurYear-1

EndIf

CallShowCal（CurYear,CurMonth）lblNote1.Caption=""lblNote2.Caption=""

EndSub

frmNote.Show1,Me

EndSub

PrivateSubmnuPict_Click（IndexAsInteger）'改变背景图片并修改配置设置

DimiAsIntegerFori=0To3

mnuPict（i）.Checked=False

NextmnuPict（Index）.Checked=Truepic=Index+1

Me.Picture=LoadPicture（App.Path&"\pics\p"&pic&".bmp"）

CallWritePrivateProfileString（"Pic","图片","p"&pic,App.Path&"\cal.set"）EndSub

PrivateSubmnuSetColor_Click（IndexAsInteger）'改变颜色并修改配置

OnErrorGoTol1CD.ShowColor

SetColor（Index+1）=CD.Color

CallShowCal（CurYear,CurMonth）lblNote2.ForeColor=SetColor（6）l1:

EndSub

PrivateSubmnuSetFont_Click（IndexAsInteger）'改变字体并修改配置

OnErrorGoTol1

CD.Flags=3

CD.ShowFont

SetFont（Index+1）=CD.FontName

CallShowCal（CurYear,CurMonth）lblNote2.Font=SetFont（4）lblNote1.Font=SetFont（4）

l1:

EndSub

'如果鼠标左键按下，移动鼠标时窗体随之移动

PrivateSubForm_MouseMove（ButtonAsInteger,ShiftAsInteger,XAsSingle,YAsSingle）IfinmovingThen

Me.Left=Me.Left+X-oldx

Me.Top=Me.Top+Y-oldy

EndIf

EndSub

PrivateSubForm_MouseUp（ButtonAsInteger,ShiftAsInteger,XAsSingle,YAsSingle）

inmoving=False