frmaddform.frm

星级酒店管理系统（附带系统自写控件源码）

      X2              =   6120
      Y1              =   3060
      Y2              =   3060
   End
   Begin VB.Line Line6 
      BorderColor     =   &H00FFFFFF&
      Index           =   1
      X1              =   6120
      X2              =   6120
      Y1              =   3480
      Y2              =   3060
   End
   Begin VB.Line Line7 
      BorderColor     =   &H00FFFFFF&
      Index           =   1
      X1              =   4920
      X2              =   6120
      Y1              =   3480
      Y2              =   3480
   End
   Begin VB.Line Line1 
      BorderColor     =   &H00FFFFFF&
      Index           =   2
      X1              =   30
      X2              =   7620
      Y1              =   3630
      Y2              =   3630
   End
   Begin VB.Line Line1 
      BorderColor     =   &H00808080&
      Index           =   3
      X1              =   30
      X2              =   7605
      Y1              =   3615
      Y2              =   3615
   End
End
Attribute VB_Name = "frmAddForm"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False

Option Explicit

Dim ChangeTrue As Boolean
Dim NoChange As Boolean, lShow As Boolean, lShowS As Boolean
Dim sName As String, sReName As String

Public sCardNO As String        '原来卡号或编号

Private Sub ExitB_Click()
 
    Unload Me

End Sub

Private Sub GetOldSheet(stmpID As String)
    
  On Error GoTo GetERR
  
  Dim mDB As Connection
  Dim mRS As Recordset
  Set mDB = CreateObject("ADODB.Connection")
  Set mRS = CreateObject("ADODB.Recordset")
      mDB.Open Constr
      mRS.Open "Select * from tbdMember Where ID='" & stmpID & "'", mDB, adOpenStatic, adLockReadOnly, adCmdText
      If Not (mRS.EOF And mRS.BOF) Then
        '有找到会员时
         txtFields(0).Text = mRS("Name")
         sReName = txtFields(0).Text   '保存原来的姓名
         txtFields(1).Text = stmpID
         txtFields(2).Text = mRS("Sex")
         txtFields(3).Text = mRS("Tel")
         txtFields(4).Text = NullValue(mRS("Fax"))
         txtFields(5).Text = NullValue(mRS("BP"))
         txtFields(6).Text = NullValue(mRS("Mobil"))
         txtFields(7).Text = NullValue(mRS("Email"))
         txtFields(8).Text = NullValue(mRS("Address"))
         cmbLevel.ListIndex = mRS("DLevel")
         txtRemain.Text = mRS("Consume")
       Else
         mRS.Close: mDB.Close
         Set mRS = Nothing
         Set mDB = Nothing
         Dim x As Integer
        '使所有失效
         For x = 0 To 8
             txtFields(x).Enabled = False
         Next
         SaveAdd.Enabled = False
         cmbLevel.Enabled = False
         MsgBox "会员编号【" & stmpID & "】不存在？  ", vbExclamation
         Exit Sub
      End If
      
      mRS.Close: mDB.Close
      Set mRS = Nothing
      Set mDB = Nothing
         
  Exit Sub
GetERR:
    MsgBox "给出会员资料错误:" & Err.Description, vbCritical
    Exit Sub
 
 
End Sub

Private Sub Form_Load()

    On Error Resume Next
    
   '给出会员信息
    GetOldSheet frmMember.lstPro.SelectedItem.Text
    
   '首先给出该会员的详细资料
    sName = sReName
 
    GetFormSet Me, Screen
    
    ChangeTrue = False
    NoChange = False: lShow = False: lShowS = False
    
End Sub

Private Sub Form_Unload(Cancel As Integer)

    SaveFormSet Me
    Unload Me

End Sub

Private Sub SaveAdd_Click()
 
    On Error GoTo SaveERR
   
   '名称必须
    If Trim(txtFields(0).Text) = "" Then
       MsgBox "客户名不能空，且不能重复,不能充值!", vbOKOnly + 64, "客户名有错误"
       txtFields(0).SetFocus
       Exit Sub
    End If
    
   '编号必须
    If Trim(txtFields(1).Text) = "" Then
       MsgBox "编号或卡号不能空，不能充值!", vbOKOnly + 64, "卡号不能为空"
       txtFields(1).SetFocus
       Exit Sub
    End If
   
   '充值金额为0，或者不正常数字时
    If Trim(txtCHUN.Text) = "" Or Trim(txtCHUN.Text) = "0" Then
       MsgBox "充值金额为空!", vbOKOnly + 64, "充值金额不能为空，或者为非法字符。"
       txtCHUN.SetFocus
       Exit Sub
    End If
    
   '充值金额为0，或者不正常数字时
    If IsNumeric(txtCHUN.Text) = False Then
       MsgBox "充值金额为非数字!", vbOKOnly + 64, "充值金额不能为非法字符。"
       txtCHUN.SetFocus
       Exit Sub
    End If
     
   If MsgBox("真的要充值【" & txtCHUN.Text & "元】吗？" & vbCrLf & vbCrLf & "按确定按钮执行充值,按取消返回。", vbInformation + vbYesNo) = vbNo Then Exit Sub
   
   sArrearagePaymethod = ""
   
  '显示付款方式
   frmShowPayMethod.Show 1
   
   If sArrearagePaymethod = "" Then
      MsgBox "付款方式为空，不能充值？  ", vbExclamation
      Exit Sub
   End If

  '**************** 开始 *****************
   Dim DB As Connection, EF As Recordset, x As Integer, tempStr As String
   Dim tmpRs As Recordset
   
   Set DB = CreateObject("ADODB.Connection")
   Set tmpRs = CreateObject("ADODB.Recordset")
   Set EF = CreateObject("ADODB.Recordset")
       DB.Open Constr
       DB.BeginTrans
       Dim sSQL As String
       sSQL = "Select * from tbdMember Where ID='" & Trim(txtFields(1).Text) & "'"
       EF.Open sSQL, DB, adOpenStatic, adLockOptimistic, adCmdText
       If Not (EF.EOF And EF.BOF) Then
          EF.Fields("Consume") = EF.Fields("Consume") + CCur(txtCHUN.Text)
          EF.Update                               '更新
        Else
          EF.Close: DB.Close
          Set EF = Nothing
          Set DB = Nothing
          MsgBox "会员编号没有找到, 不能充值？ ", vbExclamation
          Exit Sub
       End If
       EF.Close
      '添加现金帐单
       InserToCash DB, 1, "客户〖" & txtFields(0).Text & "〗卡充值【" & txtCHUN.Text & "元】", CCur(txtCHUN.Text), Date, sArrearagePaymethod
      '修改今日与总金额
       InserTodayCash DB, sArrearagePaymethod, CCur(txtCHUN.Text), Date
      '插入到卡对帐单中
       InserToCard DB, 1, "卡充值 - " & Date, CCur(txtCHUN.Text), Trim(txtFields(1).Text), 0, CCur(txtRemain.Text) + CCur(txtCHUN.Text)
      '---------------------------
       DB.CommitTrans
       DB.Close
       Set EF = Nothing
       Set DB = Nothing
    
       sFindString = ""
       Call frmMember.LoadData
        
       Unload Me  '关闭
  
       Exit Sub
SaveERR:
  MsgBox "充值错误:" & Err.Description, vbCritical
  On Error Resume Next
  DB.RollbackTrans
  DB.Close
  Set DB = Nothing
  Exit Sub
  
End Sub

Private Sub txtCHUN_Change()

  On Error Resume Next
  If Trim(txtCHUN.Text) = "" Then
     txtCHUN.Text = "0"
     txtCHUN.SelStart = 0
     txtCHUN.SelLength = 1
     Exit Sub
  End If
  If Trim(txtCHUN.Text) = "." Then
     txtCHUN.Text = "0."
     txtCHUN.SelStart = 2
     txtCHUN.SelLength = 0
     Exit Sub
  End If
  
End Sub

Private Sub txtCHUN_GotFocus()

  On Error Resume Next
  txtCHUN.SelStart = 0
  txtCHUN.SelLength = Len(txtCHUN.Text)
  
End Sub

Private Sub txtCHUN_KeyPress(KeyAscii As Integer)

 '屏蔽一些数据
  If KeyAscii = 13 Then SaveAdd.SetFocus: Exit Sub
  If KeyAscii < 46 And KeyAscii > 57 Then KeyAscii = 0
  If KeyAscii = 47 Then KeyAscii = 0
  
End Sub

Private Sub txtCHUN_LostFocus()

   On Error Resume Next
   If txtCHUN.Text <> "" Then
      If IsNumeric(txtCHUN.Text) = False Then
         MsgBox "请输入数字,不能为非数字。", vbInformation
         txtCHUN.Text = 0
      End If
   End If
   
End Sub

Private Sub txtFields_Change(Index As Integer)
 
  ChangeTrue = True
  If Index = 2 Then
    If Trim(txtFields(2).Text) = "" Then
       txtFields(2).Text = "男"
       txtFields(2).SelStart = 0
       txtFields(2).SelLength = Len(txtFields(2).Text)
       Exit Sub
    End If
 End If

End Sub

Private Sub txtFields_GotFocus(Index As Integer)

txtFields(Index).BackColor = &HFF0000
txtFields(Index).ForeColor = &HFFFFFF
txtFields(Index).SelStart = 0
txtFields(Index).SelLength = Len(Trim(txtFields(Index).Text))

End Sub

Private Sub txtFields_KeyDown(Index As Integer, KeyCode As Integer, Shift As Integer)

If KeyCode = 38 Then
   If Index > 0 Then
      txtFields(Index - 1).SetFocus
   End If
End If
If KeyCode = 40 Then
   If Index < 8 Then
      txtFields(Index + 1).SetFocus
   End If
End If

End Sub

Private Sub txtFields_KeyPress(Index As Integer, KeyAscii As Integer)

If KeyAscii = 13 Then
   SendKeys "{tab}"
   Exit Sub
End If
If KeyAscii = 8 Then
   Exit Sub
End If
 
 If Index = 1 Then
    If KeyAscii < 48 Or KeyAscii > 57 Then
       KeyAscii = 0
    End If
 End If
  
 If Index = 2 Then  '性别输入
    If KeyAscii = 49 Then
       KeyAscii = 0
       txtFields(2).Text = "男"
    End If
    If KeyAscii = 50 Then
       KeyAscii = 0
       txtFields(2).Text = "女"
    End If
    SetItFocus txtFields(2)
    KeyAscii = 0
 End If
 
End Sub

Private Sub txtFields_LostFocus(Index As Integer)

txtFields(Index).BackColor = &HFFFFFF
txtFields(Index).ForeColor = &H0
If InStr(1, txtFields(Index).Text, "'", vbTextCompare) Then
   MsgBox "该项目之中有特殊字符" + "<'>,请删除。", vbOKOnly + 48, "提示："
   txtFields(Index).SetFocus
   Exit Sub
End If

If Index = 2 Then
    If Trim(txtFields(2).Text) = "" Then
       txtFields(2).Text = "男"
       txtFields(2).SelStart = 0
       txtFields(2).SelLength = Len(txtFields(2).Text)
       Exit Sub
    End If
 End If

End Sub