frmnewwork.frm

本人用VB 6.0和ACCESS编写的水费管理系统

VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Object = "{86CF1D34-0C5F-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCT2.OCX"
Begin VB.Form frmNewWork 
   Caption         =   "新建工作期"
   ClientHeight    =   4230
   ClientLeft      =   3165
   ClientTop       =   1965
   ClientWidth     =   5385
   Icon            =   "frmNewWork.frx":0000
   LinkTopic       =   "Form1"
   LockControls    =   -1  'True
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   4230
   ScaleWidth      =   5385
   Begin VB.CommandButton cmdUpdateData 
      Caption         =   "更新数据库(&D)"
      Height          =   375
      Left            =   2825
      TabIndex        =   5
      Top             =   3720
      Width           =   1335
   End
   Begin VB.CommandButton cmdUpdateSystem 
      Caption         =   "更新系统库(&S)"
      Height          =   375
      Left            =   1225
      TabIndex        =   4
      Top             =   3720
      Width           =   1335
   End
   Begin MSComctlLib.ProgressBar ProgressBar 
      Height          =   375
      Left            =   405
      TabIndex        =   2
      Top             =   3120
      Visible         =   0   'False
      Width           =   4575
      _ExtentX        =   8070
      _ExtentY        =   661
      _Version        =   393216
      Appearance      =   1
   End
   Begin VB.CommandButton cmdCancel 
      Cancel          =   -1  'True
      Caption         =   "取消(&C)"
      Height          =   375
      Left            =   4425
      TabIndex        =   6
      Top             =   3720
      Width           =   855
   End
   Begin VB.CommandButton cmdOK 
      Caption         =   "确定(&O)"
      Default         =   -1  'True
      Height          =   375
      Left            =   105
      TabIndex        =   3
      Top             =   3720
      Width           =   855
   End
   Begin MSComCtl2.MonthView MonthView 
      Height          =   2220
      Left            =   360
      TabIndex        =   1
      Top             =   600
      Width           =   4635
      _ExtentX        =   8176
      _ExtentY        =   3916
      _Version        =   393216
      ForeColor       =   -2147483630
      BackColor       =   -2147483633
      Appearance      =   1
      ShowWeekNumbers =   -1  'True
      StartOfWeek     =   24510465
      CurrentDate     =   37397
   End
   Begin VB.Label Label1 
      Caption         =   "注意：单击日历选定日期，双击日历相当于选定日期后再点击确定！"
      Height          =   345
      Left            =   1320
      TabIndex        =   0
      Top             =   120
      Width           =   2760
   End
End
Attribute VB_Name = "frmNewWork"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim db As Database, rs As Recordset, tb As TableDef, fld As Field, idx As Index
Dim db2 As Database, rs2 As Recordset
Dim fso As New FileSystemObject
Dim strName(21) As String, strType(21) As Long, strSize(21) As Long
Const Max = 21

Private Sub cmdCancel_Click()
    Unload Me
End Sub

Private Sub cmdOK_Click()
    '判断是否存在该数据库
    Dim strNewName As String
    strNewName = App.Path & "\Main" & Year(Now) & Month(Now) & ".mdb"
    If fso.FileExists(strNewName) Then
        Dim intQuestion As Integer
        intQuestion = MsgBox("本月数据库已经存在,是否要覆盖它?", vbQuestion + vbYesNo, "新建工作期")
        If intQuestion = vbYes Then
            Kill strNewName
        Else
            Exit Sub
        End If
    End If
    '创建新数据库
    ProgressBar.Visible = True
    Set db = Workspaces(0).CreateDatabase(strNewName, dbLangGeneral, dbVersion30)
    Set tb = db.CreateTableDef("主库文件")
    Dim i As Integer
    For i = 1 To Max
        ProgressBar.Value = 100 / Max * i
        Set fld = tb.CreateField()
        With fld
            .Name = strName(i)
            .Type = strType(i)
            .Size = strSize(i)
            '这个仅用于 text
            If .Type = dbText Then .AllowZeroLength = True
        End With
        tb.Fields.Append fld
        tb.Fields.Refresh
    Next
    '添加编号索引
    Set idx = tb.CreateIndex("编号")
    idx.Primary = True
    Set fld = idx.CreateField("编号")
    idx.Fields.Append fld
    tb.Indexes.Append idx
    '添加发票号索引
    Set idx = tb.CreateIndex("发票号")
    idx.Unique = True
    idx.IgnoreNulls = True
    Set fld = idx.CreateField("发票号")
    idx.Fields.Append fld
    tb.Indexes.Append idx
    '添加表
    db.TableDefs.Append tb
    db.TableDefs.Refresh
    db.Close
    Set idx = Nothing
    Set fld = Nothing
    Set tb = Nothing
    Set db = Nothing
    ProgressBar.Visible = False
    '提示信息
    MsgBox "新建工作期完成!", vbInformation + vbOKOnly, "新建工作期"
    Unload Me
End Sub

Private Sub cmdUpdateData_Click()
    ProgressBar.Visible = True
    '拷贝数据库
    Dim strOpenName As String
    strOpenName = App.Path & "\Main" & Year(Now) & Month(Now) & ".mdb"
    Set db2 = Workspaces(0).OpenDatabase(App.Path & "\用户档案.mdb", False, True)
    Set rs2 = db2.OpenRecordset("用户档案")
    Set db = Workspaces(0).OpenDatabase(strOpenName, False, False)
    Set rs = db.OpenRecordset("主库文件")
    Dim i As Integer, intCount As Integer, rsCount As Integer
    '拷贝数据
    intCount = 0: rsCount = rs2.RecordCount
    If Not rs.BOF Then rs.MoveFirst
    While Not rs2.EOF
        intCount = intCount + 1
        ProgressBar.Value = 100 / rsCount * intCount
        If rs.BOF Or rs.EOF Then
            rs.AddNew
        Else
            rs.Edit
        End If
        For i = 0 To 22
            Select Case i
                Case 0, 1, 2, 4, 11, 22    '编号,户名,地址,户型,水表直径,分区
                    Set fld = rs2.Fields(i)
                    rs(fld.Name).Value = fld.Value
            End Select
        Next
        rs.Update
        If Not rs.EOF Then rs.MoveNext
        rs2.MoveNext
    Wend
    rs.Close
    db.Close
    rs2.Close
    db2.Close
    Set rs = Nothing
    Set db = Nothing
    Set rs2 = Nothing
    Set db2 = Nothing
    ProgressBar.Visible = False
    MsgBox "更新完毕!", vbInformation + vbOKOnly, "新建工作期"
    Unload Me
End Sub

Private Sub cmdUpdateSystem_Click()
    ProgressBar.Visible = True
    '拷贝数据库
    Dim strAppName As String
    strAppName = App.Path & "\Main" & Year(Now) & Month(Now) & ".mdb"
    Set db = Workspaces(0).OpenDatabase(strAppName, False, True)
    Set rs = db.OpenRecordset("主库文件")
    If Not fso.FileExists(strAppName) Then
        MsgBox "本月数据库不存在!", vbExclamation + vbOKOnly, "新建工作期"
        Exit Sub
    End If
    Set db2 = Workspaces(0).OpenDatabase(App.Path & "\用户档案.mdb")
    Set rs2 = db2.OpenRecordset("用户档案")
    '拷贝数据
    Dim intCount As Integer, rsCount As Integer
    intCount = 0: rsCount = rs.RecordCount
    rs.MoveFirst: rs2.MoveFirst
    While Not rs.EOF
        intCount = intCount + 1
        ProgressBar.Value = 100 / rsCount * intCount
        rs2.Edit
        If rs.Fields("上月读数") <> "" Then
            rs2.Fields("上月读数") = rs.Fields("上月读数")
        Else
            rs2.Fields("上月读数") = 0
        End If
        If rs.Fields("本月读数") <> "" Then
            rs2.Fields("终止读数") = rs.Fields("本月读数")
        Else
            rs2.Fields("终止读数") = 0
        End If
        rs2.Update
        rs.MoveNext: rs2.MoveNext
    Wend
    rs2.Close
    db2.Close
    rs.Close
    db.Close
    Set rs2 = Nothing
    Set db2 = Nothing
    Set rs = Nothing
    Set db = Nothing
    ProgressBar.Visible = False
    MsgBox "更新完毕!", vbInformation + vbOKOnly, "新建工作期"
    Unload Me
End Sub

Private Sub Form_Load()
    MonthView.Value = Now
    MonthView.Refresh
    strName(1) = "编号": strType(1) = dbLong: strSize(1) = 4         'Long
    strName(2) = "户型": strType(2) = dbText: strSize(2) = 20
    strName(3) = "户名": strType(3) = dbText: strSize(3) = 50
    strName(4) = "地址": strType(4) = dbText: strSize(4) = 50
    strName(5) = "表单类型": strType(5) = dbText: strSize(5) = 50
    strName(6) = "本月读数": strType(6) = dbLong: strSize(6) = 4
    strName(7) = "上月读数": strType(7) = dbLong: strSize(7) = 4
    strName(8) = "新表止码": strType(8) = dbLong: strSize(8) = 4
    strName(9) = "新表起码": strType(9) = dbLong: strSize(9) = 4
    strName(10) = "实用水量": strType(10) = dbLong: strSize(10) = 4
    strName(11) = "排污费金额": strType(11) = dbCurrency: strSize(11) = 8    'Currency
    strName(12) = "水费": strType(12) = dbCurrency: strSize(12) = 8
    strName(13) = "水费金额": strType(13) = dbCurrency: strSize(13) = 8
    strName(14) = "合计金额": strType(14) = dbCurrency: strSize(14) = 8
    strName(15) = "污水处理费": strType(15) = dbCurrency: strSize(15) = 8
    strName(16) = "金额大写": strType(16) = dbText: strSize(16) = 50
    strName(17) = "污水处理费折扣": strType(17) = dbCurrency: strSize(17) = 8
    strName(18) = "发票号": strType(18) = dbLong: strSize(18) = 4
    strName(19) = "录单": strType(19) = dbBoolean: strSize(19) = 1
    strName(20) = "分区": strType(20) = dbInteger: strSize(20) = 2
    strName(21) = "水表直径": strType(21) = dbLong: strSize(21) = 4
End Sub

Private Sub MonthView_DateClick(ByVal DateClicked As Date)
    Date = DateClicked
    MonthView.DayBold(Date) = True
    MonthView.Refresh
End Sub

Private Sub MonthView_DateDblClick(ByVal DateDblClicked As Date)
    Date = DateDblClicked
    MonthView.DayBold(Date) = True
    MonthView.Refresh
    cmdOK_Click
End Sub