frmcuikd.frm

财务信息管理系统,适合做毕业论文的人使用

            If Shift = 4 Then
                Gen_Key "Exit"
            End If
        Case vbKeyF6
            If Shift = 0 And Tlbckd.Buttons("SaveRecord").Enabled Then
                Gen_Key "SaveRecord"
            End If
        Case vbKeyY
            If Shift = 2 And Tlbckd.Buttons("DeleteRecord").Enabled And Tlbckd.Buttons("DeleteRecord").ToolTipText = "Ctrl+Y" Then
                Gen_Key "DeleteRecord"
                KeyCode = 0
            End If
        Case vbKeyR
            If Shift = 2 And Tlbckd.Buttons("DeleteRecord").Enabled And Tlbckd.Buttons("DeleteRecord").ToolTipText = "Ctrl+R" Then
                Gen_Key "DeleteRecord"
                KeyCode = 0
            End If
        Case vbKeyP
            If Shift = 2 And Tlbckd.Buttons("Print").Enabled Then
                Gen_Key "Print"
                KeyCode = 0
            End If
        Case vbKeyS
            'cuidong 2001.01.15
            'If Shift = 2 And Tlbckd.Buttons("Preview").Enabled Then
            '    Gen_Key "Preview"
            '    KeyCode = 0
            'End If
        Case vbKeyW
            If Shift = 2 And Tlbckd.Buttons("Dataout").Enabled Then
                Gen_Key "Dataout"
                KeyCode = 0
            End If
    End Select
End Sub

Private Sub Gen_Key(TLB_Key As String)
    On Error Resume Next
    Select Case TLB_Key
        Case Is = "Print", "Preview"
            UfGridADO1.ColWidth(0) = 2100
            UfGridADO1.ColWidth(1) = 2100
            UfGridADO1.ColWidth(2) = 1200
            UfGridADO1.ColWidth(3) = 1200
            UfGridADO1.ColWidth(4) = 3000
            zjbPrnViewOut Me, "cuikdj", TLB_Key, False
            UfGridADO1.ColWidth(0) = 1200
            UfGridADO1.ColWidth(1) = 1200
            UfGridADO1.ColWidth(1) = 830
            UfGridADO1.ColWidth(1) = 810
            UfGridADO1.ColWidth(1) = 2300
        Case Is = "Dataout"
            wTabPrnPaperSet
        Case Is = "SaveRecord"
            If Contquit() Then
                CuikdSave
                If isSave Then
                    Tlbckd.Buttons("DeleteRecord").Image = "DeleteRecord"
                    Tlbckd.Buttons("DeleteRecord").Caption = "删除"
                End If
            End If
        Case Is = "DeleteRecord"
            If IsNew Or isSave Then
                If PromptDel = vbYes Then
                    If Not IsNew Then
                        dbsZJ.Execute "Delete  from FD_Hasten Where Right([cHid],5) = '" & right(Label2(1).Caption, 5) & "'"
                    End If
                    isSave = True
                    Unload Me
                    Exit Sub
                End If
            Else
                Hfcuikd
                Tlbckd.Buttons("DeleteRecord").Image = "DeleteRecord"
                Tlbckd.Buttons("DeleteRecord").Caption = "删除"
            End If
        Case Is = "Help"
            SendKeys "{F1}"
        Case Is = "Exit"
            Unload Me
            Exit Sub
    End Select
    
    Tlbckd.Buttons("Preview").Enabled = isSave
    Tlbckd.Buttons("Print").Enabled = isSave
    Tlbckd.Buttons("Dataout").Enabled = isSave
    Tlbckd.Buttons("SaveRecord").Enabled = Not isSave
End Sub

Private Sub UpDown1_DownClick(Index As Integer)
    Dim mon As Integer
    If IsNumeric(Edity1(Index).Text) Then
        mon = CInt(Edity1(Index).Text)
    Else
        mon = 0
    End If
    If 1 + mon > 2 Then
        Edity1(Index).Text = mon - 1
    End If
End Sub

Private Sub UpDown1_UpClick(Index As Integer)
    Dim mon As Integer
    If IsNumeric(Edity1(Index).Text) Then
        mon = CInt(Edity1(Index).Text)
    Else
        mon = 0
    End If
    If mon < 12 Then
        Edity1(Index).Text = mon + 1
    End If
End Sub

Private Sub UpDown2_DownClick(Index As Integer)
    Dim mon As Integer
    If IsNumeric(Editr1(Index).Text) Then
        mon = CInt(Editr1(Index).Text)
    Else
        mon = 0
    End If
    If 1 + mon > 2 Then
        Editr1(Index).Text = mon - 1
    End If
End Sub

Private Sub UpDown2_UpClick(Index As Integer)
    Dim mon As Integer
    If IsNumeric(Editr1(Index).Text) Then
        mon = CInt(Editr1(Index).Text)
    Else
        mon = 0
    End If
    If IsDate(str(Year(zjLogInfo.curDate)) & "-" & Edity1(Index).Text & "-" & str(mon + 1)) Then
         Editr1(Index).Text = mon + 1
    End If
End Sub
' 条件合法性检查
Private Function Contquit() As Boolean
    Contquit = False
    If Editdw.Text = "" Then
        Beep
        MsgBox "付款单位不能为空！", vbCritical, zjGl_Name
        SetTxtFocus Editdw
        Exit Function
    End If
    
    Dim idn As Byte
    If Option1(0).Value = True Then
        idn = 0
    Else
        idn = 1
    End If
    If Edity1(idn) = "" Then
        Beep
        MsgBox "日期不能为空，请检查！", vbCritical, zjGl_Name
        SetTxtFocus Edity1(idn)
        Exit Function
    Else
        If val(Edity1(idn).Text) > 12 Or val(Edity1(idn).Text) < 1 Then
            Beep
            MsgBox "日期非法，请检查！", vbCritical, zjGl_Name
            SetTxtFocus Edity1(idn)
            Exit Function
        End If
    End If
    
    If Editr1(idn) = "" Then
        Beep
        MsgBox "日期不能为空，请检查！", vbCritical, zjGl_Name
        SetTxtFocus Editr1(idn)
        Exit Function
    Else
        If Not IsDate(str(Year(zjLogInfo.curDate)) & "-" & Edity1(idn).Text & "-" & Editr1(idn)) Then
            Beep
            MsgBox "日期非法，请检查！", vbCritical, zjGl_Name
            SetTxtFocus Editr1(idn)
            Exit Function
        End If
    End If
    
    Contquit = True

End Function

Private Sub CuikdSave()
    On Error Resume Next
    Dim sav_js As Integer
    If isSave Then Exit Sub
    'If Not Net_Gen Then Exit Sub
    sav_js = 0
cf: CuikdSave1
'    If Not isSave Then
'        sav_js = sav_js + 1
'        If sav_js < 1000 Then GoTo cf
'        Beep
'        MsgBox "其他工作站正在保存，请过一会儿再试！", vbCritical, zjGl_Name
'    End If
    'zjLogInfo.TaskExec "SYSLOCK10", False
End Sub

Private Sub CuikdSave1()
    Dim newmaxbh As String, rsTemp As New UfRecordset, oldbh As String
    On Error GoTo er1
    newmaxbh = Label2(1).Caption
    BillSaveLock "CKD"  'cuidong 2001.08.28
    If IsNew Then
'        Set rsTemp = dbsZJ.OpenRecordset("FD_Hasten", dbOpenTable)  'CuiDong Efficiency-A 2000/06/20 效率优化A
'        Set rsTemp = dbsZJ.OpenRecordset("Select * From FD_Hasten Where cHid='" & newmaxbh & "'", dbOpenTable)                   'cuidong 2001.08.22 'CuiDong Efficiency-A 2000/06/20 效率优化A

        Set rsTemp = dbsZJ.OpenRecordset("Select * From FD_Hasten Where cHid='" & newmaxbh & "' Order by cHid Desc", dbOpenTable) 'cuidong 2001.08.22 'CuiDong Efficiency-A 2000/06/20 效率优化A
        With rsTemp
'            .Index = "PrimaryKey"                                   'CuiDong Efficiency-A 2000/06/20 效率优化A
'            .FindFirst "cHid='" + newmaxbh + "'"                    'CuiDong Efficiency-A 2000/06/20 效率优化A
'            If Not .NoMatch Then                                    'CuiDong Efficiency-A 2000/06/20 效率优化A
            If Not (.EOF Or .BOF) Then                               'CuiDong Efficiency-A 2000/06/20 效率优化A
                .oClose
                Set rsTemp = dbsZJ.OpenRecordset("Select Max(cHid) From FD_Hasten")
                newmaxbh = right(str(100000001 + IIf(IsNull(![cHid]), 0, val(![cHid]))), 8)
                Label2(1).Caption = newmaxbh
            End If
            .oClose
        End With
        rsTckd.AddNew
    Else
        rsTckd.FindFirst "[cHid]='" & newmaxbh & "'"
        If rsTckd.NoMatch Then
            IsNew = True
            rsTckd.AddNew
        Else
            rsTckd.Edit
        End If
    End If
    Savdata newmaxbh
    BillSaveUnLock "CKD"  'cuidong 2001.08.28
    
    CloseRS rsTemp
    Exit Sub
er1:
    Select Case Err.Number
    Case 3167
        rsTckd.AddNew
        IsNew = True
        Savdata newmaxbh
        BillSaveUnLock "CKD"  'cuidong 2001.08.28
    Case 3022
        Savdata Getmaxbh()
        BillSaveUnLock "CKD"  'cuidong 2001.08.28
    Case Else
        BillSaveUnLock "CKD"  'cuidong 2001.08.28
        MsgBox "由于网络原因，暂时不能保存。" & vbCrLf & vbCrLf & "请稍后再试。", vbOKOnly + vbInformation, zjGl_Name  'cuidong 2001.08.28
        
    End Select
    CloseRS rsTemp
End Sub
' 给表赋值
Private Sub Savdata(bh As String)
    With rsTckd
        ![cUnitNmae] = Editdw.Text
        ![cHid] = bh
        ![cexch_name] = Label2(2).Caption
        ![ctext] = IIf(Editbh.Text = "", Null, Editbh.Text)
        ![mMoney] = Unforstr(Label2(3).Caption)
        ![dBeday] = zjLogInfo.curDate
        ![cIntrest] = Unforstr(UfGridADO1.TextMatrix(UfGridADO1.Rows - 1, 4))
        ![cMark] = IIf(Editbz.Text = "", Null, Editbz.Text)
        If Option1(0).Value Then
            ![dDate1] = Year(zjLogInfo.curDate) & "-" & Edity1(0).Text & "-" & Editr1(0).Text
        Else
            ![dDate2] = Year(zjLogInfo.curDate) & "-" & Edity1(1).Text & "-" & Editr1(1).Text
        End If
        .Update
        Label2(1).Caption = bh
        If IsNew Then
            Dim i As Integer, j As Integer
            j = UfGridADO1.Rows - 2
            For i = 2 To j
                .AddNew
                ![cHid] = right(str(1000 + i), 3) & right(bh, 5)
                ![dBeday] = UfGridADO1.TextMatrix(i, 0)
                ![dEndday] = UfGridADO1.TextMatrix(i, 1)
                ![Intra] = UfGridADO1.TextMatrix(i, 2)
                ![Days] = UfGridADO1.TextMatrix(i, 3)
                ![cMoney] = UfGridADO1.TextMatrix(i, 4)
                .Update
            Next
        End If
    End With
    IsNew = False
    isSave = True
End Sub

Private Sub Tbr_Change()
    If Frtin Then
        Exit Sub
    End If
    If isSave Then
        Tlbckd.Buttons("Preview").Enabled = False
        Tlbckd.Buttons("Print").Enabled = False
        Tlbckd.Buttons("Dataout").Enabled = False
        Tlbckd.Buttons("SaveRecord").Enabled = True
        If Not IsNew Then
            Tlbckd.Buttons("DeleteRecord").Image = "RestoreRecord"
            Tlbckd.Buttons("DeleteRecord").Caption = "恢复"
        End If
        isSave = False
    End If
End Sub

Private Sub Hfcuikd()
    Frtin = True
    With rsTckd
        .FindFirst "[cHid]='" & Label2(1).Caption & "'"
        Editdw.Text = ![cUnitNmae]
        If IsNull(![ctext]) Then
            Editbh.Text = ""
        Else
            Editbh.Text = ![ctext]
        End If
        If IsNull(![cMark]) Then
            Editbz.Text = ""
        Else
            Editbz.Text = ![cMark]
        End If
        
        If IsNull(![dDate1]) Then
            Option1(0).Value = False
            Option1(1).Value = True
            Edity1(1).Text = Month(![dDate2])
            Editr1(1).Text = Day(![dDate2])
        Else
            Option1(1).Value = False
            Option1(0).Value = True
            Edity1(0).Text = Month(![dDate1])
            Editr1(0).Text = Day(![dDate1])
        End If
    End With
    Frtin = False
    isSave = True
End Sub