frmlistvoucher.frm

金算盘软件代码

        
        '设置按纽菜单/右键菜单
        Utility.CloneMenu .mnuEditEdit, .mnuListEditMenu(0)       '修改
        Utility.CloneMenu .mnuEditNew, .mnuListEditMenu(1)        '新增
        Utility.CloneMenu .mnuEditDel, .mnuListEditMenu(2)        '删除
        Utility.CloneMenu .mnuEditBar2, .mnuListEditMenu(3)       '----
        .mnuListEditMenu(4).Caption = "冲销(&S)"                  '冲销
        .mnuListEditMenu(4).Enabled = blnIsnotEmpty
        .mnuListEditMenu(4).Visible = True
        Utility.CloneMenu .mnuEditBar2, .mnuListEditMenu(5)       '----
        Utility.CloneMenu .mnuEditInActive, .mnuListEditMenu(6)   '作废
        .mnuListEditMenu(6).Visible = True
        Utility.CloneMenu .mnuEditShowAll, .mnuListEditMenu(7)    '显示所有/显示非作废
        .mnuListEditMenu(7).Visible = True
        Utility.CloneMenu .mnuEditBar2, .mnuListEditMenu(8)       '----
        .mnuListEditMenu(8).Visible = True
        .mnuListEditMenu(9).Caption = "复核(&A)"                  '复核/取消复核
        .mnuListEditMenu(10).Caption = "记帐(&B)"                  '记帐/取消记帐
        Utility.CloneMenu .mnuEditBar2, .mnuListEditMenu(11)       '----
        .mnuListEditMenu(12).Caption = "多张复核(&I)"             '多张复核
        .mnuListEditMenu(13).Caption = "多张取消(&J)"             '多张取消
        Utility.CloneMenu .mnuEditBar2, .mnuListEditMenu(14)      '----
        .mnuListEditMenu(15).Caption = "多张记帐(&K)"             '多张记帐
        .mnuListEditMenu(16).Caption = "多张取消(&L)"             '多张取消
        Utility.CloneMenu .mnuEditBar2, .mnuListEditMenu(17)      '----
        .mnuListEditMenu(18).Caption = "凭证分册(&P)"             '多张记帐
        Utility.CloneMenu .mnuEditBar2, .mnuListEditMenu(19)      '----
        Utility.CloneMenu .mnuEditFilter, .mnuListEditMenu(20)    '筛选
        Utility.CloneMenu .mnuEditColumn, .mnuListEditMenu(21)    '栏目设置
        Utility.CloneMenu .mnuEditBar2, .mnuListEditMenu(22)      '----
        Utility.CloneMenu .mnuToolRefresh, .mnuListEditMenu(23)   '刷新
        Utility.CloneMenu .mnuFilePrintReceipt, .mnuListEditMenu(24)
        Utility.CloneMenu .mnuFilePrint, .mnuListEditMenu(25)     '打印
        .mnuFilePrintSetup.Enabled = True
    End With
    mblnIsFindTextChange = False
    With mclsList
    If mclsList.DbTabCtrl.Row = 0 Then  '无当前选定行
        txtFind.Text = ""
        cmdAgain.Enabled = False
    Else
        If .DbTabCtrl.Row < .TotalRow(.intTab) + 1 Then
            '.Resultset(.intTab).Move .DbTabCtrl.Row - 1, 1
            .Resultset(.intTab).AbsolutePosition = .DbTabCtrl.Row
            txtFind.Text = .Resultset(.intTab).rdoColumns(.SortCol + 1)
        End If
    End If
    End With
    mblnIsFindTextChange = True
    frmMain.SetToolBar
End Sub

Private Sub mclsMainControl_ListEditMenu(ByVal intIndex As Integer)
    If mclsList.ListSet.ListID < 1 Then
       mclsList.ListSet.SaveList
       DefaultCurrentDate mclsList.ListSet.ListID, 9975
    End If
    frmVoucherMultiList.MuliListID = mclsList.ListSet.ListID
    Select Case intIndex
    Case 0: '修改
        blnChange = True
        mclsMainControl_EditEdit
    Case 1: '新增
        blnChange = True
        mclsMainControl_EditNew
    Case 2: '删除
        mclsMainControl_EditDel
    Case 4: '冲销
        Dim lngVoucherID As Long
        lngVoucherID = GetlngVoucherID()
        If lngVoucherID = -1 Then lngVoucherID = 0
        lngVoucherID = frmWriteOffBill.WriteOffBill(41, lngVoucherID, Me.hWnd)
        If lngVoucherID > 0 Then theEditForm.GenCacelVoucher lngVoucherID
    Case 6 '作废
        mclsMainControl_EditInActive
    Case 7: '全部显示
        mclsMainControl_EditShowAll
    Case 9: '复核/取消复核
        If mclsVoucher.ChangeCheck(GetlngVoucherID(), strVoucher) Then
            RefreshRecList
        Else
            mclsList.Resultset(0).Requery
        End If
    Case 10: '记帐/取消记帐
        If mclsVoucher.ChangePost(GetlngVoucherID(), strVoucher) Then
            RefreshRecList
        Else
            mclsList.Resultset(0).Requery
        End If
    Case 12: '多张复核
        mclsVoucher.MultiCheckVoucher
        If Me.Visible Then cboFindKind.SetFocus
    Case 13: '多张取消
        mclsVoucher.MultiUnCheckVoucher
        If Me.Visible Then cboFindKind.SetFocus
    Case 15: '多张记帐
        mclsVoucher.MultiPostVoucher
        If Me.Visible Then cboFindKind.SetFocus
    Case 16: '多张取消
        mclsVoucher.MultiUnPostVoucher
        If Me.Visible Then cboFindKind.SetFocus
    Case 18
        frmVoucherVolume.ShowVoucherVolume gclsBase.AccountYear, gclsBase.Period, 0
    Case 20: '筛选
        mclsMainControl_EditFilter
    Case 21: '栏目设置
        mclsMainControl_EditColumn
    Case 23: '刷新
        mclsMainControl_ToolRefresh
    Case 24: '打印
        mclsMainControl_FilePrintReceipt
    Case 25
        mclsMainControl_FilePrint
    End Select
    blnChange = False
    'mclsList.Resultset(mclsList.intTab).Requery
    'Me.Refresh
    mclsList.DbTabCtrl.Refresh
End Sub
Private Sub MakeListEditMenu()
    Dim intCnt As Integer
    Dim i As Integer
    With frmMain
        For intCnt = .mnuListEditMenu.Count - 1 To 1 Step -1
            Unload .mnuListEditMenu(intCnt)
        Next
        For i = 1 To 25
            Load .mnuListEditMenu(i)
        Next i
    End With
    blnMenuBuilded = True
End Sub
Private Sub MakeListReportMenu(Optional ByVal strAccount As String = "")
    Dim intCnt As Integer
'    Dim blnIsnotEmpty As Boolean
'    'If blnReceptionList And blnIsHavingReport Then
'    With frmMain
'        For intCnt = .mnuListReportMenu.Count - 1 To 1 Step -1
'            Unload .mnuListReportMenu(intCnt)
'        Next
'        For intCnt = 1 To mintReportNo - 1
'            Load .mnuListReportMenu(intCnt)
'        Next
'        For intCnt = 0 To mintReportNo - 1
'            .mnuListReportMenu(intCnt).Caption = mstrReportName(intCnt)
'        Next
'    End With
   ' End If
    With frmMain
        For intCnt = .mnuListReportMenu.Count - 1 To 1 Step -1
            Unload .mnuListReportMenu(intCnt)
        Next
        
        .mnuListReportMenu(0).Caption = "科目汇总表(&A)"
        .mnuListReportMenu(0).Enabled = True
        .mnuListReportMenu(0).Visible = True
        .mnuListReportMenu(0).Checked = False
        
        Load .mnuListReportMenu(1)
        .mnuListReportMenu(1).Caption = "凭证汇总表(&V)"
        .mnuListReportMenu(1).Enabled = True
        .mnuListReportMenu(1).Visible = True
        .mnuListReportMenu(1).Checked = False
    End With

End Sub
Private Sub txtFind_Change()
    cmdAgain.Enabled = True
    If mblnIsFindTextChange Then mclsList.FindText txtFind.Text
End Sub
Private Sub txtFind_KeyDown(KeyCode As Integer, Shift As Integer)
    Dim intSelLen As Integer
    If KeyCode = 8 Then
        intSelLen = txtFind.SelLength
        If txtFind.SelStart > 0 Then txtFind.SelStart = txtFind.SelStart - 1
        txtFind.SelLength = intSelLen + 1
    End If
End Sub

Private Sub cMsgBox(strMsg As String, Optional strTitle As String)
    If Trim(strTitle) = "" Then
        strTitle = "提示信息"
    End If

    ShowMsg Me.hWnd, strMsg, MB_OK + MB_ICONEXCLAMATION + MB_SYSTEMMODAL, strTitle
End Sub


Public Function SetFormation()
    Dim lngFRow As Long
    Dim lngSRow As Long
    Dim intCol As Integer
    Dim strCompareDate As String
    Dim strCompareNo As String
    Dim intColData As Integer
    Dim intColNo As Integer
    Dim intCnt As Integer
    With mclsList.Resultset(0)
        If mclsList.TotalRow(0) < 1 Then Exit Function
        .MoveFirst
        For intCnt = 0 To .rdoColumns.Count - 1
            If .rdoColumns(intCnt).Name = "日期" Then
                intColData = intCnt
            ElseIf .rdoColumns(intCnt).Name = "凭证字号" Then
                intColNo = intCnt
            End If
        Next
        lngSRow = 0
        lngFRow = 1
        strCompareDate = .rdoColumns("日期").Value
        
        strCompareNo = .rdoColumns("凭证字号").Value
        Do Until .EOF
            .MoveNext
            If .EOF Then Exit Do
            lngSRow = lngSRow + 1
           If .rdoColumns("日期").Value = strCompareDate And .rdoColumns("凭证字号") = strCompareNo Then
                mclsList.DbTabCtrl.CellFormula(lngFRow + lngSRow, intColData) = " "
                mclsList.DbTabCtrl.CellFormula(lngFRow + lngSRow, intColNo) = " "
           Else
                strCompareDate = .rdoColumns("日期").Value
                strCompareNo = .rdoColumns("凭证字号").Value
'                mclsList.DbTabCtrl.SetRowAlignment lngFRow, lngFRow + lngSRow - 1, -1, -1, 1, lngSRow, 2
               ' mclsList.DbTabCtrl.SetCellAlignment lngFRow, intColData, lngFRow + lngSRow - 1, intColData, -1, -1, -1, lngSRow, -1
                'mclsList.DbTabCtrl.SetCellAlignment lngFRow, intColNo, lngFRow, intColNo, -1, -1, -1, lngSRow, -1
                lngFRow = lngFRow + lngSRow
                lngSRow = 0
           End If
        Loop
'        mclsList.DbTabCtrl.SetRowAlignment lngFRow, lngFRow + lngSRow - 1, -1, -1, 1, lngSRow, 2
        'mclsList.DbTabCtrl.SetCellAlignment lngFRow, 2, lngFRow, 2, -1, -1, -1, lngSRow, -1
       ' mclsList.DbTabCtrl.SetCellAlignment lngFRow, intColData, lngFRow + lngSRow - 1, intColData, -1, -1, -1, lngSRow, -1
        'mclsList.DbTabCtrl.SetCellAlignment lngFRow, intColNo, lngFRow, intColNo, -1, -1, -1, lngSRow, -1
    End With
    
End Function
Private Function GetlngVoucherID()
    Dim i As Integer
    Dim bFound As Boolean
    Dim recTmp As rdoResultset
    Dim strSql As String
    Dim lngID As Long
    
    With mclsList.DbTabCtrl
        If .Row > 0 Then
            'GetlngVoucherID = CLng(.CellValue(.Row, 0))
            lngID = CLng(.CellValue(.Row, 0))
        Else
            GetlngVoucherID = -1
            Exit Function
        End If
        strVoucher = ""
        '获得本张凭证的凭证名称
        strSql = "Select VOUCHERTYPE.STRVOUCHERTYPECODE  ||  ' '  ||  TO_CHAR(VOUCHER.INTVOUCHERNO,'0000') as Nun from Voucher ,VoucherType " _
                & " Where Voucher.lngVoucherTypeID = VoucherType.lngVoucherTypeID and " _
                & " Voucher.lngVoucherID=" & lngID
        Set recTmp = gclsBase.BaseDB.OpenResultset(strSql, rdOpenForwardOnly)
        If Not recTmp.EOF Then
            GetlngVoucherID = lngID
            strVoucher = recTmp!Nun
        Else
            Exit Function
        End If
        recTmp.Close
        Set recTmp = Nothing
        strVoucher = "“" + strVoucher + "”"
    End With
'        For i = 1 To .Cols - 1
'            If "凭证字号" = Trim(.CellValue(0, i)) Then
'                intFindCol = i
'                bFound = True
'                Exit For
'            End If
'        Next i
'        If Not bFound Then Exit Function
'        '从本行开始往上找
'        i = .Row
'        Do While i >= 1
'            If CLng(.CellValue(i, 0)) = GetlngVoucherID Then
'                i = i - 1
'            Else
'                Exit Do
'            End If
'        Loop
'        strVoucher = .CellValue(i + 1, intFindCol)
    
End Function


Private Function RefreshRecList()
     Dim strSql As String
    Debug.Print "Re1: "; Timer
    mclsList.DbTabCtrl.Clear
'    If mV_Connect.State = 1 Then
'        mV_Connect.Close
'    End If
'    mV_Connect.Open
'    If mclsList.Resultset(0).State = 1 Then
'        mclsList.Resultset(0).Close
'    End If
'    strSql = mclsList.Resultset(0).Source
'    mclsList.Resultset(0).Open strSql, mV_Connect, adOpenStatic
    mclsList.Resultset(0).Requery
    'mclsList.RefreshCurrTab 0
    ToolRefresh
    mclsList.SetGridFormate
    Debug.Print "Re2: "; Timer
    'SetFormation
    mclsList.DbTabCtrl.Refresh
    UpdateEditMenuStatus
End Function