frmmemberedit.frm

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

     ftGuest(0).SetFocus
     Exit Sub
  End If
  If ftGuest(1).Text = "" Then
     MsgBox "请输入客户名称,最好不要重复? ", vbInformation
     ftGuest(1).SetFocus
     Exit Sub
  End If
      
 '检查该客户编号是否存在
  Dim DB As Connection
  Dim Rs As Recordset
  Dim sTmp As String
  Dim intTmp As Integer
      intTmp = 0
      
  Set DB = CreateObject("adodb.connection")
  Set Rs = CreateObject("adodb.recordset")
      DB.Open Constr
      DB.BeginTrans
      sTmp = "Select * from tbdGuest WHere Dguest='" & Trim(ftGuest(0).Text) & "'"
      Rs.Open sTmp, DB, adOpenStatic, adLockOptimistic, adCmdText
                 
      If Not (Rs.EOF And Rs.BOF) Then
            '修改数据
             For intTmp = 0 To 7
                    If Trim(ftGuest(intTmp).Text) <> "" Then
                       Select Case intTmp
                       Case 6
                         Rs.Fields("DEmail") = ftGuest(6).Text
                       Case 7
                         Rs.Fields("DStr") = ftGuest(7).Text
                       Case Else
                         Rs.Fields(intTmp) = ftGuest(intTmp).Text
                       End Select
                      Else
                      '缺省给出空
                       Select Case intTmp
                         Case 6
                           Rs.Fields("DEmail") = " "
                         Case 7
                           Rs.Fields("Dstr") = " "
                         Case Else
                           Rs.Fields(intTmp) = " "
                       End Select
                    End If
             Next
             If Trim(ftMemo.Text) <> "" Then
                Rs.Fields("DMemo") = ftMemo.Text
             End If
             Rs.Update
         Else
            Rs.Close
            Set Rs = Nothing
            DB.RollbackTrans
            DB.Close
            Set DB = Nothing
            cmdSave.Enabled = False
            MsgBox Trim(ftGuest(0).Text) & "编号不存在,不能修改该员工资料?  ", vbExclamation
            Exit Sub
      End If
      Rs.Close
      Set Rs = Nothing
     '如果名称不同时
      If UCase(sOldName) <> UCase(ftGuest(1).Text) Then
         '修正操作员库
          sTmp = "Update Main Set 操作员='" & Trim(ftGuest(1).Text) & "' Where 操作员='" & sOldName & "'"
          DB.Execute sTmp
      End If
      DB.CommitTrans
      DB.Close
      Set DB = Nothing
      
      IsChangeIT = True
      AddTrue = False
      
     '修改列表中的数据
      frmEmploy.lvwList.SelectedItem.SubItems(1) = ftGuest(1).Text   '名称
      frmEmploy.lvwList.SelectedItem.SubItems(2) = ftGuest(2).Text   '地址
      frmEmploy.lvwList.SelectedItem.SubItems(3) = ftGuest(3).Text   '电话
      frmEmploy.lvwList.SelectedItem.SubItems(4) = ftGuest(4).Text   '身份证
      frmEmploy.lvwList.SelectedItem.SubItems(5) = ftGuest(6).Text   '邮件

      Unload Me
   
   Exit Sub
LoadERR:
   MsgBox "修改员工数据错误:" & Err.Description & vbCrLf & vbCrLf & "请输入更多信息,才能保存。  ", vbCritical
   IsChangeIT = False
   AddTrue = False
   Unload Me
   Exit Sub
   
End Sub

Private Sub DTPicker1_CallbackKeyDown(ByVal KeyCode As Integer, ByVal Shift As Integer, ByVal CallbackField As String, CallbackDate As Date)

End Sub

Private Sub cmdScan_Click()

  On Error Resume Next
  
  ScanFileName = ""
  Me.MousePointer = 11
  
  frmScan.Show 1
  
  Me.MousePointer = 0
  If ScanFileName <> "" Then
     ftGuest(7).Text = ScanFileName
     imgView.Picture = LoadPicture(ScanFileName)
    Else
     ftGuest(7).SetFocus
  End If

End Sub

Private Sub cmdSelect_Click()

  On Error Resume Next
  
  dlgAccess.CancelError = True
  dlgAccess.DialogTitle = "选择图片文件"
  dlgAccess.Filter = "所有图片文件|*.bmp;*.jpg;*.gif"
  dlgAccess.Flags = cdlOFNFileMustExist + cdlOFNHideReadOnly
  dlgAccess.ShowOpen
  
  If Err.Number = 32755 Then
     '用户取消时
      ftGuest(7).SetFocus
      Exit Sub
    Else
      ftGuest(7).Text = dlgAccess.FileName
      imgView.Picture = LoadPicture(dlgAccess.FileName)
  End If

End Sub

Private Sub cmdType_Click()

  '显示员工管理
   frmMemberLevel.Show 1
  
End Sub

Private Sub Form_Load()

   On Error GoTo LoadERR
   
   GetFormSet Me, Screen
   
   If GetGuestInformation(sOldID) = False Then
      Dim intX As Integer
      For intX = 0 To 7
          ftGuest(intX).Enabled = False
      Next
      cmdSave.Enabled = False
      AddTrue = False
      Exit Sub
   End If
      
  '员工编号禁止修改,押金禁止修改
   ftGuest(0).Enabled = False
   ftGuest(5).Enabled = False
   sOldName = Trim(ftGuest(1).Text)
   
   AddTrue = False
   
   Exit Sub
LoadERR:
   MsgBox "安装数据错误:" & Err.Description, vbCritical
   cmdSave.Enabled = False
   AddTrue = False
   
   Exit Sub
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)

  On Error Resume Next
  Dim intTmp As Integer
  
  If AddTrue = True Then
     intTmp = MsgBox("您已经修改部份数据,尚未保存？ " & vbCrLf & "按[是]保存退出,按[否]返回。  ", vbYesNoCancel + vbInformation)
     If intTmp = vbCancel Then
        Cancel = -1
        Exit Sub
     End If
     If intTmp = vbYes Then
        Call cmdSave_Click
        Exit Sub
     End If
     If intTmp = vbNo Then
        Exit Sub
     End If
  End If
  
End Sub

Private Sub Form_Resize()

   On Error Resume Next
   
   If Me.WindowState = 1 Then Exit Sub
   
      Me.Width = 7905
      Me.Height = 6465
      
End Sub

Private Sub Form_Unload(Cancel As Integer)

   SaveFormSet Me
   SaveSetting App.EXEName, "SET", "DEDUCT", cmbCheck.ListIndex
   
End Sub

Private Sub ftExpireDate_Change()

  ftGuest(11).Text = ftExpireDate.Value
  
End Sub

Private Sub ftGuest_Change(Index As Integer)

  On Error Resume Next
  
  AddTrue = True
  
  Select Case Index
    Case 5
        If ftGuest(5).Text = "" Then
           ftGuest(5).Text = "0"
           ftGuest(5).SelStart = 0
           ftGuest(5).SelLength = 1
           Exit Sub
        End If
   Case 7
        If ftGuest(7).Text = "" Then
          '清空图片框
           imgView.Picture = LoadPicture()
           Exit Sub
        End If
 End Select
 
End Sub

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

  On Error Resume Next
  
  Select Case KeyCode
         Case 13
          If Index >= 0 And Index < 7 Then
             If Index = 4 Then
               ftGuest(Index + 2).SetFocus
              Else
               ftGuest(Index + 1).SetFocus
             End If
             Exit Sub
          End If
         Case 38
          If Index >= 1 And Index <= 7 Then
             If Index = 6 Then
               ftGuest(Index - 2).SetFocus
              Else
               ftGuest(Index - 1).SetFocus
             End If
             Exit Sub
          End If
         Case 0
         '向下
          If Index >= 0 And Index < 7 Then
             If Index = 4 Then
               ftGuest(Index + 2).SetFocus
              Else
               ftGuest(Index + 1).SetFocus
             End If
             Exit Sub
          End If
  End Select
  
End Sub

Private Sub ResetAddForm()

   On Error Resume Next
   
   ftGuest(0).Text = ""
   ftGuest(1).Text = ""
   ftGuest(2).Text = ""
   ftGuest(3).Text = ""
   ftGuest(4).Text = ""
   ftGuest(5).Text = "0"
   ftGuest(6).Text = ""
   ftGuest(7).Text = ""
   
   ftGuest(0).SetFocus
   
End Sub

Private Function GetGuestInformation(sID As String) As Boolean
  
  On Error GoTo GetERR
  
 '检查该客户编号是否存在
  Dim DB As Connection
  Dim Rs As Recordset
  Dim sTmp As String
  Dim intTmp As Integer
      intTmp = 0
      
  Set DB = CreateObject("adodb.connection")
  Set Rs = CreateObject("adodb.recordset")
      DB.Open Constr
      
     '修改现金库中的押金额及现金额
      sTmp = "Select * from tbdGuest WHere Dguest='" & sID & "'"
      Rs.Open sTmp, DB, adOpenStatic, adLockOptimistic, adCmdText
           
      If Rs.EOF And Rs.BOF Then
         Rs.Close
         Set Rs = Nothing
         DB.Close
         Set DB = Nothing
         MsgBox sID & "编号不存在,无法修改该员工资料。 ", vbExclamation
         GetGuestInformation = False
         Exit Function
         Else
        '给出员工数据
         For intTmp = 0 To 7
             Select Case intTmp
                Case 6
                  If Not IsNull(Rs.Fields("DEmail")) Then
                     ftGuest(intTmp).Text = NullValue(Rs.Fields("DEmail"))
                  End If
                Case 7
                  If Not IsNull(Rs.Fields("DStr")) Then
                     ftGuest(intTmp).Text = NullValue(Rs.Fields("DStr"))
                  End If
                  If Trim(ftGuest(7).Text) <> "" Then
                     On Error Resume Next
                     imgView.Picture = LoadPicture(Trim(ftGuest(7).Text))
                    Else
                     imgView.Picture = LoadPicture()
                  End If
                Case Else
                  If Not IsNull(Rs.Fields(intTmp)) Then
                     ftGuest(intTmp).Text = NullValue(Rs.Fields(intTmp))
                  End If
                End Select
         Next
         ftMemo.Text = NullValue(Rs.Fields("Dmemo"))
      End If
      Rs.Close
      DB.Close
      Set Rs = Nothing
      Set DB = Nothing
      GetGuestInformation = True
      
 Exit Function
GetERR:
  MsgBox "给出员工资料错误:" & Err.Description, vbCritical
  GetGuestInformation = False
  Exit Function
  
End Function