目   录

摘  要
关键字
前  言
第一章 VB语言概述
1．1、VB简介  
1．2、VB语言的基本特点及VB应用程序的基本持点
1．3、为何我选择VB作为开发语言
1．4、VB6.0应用的基本开发方法
第二章 用VB开发多功能日历程序
2．1、本程序运行界面简介
2．2、本程序部分控件的设置
2．3、主程序部分代码
第三章 毕业设计总结
第四章 主要参考文献
附录

摘   要：
 在日常生活和工作中经常有人用到农历和公历的查询问题。因此，我借这次毕业设计之机，在辅导老师的指导下，编写了一个可以在VB6下正常运行的日历、计算器多功能应用程序，编程的思路是:先把公、农历的数据用数组查询设置好，再通过算法转换成具体应用。程序应用了不规则窗体技术，使得窗体比较美观。单击属相标志可以退出程序。单击时钟数字将返回到今天。单击查询控制面板开关将向下拉出查询控制面板。
.
关键字：农历公历转换及计算器、查询控制面板、VB6。
 
  
 
 
 多功能电子日历的开发
  
 前  言
 电脑已经成为挂在我们嘴角的一句口头禅，它已经深入到日常工作和生活的方方面面，比如文字处理、信息管理、辅助设计、图形图像处理、教育培训以及游戏娱乐等。Windows系统的推出使电脑从高雅的学术殿堂走入了寻常百姓家，各行各业的人们无须经过特别的训练就能够使用电脑完成许许多多复杂的工作。然而，虽然现在世界上已经充满了多如牛毛的各种软件，但它们依然不能满足用户的各种特殊需要，人们还不得不开发适合自己特殊需求的软件。以前开发Windows下软件是专业人员的工作，需要掌握许多专业知识和经过特殊的培训才能胜任。现在不同了，即使你没有接受过严格的程序设计训练，使用Visual Basic也一样能够开发出功能强大、适合自己特殊需求的应用程序了。Visual Basic继承了Basic语言易学易用的特点，特别适合于初学者学习Windows系统编程。
 我作为一名中央电大的学生，对从事计算机操作和编程工作有着特殊的爱好，在工作和学习之余，我时常钻研专业课基础理论，经常用VB搞一些小程序，在工作中经常有人问到农历和公历的查询问题。网页上有一些这方面的介绍，但是关于VB方面的编程资料却比较少。因此，借这次毕业设计之机，我编写了一个可以在VB6下正常运行的日历、计算器多功能应用程序，欢迎各位老师提出批评改进意见。
  
VB语言概述
 一、VB简介  
 VB是微软公司出品的一个快速可视化程序开发工具软件，借助微软在操作系统和办公软件的垄断地位，VB在短短的几年内风靡全球。VB是极有和功能强大的软件，主要表现在：所见即所得的界面设计，基于对象的设计方法，极短的软件开发周期，较易维护的生成代码。
    美国微软公司在1991年推出VB1.0至今已经经历了6个版本，VB6.0运行在win9x或winme，win2000，winxp，windowsNT等操作系统下，是一个32位的应用程序开发工具。
二、VB语言的基本特点及VB应用程序的基本持点
    VB程序语言具有许多优秀的特性,用其设计应用程序时有两个基本特点:可视化设计和事件驱动编程.
1、可视化设计
   同其他的一些可视化程序开发工具一样,VB具有可视化设计的特点,微软的Word在刚刚进入市场时,同WPS竞争的一个重要的功能砝码就是"所见即所得"的字处理功能,VB在设计应用程序界面时也可以说是"所见即所得".在设计时,头脑中所想象的应用程序界面,完全可以通过键盘鼠标以及徒手画出来,而不是编制大量的代码然后再编译生成,如果需要修改,也是利用键盘鼠标和手画,而底层的一些程序代码由VB自动生成或修改。
    VB为用户提供大量的界面元素(在VB中称为控件对象),这些控件对象对于熟悉Windows应用程序的用户而言是一点也不陌生,如"窗体"、"菜单"、"命令按钮"、"工具按钮"、"检查框"等等,用户只需要利用鼠标、键盘把这些控件对象拖动到适当的位置,设置它们的大小、形状、属性等,就可以设计出所需的应用程序界面。
2事件驱动编程
     Windows操作系统出现以来,图形化的用户界面和多任务多进程的应用程序要求程序设计不能是单一性的,在使用VB设计应用程序时,必须首先确定应用程序如何同用户进行交互.例如发生鼠标单击、键盘输入等事件时,由用户编写的代码控制这些事件的响应,这就是所谓的事件驱动编程。
    前面已经谈到,在VB中把窗体以及"菜单"、"按钮"等控件称为对象,如果设计出了应用程序,那么与应用程序的用户直接进行交互的就是这些对象组成的图形界面,也称为用户接口或用户界面,在设计应用程序时就必须考虑到用户如何与程序进行交户.更进一步,甚至程序和程序之间也会有通讯和交户,基本上用户是通过鼠标、键盘与应用程序进行交互的,这时那些对象就必须对鼠标和键盘操作所引发的事件做出响应.响应就是指执行一段应用程序,它不沿预定的路径执行,而是在响应不同事件时执行不同的代码.因此,应用程序代码的路径在每次响应而执行时可能都是不形同的。     
三、为何选择VB作为开发语言
      除了VB之外,当前能够编制Windows应用程序的可视化编程工具还有很多,所针对的编程领域也各有侧重,就微软系列的可视化开发工具而言,就有VB,VisualC++,VisualJ++,Visual Foxpro等,其中Visual Foxpro是针对数据库编程的开发工具;Visual  C++是为专业程序设计员提供的开发工具,变量声明和定义严密,功能强大灵活,必须经过相当的努力才能掌握;而VB不支持虚类、多态性和类的继承,相对而言VB简单易学,变量定义不太严密,对于非专业程序员而言功能足够强大,同Visual  C++一样也支持网络编程和数据库编程。
    除了微软之外,其他公司也在为Windows操作系统平台制作应用程序开发工具,例如前Borland的公司出品的Delphi,C++Bulider, J++Bulider等,其他一些公司出品的针对数据库编程的PowerBulider, PowerDesigner等,不可否认,这些产品相当出色,如果能够熟练掌握将是编程者能力的体现,但是必须承认,对Windows操作系统最熟悉的还是微软,而且微软本身Windows操作系统的源代码采取不公开的策略,使得其他公司出品的产品在实现相同功能时多少都要走些弯路,用户在使用这些产品设计应用程序时,程序的效率将会受到影响。
    在选择所需要的应用程序开发工具时,不但要考虑开发工具的功能是否强大,还要考虑所花费的时间和效果,单纯地追求功能的强大,也许会事倍功半。
    中央电大陈明主编的《Visual Basic程序设计》是计算机应用专业采用的一本难得的教材,使我受益匪浅。通过这门课程的学习，我已能用VB编写简单的程序，为了搞好这次毕业设计，我决定使用VB作为编程语言。
  四、VB6.0应用的基本开发方法
 1、交互式开发
    传统的应用程序开发过程可以分为三个明显的步骤:编码、编译和测试。但是VB与传统的语言不同,它使用交互式方法开发应用程序,使三个步骤之间不再有明显的界限。
    在大多数语言里,如果编写代码时发生了错误,则在开始编译应用程序时该错误就会被编译器捕获。此时必须查找并改正该错误,然后再次进行编译,对每一个发现的错误都要重复这样的过程。VB在编程者输入代码时便进行解释,即时捕获并突出显示大多数语法或拼写错误。看起来就像一位专家在监视代码的输入。
     除即时捕获错误以外,VB也在输入代码时部分地编译该代码。当准备运行和测试应用程序时,只需极短时间即可完成编译。如果编译器发现了错误、则将错误突出显示于代码中。这时可以更正错误并继续编译、而不需从头开始。
    由于VB的交互特性,因此在开发应用程序时,系统频繁地运行着应用程序。通过这种方式,代码运行的效果可以在开发时进行测试,而不必等到编译完成以后。
           
 第二章    用VB开发多功能日历程序
 一、本程序运行界面简介
 编程的主导思想是:先把公、农历的数据用数组查询设置好，再通过算法转换成具体应用。程序的运行界面见图1，
 
 
 
 
 
                                  图1
 程序应用了不规则窗体技术，使得窗体比较美观。单击属相标志可以退出程序。单击时钟数字将返回到今天。单击计算器面板开关将向下拉出计算器面板,单击查询控制面板开关将向下拉出查询控制面板,见图2。
 
                                 图2
二、本程序部分控件的设置
 

 
 
三、主程序部分代码：
Option Explicit
'***************************************
'拖动无标题窗体
Const HTCAPTION = 2
Const WM_NCLBUTTONDOWN = &HA1
Private Declare Function ReleaseCapture Lib "user32" () As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Long) As Long
'=============================================================================
Private Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function SetWindowRgn Lib "user32" (ByVal hwnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
Private Declare Function GetBitmapBits Lib "gdi32" (ByVal hBitmap As Long, ByVal dwCount As Long, lpBits As Any) As Long
Private Type BITMAP
    bmType As Long
    bmWidth As Long
    bmHeight As Long
    bmWidthBytes As Long
    bmPlanes As Integer
    bmBitsPixel As Integer
    bmBits As Long
End Type
Private Const RGN_OR = 2
Dim bmByte() As Byte
'***************************************
'滚动字幕
Private Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hdc As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
Private Declare Function GetTickCount Lib "kernel32" () As Long
Const DT_BOTTOM As Long = &H8
Const DT_CALCRECT As Long = &H400
Const DT_CENTER As Long = &H1
Const DT_EXPANDTABS As Long = &H40
Const DT_EXTERNALLEADING As Long = &H200
Const DT_LEFT As Long = &H0
Const DT_NOCLIP As Long = &H100
Const DT_NOPREFIX As Long = &H800
Const DT_RIGHT As Long = &H2
Const DT_SINGLELINE As Long = &H20
Const DT_TABSTOP As Long = &H80
Const DT_TOP As Long = &H0
Const DT_VCENTER As Long = &H4
Const DT_WORDBREAK As Long = &H10
Private Type RECT
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
End Type
Const ScrollText As String = "1901-2049" & vbCrLf & _
                               "多功能电子日历 "
'***********************************************
Dim EndingFlag As Boolean, jS As Integer
Dim e As String
Dim f As String
Dim g As Double
Dim S_mem As Double
Dim op As String
Dim chk As Integer
Const Pi = 3.14159265358979
Private Const SWP_NOMOVE = 2
Private Const SWP_NOSIZE = 1
Private Const FLAGS = SWP_NOMOVE Or SWP_NOSIZE
Private Const HWND_TOPMOST = -1
Private Const HWND_NOTOPMOST = -2
Dim flAge As Boolean, color_index As Integer, tiAo As Boolean, jiSuan As Boolean
Dim s_mem_B As Boolean, tip As Integer, ziShi As String
'**************************************************
   '数字按下、松开
Private Sub cmdNum_MouseDown(Index As Integer, Button As Integer, Shift As Integer, x As Single, y As Single)
   Show_b Picture5, P8, cmdNum(Index)
End Sub
Private Sub cmdNum_MouseUp(Index As Integer, Button As Integer, Shift As Integer, x As Single, y As Single)
   Show_b Picture5, P9, cmdNum(Index)
End Sub
'**************************************************
   '角度、弧度
Private Sub cmdOp_1_Click(Index As Integer)
  MPl.Play
 Select Case Index
   Case 0
     If g = 1 Then
        If op = "" Then
            e = Str((Val(e) * 180 / Pi))
            txtDisp.Text = e
        Else
            f = Str((Val(e) * 180 / Pi))
            txtDisp.Text = f
        End If
        chk = 1
        g = Pi / 180
     End If
        ShowNumARG Pt, wPw1(3), 19
   Case 1
     If g <> 1 Then
        If op = "" Then
            e = Str((Val(e) * Pi / 180))
            txtDisp.Text = e
        Else
            f = Str((Val(e) * Pi / 180))
            txtDisp.Text = f
        End If
        chk = 1
        g = 1
     End If
        ShowNumARG Pt, wPw1(3), 20
   Case 2
'        g = 1
        ShowNumARG Pt, wPw1(3), 21
   End Select
End Sub
Private Sub cmdOp_1_MouseUp(Index As Integer, Button As Integer, Shift As Integer, x As Single, y As Single)
   Show_b Picture5, P9, cmdOp_1(Index)
End Sub
Private Sub cmdOp_1_MouseDown(Index As Integer, Button As Integer, Shift As Integer, x As Single, y As Single)
   Show_b Picture5, P8, cmdOp_1(Index)
End Sub
'**************************************************
   '单一功能键按下、松开
Private Sub cmdops_MouseDown(Index As Integer, Button As Integer, Shift As Integer, x As Single, y As Single)
   Show_b Picture5, P8, cmdOps(Index)
End Sub
Private Sub cmdops_MouseUp(Index As Integer, Button As Integer, Shift As Integer, x As Single, y As Single)
   Show_b Picture5, P9, cmdOps(Index)
End Sub
'**************************************************
   '单一功能键按下、松开
Private Sub cmdOps_Click(Index As Integer)
 Dim sum As Double, i As Integer
On Error GoTo eh1
 MPl.Play
 Select Case Index
   Case 0
        e = Str(Sqr(Val(e)))
        ShowNumFun Pt, wPw1(3), 10
        Ji_suan
   Case 1
      If e <> 0 Then
        e = -Val(txtDisp)
      Else
        e = 0
      End If
        Ji_suan
   Case 2
        e = Str(Sin(Val(e) * g))
        ShowNumFun Pt, wPw1(3), Index - 1
        Ji_suan
   Case 3
        e = Str(Cos(Val(e) * g))
        ShowNumFun Pt, wPw1(3), Index - 1
        Ji_suan
   Case 4
        e = Str(Tan(Val(e) * g))
        ShowNumFun Pt, wPw1(3), Index - 1
        Ji_suan
   Case 5
        e = Str(Atn(Val(e)))
        ShowNumFun Pt, wPw1(3), Index - 1
        Ji_suan
   Case 6
        e = Str(1 / Sin(Val(e) * g))
        ShowNumFun Pt, wPw1(3), Index - 1
        Ji_suan
   Case 7
        e = Str(1 / Cos(Val(e) * g))
        ShowNumFun Pt, wPw1(3), Index - 1
        Ji_suan
   Case 8
        e = Str(Exp(Val(e)))
        ShowNumFun Pt, wPw1(3), Index - 1
        Ji_suan
   Case 9
        e = Str(Log(Val(e)))
        ShowNumFun Pt, wPw1(3), Index - 1
        Ji_suan
   Case 10
        Randomize
        If op = "" Then
          e = Str(9999999999# * Rnd)
            txtDisp.Text = e
          f = ""
        Else
          f = Str(99999999 * Rnd)
            txtDisp.Text = f
        End If
           ShowNumFun Pt, wPw1(3), Index - 1
   Case 11
        e = Str(1 / Val(e))
        Ji_suan
  *** 第11-23种情况略****
  Case 24
      If s_mem_B = False Then
            If op = "" Then
              e = Str(S_mem)
                txtDisp.Text = e
              f = ""
            Else
              f = Str(S_mem)
                txtDisp.Text = f
            End If
            s_mem_B = True
       Else
            S_mem = 0
            s_mem_B = False
       End If
 End Select
Exit Sub
eh1:
txtDisp.Text = "-E-"
e = ""
f = ""
op = ""
End Sub
Private Sub cmdAC_Click()
     MPl.Play
         g = 1
        ShowNumFun Pt, wPw2(3), 1
        ShowNumARG Pt, wPw1(3), 20
     e = ""
     f = ""
     op = ""
    txtDisp.Text = "0"
End Sub
Private Sub cmdAC_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
   Show_b Picture5, P8, cmdAC
End Sub
Private Sub cmdAC_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
   Show_b Picture5, P9, cmdAC
End Sub
Private Sub cmdEq_Click()
     MPl.Play
    If op = "" Then
        e = Str(-(Val(e)))
        txtDisp.Text = e
    Else
        f = Str(-(Val(e)))
        txtDisp.Text = f
    End If
    chk = 1
End Sub
Private Sub cmdEq_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
   Show_b Picture5, P8, cmdEq
End Sub
Private Sub cmdEq_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
   Show_b Picture5, P9, cmdEq
End Sub
Private Sub cmdNum_Click(Index As Integer)
    On Error GoTo eh2
      MPl.Play
    If chk = 1 Then
        e = ""
        f = ""
        op = ""
        chk = 0
    End If
    If op = "" Then
        e = e & Trim(Str(Index))
        txtDisp.Text = e
    Else
        f = f & Trim(Str(Index))
        txtDisp.Text = f
    End If
    Exit Sub
eh2:
    txtDisp.Text = "-E-"
    e = ""
    f = ""
    op = ""
End Sub
Private Sub cmdOp_MouseDown(Index As Integer, Button As Integer, Shift As Integer, x As Single, y As Single)
   Show_b Picture5, P8, cmdOp(Index)
End Sub
Private Sub cmdOp_MouseUp(Index As Integer, Button As Integer, Shift As Integer, x As Single, y As Single)
   Show_b Picture5, P9, cmdOp(Index)
End Sub
Private Sub cmdOp_Click(Index As Integer)
    On Error GoTo eh3
       op_Sub
        txtDisp.Text = e
        op = ""
        chk = 0
    Select Case Index
        Case 0
            op = "+"
        Case 1
            op = "-"
        Case 2
            op = "*"
        Case 3
            op = "/"
        Case 4
            op = "^"
    End Select
    Exit Sub
eh3:
    txtDisp.Text = "-E-"
    e = ""
    f = ""
    op = ""
End Sub
Private Sub cmdPi_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
   Show_b Picture5, P8, cmdPi
End Sub
Private Sub cmdPi_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
   Show_b Picture5, P9, cmdPi
End Sub
Private Sub cmdPi_Click()
     MPl.Play
    If op = "" Then
        e = "3.141592654"
        txtDisp.Text = e
    Else
        f = "3.141592654"
        txtDisp.Text = f
    End If
End Sub
Private Sub cmdPM_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
   Show_b Picture5, P8, cmdPM
End Sub
Private Sub cmdPM_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
   Show_b Picture5, P9, cmdPM
End Sub
Private Sub cmdPM_Click()
    On Error GoTo eh1
    op_Sub
    txtDisp.Text = e
    op = ""
    chk = 1
    Exit Sub
eh1:
    txtDisp.Text = "-E-"
    e = ""
    f = ""
    op = ""
End Sub
Private Sub cmdPt_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
   Show_b Picture5, P8, cmdPt
End Sub
Private Sub cmdPt_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
   Show_b Picture5, P9, cmdPt
End Sub
Private Sub cmdPt_Click()
 MPl.Play
If op = "" Then
    e = e & "."
    txtDisp.Text = e
Else
    f = f & "."
    txtDisp.Text = f
End If
End Sub
Private Sub cmdT_Click()
    '显示查询面板
    If tiAo Then
        Timer4.Enabled = False
        Timer3.Enabled = True
    Else
        Timer4.Enabled = True
        Timer3.Enabled = False
    End If
     Label4.Enabled = False
     Picture4.Visible = True
     Picture5.Visible = False
End Sub

Private Sub Label4_Click()
   Pt.Visible = True
   cmdT.Enabled = False
   Picture5.Visible = True
   Picture4.Visible = False
    If jiSuan Then
        Timer6.Enabled = True
        Timer5.Enabled = False
        Timer1.Enabled = True
        Timer8.Enabled = False
    Else
        Timer6.Enabled = False
        Timer5.Enabled = True
        Timer8.Enabled = True
        Timer1.Enabled = False
    End If
   Picture5.SetFocus
End Sub
'单击返回今天
Private Sub C_clock_Click()
  Text1.Text = Year(Date)
  Text2.Text = Month(Date)
  Text3.Text = Day(Date)
    txt_Sub
    disPlay (Date)
End Sub
Private Sub Form_Activate()
    RunMain picScroll
End Sub
Private Sub Form_Load()
'===============================================
    Dim t As Single, rtn
    Form1.Height = 2715
    Form1.Width = 5400
     rtn = SetWindowPos(Form1.hwnd, -1, 0, 0, 0, 0, FLAGS)
     tip = 1
    t = Timer
    If Me.Picture <> 0 Then Call SetAutoRgn(Me)
    tiAo = False
    jiSuan = False
'-----------------------------------------------
    Picture4.Visible = False
    Picture5.Visible = False
'---------------------------------------
'计算器变量初始化
    s_mem_B = False
    S_mem = 0
    chk = 0
    e = ""
    f = ""
    op = ""
    txtDisp.Text = "0"
    g = 1
    ShowNumFun Pt, wPw2(3), 1
    ShowNumARG Pt, wPw1(3), 20
'-----------------------------------------
  fhSec3 = 0
  color_index = 1
  jS = 0
  picScroll.ForeColor = vbRed
  picScroll.FontSize = 8
  Picture2.Visible = False
  color1 = 1
  flAge = False
  shxing
'=========================================
  Text1.Text = Year(Date)
  Text2.Text = Month(Date)
  Text3.Text = Day(Date)
        txt_Sub
        disPlay (Date)
End Sub
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    If Button = 1 Then
           Dim ReturnVal As Long
           x = ReleaseCapture()
           ReturnVal = SendMessage(hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0)
    End If
End Sub
Private Sub Gz_Click()
    End
End Sub
Private Sub picScroll_Click()
   Picture2.Visible = True
       RunMain Picture2
End Sub
Private Sub Picture1_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    If Button = 1 Then
           Dim ReturnVal As Long
           x = ReleaseCapture()
           ReturnVal = SendMessage(hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0)
    End If

End Sub
Private Sub Picture2_Click()
  Picture2.Visible = False
      RunMain picScroll
End Sub
Private Sub Picture4_Click()
   Timer3.Enabled = True
   Timer4.Enabled = False
End Sub
Private Sub Picture5_Click()
  Pt.Visible = False
  Timer6.Enabled = True
  Timer5.Enabled = False
  Timer1.Enabled = True
  Timer8.Enabled = False
End Sub
Private Sub Picture5_KeyPress(KeyAscii As Integer)
  Select Case KeyAscii
    Case 13
        cmdPM_Click
    Case 48, 49, 50, 51, 52, 53, 54, 55, 56, 57
        cmdNum_Click (KeyAscii - 48)
    Case 46
        cmdPt_Click
    Case 42
        cmdOp_Click (2)
    Case 43
        cmdOp_Click (0)
    Case 45
        cmdOp_Click (1)
    Case 47
        cmdOp_Click (3)
    Case Else
         KeyAscii = 0
  End Select
 End Sub
Private Sub Picture8_Click()
  Picture8.Visible = False
End Sub
Private Sub Pt_Click()
  Timer6.Enabled = True
  Timer5.Enabled = False
  Pt.Visible = False
  Timer1.Enabled = True
  Timer8.Enabled = False
End Sub
Private Sub Text1_Change()
    txt_Sub
    s_Disp
End Sub
Private Sub Text2_Change()
        txt_Sub
        If (Val(Text3.Text) > UpDown3.Max) Then
           Text3.Text = Str(UpDown3.Max)
        End If
        s_Disp
End Sub
Private Sub Text3_Change()
      s_Disp
End Sub
Private Sub Timer1_Timer()
   Dim textTime As String, h As Integer, m As Integer, s As Integer
   Dim hh As String, mm As String, ss As String, zIs As Integer
        fhHour = Hour(Now)
        fhMin = Minute(Now)
        fhSec = Second(Now)
        If (fhHour Mod 2) = 1 Then
          zIs = (fhHour + 1) / 2
        Else
          If fhHour = 0 Then
            zIs = 12
          Else
            zIs = fhHour / 2
          End If
        End If
    G_z.Caption = ziShi + Zhi(zIs - 1) + "时"
    If (fhHour < 10) Then
        fhHour1 = 0
        fhHour2 = fhHour
    Else
        fhHour1 = Int(fhHour / 10)
        fhHour2 = fhHour - fhHour1 * 10
    End If

    If (fhMin < 10) Then
        fhMin1 = 0
        fhMin2 = fhMin
    Else
        fhMin1 = Int(fhMin / 10)
        fhMin2 = fhMin - fhMin1 * 10
    End If
    If (fhSec < 10) Then
        fhSec1 = 0
        fhSec2 = fhSec
    Else
        fhSec1 = Int(fhSec / 10)
        fhSec2 = fhSec - fhSec1 * 10
    End If
        ShowNum wPw1(color_index), C_clock, fhHour1, color1, 1
        ShowNum wPw1(color_index), C_clock, fhHour2, color1, 2
        ShowNum wPw1(color_index), C_clock, fhMin1, color1, 4
        ShowNum wPw1(color_index), C_clock, fhMin2, color1, 5
        ShowNumS wPw2(color_index), SecP, fhSec1 + 1, color1, 2
        ShowNumS wPw2(color_index), SecP, fhSec2 + 1, color1, 3
        ShowNum wPw1(color_index), C_clock, 10, color1, 3
    If flAge = True Then
        ShowNumS wPw2(color_index), SecP, 0, color1, 1
        flAge = False
     Else
        ShowNumS wPw2(color_index), SecP, 11, color1, 1
        flAge = True
     End If
End Sub
Private Sub Timer2_Timer()
 Dim fhsec4, fhsec5
    If (fhSec3 < 10) Then
        fhsec4 = 0
        fhsec5 = fhSec3
    Else
        fhsec4 = Int(fhSec3 / 10)
        fhsec5 = fhSec3 - fhsec4 * 10
    End If
       ShowNumS wPw2(color_index), mSecP, fhsec4 + 1, color1, 1
        ShowNumS wPw2(color_index), mSecP, fhsec5 + 1, color1, 2
    If fhSec3 > 99 Then
       fhSec3 = 0
    Else
       fhSec3 = fhSec3 + 1
    End If
End Sub
Private Sub Timer8_Timer()
    Dim ss
    L1.X1 = 234 + 5 * Sin(6 * Second(Now) * Pi / 180)
    L1.Y1 = 21 - 5 * Cos(6 * Second(Now) * Pi / 180)
    L1.X2 = 234 + 18 * Sin(6 * Second(Now) * Pi / 180)
    L1.Y2 = 21 - 18 * Cos(6 * Second(Now) * Pi / 180)
    L2.X1 = 234 - 2 * Sin(6 * Minute(Time) * Pi / 180)
    L2.Y1 = 21 + 2 * Cos(6 * Minute(Time) * Pi / 180)
    L2.X2 = 234 + 15 * Sin(6 * Minute(Time) * Pi / 180)
    L2.Y2 = 21 - 15 * Cos(6 * Minute(Time) * Pi / 180)
    ss = Hour(Time)
    If ss > 12 Then ss = ss - 12
    L3.X1 = 234 - 2 * Sin(ss * 30 * Pi / 180 + Minute(Time) / 2 * Pi / 180)
    L3.Y1 = 21 + 2 * Cos(ss * 30 * Pi / 180 + Minute(Time) / 2 * Pi / 180)
    L3.X2 = 234 + 11 * Sin(ss * 30 * Pi / 180 + Minute(Time) / 2 * Pi / 180)
    L3.Y2 = 21 - 11 * Cos(ss * 30 * Pi / 180 + Minute(Time) / 2 * Pi / 180)
End Sub
Public Sub disPlay(kDay As Date)
  Dim mY1 As Integer, mY2 As Integer, dY1 As Integer, dY2 As Integer, wY As Integer
  Dim temP As String, temP1 As Integer, temP2 As String, temP3 As String, temP4 As String, temP5 As String
   ShowNum wPw1(color_index), G_y, Val(Mid(Trim(Str(Year(kDay))), 1, 1)), 1, 1
    ShowNum wPw1(color_index), G_y, Val(Mid(Trim(Str(Year(kDay))), 2, 1)), 1, 2
    ShowNum wPw1(color_index), G_y, Val(Mid(Trim(Str(Year(kDay))), 3, 1)), 1, 3
    ShowNum wPw1(color_index), G_y, Val(Mid(Trim(Str(Year(kDay))), 4, 1)), 1, 4
        If Month(kDay) < 10 Then
           mY1 = 0
           mY2 = Month(kDay)
        Else
           mY1 = Int(Month(kDay) / 10)
           mY2 = Int(Month(kDay) Mod 10)
        End If
        ShowNum wPw1(color_index), G_m, mY1, color1, 1
        ShowNum wPw1(color_index), G_m, mY2, 1, 2
        If Day(kDay) < 10 Then
           dY1 = 0
           dY2 = Day(kDay)
        Else
           dY1 = Int(Day(kDay) / 10)
           dY2 = Int(Day(kDay) Mod 10)
        End If
        ShowNum wPw1(color_index), G_d, dY1, 1, 1
        ShowNum wPw1(color_index), G_d, dY2, 1, 2
        Gl_j.Caption = "今日是:" + ssFtv(Month(kDay), Day(kDay))
        J_q.Caption = seaSonYx(kDay)
'----------------------------------------------------------------------
    temP = sdayF(Year(kDay), Month(kDay), Day(kDay))
    Ljf.Caption = seaSonYxr(kDay)
    temP1 = Val(Trim(Mid(temP, 1, 4)))
    temP2 = Trim(Mid(temP, 10, 2))
    temP3 = Trim(Mid(temP, 20, 2))
    temP4 = Trim(Mid(temP, 9, 1))
    temP5 = Trim(Mid(temP, 17, 3))
      If temP5 = "Big" Then
         temP5 = "大 "
      Else
         temP5 = "小 "
      End If
      If temP4 = "Y" Then
         ziShi = yTGDZ(temP1) + "年 润" + nStr1(Val(temP2)) + "月" + temP5 + sdayF_gzr(kDay) + "日 "
      Else
        ziShi = yTGDZ(temP1) + "年 " + sdayF_gzm(temP1, Val(temP2)) + "月" + temP5 + sdayF_gzr(kDay) + "日 "
      End If
        ShowNum wPw1(color_index), N_y, Val(Mid(Trim(Str(temP1)), 1, 1)), 1, 1
        ShowNum wPw1(color_index), N_y, Val(Mid(Trim(Str(temP1)), 2, 1)), 1, 2
        ShowNum wPw1(color_index), N_y, Val(Mid(Trim(Str(temP1)), 3, 1)), 1, 3
        ShowNum wPw1(color_index), N_y, Val(Mid(Trim(Str(temP1)), 4, 1)), 1, 4
        ShowNumGz wPw1(6), Gz, ((temP1 - 1900) Mod 12), 1, 1
    mY1 = Val(Left(temP2, 1))
    mY2 = Val(Right(temP2, 1))
        ShowNum wPw1(color_index), N_m, mY1, color1, 1
        ShowNum wPw1(color_index), N_m, mY2, 1, 2
    dY1 = Val(Left(temP3, 1))
    dY2 = Val(Right(temP3, 1))
        ShowNum wPw1(color_index), N_d, dY1, 1, 1
        ShowNum wPw1(color_index), N_d, dY2, 1, 2
     Nl_j.Caption = "今日是:" + llFtv(Val(temP2), Val(temP3))
     Label2.Caption = Str(Len(Trim(temP))) + "" + Str(LenB(Trim(temP))) + " " + temP + vbCrLf + Str(temP1) + " " + Str(temP2) + " " + Str(temP3)
'---------------------------------------------------------------------------
        wY = Weekday(kDay)
        Select Case wY
               Case 2, 3, 4, 5, 6, 7
                 ShowNumW wPw1(0), Week_p, wY - 1, 1, 1
                 ShowNumWs wPw1(2), wWeekP, wY - 2
               Case 1
                 ShowNumW wPw1(0), Week_p, 0, 1, 1
                 ShowNumWs wPw1(2), wWeekP, 6
        End Select
End Sub
Private Sub RunMain(picScroll As PictureBox)
'    滚动字幕
    Dim LastFrameTime As Long
    Const IntervalTime As Long = 40
    Dim rt As Long
    Dim DrawingRect As RECT
    Dim UpperX As Long, UpperY As Long 'Upper left point of drawing rect
    Dim RectHeight As Long
    Form1.Refresh
    rt = DrawText(picScroll.hdc, ScrollText, -1, DrawingRect, DT_CALCRECT)
    If rt = 0 Then 'err
        MsgBox "Error scrolling text", vbExclamation
        EndingFlag = True
    Else
        DrawingRect.Top = picScroll.ScaleHeight
        DrawingRect.Left = 0
        DrawingRect.Right = picScroll.ScaleWidth
        RectHeight = DrawingRect.Bottom
        DrawingRect.Bottom = DrawingRect.Bottom + picScroll.ScaleHeight
    End If
    Do While Not EndingFlag
        If GetTickCount() - LastFrameTime > IntervalTime Then
            picScroll.Cls
            DrawText picScroll.hdc, ScrollText, -1, DrawingRect, DT_CENTER   'Or DT_WORDBREAKDT_SINGLELINE And
            DrawingRect.Top = DrawingRect.Top - 1
            DrawingRect.Bottom = DrawingRect.Bottom - 1
            If DrawingRect.Top < -(RectHeight) Then 'time to reset
                DrawingRect.Top = picScroll.ScaleHeight
                DrawingRect.Bottom = RectHeight + picScroll.ScaleHeight
            End If
            picScroll.Refresh
            LastFrameTime = GetTickCount()
        End If
        DoEvents
    Loop
End Sub
Private Sub Timer3_Timer()
    Dim hei As Integer
    tiAo = False
    Form1.Height = Form1.Height - 50
    hei = ScaleY(Form1.Height, vbTwips, vbPixels) - Picture4.Height ', vbTwips, vbPixels)
    Picture4.Top = hei - 2 ' Picture4.Top + 1
If Form1.Height < 2745 Then
    Timer3.Enabled = False
    Label4.Enabled = True
    cmdT.Enabled = True
 End If
End Sub
Private Sub Timer4_Timer()
    Dim hei, w, h
    tiAo = True
 If Form1.Height > 5065 Then
    Timer4.Enabled = False
 Else
   Form1.Height = Form1.Height + 50
    hei = ScaleY(Form1.Height, vbTwips, vbPixels) - Picture4.Height ', vbTwips, vbPixels)
    Picture4.Top = hei  ' Picture4.Top + 1
 End If
End Sub
Private Sub Timer5_Timer()
    Dim hei, w, h
    jiSuan = True
 If Form1.Height >= 6225 Then
    Timer5.Enabled = False
    hei = Int(ScaleY(Form1.Height, vbTwips, vbPixels)) - Picture5.Height ', vbTwips, vbPixels)
    Label3.Caption = Str(Picture5.Height) & Str(ScaleY(Form1.Height, vbTwips, vbPixels)) & " " & Str(hei)
    Picture5.Top = hei '- 70 ' Picture4.Top + 1
Else
    Form1.Height = Form1.Height + 50
    hei = Int(ScaleY(Form1.Height, vbTwips, vbPixels)) - Picture5.Height ', vbTwips, vbPixels)
    Label3.Caption = Str(Picture5.Height) & Str(ScaleY(Form1.Height, vbTwips, vbPixels)) & " " & Str(hei)
    Picture5.Top = hei '- 70 ' Picture4.Top + 1
End If
End Sub
Private Sub Timer6_Timer()
    Dim hei
   Pt.Visible = False
  jiSuan = False
    Form1.Height = Form1.Height - 50
    hei = Int(ScaleY(Form1.Height, vbTwips, vbPixels) - Picture5.Height) ', vbTwips, vbPixels))
   Label3.Caption = Str(Picture5.Height) & Str(ScaleY(Form1.Height, vbTwips, vbPixels)) & " " & Str(hei)
  Picture5.Top = hei '- 70
If Form1.Height < 2745 Then
    Timer6.Enabled = False
    Label4.Enabled = True
    cmdT.Enabled = True
 End If
End Sub
Private Sub Timer7_Timer()
  If S_mem <> 0 Then
   ShowNumSam wPw2(1), Pt, 16, 1, -1
  Else
   ShowNumSam wPw2(1), Pt, 17, 1, -1
  End If
If tip > 0 Then
tip = tip + 1
End If
If tip > 2 Then
  frmTip.Show
  tip = -1
End If
End Sub
Private Sub txtDisp_Change()
  Dim deLc As String, i As Integer, kL As Integer
 
  For i = 24 To 14 Step -1
         If (i - 23 + Len(Trim(txtDisp.Text))) > 0 Then
           deLc = Mid(txtDisp.Text, i - 23 + Len(Trim(txtDisp.Text)), 1)
           Label3.Caption = Str(Len(Trim(txtDisp.Text)))
         Else
           deLc = ""
         End If
     Select Case deLc
       Case "1", "2", "3", "4", "5", "6", "7", "8", "9", "0"
            kL = Val(deLc)
               ShowNumC2 wPw1(1), Pt, kL, 1, i - 9
       Case "."
               ShowNumC2 wPw1(1), Pt, 11, 1, i - 9
       Case "E"
               ShowNumC2 wPw1(1), Pt, 13, 1, i - 9
       Case "+"
               ShowNumC2 wPw1(1), Pt, 14, 1, i - 9
       Case "-"
               ShowNumC2 wPw1(1), Pt, 15, 1, i - 9
       Case Else
               ShowNumC2 wPw1(1), Pt, 12, 1, i - 9
     End Select
  Next i
  For i = 13 To 1 Step -1
         If (i - 23 + Len(Trim(txtDisp.Text))) > 0 Then
           deLc = Mid(txtDisp.Text, i - 23 + Len(Trim(txtDisp.Text)), 1)
           Label3.Caption = Str(Len(Trim(txtDisp.Text)))
         Else
           deLc = " "
         End If
     Select Case deLc
       Case "1", "2", "3", "4", "5", "6", "7", "8", "9", "0"
            kL = Val(deLc)
               ShowNumC wPw1(1), Pt, kL, 1, i
       Case "."
               ShowNumC wPw1(1), Pt, 11, 1, i
       Case "E"
               ShowNumC wPw1(1), Pt, 13, 1, i
       Case "+"
               ShowNumC wPw1(1), Pt, 14, 1, i
       Case "-"
               ShowNumC wPw1(1), Pt, 15, 1, i
       Case Else
               ShowNumC wPw1(1), Pt, 12, 1, i
     End Select
  Next i
  '小字符显示
  For i = 24 To 1 Step -1
         If (i - 23 + Len(Trim(txtDisp.Text))) > 0 Then
           deLc = Mid(txtDisp.Text, i - 23 + Len(Trim(txtDisp.Text)), 1)
           Label3.Caption = Str(Len(Trim(txtDisp.Text)))
         Else
           deLc = " "
         End If
     Select Case deLc
       Case "1", "2", "3", "4", "5", "6", "7", "8", "9", "0"
            kL = Val(deLc)
               ShowNumSam wPw2(1), Pt, kL + 1, 1, i
       Case "."
               ShowNumSam wPw2(1), Pt, 14, 1, i
       Case "E"
               ShowNumSam wPw2(1), Pt, 12, 1, i
       Case "+"
               ShowNumSam wPw2(1), Pt, 13, 1, i
       Case "-"
               ShowNumSam wPw2(1), Pt, 15, 1, i
       Case Else
               ShowNumSam wPw2(1), Pt, 0, 1, i
     End Select
  Next i
End Sub
Public Sub SetAutoRgn(hForm As Form, Optional transColor As Byte = vbNull)
    Dim x As Long, y As Long
    Dim Rgn1 As Long, Rgn2 As Long
    Dim SPos As Long, EPos As Long
    Dim bm As BITMAP
    Dim hbm As Long
    Dim Wid As Long, Hgt As Long
    '获取窗体背景图片尺寸
    hbm = hForm.Picture
    GetObjectAPI hbm, Len(bm), bm
    Wid = bm.bmWidth ' ScaleX(Picture2.Width, vbTwips, vbPixels)
    Hgt = bm.bmHeight ' ScaleY(Picture2.Height, vbTwips, vbPixels)
    ReDim bmByte(1 To Wid, 1 To Hgt)
    GetBitmapBits hForm.Picture, Wid * Hgt, bmByte(1, 1) '获取图像数组
    If transColor = vbNull Then transColor = bmByte(1, 1)
    Rgn1 = CreateRectRgn(0, 0, 0, 0)
    For y = 1 To Hgt '逐行扫描
        x = 0
        Do
            x = x + 1
            While (bmByte(x, y) = transColor) And (x < Wid)
                x = x + 1 '跳过透明色的点
            Wend
            SPos = x
            While (bmByte(x, y) <> transColor) And (x < Wid)
                x = x + 1 '跳过不是透明色的点
            Wend
            EPos = x - 1
            '这一段是合并区域
            If SPos <= EPos Then
                Rgn2 = CreateRectRgn(SPos - 1, y - 1, EPos, y)
                CombineRgn Rgn1, Rgn1, Rgn2, RGN_OR
                DeleteObject Rgn2
            End If
        Loop Until x >= Wid
    Next y
    SetWindowRgn hForm.hwnd, Rgn1, True '设定窗体形状区域
    DeleteObject Rgn1
End Sub
Public Sub Ji_suan()
        f = ""
        txtDisp.Text = e
        op = ""
        chk = 1
End Sub
Public Sub txt_Sub()
       Select Case Val(Text2.Text)
         Case 1, 3, 5, 7, 8, 10, 12
            UpDown3.Max = 31
         Case 4, 6, 9, 11
            UpDown3.Max = 30
         Case 2
            If ((Val(Text1.Text) Mod 4) = 0) And ((Val(Text1.Text) Mod 100) <> 0) Or ((Val(Text1.Text) Mod 400) = 0) Then
                UpDown3.Max = 29
            Else
                UpDown3.Max = 28
            End If
       End Select
End Sub
Public Sub s_Disp()
  Dim kDay1 As Date, skDay1 As String
  Text4.Text = sdayF(Val(Text1.Text), Val(Text2.Text), Val(Text3.Text))
    skDay1 = Text1.Text + "," + Text2.Text + "," + Text3.Text
    kDay1 = skDay1
    disPlay (kDay1)
End Sub

Public Sub op_Sub()
     MPl.Play
    Select Case op
        Case "+"
            e = Str(Val(e) + Val(f))
            f = ""
        Case "-"
            e = Str(Val(e) - Val(f))
            f = ""
        Case "*"
            e = Str(Val(e) * Val(f))
            f = ""
        Case "/"
            e = Str(Val(e) / Val(f))
            f = ""
        Case "^"
            e = Str(Val(e) ^ Val(f))
            f = ""
    End Select
End Sub

二、提示信息模块相关代码：
Option Explicit
Private Const SWP_NOMOVE = 2
Private Const SWP_NOSIZE = 1
Private Const FLAGS = SWP_NOMOVE Or SWP_NOSIZE
Private Const HWND_TOPMOST = -1
Private Const HWND_NOTOPMOST = -2
Const HTCAPTION = 2
Const WM_NCLBUTTONDOWN = &HA1
Private Declare Function ReleaseCapture Lib "user32" () As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Long) As Long
' 内存中的提示数据库。
Dim Tips As New Collection
' 提示文件名称
Const TIP_FILE = "TIPOFDAY.TXT"
' 当前正在显示的提示集合的索引。
Dim CurrentTip As Long
Private Sub DoNextTip()
  If Op1.Value = 1 Then
    ' 随机选择一条提示。
    CurrentTip = Int((Tips.Count * Rnd) + 1)
  Else
    ' 或者，您可以按顺序遍历提示
   CurrentTip = CurrentTip + 1
    If Tips.Count < CurrentTip Then
        CurrentTip = 1
    End If
  End If
    ' 显示它。
    frmTip.DisplayCurrentTip
  End Sub
Function LoadTips(sFile As String) As Boolean
    Dim NextTip As String   ' 从文件中读出的每条提示。
    Dim InFile As Integer   ' 文件的描述符。
     ' 包含下一个自由文件描述符。
    InFile = FreeFile
    ' 确定为指定文件。
    If sFile = "" Then
        LoadTips = False
        Exit Function
    End If   
    ' 在打开前确保文件存在。
    If Dir(sFile) = "" Then
        LoadTips = False
        Exit Function
    End If
     ' 从文本文件中读取集合。
    Open sFile For Input As InFile
    While Not EOF(InFile)
        Line Input #InFile, NextTip
        Tips.Add NextTip
    Wend
    Close InFile
    ' 随机显示一条提示。
    DoNextTip
    LoadTips = True
    End Function
Private Sub chkLoadTipsAtStartup_Click()
    ' 保存在下次启动时是否显示此窗体
    SaveSetting App.EXEName, "Options", "在启动时显示提示", 1
End Sub
Private Sub cmdNextTip_Click()
    DoNextTip
End Sub
Private Sub cmdOK_Click()
    Unload Me
End Sub
Private Sub Form_Load()
    Dim ShowAtStartup As Long, rtn
   frmTip.Height = 4530
   frmTip.Width = 4515
     rtn = SetWindowPos(frmTip.hwnd, -1, 0, 0, 0, 0, 3)
    ' 察看在启动时是否将被显示
    ShowAtStartup = GetSetting(App.EXEName, "Options", "在启动时显示提示", 1)
    If ShowAtStartup = 0 Then
        Unload Me
        Exit Sub
    End If
     ' 设置复选框，强行将值写回到注册表
    'Me.chkLoadTipsAtStartup.Value = vbChecked
      ' 随机寻找
    Randomize
     ' 读取提示文件并且随机显示一条提示。
  If LoadTips(App.Path & "\" & TIP_FILE) = False Then
    blTipText.Text = "文件 " & TIP_FILE & " 没有被找到吗? " & vbCrLf & vbCrLf & _
           "创建文本文件名为 " & TIP_FILE & " 使用记事本每行写一条提示。 " & _
           "然后将它存放在应用程序所在的目录 "
    End If
End Sub
Private Sub Picture3_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    If Button = 1 Then
           Dim ReturnVal As Long
           x = ReleaseCapture()
           ReturnVal = SendMessage(hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0)
    End If
End Sub
Public Sub DisplayCurrentTip()
    If Tips.Count > 0 Then
        lblTipText.Text = Tips.Item(CurrentTip)
    End If
End Sub
                    
  第三章    毕业设计总结
    历时近两个月的毕业设计终于快到了尾声，通过这次毕业设计，在老师的指导下，我初步掌握了用VB开发软件的方法，使我意识到在开发一个应用软件的同时，搞好准备工作的重要性，特别是各种素材的准备，尤其是对数据结构算法要心中有数。感谢中央电大**分校的指导老师对我的悉心指导与帮助。由于时间仓促，这个软件还很不完善，比如农历的转换我还没能设计成功，计算器功能也有错误。这些有待我以后继续完善。

                        第四章  主要参考文献
1、《数据结构（c++描述）》  中央电大出版  2000年12月第1版   徐孝凯主编
2、《Visual Basic 程序设计》中央电大出版 2000年12月第1版   陈明  主编
3、《Visual Basic 程序设计》清华大学出版 2002年7月第1版    李大友主编
4、《Visual Basic开发人员指南》机械工业出版社 1999年1月  EricBrierley主编
5、《Visual Basic6.0实效编程百例》人民邮电出版社 2002年7月 刘韬、骆娟主编

相关论文