frmmember.frm

用vb写的饮食管理系统功能全面

    
    Set t = Abar.Tools.Add(GetUniqueToolID(), "m_print")
    With t
        .Caption = "打印"
        .SetPicture ddITNormal, LoadResPicture(106, vbResBitmap)
        .ControlType = ddTTButton
        keys(0) = "Control+Q"
        .ShortCuts = keys
        .ToolTipText = "打印"
        .CaptionPosition = ddCPBelow
        .Style = ddSIconText
    End With
    
    Set t = Abar.Tools.Add(GetUniqueToolID(), "m_exit")
    With t
        .Caption = "关闭": Tool.Category = "m_sys"
        .SetPicture ddITNormal, LoadResPicture(103, vbResBitmap)
        .ControlType = ddTTButton
        keys(0) = "Control+C"
        .ShortCuts = keys
        .ToolTipText = "关闭本窗口"
        .CaptionPosition = ddCPBelow
        .Style = ddSIconText
    
    End With
    With b.Tools

        .Insert .Count, Abar.Tools("m_add")
        .Insert .Count, Abar.Tools("m_del")
        .Insert .Count, Abar.Tools("m_modify")
        
        .Insert .Count, Abar.Tools("Separator")
        
        .Insert .Count, Abar.Tools("m_print")
        
        .Insert .Count, Abar.Tools("Separator")
                
        .Insert .Count, Abar.Tools("m_exit")
       
    End With

    Abar.RecalcLayout
    Abar.Refresh
    
    Set dbs = OpenDatabase(ConData, False, False, Constr)
    Set rst = dbs.OpenRecordset("Select 卡号,姓名,性别,电话,邮件,工作单位,职务,折扣率  From VIP", dbOpenDynaset)
    
    Set siteData.Recordset = rst
    fpsp.OperationMode = OperationModeRow
    fpsp.SelBackColor = &HFFC0C0
    InitGrid
    Debug.Print Me.Width
End Sub

Private Sub InitGrid()
         
    With rst
        If .RecordCount > 0 Then
            .MoveLast
            .MoveFirst
        
            Tcode.Text = !卡号
            Tname.Text = !姓名
            Tsex.Text = !性别
            Tphone.Text = !电话
            temail.Text = !邮件
            tunit.Text = !工作单位
            tzw.Text = !职务
            Tprice.Text = !折扣率

        Else
        
            VSrs.Value = 2
            VSrs.Value = 2
        End If
    End With
        
    With fpsp
        .UnitType = UnitTypeTwips

        .RowHeight(0) = 500
        
        .MaxRows = rst.RecordCount
        .MaxCols = rst.Fields.Count
        
        .Row = 0
        .Row2 = .MaxRows
        .Col = 1
        .Col2 = .MaxCols
        
        .BlockMode = True
        .Protect = True
        .FontName = "宋体"
        .FontSize = "9.25"
        .Lock = True
        .BlockMode = False
        
         
        .ColWidth(1) = 1200
        .ColWidth(2) = 800
        .ColWidth(3) = 600
        .ColWidth(4) = 1000
        .ColWidth(5) = 1000
        .ColWidth(6) = 2000
        .ColWidth(7) = 800
        .ColWidth(8) = 800
    End With
        

        
End Sub

Private Sub Form_Unload(Cancel As Integer)
    rst.Close
    Set rst = Nothing
    dbs.Close
    Set dbs = Nothing
    SaveFormSet Me
End Sub

Private Sub ccancle_Click()
    Fredit.Enabled = False
    fpsp.Enabled = True
    
    
    With fpsp
        .Col = 1
        Tcode.Text = .Value
        .Col = 2
        Tname.Text = .Value
        .Col = 3
        Tsex.Text = .Value
        .Col = 4
        Tphone.Text = .Value
        .Col = 5
        temail.Text = .Value
        .Col = 6
        tunit.Text = .Value
        .Col = 7
        tzw.Text = .Value
        .Col = 8
        Tprice.Text = .Value

    End With
    Abar.Tools("m_add").Enabled = True
    Abar.Tools("m_modify").Enabled = True
    Abar.Tools("m_del").Enabled = True
    Abar.Tools("m_print").Enabled = True
End Sub


Private Sub cok_Click()
'On Error GoTo er
    If CheckOK() Then
        If CurrOp = "add" Then
            sqlstr = "Insert into vip (卡号,姓名,性别,电话,邮件,工作单位,职务,折扣率) values ('" & Trim(Tcode.Text) & "','" & Trim(Tname.Text) & _
                     "','" & Tsex.Text & "','" & Tphone.Text & "','" & temail.Text & "','" & _
                     tunit.Text & "','" & tzw.Text & "'," & CStr(Tprice.Text) & ");"
                     
            
            dbs.Execute sqlstr
        
        Else
            fpsp.Row = fpsp.ActiveRow
            fpsp.Col = 1
            t = fpsp.Text
            dbs.Execute "update vip set 卡号 ='" & Tcode.Text & _
                                          "',姓名='" & Tname.Text & _
                                          "',性别='" & Tsex.Text & _
                                          "',电话='" & Tphone.Text & _
                                          "',邮件='" & temail.Text & _
                                          "',工作单位='" & tunit.Text & _
                                          "',职务='" & tzw.Text & _
                                          "',折扣率=" & Tprice.Text & _
                                          " where 卡号 = '" & t & "';"
        End If
        rst.Requery
        InitGrid
        Fredit.Enabled = False
        fpsp.Enabled = True
        Abar.Tools("m_add").Enabled = True
        Abar.Tools("m_modify").Enabled = True
        Abar.Tools("m_del").Enabled = True
        Abar.Tools("m_print").Enabled = True
        
    End If
    

    Exit Sub
er:
    ErrorHandle ""
    Fredit.Enabled = False
    fpsp.Enabled = True
    
    Abar.Tools("m_add").Enabled = True
    Abar.Tools("m_modify").Enabled = True
    Abar.Tools("m_del").Enabled = True
    Abar.Tools("m_print").Enabled = True

End Sub


Private Sub fpsp_LeaveRow(ByVal Row As Long, ByVal RowWasLast As Boolean, ByVal RowChanged As Boolean, ByVal AllCellsHaveData As Boolean, ByVal NewRow As Long, ByVal NewRowIsLast As Long, Cancel As Boolean)
    With fpsp
        .Row = NewRow
        .Col = 1
        Tcode.Text = .Value
        .Col = 2
        Tname.Text = .Value
        .Col = 3
        Tsex.Text = .Value
        .Col = 4
        Tphone.Text = .Value
        .Col = 5
        temail.Text = .Value
        .Col = 6
        tunit.Text = .Value
        .Col = 7
        tzw.Text = .Value
        .Col = 8
        Tprice.Text = .Value
        
    End With
    
End Sub



Private Sub Pic_Resize()
'On Error Resume Next
    fpsp.Left = 0
    fpsp.Top = 0
    fpsp.Height = Pic.Height - 50
    Fredit.Height = fpsp.Height - Fredit.Top
    Fredit.Left = Pic.Width - Fredit.Width - 100
    fpsp.Width = Fredit.Left - 50
    cok.Top = Fredit.Top + Fredit.Height - 350 - cok.Height
    ccancle.Top = cok.Top
End Sub

Private Sub Tprice_Validate(Cancel As Boolean)
    If Not IsNumeric(Tprice.Text) Then
        MsgBox Tprice.Text & "不是有效的折扣率,‘折扣率’必须为数字！", vbCritical, "提示"
        Cancel = True
    
        Tprice.SetFocus
    End If

End Sub


Private Function CheckOK() As Boolean

    CheckOK = False
    
    If Len(Tname.Text) > 0 Then
        If Not IsNumeric(Tprice.Text) Then
            MsgBox Tprice.Text & "不是有效的单价,‘单价’必须为数字！", vbCritical, "提示"
            Tprice.SetFocus
            Exit Function
        End If
        If Len(Trim(Tcode.Text)) = 0 Then
            MsgBox Tcode.Text & "VIP会员代码不能为空,且不能重复,不能保存！", vbCritical, "提示"
            Tcode.SetFocus
            Exit Function
        Else
            '检查卡号
            '检查是否是原号
            If CurrOp = "add" Then
                If CheckProduct("vip", "卡号", Trim(Tcode.Text), 1) <> "" Then
                    MsgBox "卡号重复，不能保存!", vbOKOnly + 64, "卡号不能重复"
                    Tcode.SetFocus
                    Exit Function
                End If
            End If
        
        End If
    Else
        MsgBox Tname.Text & "VIP会员名称不能为空,且不能重复,不能保存！", vbCritical, "提示"
        Tname.SetFocus
    End If
    CheckOK = True
End Function

Private Sub Tname_GotFocus()
    SendKeys "{Home}+{End}"
End Sub

Private Sub Tsp_GotFocus()
    SendKeys "{Home}+{End}"
End Sub


Private Sub SaveAdd_Click()

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(sCardNO) <> Trim(txtFields(1).Text) Then
   If CheckProduct("Detail", "卡号", Trim(txtFields(1).Text), 1) <> "" Then
      MsgBox "卡号重复，不能保存!", vbOKOnly + 64, "卡号不能为空"
      txtFields(1).SetFocus
      Exit Sub
   End If
 End If
'Save Data
  '**************** 开始 *****************
   DBEngine.BeginTrans
   Dim DB As Database, EF As Recordset, x As Integer, tempStr As String
  
  Set DB = OpenDatabase(ConData, False, False, Constr)
      Dim sSQL As String
          sSQL = "Name='" & sName & "'"
  Set EF = DB.OpenRecordset("Detail", dbOpenDynaset, dbOptimistic)
      EF.FindFirst sSQL
    If EF.NoMatch Then
       MsgBox "不可预料的更新错误？   " & vbCrLf & vbCrLf & err.Description, vbCritical
    Else
      EF.Edit
      EF.Fields("Name") = txtFields(0).Text
      EF.Fields("卡号") = txtFields(1).Text
      EF.Fields("性别") = txtFields(2).Text
      EF.Fields("电话") = txtFields(3).Text
      EF.Fields("传真") = txtFields(4).Text
      EF.Fields("传呼") = txtFields(5).Text
      EF.Fields("手机") = txtFields(6).Text
      EF.Fields("邮件") = txtFields(7).Text
      EF.Fields("地址") = txtFields(8).Text
      EF.Update
    End If
      EF.Close
      DB.Close
   DBEngine.CommitTrans
  
  '指针调回编号
   For x = 0 To 8
       txtFields(x).Text = ""
   Next
   
   txtFields(0).SetFocus
   
  '**************** 结束 *****************
  ChangeTrue = False
  NoChange = True
  
  Call frmMember.mnuRefresh_Click  '刷新数据
  
  Unload Me  '关闭
  
End Sub

Private Sub txtFields_Change(Index As Integer)
 
 ChangeTrue = True
 
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 = 0 And txtFields(0).Text <> sReName Then
   Dim DB As Database, EF As Recordset, tempStr As String
   Set DB = OpenDatabase(ConData, False, False, Constr)
   Set EF = DB.OpenRecordset("Detail", dbOpenDynaset)
       tempStr = "Name='" & txtFields(0).Text & "'"
       EF.FindFirst tempStr
   If Not EF.NoMatch Then
        MsgBox "重复的客户名称,请修改!", vbOKOnly + 48, "警告!"
        DB.Close
        txtFields(0).Text = sReName
        txtFields(0).SetFocus
        Exit Sub
       Else
        DB.Close
   End If
End If
End Sub



Private Sub Tsex_KeyPress(KeyAscii As Integer)
    If KeyAscii = 49 Then
       KeyAscii = 0
       Tsex.Text = "男"
    End If
    If KeyAscii = 50 Then
       KeyAscii = 0
       Tsex.Text = "女"
    End If
    SetItFocus Tsex
    KeyAscii = 0

End Sub