frmviewform.frm

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

      X2              =   7620
      Y1              =   15
      Y2              =   15
   End
   Begin VB.Line Line1 
      BorderColor     =   &H00FFFFFF&
      Index           =   2
      X1              =   30
      X2              =   7635
      Y1              =   3045
      Y2              =   3045
   End
   Begin VB.Line Line1 
      BorderColor     =   &H00808080&
      Index           =   3
      X1              =   30
      X2              =   7590
      Y1              =   3030
      Y2              =   3030
   End
   Begin VB.Line Line3 
      BorderColor     =   &H00E0E0E0&
      Index           =   0
      X1              =   45
      X2              =   45
      Y1              =   15
      Y2              =   3045
   End
   Begin VB.Line Line2 
      BorderColor     =   &H00808080&
      Index           =   1
      X1              =   7605
      X2              =   7605
      Y1              =   -15
      Y2              =   3045
   End
   Begin VB.Line Line3 
      BorderColor     =   &H00E0E0E0&
      Index           =   1
      X1              =   7620
      X2              =   7620
      Y1              =   0
      Y2              =   3045
   End
End
Attribute VB_Name = "frmViewForm"
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")
         txtCHUN.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
    
   '性别必须
    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

  '**************** 开始 *****************
   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
       Dim sSQL As String
      '查找是否重新
       If UCase(sCardNO) <> UCase(Trim(txtFields(1).Text)) Then
            sSQL = "Select * from tbdMember Where ID='" & Trim(txtFields(1).Text) & "'"
            tmpRs.Open sSQL, DB, adOpenStatic, adLockReadOnly, adCmdText
            If Not (tmpRs.EOF And tmpRs.BOF) Then
               tmpRs.Close: DB.Close
                 Set tmpRs = Nothing
                 Set DB = Nothing
                 MsgBox "会员编号〖" & Trim(txtFields(1).Text) & "〗重新, " & vbCrLf _
                       & "修改会员编号后继续？ ", vbExclamation
                 txtFields(1).SetFocus
                 Exit Sub
               Exit Sub
            End If
            tmpRs.Close
            Set tmpRs = Nothing
       End If
       sSQL = "Select * from tbdMember Where ID='" & sCardNO & "'"
       EF.Open sSQL, DB, adOpenStatic, adLockOptimistic, adCmdText
       If Not (EF.EOF And EF.BOF) Then
            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("DLevel") = cmbLevel.ListIndex
            EF.Update                               '更新
        Else
            EF.Close: DB.Close
            Set EF = Nothing
            Set DB = Nothing
            MsgBox "会员编号没有找到, 不能更新？ ", vbExclamation
            Exit Sub
      End If
        EF.Close
        DB.Close
        Set EF = Nothing
        Set DB = Nothing
    
        sFindString = ""
        Call frmMember.LoadData
        
       '改变为假
        ChangeTrue = False
        Unload Me  '关闭
  
        Exit Sub
SaveERR:
  MsgBox "保存会员资料错误:" & Err.Description, vbCritical
  Exit Sub
  
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