frmin_pztypelist.frm

一个用VB写的财务软件源码

End Sub

Private Sub mnuSave_Click()
    Call Operate("SAVE")
End Sub

Private Sub tbrPzType_ButtonClick(ByVal Button As Button)
    Call Operate(UCase(Button.Key))
End Sub

'打印预览
Private Sub PrintAll(strPrt As String)
    Dim i As Integer
    Dim j As Integer
    Dim frmP As frmPreview
    
    If Printers.Count = 0 Then
        MsgBox "未安装打印。", vbInformation
    Else
        On Error Resume Next
        mfgPzType.HighLight = flexHighlightNever
        mfgPzType.FocusRect = flexFocusNone
        Set frmP = New frmPreview
        With frmP
            .pControlType = pmsFlexGrid
            .pControl = mfgPzType
            .PaperWidth = Printer.Width
            .PaperHeight = Printer.Height
            .PaperScaleTop = Printer.ScaleTop
            .PaperScaleLeft = 500 ' Printer.ScaleLeft
            .PaperScaleWidth = Printer.ScaleWidth * 0.9
            .PaperScaleHeight = Printer.ScaleHeight * 0.9
            .Title = "凭证类别设置表"
            .TitleFontBold = True
            .TitleTop = 200
            .HeadLeft = 700
            .GridLeft = 700
            If strPrt = "PRINT" Then
                .ExcutePrint
            Else
                .ExcutePreview
            End If
        End With
        Unload frmP
        mfgPzType.HighLight = flexHighlightAlways
        mfgPzType.FocusRect = flexFocusHeavy
    End If
End Sub

Private Sub Operate(strKey As String)
    Dim i As Integer, j As Integer
    Dim strUpd As String
    Dim aryKM() As String
    Select Case strKey
        Case "PRINT"
            bChk = False
            Call PrintAll("PRINT")
            bChk = True
 '           frmIN_ItemClass.PrintMfg2 mfgPzType, "凭证类别设置表"
        Case "PREVIEW"
            bChk = False
''            frmUSU_Print.cdlgPrt.ShowPrinter
            Call PrintAll("PREVIEW")
            bChk = True
      '      frmIN_ItemClass.PrintMfg mfgPzType, "凭证类别设置表"
        Case "ADD"
            With mfgPzType
                .Rows = .Rows + 1
                .RowHeight(.Rows - 1) = 300
                .row = .Rows - 1
                .col = 0
                txtTemp.Top = Frame1.Top + .Top + .CellTop
                txtTemp.Left = .CellLeft + .Left + Frame1.Left
                txtTemp.Width = .cellWidth
                .TextMatrix(.row, 2) = "无限制"
            End With
            txtTemp.Visible = True
            txtTemp.text = ""
            If txtTemp.Visible = True Then txtTemp.SetFocus
            cboPzType.Visible = False
            AddFlag = True
            tbrPzType.Buttons("Add").Enabled = False
            tbrPzType.Buttons("Delete").Enabled = False
            tbrPzType.Buttons("Save").Enabled = True
            tbrPzType.Buttons("Cancel").Enabled = True
            mnuNew.Enabled = False
            mnuDelete.Enabled = False
            mnuSave.Enabled = True
            mnuCancel.Enabled = True
        Case "DELETE"
            If mfgPzType.row = 0 Then Exit Sub
            Dim rstRec As New ADODB.Recordset
            Dim sSQL As String
            rstRec.CursorLocation = adUseClient
            sSQL = "select distinct pzzl  from tzw_pzsj" & glo.sOperateYear & "   where pzzl='" & Trim(mfgPzType.TextMatrix(mfgPzType.row, 0)) & "'"
            rstRec.Open sSQL, glo.cnnMain, adOpenStatic, adLockReadOnly
            If Not (rstRec.EOF And rstRec.BOF) Then
                MsgBox "此凭证类别已经在凭证数据表中使用，不可删除！", vbCritical
                rstRec.Close
                Set rstRec = Nothing
                Exit Sub
            End If
            rstRec.Close
            sSQL = "Select * from tZw_zzhdSet" + glo.sOperateYear & " where pzlb='" & Trim(mfgPzType.TextMatrix(mfgPzType.row, 0)) & "'"
            rstRec.Open sSQL, glo.cnnMain, adOpenKeyset, adLockPessimistic
            If Not (rstRec.EOF And rstRec.BOF) Then
                MsgBox "此凭证类别已经在调汇凭证定义中使用，不可删除！", vbCritical
                rstRec.Close
                Set rstRec = Nothing
                Exit Sub
            End If
            rstRec.Close
            Set rstRec = Nothing
            If MsgBox("确认要删除此凭证类别吗？", vbQuestion + vbYesNo) = vbYes Then
                With mfgPzType
                    rSt.Filter = "signtext='" & .TextMatrix(.row, 1) & "'"
                    rSt.Requery
                    For i = .row To .Rows - 2
                        .TextMatrix(i, 0) = .TextMatrix(i + 1, 0)
                        .TextMatrix(i, 1) = .TextMatrix(i + 1, 1)
                        .TextMatrix(i, 2) = .TextMatrix(i + 1, 2)
                        .TextMatrix(i, 3) = .TextMatrix(i + 1, 3)
                    Next i
                    .Rows = .Rows - 1
                End With
                
                txtTemp.Visible = False
                cboPzType.Visible = False
                
                rSt.Delete
                rSt.Requery
                rSt.Filter = adFilterNone
                rSt.Requery
                If mfgPzType.Rows = 1 Then
                    tbrPzType.Buttons("Delete").Enabled = False
                    tbrPzType.Buttons("Save").Enabled = False
                    mnuDelete.Enabled = False
                    mnuSave.Enabled = False
                    mfgPzType.HighLight = flexHighlightNever
                    mfgPzType.FocusRect = flexFocusNone
                    cmdUp.Enabled = False
                    cmdDown.Enabled = False
                End If
                
            End If
        Case "SAVE"
            mfgPzType_LeaveCell
            If ValidAll Then
                txtTemp.Visible = False
                cmdKmList.Visible = False
                cboPzType.Visible = False
                AddFlag = True
                With mfgPzType
                    '先保存顺序更改
                    glo.cnnMain.Execute "DELETE from tZw_Type" & glo.sOperateYear
                    For i = 1 To .Rows - 1
                        Select Case Trim$("" & .TextMatrix(i, 2))
                            Case "借方必有"
                                strUpd = "jfbykm"
                            Case "借方必无"
                                strUpd = "jfbwkm"
                            Case "贷方必有"
                                strUpd = "dfbykm"
                            Case "贷方必无"
                                strUpd = "dfbwkm"
                            Case "凭证必有"
                                strUpd = "pzbykm"
                            Case "凭证必无"
                                strUpd = "pzbwkm"
                            Case Else
                                strUpd = ""
                        End Select
                        rSt.Requery
                        rSt.AddNew
                        rSt.Fields("signID") = i
                        rSt.Fields("sign") = .TextMatrix(i, 0)
                        rSt.Fields("signtext") = .TextMatrix(i, 1)
                        If Trim$("" & .TextMatrix(i, 2)) <> "无限制" Then
                            rSt.Fields(strUpd) = .TextMatrix(i, 3)
                        End If
                        rSt.Update
        '==================================8.12=yao===================================
'                        k = 1
'                        j = 1
'                        While j <> 0
'
''                           j = InStr(Len(Trim$("" & .TextMatrix(k, 3))), ",")
'                            j = InStr(Len(Trim$("" & .TextMatrix(k, 3))), ",")
'
'                           glo.cnnMain.Execute "UPDATE tZW_Km" & glo.sOperateYear & " set bUse=-1 where kmdm='" & Mid(Trim$("" & .TextMatrix(i, 3)), k, j) & "'"
'                           k = j + 1
'                        Wend
'                         If Trim$("" & .TextMatrix(i, 3)) <> "" Then
'                            aryKM() = Split(Trim$("" & .TextMatrix(i, 3)), ",")
'                            For j = LBound(aryKM) To UBound(aryKM)
'                                glo.cnnMain.Execute "UPDATE tZW_Km" & glo.sOperateYear & " set bUse=-1 where kmdm='" & aryKM(j) & "'"
'                            Next j
'                        End If
       '==========================================================================
                    Next i
                    .HighLight = flexHighlightAlways
                    .FocusRect = flexFocusLight
                End With
                AddFlag = False
                tbrPzType.Buttons("Add").Enabled = True
                tbrPzType.Buttons("Delete").Enabled = True
                tbrPzType.Buttons("Cancel").Enabled = False
                mnuNew.Enabled = True
                mnuDelete.Enabled = True
                mnuCancel.Enabled = False
                cmdUp.Enabled = True
                cmdDown.Enabled = True
            Else
                Exit Sub
            End If
        Case "CANCEL"
            txtTemp.Visible = False
            cmdKmList.Visible = False
            cboPzType.Visible = False
            tbrPzType.Buttons("Add").Enabled = True
            tbrPzType.Buttons("Save").Enabled = True
            tbrPzType.Buttons("Delete").Enabled = True
            tbrPzType.Buttons("Cancel").Enabled = False
            mnuNew.Enabled = True
            mnuDelete.Enabled = True
            mnuSave.Enabled = True
            mnuCancel.Enabled = False
            mfgPzType.Rows = mfgPzType.Rows - 1
            If mfgPzType.Rows = 1 Then
                tbrPzType.Buttons("Delete").Enabled = False
                tbrPzType.Buttons("Save").Enabled = False
                mnuDelete.Enabled = False
                mnuSave.Enabled = False
            End If
        Case "HELP"
            Call ShowHelp
        Case "EXIT"
            Unload Me
    End Select

End Sub
Private Function ValidAll() As Boolean
    Dim i As Integer
    Dim sStrKm As String
    Dim rstKm As ADODB.Recordset
    Dim sKm() As String
    
    ValidAll = False
    With mfgPzType
        For i = 1 To .Rows - 1
            If Trim$("" & .TextMatrix(i, 0)) = "" Then
                MsgBox "类型字不能为空！", vbInformation
                .col = 0
                .row = i
                Exit Function
            End If
            If Trim$("" & .TextMatrix(i, 1)) = "" Then
                MsgBox "类型名称不能为空！", vbInformation
                .col = 1
                .row = i
                Exit Function
            End If
            If LenB(StrConv(.TextMatrix(i, 0), vbFromUnicode)) > 4 Then
                MsgBox "凭证类别字长度不能大于4！", vbInformation
                .col = 0
                .row = i
                Exit Function
            End If
            If Trim$("" & .TextMatrix(i, 2)) <> "无限制" And Trim$("" & .TextMatrix(i, 3)) = "" Then
                .TextMatrix(i, 2) = "无限制"
            End If
            If i = 1 Then
                sStrKm = Trim$("" & .TextMatrix(i, 3))
            Else
                sStrKm = sStrKm & "," & Trim$("" & .TextMatrix(i, 3))
            End If
        Next i
    End With
    sKm = Split(sStrKm, ",")
    Set rstKm = New ADODB.Recordset
    With rstKm
        .CursorLocation = adUseClient
        For i = LBound(sKm) To UBound(sKm)
            If sKm(i) <> "" Then
                .Open "SELECT COUNT(*) FROM tZW_Km" & glo.sOperateYear & _
                        " WHERE kmdm = '" & sKm(i) & "'", _
                    glo.cnnMain, adOpenStatic, adLockReadOnly
                If .Fields(0).value = 0 Then
                    MsgBox "限制科目中有的科目不存在！", vbInformation
                    ValidAll = False
                    .Close
                    Exit Function
                End If
            .Close
            End If
        Next i
    End With
    ValidAll = True
End Function

Private Sub txtTemp_KeyDown(KeyCode As Integer, Shift As Integer)
    Select Case KeyCode
        Case vbKeyLeft
            If txtTemp.SelStart > 1 Then Exit Sub
            If mfgPzType.col > 0 Then mfgPzType.col = mfgPzType.col - 1
        Case vbKeyRight
            If txtTemp.SelStart < Len(txtTemp) Then Exit Sub
            If mfgPzType.col < mfgPzType.Cols - 1 Then mfgPzType.col = mfgPzType.col + 1
        Case vbKeyUp
            If mfgPzType.row > 1 Then mfgPzType.row = mfgPzType.row - 1
        Case vbKeyDown
            If mfgPzType.row < mfgPzType.Rows - 1 Then mfgPzType.row = mfgPzType.row + 1
    End Select
    If KeyCode <> vbKeyDelete And KeyCode <> vbKeyHome And KeyCode <> vbKeyEnd Then KeyCode = 0
End Sub

Private Sub txtTemp_KeyPress(KeyAscii As Integer)
    Dim s As String
    If KeyAscii = 13 Then
        If Trim$("" & txtTemp.text) = "" Then
            MsgBox "请输入具体数据！", vbInformation
            Exit Sub
        Else
            With mfgPzType
                If mfgPzType.col = 3 Then
                    txtTemp.text = Trim$(txtTemp.text)
                    If Left$(txtTemp.text, 1) = "," Then txtTemp.text = Mid$(txtTemp.text, 2)
                    If Right$(txtTemp.text, 1) = "," Then
                        If Len(txtTemp.text) > 1 Then
                            txtTemp.text = Mid$(txtTemp.text, 1, Len(txtTemp.text) - 1)
                        Else
                            txtTemp.text = ""
                        End If
                    End If
                End If
                .TextMatrix(.row, .col) = txtTemp.text
                txtTemp.Visible = False
                cmdKmList.Visible = False
            End With
            If mfgPzType.Visible = True Then mfgPzType.SetFocus
        End If
    End If
    If mfgPzType.col = 3 Then
        If (KeyAscii >= Asc("0") And KeyAscii <= Asc("9")) Or KeyAscii = Asc(",") Or KeyAscii = 13 Or KeyAscii = 8 Or KeyAscii = Asc(glo.sSeparateSubject) Then
            If KeyAscii = 13 Then
                txtTemp.Visible = False
                cmdKmList.Visible = False
            End If
            If txtTemp.SelStart = 0 Then
                s = chr(KeyAscii)
                If txtTemp.SelLength > 0 Then
                    s = s + Mid$(txtTemp.text, txtTemp.SelLength + txtTemp.SelStart)
                End If
            Else
                s = Left(txtTemp.text, txtTemp.SelStart) + chr(KeyAscii)
                If txtTemp.SelLength > 0 Then
                    s = s + Mid$(txtTemp.text, txtTemp.SelLength + txtTemp.SelStart)
                End If
            End If
            If InStr(1, s, ",,") Then KeyAscii = 0
        Else
            KeyAscii = 0
        End If
    End If
End Sub

Private Function IsUsed(ByVal s As String) As Boolean
IsUsed = False
    If mfgPzType.col = 0 And bChk Then
        Dim rstRec As New ADODB.Recordset
        Dim sSQL As String
        rstRec.CursorLocation = adUseClient
        sSQL = "select distinct pzzl  from tzw_pzsj" & glo.sOperateYear & "   where pzzl='" & s & "'"
        rstRec.Open sSQL, glo.cnnMain, adOpenStatic, adLockReadOnly
        If Not (rstRec.EOF And rstRec.BOF) Then
            MsgBox "此凭证类别已经在使用，不可修改！", vbCritical
            FrmAct = False
            Exit Function
        End If
    End If
IsUsed = True
End Function