商户.frm

一间公司的管理系统的源码

Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim LimitDay As Long
Dim SumDay As Long

Private Sub cmdAdd_Click()
  strCheck = "增加"
  Call ClearInput
  Call LockInput(False)
  Call LockButton(True)
  lblJoinDate.Visible = False
  lblModifyDate.Visible = False
  txtShangHu(1).SetFocus
End Sub

Private Sub cmdCancel_Click()
  If strCheck = "增加" Or strCheck = "修改" Then
    If MsgBox("确定要取消当前的操作吗？", vbQuestion + vbYesNo + vbDefaultButton2, App.Title) = vbYes Then
      Call OnlyAdd
      Call ClearInput
      Call LockInput(True)
      txtHeTong(11).SetFocus
      strCheck = "" '清空strCheck标志，以备运行后面关闭窗体
    End If
  Else
    Unload Me
  End If
End Sub

Private Sub cmdDel_Click()
  If MsgBox("确定要删除姓名为【" & txtShangHu(2).Text & "】的档案吗？", vbYesNo, App.Title) = vbYes Then
    sql = "Select * from [商户档案] where [法人代表]='" & txtShangHu(2).Text & "'"
    rs.Open sql, conn, 1, 3
    rs.Delete
    rs.Update
    MsgBox "成功地将【" & txtShangHu(2).Text & "】的档案删除了！", vbOKOnly + vbInformation, App.Title
    rs.Close
    Set rs = Nothing
    Call ClearInput
  Else
    Exit Sub
  End If
End Sub

Private Sub cmdModify_Click()
  strCheck = "修改"
  Call LockInput(False)
  Call LockButton(True)
End Sub

Private Sub cmdSave_Click()
  Call CheckInput
  If FoundErr = True Then
      FoundErr = False
      Exit Sub
  End If

  If strCheck = "增加" Then
  
      sql = "Select * from [商户档案] where [合同编号]='" & Trim(txtHeTong(11).Text) & "'"
      rs.Open sql, conn, 1, 3
    
      If rs.EOF = False Then
          MsgBox "合同编号【" & txtHeTong(11).Text & "】已经存在！"
          rs.Close
          Set rs = Nothing
          txtHeTong(11).SetFocus
          txtHeTong(11).SelStart = 0
          txtHeTong(11).SelLength = Len(txtHeTong(11).Text)
          Exit Sub
      Else
          rs.AddNew
          For i = 1 To 10
              rs.Fields(i) = txtShangHu(i).Text
          Next i
      
          For j = 11 To 20
              rs.Fields(j) = txtHeTong(j).Text
          Next j

          rs.Fields("登记日期") = Date
          rs.Fields("修改日期") = Date
          rs.Update
          txtShangHu(1).SetFocus
          MsgBox txtShangHu(2).Text & " 的信息成功加入商户档案中！", vbOKOnly + vbInformation, App.Title
      End If
      
  ElseIf strCheck = "修改" Then
      
      sql = "Select * from [商户档案] where [id]=" & ID
      rs.Open sql, conn, 1, 3
      
      If txtHeTong(18).Text <> "" And txtHeTong(19).Text <> "" Then
          txtHeTong(20).Text = Val(txtHeTong(19).Text) - Val(txtHeTong(18).Text)
      End If
      
      Call Change20Color
      
      For i = 1 To 10
          rs.Fields(i) = Trim(txtShangHu(i).Text)
      Next i
      
      For j = 11 To 20
          rs.Fields(j) = Trim(txtHeTong(j).Text)
      Next j
      rs.Fields("修改日期") = Date
      rs.Update
      txtHeTong(11).SetFocus
      MsgBox "成功地修改了【" & txtShangHu(2).Text & "】的档案！", vbOKOnly + vbInformation, App.Title
  End If
  
  Call ClearInput '清空所有输入框
  Call LockInput(True) '锁定所有输入框
  Call OnlyAdd '增加按可用，其他按钮不可用
  strCheck = "" '清空strCheck标志，以备以后继续查询使用，而不是转化为跳格键功能
  
  rs.Close
  Set rs = Nothing
End Sub

Private Sub Form_Load()

  Call CheckLogin(Me)
  Call SetCenter(Me)
  Call shanghuSet(Me)
  Call LockInput(True)
  Call OnlyAdd
  
  Call OpenDB
  
End Sub
'过程--锁定输入
Sub LockInput(YesNo As Boolean)
  For i = 1 To 10
    txtShangHu(i).Locked = YesNo
  Next i
  For j = 11 To 20
    txtHeTong(j).Locked = YesNo
  Next j
  
  txtShangHu(2).Locked = False
  txtHeTong(11).Locked = False
End Sub
'过程--清空输入
Sub ClearInput()

  For i = 1 To 10
    txtShangHu(i).Text = ""
  Next i
  For j = 11 To 20
    txtHeTong(j).Text = ""
  Next j
  
  lblSumDay.Visible = False '隐藏共计天数
  lblLimitDay.Visible = False '隐藏剩余天数
  lblJoinDate.Visible = False '隐藏登记日期
  lblModifyDate.Visible = False '隐藏修改日期

End Sub
'过程--按钮的禁用状态
Sub LockButton(YesNo As Boolean)
  cmdAdd.Enabled = Not (YesNo)
  cmdModify.Enabled = Not (YesNo)
  cmdDel.Enabled = Not (YesNo)
  cmdSave.Enabled = YesNo
End Sub
'过程--只能增加记录
Sub OnlyAdd()
  cmdAdd.Enabled = True
  cmdModify.Enabled = False
  cmdDel.Enabled = False
  cmdSave.Enabled = False
End Sub
'过程--显示记录内容
Sub ShowInfo()
  If Trim(txtShangHu(2).Text) <> "" And Trim(txtHeTong(11).Text) = "" Then
    sql = "Select * from [商户档案] where [法人代表]='" & Trim(txtShangHu(2).Text) & " '"
  ElseIf Trim(txtShangHu(2).Text) = "" And Trim(txtHeTong(11).Text) <> "" Then
    sql = "Select * from [商户档案] where [合同编号]='" & Trim(txtHeTong(11)) & "'"
  Else
    sql = "Select * from [商户档案] where [合同编号]='" & Trim(txtHeTong(11)) & "' and [法人代表]='" & Trim(txtShangHu(2).Text) & "'"
  End If
  
  rs.Open sql, conn, 1, 1

  If rs.EOF = True Then
      If Trim(txtShangHu(2).Text) <> "" And Trim(txtHeTong(11).Text) = "" Then
          MsgBox "没有找到商户姓名为【" & txtShangHu(2).Text & "】的记录！"
          txtShangHu(2).SetFocus
      ElseIf Trim(txtShangHu(2).Text) = "" And Trim(txtHeTong(11).Text) <> "" Then
          MsgBox "没有找到合同编号为【" & txtHeTong(11).Text & "】的记录！"
          txtHeTong(11).SetFocus
      Else
          MsgBox "没有找到商户姓名为【" & txtShangHu(2).Text & "】且合同编号为【" & txtHeTong(11).Text & "】的记录！" & vbCr & vbCr & "建议只取一种条件进行查询！"
          txtHeTong(11).SetFocus
      End If
      
      '没有找到清空上次显示的旧记录
      Call ClearInput
      
      rs.Close
      Set rs = Nothing
      Exit Sub
  Else
      For i = 1 To 10
          txtShangHu(i).Text = rs.Fields(i) & "" '最后的&""可以防止出现Null错误
      Next i
      For j = 11 To 20
        txtHeTong(j).Text = rs.Fields(j) & ""
      Next j
      If rs.Fields("登记日期") <> "" Then
          lblJoinDate.Visible = True
          lblJoinDate.Caption = "登记日期：" & rs.Fields("登记日期")
      Else
          lblJoinDate.Visible = False
      End If
      If rs.Fields("修改日期") <> "" Then
          lblModifyDate.Visible = True
          lblModifyDate.Caption = "修改日期：" & rs.Fields("修改日期")
      Else
          lblModifyDate.Visible = False
      End If
      If rs.Fields("开始日期") <> "" And rs.Fields("到期日期") <> "" Then
          lblSumDay.Visible = True
          lblLimitDay.Visible = True
          lblSumDay.Caption = "共" & rs.Fields("到期日期") - rs.Fields("开始日期") & "天"
          lblLimitDay.Caption = "剩" & rs.Fields("到期日期") - Date & "天"
      Else
          lblSumDay.Visible = False
          lblLimitDay.Visible = False
      End If
      Call Change20Color
      '将当前记录的编号给变量ID，为以后的查询修改使用
      ID = rs("id")
      Call LockInput(True)
      Call LockButton(False)
  End If
  
  rs.Close
  Set rs = Nothing
End Sub
'过程--检查输入
Sub CheckInput()

  If Trim(txtShangHu(1).Text) = "" Then
    MsgBox "公司名称不能为空！"
    txtShangHu(1).SetFocus
    FoundErr = True
  ElseIf Trim(txtShangHu(2).Text) = "" Then
    MsgBox "法人代表不能为空！"
    txtShangHu(2).SetFocus
    FoundErr = True
  ElseIf Trim(txtHeTong(11).Text) = "" Then
    MsgBox "合同编号不能为空！"
    txtHeTong(11).SetFocus
    FoundErr = True
  ElseIf Trim(txtHeTong(12).Text) = "" Then
    MsgBox "所在区位不能为空！"
    txtHeTong(12).SetFocus
    FoundErr = True
  ElseIf Trim(txtHeTong(14).Text) = "" Then
    MsgBox "合同开始日期不能为空！"
    txtHeTong(14).SetFocus
    FoundErr = True
  ElseIf IsDate(txtHeTong(14).Text) = False Then
    MsgBox "合同开始日期格式不正确！" & vbCr & vbCr & "正确的格式为：2004-6-12"
    txtHeTong(14).SetFocus
    txtHeTong(14).SelStart = 0
    txtHeTong(14).SelLength = Len(txtHeTong(14).Text)
    FoundErr = True
  ElseIf Trim(txtHeTong(15).Text) = "" Then
    MsgBox "合同到期日期不能为空！"
    txtHeTong(15).SetFocus
    FoundErr = True
  ElseIf IsDate(txtHeTong(15).Text) = False Then
    MsgBox "合同到期日期格式不正确！" & vbCr & vbCr & "正确的格式为：2005-6-12"
    txtHeTong(15).SetFocus
    txtHeTong(15).SelStart = 0
    txtHeTong(15).SelLength = Len(txtHeTong(15).Text)
    FoundErr = True
  ElseIf Trim(txtHeTong(16).Text) = "" Then
    MsgBox "每平方米的单价不能为空！"
    txtHeTong(16).SetFocus
    FoundErr = True
  ElseIf Trim(txtHeTong(17).Text) = "" Then
    MsgBox "占地面积不能为空！"
    txtHeTong(17).SetFocus
    FoundErr = True
  ElseIf Trim(txtHeTong(18).Text) = "" Then
    MsgBox "共计金额不能为空！"
    txtHeTong(18).SetFocus
    FoundErr = True
  ElseIf Trim(txtHeTong(19).Text) = "" Then
    MsgBox "实交金额不能为空！"
    txtHeTong(19).SetFocus
    FoundErr = True
  ElseIf Trim(txtHeTong(20).Text) = "" Then
    MsgBox "欠费金额不能为空！"
    txtHeTong(20).SetFocus
    FoundErr = True
  End If
 
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
Call Closewindow(UnloadMode, Cancel, Me)
End Sub

Private Sub Form_Unload(Cancel As Integer)
  Call CloseDB
End Sub

Private Sub txtHeTong_Change(Index As Integer)
  '限制输入的数值在10000以内
  If Len(txtHeTong(11).Text) > 4 Then
    MsgBox "合同编号最多为四个字符！" & vbCr & vbCr & "如：0001  0002 A001 A002 ……"
    txtHeTong(11).SetFocus
    txtHeTong(11).SelStart = 0
    txtHeTong(11).SelLength = Len(txtHeTong(11).Text)
    Exit Sub
  End If
End Sub

Private Sub txtHeTong_KeyPress(Index As Integer, KeyAscii As Integer)
  If KeyAscii = 13 Then
  
    If strCheck = "" And txtHeTong(11).Text <> "" Then
      Call ShowInfo
    Else
      If txtHeTong(14).Text <> "" And txtHeTong(15).Text <> "" Then
          '自动计算剩余天数(到期日期-现在日期=剩余天数)
          SumDay = CDate(txtHeTong(15).Text) - CDate(txtHeTong(14).Text)
          LimitDay = CDate(txtHeTong(15).Text) - Date
          lblSumDay.Caption = "共" & SumDay & "天"
          lblLimitDay.Caption = "剩" & LimitDay & "天"
          lblSumDay.Visible = True
          lblLimitDay.Visible = True
      End If

      If txtHeTong(16).Text <> "" And txtHeTong(17).Text <> "" And txtHeTong(14).Text <> "" And txtHeTong(15).Text <> "" Then
          '自动计算共计金额(单价*面积*月数=共计金额)
          txtHeTong(18).Text = Val(txtHeTong(16).Text) * Val(txtHeTong(17).Text) * (SumDay \ 30)
      End If

      If txtHeTong(18).Text <> "" And txtHeTong(19).Text <> "" Then
          '自动计算欠费金额(共计金额-实交金额=欠费金额)
          txtHeTong(20).Text = Val(txtHeTong(19).Text) - Val(txtHeTong(18).Text)
      End If
    
      Call Change20Color
      SendKeys "{TAB}"

    End If

  End If
End Sub

Private Sub txtShangHu_KeyPress(Index As Integer, KeyAscii As Integer)
  If KeyAscii = 13 Then
    If strCheck = "" And txtShangHu(2).Text <> "" Then
      Call ShowInfo
    Else
      SendKeys "{TAB}"
    End If
  End If
End Sub
Sub Change20Color()
      If Val(txtHeTong(20).Text) < 0 Then
          txtHeTong(20).ForeColor = vbRed
      ElseIf Val(txtHeTong(20).Text) > 0 Then
          txtHeTong(20).ForeColor = vbBlue
      Else
          txtHeTong(20).ForeColor = vbBlack
      End If
End Sub