dailyoper.frm

现金系统： 有直销奖金发放等功能

VERSION 5.00
Object = "{5E9E78A0-531B-11CF-91F6-C2863C385E30}#1.0#0"; "MSFLXGRD.OCX"
Begin VB.Form dailyoper 
   Caption         =   "dailyoper"
   ClientHeight    =   5835
   ClientLeft      =   60
   ClientTop       =   450
   ClientWidth     =   13080
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   5835
   ScaleWidth      =   13080
   StartUpPosition =   3  '窗口缺省
   Begin VB.CommandButton Command1 
      Caption         =   "Exit"
      Height          =   255
      Left            =   120
      TabIndex        =   14
      Top             =   2520
      Width           =   975
   End
   Begin VB.CommandButton savea 
      Caption         =   "save"
      Height          =   255
      Left            =   2880
      TabIndex        =   13
      Top             =   2520
      Width           =   855
   End
   Begin VB.Frame Frame1 
      Caption         =   "brief"
      Height          =   1455
      Left            =   2520
      TabIndex        =   11
      Top             =   840
      Width           =   1455
      Begin VB.TextBox brief 
         Height          =   1095
         Left            =   120
         MultiLine       =   -1  'True
         TabIndex        =   12
         Top             =   240
         Width           =   1215
      End
   End
   Begin MSFlexGridLib.MSFlexGrid msfg 
      Height          =   5655
      Left            =   4080
      TabIndex        =   10
      Top             =   120
      Width           =   8895
      _ExtentX        =   15690
      _ExtentY        =   9975
      _Version        =   393216
      Cols            =   6
   End
   Begin VB.ComboBox Cashtype 
      Height          =   300
      Left            =   1200
      Style           =   2  'Dropdown List
      TabIndex        =   9
      Top             =   840
      Width           =   1215
   End
   Begin VB.ComboBox Opertype 
      Height          =   300
      Left            =   1200
      Style           =   2  'Dropdown List
      TabIndex        =   8
      Top             =   1200
      Width           =   1215
   End
   Begin VB.ComboBox Person 
      Height          =   300
      Left            =   1200
      Style           =   2  'Dropdown List
      TabIndex        =   7
      Top             =   1560
      Width           =   1215
   End
   Begin VB.TextBox amount 
      Height          =   270
      Left            =   1200
      TabIndex        =   6
      Top             =   1920
      Width           =   1215
   End
   Begin VB.ComboBox dtdate 
      Height          =   300
      Left            =   2280
      Style           =   2  'Dropdown List
      TabIndex        =   1
      Top             =   240
      Width           =   1575
   End
   Begin VB.Label Label5 
      Caption         =   "InOrOut"
      Height          =   255
      Left            =   120
      TabIndex        =   5
      Top             =   1200
      Width           =   855
   End
   Begin VB.Label Label4 
      Caption         =   "Employee"
      Height          =   255
      Left            =   120
      TabIndex        =   4
      Top             =   1560
      Width           =   855
   End
   Begin VB.Label Label3 
      Caption         =   "Amount"
      Height          =   255
      Left            =   120
      TabIndex        =   3
      Top             =   1920
      Width           =   855
   End
   Begin VB.Label Label2 
      Caption         =   "CashType"
      Height          =   255
      Left            =   120
      TabIndex        =   2
      Top             =   840
      Width           =   855
   End
   Begin VB.Label Label1 
      Caption         =   "Operation"
      Height          =   255
      Left            =   600
      TabIndex        =   0
      Top             =   240
      Width           =   975
   End
End
Attribute VB_Name = "dailyoper"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private Sub amount_KeyPress(KeyAscii As Integer)
 Select Case KeyAscii
        Case 48 To 57 '0-9,這裏還可以限制只能輸入哪幾個數字
            Exit Sub
        Case 8 '退格鍵
            Exit Sub
        Case 46  '  .键   Delete鍵
            If InStr(cashamount, ".") = 0 Then
                Exit Sub
            Else
                KeyAscii = 0
            End If
        Case 45
             If InStr(cashamount, "-") = 0 Or InStr(cashamount, "-") = 1 Then
                Exit Sub
            Else
                KeyAscii = 0
            End If
        Case Else
            KeyAscii = 0
    End Select
End Sub

Private Sub brief_Change()
    If LCase(Trim(brief)) = "initial" Then
        MsgBox "sorry!you cannt input 'initial'"
        brief.SetFocus
    End If
End Sub

Private Sub Cashtype_Click()
Call fillgrid
End Sub

Private Sub Command1_Click()
   Unload Me
End Sub



Private Sub dtdate_Click()
If Cashtype.ListCount > 0 Then
Cashtype.ListIndex = 0
End If
    If Cashtype.ListIndex <> -1 Then
    Call fillgrid
    End If

End Sub

Private Sub Form_Load()
MSFg.FormatString = " No|  operDate |   Employee   |          Brief       |    Income   |  Payment   |     Remained  "

ddt = Date
For i = -1000 To 2
  mm = ddt + i
  strdate = Format(mm, "yyyy-MM-dd")
dtdate.AddItem strdate
Next i

Dim db As Database
Set db = DAO.OpenDatabase(App.Path + "\cashsys.mdb") ', False , False , " ; pwd=1234")
Dim rs As Recordset
Set rs = db.OpenRecordset("SELECT str(CASHTYPE) +'|'+ CASHNAME as TypeName From Cashtype ORDER BY CASHTYPE")
Do While Not rs.EOF
    Cashtype.AddItem rs("TypeName")
    rs.MoveNext
Loop
    Me.Opertype.AddItem "0|IN"
    Me.Opertype.AddItem "1|OUT"
Set rs = db.OpenRecordset("SELECT str(personNo) +'|'+personname as person FROM PERsons")
Do While Not rs.EOF
    Person.AddItem rs("person")
    rs.MoveNext
Loop

rs.Close
db.Close
Set rs = Nothing
Set db = Nothing
 amount.Text = 0
dtdate.ListIndex = 1000


End Sub

Private Sub savea_Click()
    If Cashtype.ListIndex = -1 Or Opertype.ListIndex = -1 Or Person.ListIndex = -1 Then
        MsgBox "pls select cashtype or inorout or Employee"
        Cashtype.SetFocus
        Exit Sub
    End If
    If Len(Trim(brief.Text)) = 0 Then
        MsgBox "pls input Brief"
        brief.SetFocus
        Exit Sub
    End If
    If Trim(brief.Text) = "initial" Then
        MsgBox " sorry you cannt input 'initial'"
        brief.SetFocus
        Exit Sub
    End If
    If amount.Text = "-" Then
    MsgBox "pls input amount"
    amount.SetFocus
    Exit Sub
    End If
     Dim ttCtype As String
     ttCtype = Left(Cashtype.Text, InStr(Cashtype.Text, "|") - 1)
     Dim ttCtypename As String
     ttCtypename = Right(Cashtype.Text, Len(Cashtype.Text) - InStr(Cashtype.Text, "|"))
     Dim ttOpertype As String
     ttOpertype = Left(Opertype.Text, InStr(Opertype.Text, "|") - 1)
     Dim ttOpertypename As String
     ttOpertypename = Right(Opertype.Text, Len(Opertype.Text) - InStr(Opertype.Text, "|"))
     Dim ttperson As String
     ttperson = Left(Person.Text, InStr(Person.Text, "|") - 1)
     Dim ttpersonName As String
     ttpersonName = Right(Person.Text, Len(Person.Text) - InStr(Person.Text, "|"))
     
    If MsgBox(" save the following information:" + ttCtypename + vbCrLf + "        InOrOut:" + ttOpertypename + vbCrLf + "       employee:" + ttpersonName + vbCrLf + "         brief:" + brief + vbCrLf + "        amount:" + Format(amount, "#,###.00") + vbCrLf + "?", vbYesNo) = vbNo Then
        Exit Sub
    End If
    Dim db As DAO.Database
    Dim rs As DAO.Recordset
    Dim oldvalue
Set db = DAO.OpenDatabase(App.Path + "\cashsys.mdb") ', False , False , " ; pwd=1234")
    Set rs = db.OpenRecordset("SELECT top 1  operdate FROM CASH where cashtype=" + ttCtype + " ORDER BY ID DESC")
    Dim dateo
    dateo = dtdate.Text
    If rs("operdate") > dateo Then
       MsgBox "the date is over,pls check"
       Exit Sub
    End If
     Set rs = db.OpenRecordset("SELECT top 1 operdate, idcash  FROM CASH where brief<>'initial' ORDER BY ID DESC")
  Dim idcash
  If rs.EOF = True Then
     idcash = 1
Else
Dim ttOperdate
ttOperdate = rs("operdate")
If Int(Mid(ttOperdate, 6, 2)) <> Int(Mid(dateo, 6, 2)) Then
MsgBox "NO from new start  "
    idcash = 1
   Else
     idcash = rs("idcash") + 1
     End If
     End If
    Set rs = db.OpenRecordset("SELECT top 1  REMAINAMOUNT FROM CASH where cashtype=" + ttCtype + " ORDER BY ID DESC")
    If ttOpertype = 0 Then
    oldvalue = rs("remainamount") + amount
    Else
   oldvalue = rs("remainamount") - amount
    End If
    db.Execute " insert into cash (operdate,opertype,person,brief,cashtype,amount,remainamount,operator,idcash)  values ('" + dateo + "'," + ttOpertype + ",'" + ttpersonName + "','" + brief + "'," + ttCtype + "," + Trim(amount) + "," + Trim(oldvalue) + ",' '," + Trim(idcash) + ")"
    Call fillgrid
    'amountonaccount = oldvalue
    MsgBox "saved ,No is:" + Trim(idcash)
    rs.Close
    db.Close
    'diff = realamount - amountonaccount


Exit_savedata_Click:
    Exit Sub

Err_savedata_Click:
    MsgBox Err.Description
    Resume Exit_savedata_Click
End Sub
Private Sub fillgrid()
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim ttCtype As String
     ttCtype = Left(Cashtype.Text, InStr(Cashtype.Text, "|") - 1)
     
Set db = DAO.OpenDatabase(App.Path + "\cashsys.mdb")
strsql = "SELECT idcash as No,o as operDate,P as Employee,B as Brief,IIF(OP=0,A,'') AS Income,IIF(OP=1,A,'') AS PayOut,R as Remained,id FROM " & _
   "(SELECT top 1 ' ' as idcash,' ' as o,' ' as P,'Beginning' as B,0 as a,REMAINAMOUNT as r,id,OPERTYPE as op FROM CASH  where operdate<'" + dtdate.Text + "' and cashtype=" + ttCtype + " order by id desc " & _
   "union  SELECT idcash,operdate as o,PERSON as p,BRIEF as b,AMOUNT as a,REMAINAMOUNT as r,id,OPERTYPE as op FROM CASH where operdate='" + dtdate.Text + "' and cashtype=" + ttCtype + ")  as a order by a.id"

Set rs = db.OpenRecordset(strsql)
MSFg.FormatString = " No|  operDate |   Employee   |          Brief       |    Income   |  Payment   |     Remained  "
MSFg.Rows = rs.RecordCount + 1
MSFg.Cols = rs.Fields.count - 1
Do While Not rs.EOF
i = i + 1
    For j = 0 To rs.Fields.count - 2
     If j > 3 Then
   MSFg.TextMatrix(i, j) = Format(rs(j), "#,###.00")
   Else
   MSFg.TextMatrix(i, j) = rs(j)
   End If
 Next
  
    rs.MoveNext
Loop
rs.Close
db.Close
Set rs = Nothing
Set db = Nothing
End Sub