frmmemberview.frm

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

   End
   Begin VB.CommandButton cmdSave 
      Caption         =   "保存(&S)"
      Height          =   390
      Left            =   4725
      TabIndex        =   12
      Top             =   5370
      Visible         =   0   'False
      Width           =   1455
   End
   Begin VB.PictureBox Picture1 
      BackColor       =   &H00808000&
      Height          =   630
      Left            =   15
      ScaleHeight     =   570
      ScaleWidth      =   7710
      TabIndex        =   14
      Top             =   15
      Width           =   7770
      Begin VB.Label Label1 
         AutoSize        =   -1  'True
         BackStyle       =   0  'Transparent
         Caption         =   "员 工 资 料 浏 览"
         ForeColor       =   &H00FFFFFF&
         Height          =   210
         Index           =   1
         Left            =   2955
         TabIndex        =   16
         Top             =   225
         Width           =   1785
      End
      Begin VB.Label Label1 
         AutoSize        =   -1  'True
         BackStyle       =   0  'Transparent
         Caption         =   "员 工 资 料 浏 览"
         ForeColor       =   &H00000000&
         Height          =   210
         Index           =   0
         Left            =   2970
         TabIndex        =   15
         Top             =   255
         Width           =   1785
      End
   End
End
Attribute VB_Name = "frmMemberView"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False

Public AddTrue As Boolean   '添加为真时

Public sOldID As String     '修改员工的ID

Private Sub cmbCheck_Change()

  AddTrue = True
  
End Sub

Private Sub cmbCheck_Click()

  AddTrue = True
  ftGuest(12).Text = cmbCheck.ListIndex
    
End Sub

Private Sub cmdCancel_Click()

   IsChangeIT = False
   Unload Me
  
End Sub

Private Sub cmdClear_Click()

   ftGuest(7).Text = ""

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
      ftMemo.Enabled = False
      cmdSave.Enabled = False
      AddTrue = False
      Exit Sub
   End If
   
   AddTrue = False
   
   Exit Sub
LoadERR:
   MsgBox "安装数据错误:" & Err.Description, vbCritical
   cmdSave.Enabled = False
   AddTrue = False
   
   Exit Sub
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