frmnewform.frm

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

      X1              =   7620
      X2              =   7620
      Y1              =   0
      Y2              =   3390
   End
End
Attribute VB_Name = "frmNewForm"
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

Private Sub cmbLevel_Change()

  ChangeTrue = True
  
End Sub

Private Sub ExitB_Click()
 
  Unload Me
 
End Sub

Private Sub Form_Load()

  GetFormSet Me, Screen

  ChangeTrue = False
  Me.Caption = "正在添加新会员"
  
 '给出缺省的ID
  txtFields(1).Text = GetNo("会员")
  cmbLevel.ListIndex = 0
  
  NoChange = False: lShow = False: lShowS = False
  ChangeTrue = False
  
End Sub

Private Sub Form_Unload(Cancel As Integer)

    On Error GoTo ERRUNLOAD
    
    SaveFormSet Me
    
    If NoChange = True Then
       Call frmMember.LoadData
    End If
  
    If ChangeTrue = True Then
       Dim OK As Integer
       OK = MsgBox("有添加记录，需要保存码？(Y/N)", vbYesNo + 32, "未保存")
       If OK = vbNo Then
          Unload Me
          Exit Sub
        Else
         '保存记录代码
          Call SaveAdd_Click
          Exit Sub
       End If
    Else
       Unload Me
    End If

    Exit Sub
ERRUNLOAD:
    MsgBox "御载会员添加部份出错:" & Err.Description, vbCritical
    Exit Sub
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
    
   '性别必须
    If Trim(txtFields(2).Text) = "" Then
       MsgBox "性别不能空，不能保存!", vbOKOnly + 64, "请输入性别：男/女"
       txtFields(2).SetFocus
       Exit Sub
    End If
   '电话必须
    If Trim(txtFields(3).Text) = "" Then
       MsgBox "电话号码不能空，不能保存!", vbOKOnly + 64, "必须有联系电话"
       txtFields(3).SetFocus
       Exit Sub
    End If
    
   sArrearagePaymethod = ""
   
  '显示付款方式
   frmShowPayMethod.Show 1
   If sArrearagePaymethod = "" Then
      MsgBox "付款方式为空，不能保存？  ", vbExclamation
      Exit Sub
   End If
  'Save Data
  '**************** 开始 *****************
   Dim DB As Connection, EF As Recordset, x As Integer, tempStr As String
   Set DB = CreateObject("ADODB.Connection")
       DB.Open Constr
       DB.BeginTrans
       
   Set EF = CreateObject("ADODB.Recordset")
       EF.Open "Select * from tbdMember Where ID='" & Trim(txtFields(1).Text) & "'", DB, adOpenStatic, adLockOptimistic, adCmdText
       If EF.EOF And EF.BOF Then
            EF.AddNew
            EF.Fields("Name") = txtFields(0).Text
            EF.Fields("ID") = txtFields(1).Text
            EF.Fields("Sex") = txtFields(2).Text
            EF.Fields("Tel") = txtFields(3).Text
            If Trim(txtFields(4).Text) <> "" Then
               EF.Fields("Fax") = Trim(txtFields(4).Text)
            End If
            If Trim(txtFields(5).Text) <> "" Then
               EF.Fields("BP") = Trim(txtFields(5).Text)
            End If
            If Trim(txtFields(6).Text) <> "" Then
               EF.Fields("Mobil") = Trim(txtFields(6).Text)
            End If
            If Trim(txtFields(7).Text) <> "" Then
               EF.Fields("Email") = Trim(txtFields(7).Text)
            End If
            If Trim(txtFields(8).Text) <> "" Then
               EF.Fields("Address") = Trim(txtFields(8).Text)
            End If
            EF("Consume") = txtCHUN.Text                       '卡金额
            EF("DLevel") = cmbLevel.ListIndex
            EF.Update
            UpdateNo "会员"
         Else
            EF.Close
            DB.RollbackTrans
            DB.Close
            Set EF = Nothing
            Set DB = Nothing
            MsgBox "编号或卡号已经存在,请修改后继续？ ", vbExclamation
            UpdateNo "会员"
            Exit Sub
        End If
        EF.Close
        If CCur(txtCHUN.Text) > 0 Then
           '添加现金帐单
            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(txtCHUN.Text)
            '---------------------------
        End If
        
        DB.CommitTrans
        DB.Close
        Set EF = Nothing
        Set DB = Nothing
  
   If chkMulti.Value = vbUnchecked Then
      Unload Me
     Else
      '继续添加    '指针调回编号
         For x = 0 To 8
             txtFields(x).Text = ""
         Next
         txtFields(1).Text = GetNo("会员")
         cmbLevel.ListIndex = 0
         txtFields(0).SetFocus
         ChangeTrue = False
         NoChange = True
   End If
   
  '**************** 结束 *****************
  
   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