frmuptownmanage.frm

这是一个在某本书上获得的一个小区物业管理系统

      Begin VB.Label Label11 
         AutoSize        =   -1  'True
         BackColor       =   &H8000000E&
         Caption         =   "用户名："
         Height          =   180
         Left            =   240
         TabIndex        =   29
         Top             =   720
         Width           =   720
      End
      Begin VB.Label Label17 
         AutoSize        =   -1  'True
         BackColor       =   &H8000000E&
         Caption         =   "Label17"
         Height          =   180
         Left            =   960
         TabIndex        =   28
         Top             =   720
         Width           =   630
      End
      Begin VB.Label Label13 
         AutoSize        =   -1  'True
         BackColor       =   &H8000000E&
         Caption         =   "水  量："
         Height          =   180
         Left            =   240
         TabIndex        =   27
         Top             =   1200
         Width           =   720
      End
      Begin VB.Label Label19 
         AutoSize        =   -1  'True
         BackColor       =   &H8000000E&
         Caption         =   "Label19"
         Height          =   180
         Left            =   960
         TabIndex        =   26
         Top             =   1200
         Width           =   630
      End
      Begin VB.Label Label14 
         AutoSize        =   -1  'True
         BackColor       =   &H8000000E&
         Caption         =   "电  量："
         Height          =   180
         Left            =   240
         TabIndex        =   25
         Top             =   1440
         Width           =   720
      End
      Begin VB.Label Label20 
         AutoSize        =   -1  'True
         BackColor       =   &H8000000E&
         Caption         =   "Label20"
         Height          =   180
         Left            =   960
         TabIndex        =   24
         Top             =   1440
         Width           =   630
      End
      Begin VB.Label Label15 
         AutoSize        =   -1  'True
         BackColor       =   &H8000000E&
         Caption         =   "气  量："
         Height          =   180
         Left            =   240
         TabIndex        =   23
         Top             =   1680
         Width           =   720
      End
      Begin VB.Label Label21 
         AutoSize        =   -1  'True
         BackColor       =   &H8000000E&
         Caption         =   "Label21"
         Height          =   180
         Left            =   960
         TabIndex        =   22
         Top             =   1680
         Width           =   630
      End
      Begin VB.Label Label16 
         AutoSize        =   -1  'True
         BackColor       =   &H8000000E&
         Caption         =   "合  计："
         Height          =   180
         Left            =   240
         TabIndex        =   21
         Top             =   2280
         Width           =   720
      End
      Begin VB.Label Label22 
         AutoSize        =   -1  'True
         BackColor       =   &H8000000E&
         Caption         =   "Label22"
         Height          =   180
         Left            =   960
         TabIndex        =   20
         Top             =   2280
         Width           =   630
      End
      Begin VB.Label Label23 
         Alignment       =   1  'Right Justify
         AutoSize        =   -1  'True
         BackColor       =   &H8000000E&
         Caption         =   "Label23"
         Height          =   180
         Left            =   2160
         TabIndex        =   19
         Top             =   2760
         Width           =   630
      End
      Begin VB.Label Label12 
         AutoSize        =   -1  'True
         BackColor       =   &H8000000E&
         Caption         =   "门牌号："
         Height          =   180
         Left            =   240
         TabIndex        =   18
         Top             =   960
         Width           =   720
      End
      Begin VB.Label Label18 
         AutoSize        =   -1  'True
         BackColor       =   &H8000000E&
         Caption         =   "Label18"
         Height          =   180
         Left            =   960
         TabIndex        =   17
         Top             =   960
         Width           =   630
      End
      Begin VB.Line Line1 
         X1              =   240
         X2              =   2760
         Y1              =   2160
         Y2              =   2160
      End
   End
End
Attribute VB_Name = "UptownManage"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False

Private Sub Adodc1_MoveComplete(ByVal adReason As EventReasonEnum, _
        ByVal pError As Error, adStatus As EventStatusEnum, ByVal pRecordset As Recordset)
    With Adodc1.Recordset
        If Check1.Value = 1 Then
        If .AbsolutePosition > 0 Then       '显示当前缴费记录数据
            cmbUser = .Fields("用户名"):    cmbNumber = .Fields("门牌号")
            txtWater = .Fields("水"):       txtPower = .Fields("电")
            txtGas = .Fields("气"):         txtArea = .Fields("物管")
            txtDate = .Fields("日期")
            Adodc1.Caption = "当前记录：" & .AbsolutePosition & "/" & .RecordCount
        Else
            cmbUser = "":   cmbNumber = "": txtWater = "": txtPower = ""
            txtGas = "":    txtArea = "":   txtDate = ""
            Adodc1.Caption = "无收费记录"
        End If
        End If
    End With
End Sub

Private Sub Check1_Click()
    If Check1.Value = 1 Then
        Adodc1.Visible = True                               '显示Adodc1导航条
        Adodc1.Refresh
        txtWP.Visible = False:  txtPP.Visible = False       '隐藏单价
        txtGP.Visible = False:  txtAP.Visible = False
        Label7.Visible = False: Label8.Visible = False
        Label9.Visible = False: Label27.Visible = False
    Else
        Adodc1.Visible = False                              '显示Adodc1导航条
        txtWP.Visible = True:   txtPP.Visible = True        '显示单价
        txtGP.Visible = True:   txtAP.Visible = True
        Label7.Visible = True:  Label8.Visible = True
        Label9.Visible = True:  Label27.Visible = True
        cmbUser = "":   cmbNumber = ""                      '恢复添加收费数据默认状态
        txtWater = "":  txtWP = "1.20": txtPower = "":  txtPP = "0.50"
        txtGas = "":    txtGP = "1.00": txtArea = "":   txtAP = "0.25"
        txtDate = Format(Date, "Long date")
    End If
End Sub

Private Sub cmbNumber_Click()
    If Check1.Value = 0 Then
        cmbUser.ListIndex = cmbNumber.ListIndex         '显示对应的用户名
        txtArea = cmbUser.ItemData(cmbUser.ListIndex)   '显示房屋面积
        CheckToPay                                      '检查是否应该缴费
    End If
End Sub

Private Sub cmbUser_click()
    If Check1.Value = 0 Then
        cmbNumber.ListIndex = cmbUser.ListIndex         '显示对应的用户名
        txtArea = cmbUser.ItemData(cmbUser.ListIndex)   '显示房屋面积
        CheckToPay                                      '检查是否应该缴费
    End If
End Sub

Private Sub cmdCalculate_Click()
    Dim isOk As Boolean, sglWater!, sglPower!, sglGas!, sglArea!
    isOk = Trim(cmbUser) = "" Or Trim(cmbNumber) = "" Or Trim(txtWater) = "" _
           Or Trim(txtPower) = "" Or Trim(txtGas) = "" Or Trim(txtArea) = "" _
           Or Trim(txtDate) = ""
    If Check1.Value = 0 Then
        isOk = isOk Or Trim(txtWP) = "" Or Trim(txtPP) = "" Or Trim(txtGP) = "" _
               Or Trim(txtAP) = ""
    End If
    If isOk Then                        '检验数据是否完整
        MsgBox "收费记录各个数据项不能为空白！", vbCritical, "物管收费"
    Else
        If Check1.Value = 0 Then
            Label17 = Trim(cmbUser)
            Label18 = Trim(cmbNumber)
            sglWater = Val(txtWater) * Val(txtWP)
            Label19 = Trim(txtWater) & " * " & Trim(txtWP) & " = " & sglWater
            sglPower = Val(txtPower) * Val(txtPP)
            Label20 = Trim(txtPower) & " * " & Trim(txtPP) & " = " & sglPower
            sglGas = Val(txtGas) * Val(txtGP)
            Label21 = Trim(txtGas) & " * " & Trim(txtGP) & " = " & sglGas
            sglArea = Val(txtArea) * Val(txtAP)
            Label26 = Trim(txtArea) & " * " & Trim(txtAP) & " = " & sglArea
            Label22 = sglWater + sglPower + sglGas + sglArea
            Label23 = Format(Date, "Long date")
        End If
    End If
End Sub

Private Sub cmdDelete_Click()
    With Adodc1.Recordset
    If Not .EOF And Check1.Value = 1 Then
        If MsgBox("将删除<" & Trim(cmbUser) & ">在<" & Trim(txtDate) & _
                 ">的缴费数据，是否继续？", vbCritical + vbYesNo, "物管收费") = vbYes Then
            .Delete adAffectCurrent
            .MoveNext
            If .EOF And .RecordCount > 0 Then .MoveLast
        End If
    End If
    End With
End Sub

Private Sub cmdParking_Click()
    If Label17 = "" Then
        MsgBox "当前无票据打印！", vbCritical, "物管收费"
    Else
        UptownCharge.Label17 = Label17
        UptownCharge.Label18 = Label18
        UptownCharge.Label19 = Label19
        UptownCharge.Label20 = Label20
        UptownCharge.Label21 = Label21
        UptownCharge.Label26 = Label26
        UptownCharge.Label22 = Label22
        UptownCharge.Label23 = Label23
        UptownCharge.PrintForm  '打印收费票据
    End If
End Sub

Private Sub cmdRefresh_Click()
    If Check1.Value = 1 Then
        Adodc1.Refresh                  '刷新记录集
    Else
        cmbUser = "": cmbNumber = ""    '清空输入框
        txtWater = "": txtPower = ""
        txtGas = "": txtArea = ""
    End If
    '初始化收费票据
    Label17 = "": Label18 = "": Label19 = "": Label20 = ""
    Label21 = "": Label26 = "": Label22 = "": Label23 = ""
End Sub

Private Sub cmdSave_Click()
    Dim isOk As Boolean
    isOk = Trim(cmbUser) = "" Or Trim(cmbNumber) = "" Or Trim(txtWater) = "" _
           Or Trim(txtPower) = "" Or Trim(txtGas) = "" Or Trim(txtArea) = "" _
           Or Trim(txtDate) = ""
    If Check1.Value = 0 Then
        isOk = isOk Or Trim(txtWP) = "" Or Trim(txtPP) = "" Or Trim(txtGP) = "" _
               Or Trim(txtAP) = ""
    End If
    If isOk Then                        '检验数据是否完整
        MsgBox "收费记录各个数据项不能为空白！", vbCritical, "物管收费"
    Else
        If Check1.Value = 0 Then        '仅保存新增加的收费记录
            With Adodc1.Recordset
                If CheckToPay Then      '检查是否应该缴费
                    .AddNew             '保存新增收费记录
                    .Fields("用户名") = Trim(cmbUser)
                    .Fields("门牌号") = Trim(cmbNumber)
                    .Fields("水") = Val(txtWater) * Val(txtWP)
                    .Fields("电") = Val(txtPower) * Val(txtPP)
                    .Fields("气") = Val(txtGas) * Val(txtGP)
                    .Fields("物管") = Val(txtArea) * Val(txtAP)
                    .Fields("日期") = Trim(txtDate)
                    .Update
                    MsgBox "收费记录保存成功！", vbInformation, "物管收费"
                End If
            End With
        End If
    End If
DealError:
End Sub

Private Sub Form_Load()
    Dim objCopy As New Recordset
    Set objCopy.ActiveConnection = Adodc1.Recordset.ActiveConnection
    With objCopy
        .Open "Select 户主,门牌号,面积 From 楼盘数据"
        While Not .EOF
            cmbUser.AddItem (.Fields("户主"))
            cmbUser.ItemData(cmbUser.NewIndex) = .Fields("面积")
            cmbNumber.AddItem (.Fields("门牌号"))
            .MoveNext
        Wend
    End With
    
    cmbUser = ""                        '恢复添加收费数据默认状态
    cmbNumber = ""
    txtWater = "":  txtWP = "1.20": txtPower = "":  txtPP = "0.50"
    txtGas = "":    txtGP = "1.00": txtArea = "":   txtAP = "0.25"
    txtDate = Format(Date, "Long date")
    '初始化收费票据
    Label17 = "": Label18 = "": Label19 = "": Label20 = ""
    Label21 = "": Label26 = "": Label22 = "": Label23 = ""
End Sub
Private Sub cmdExit_Click()
    Unload Me               '关闭红光苑物管收费窗体
End Sub
  
Private Function CheckToPay() As Boolean
    With Adodc1.Recordset
        If .RecordCount > 0 Then    '检查用户是否应该缴费
            .MoveFirst
            .Find "门牌号='" & Trim(cmbNumber) & "'"
            If Not .EOF Then
                If DateDiff("d", Date, .Fields("日期")) > 30 Then
                    CheckToPay = True
                Else
                    MsgBox "<" & cmbUser & ">上次缴费日期：" & .Fields("日期") _
                          & "，本月可不缴费！", vbInformation, "物管收费"
                End If
            End If
            CheckToPay = True
        Else
            CheckToPay = True
        End If
    End With
End Function