frmvouchermultilist.frm

金算盘软件代码

    With grdList
        If .Row > 0 Then
            GetlngVoucherID = CLng(.TextArray(pos(.Row, 0)))
        Else
            GetlngVoucherID = -1
        End If
    End With
End Function
Private Function conSet()
    Dim recTemp As rdoResultset
    Dim strSelect As String
    Dim strFrom   As String
    Dim strWhere  As String
    Dim strWhere_1 As String
    Dim i As Integer
    Dim strSQLIN As String

On Error Resume Next
    strSelect = mclsList.ListSet.SelectOfSql
    strFrom = mclsList.ListSet.FromOfSql
    strWhere = mclsList.ListSet.WhereOfSql
   
    If Trim(strSelect) = "" Or Trim(strFrom) = "" Then
        Exit Function
    End If
   
    strSelect = "Select Voucher.lngVoucherID As id," & strSelect
    
    strSQLIN = " IN(-1"
    If intFormType < 2 Then '复核/取消复核
        For i = 0 To UBound(arrRights_Check)
            strSQLIN = strSQLIN + "," + CStr(arrRights_Check(i))
        Next i
        strSQLIN = strSQLIN + ")"
    Else                    '记帐/取消记帐
        For i = 0 To UBound(arrRights_Post)
            strSQLIN = strSQLIN + "," + CStr(arrRights_Post(i))
        Next i
        strSQLIN = strSQLIN + ")"
    End If
    
    Select Case intFormType
    Case 0      '当期所有未复核的凭证，不包含有作废、错误标志的凭证。，无权限复核的凭证，也不包含复核人本人制作的凭证
        strWhere_1 = " (Voucher.lngCheckerID=0)  AND (Voucher.blnIsError=0) AND (voucher.blnIsVoid=0) and  Voucher.lngOperatorID<>" & gclsBase.OperatorID & " and (Voucher.lngOperatorID) " & strSQLIN
    
    Case 1     '列出当期所有本操作员复核的未记帐的凭证（注意：仅能取消自己复核的凭证，不包括范围）
        strWhere_1 = " (Voucher.lngCheckerID= " & gclsBase.OperatorID & ")  AND (Voucher.blnIsError=0) AND Voucher.lngPostID=0"
        
    Case 2     '列出当期所有已复核未记帐的凭证
        strWhere_1 = " (Voucher.lngCheckerID<>0)  AND (Voucher.blnIsError=0) AND Voucher.lngPostID=0 AND Voucher.lngOperatorID" & strSQLIN
        
    Case 3     '列出当期所有已记帐的凭证
        strWhere_1 = " Voucher.lngPostID<>0 AND Voucher.lngOperatorID" & strSQLIN
        
    End Select
    
    If strWhere <> "" Then
       strWhere = " where " & strWhere & " and " & strWhere_1
    Else
       strWhere = " where " & strWhere_1
    End If
    
    strSQL = strSelect & strFrom & strWhere & " ORDER BY Voucher.lngVoucherID"
    Set recTemp = gclsBase.BaseDB.OpenResultset(strSQL, rdOpenStatic)
    '列表是否为空
    If recTemp.RowCount = 0 Then Exit Function
    recTemp.MoveLast
    recTemp.MoveFirst
    Do While Not recTemp.EOF
       For i = 1 To grdList.Rows - 1
           If recTemp.rdoColumns(0) = grdList.TextMatrix(i, 0) And grdList.RowHeight(i) <> 0 Then
              grdList.TextMatrix(i, 1) = "√"
              Exit For
           End If
       Next
       recTemp.MoveNext
    Loop
    Set recTemp = Nothing
End Function

Public Function GetList() As rdoResultset
    Dim recTemp As rdoResultset
    Dim strVoucherCon As String
    Dim strSelect As String
    Dim strFrom   As String
    Dim strFromOfMe As String
    Dim strWhere  As String
    Dim strWhere_1 As String
    Dim i As Integer
    Dim strSQLIN As String
    Dim strPureWhere As String
    Dim strWhereInFrom As String
On Error Resume Next
    strSelect = mclsList.ListSet.SelectOfSql
    strSelect = strSelect & ",Voucher.intYear as MultiYear,Voucher.bytPeriod as MultiPeriod"
    strFrom = mclsList.ListSet.FromOfSql
    strWhere = mclsList.ListSet.WhereOfSql
    strPureWhere = mclsList.ListSet.GetPureWhere
    strWhereInFrom = mclsList.ListSet.GetWhereInFrom
   
    If Trim(strSelect) = "" Or Trim(strFrom) = "" Then
        Set GetList = Nothing
        Exit Function
    End If
   
        
    strSelect = "Select Voucher.lngVoucherID As id, '' As ""选定""," & strSelect
    
    strSQLIN = " IN (-1"
    If intFormType < 2 Then '复核/取消复核
        For i = 0 To UBound(arrRights_Check)
            strSQLIN = strSQLIN + "," + CStr(arrRights_Check(i))
        Next i
        strSQLIN = strSQLIN + ")"
    Else                    '记帐/取消记帐
        For i = 0 To UBound(arrRights_Post)
            strSQLIN = strSQLIN + "," + CStr(arrRights_Post(i))
        Next i
        strSQLIN = strSQLIN + ")"
    End If
    
    Select Case intFormType
    Case 0      '当期所有未复核的凭证，不包含有作废、错误标志的凭证。，无权限复核的凭证，也不包含复核人本人制作的凭证
        strWhere_1 = " (Voucher.lngCheckerID=0)  AND (Voucher.blnIsError=0) AND (voucher.blnIsVoid=0) and  Voucher.lngOperatorID<>" & gclsBase.OperatorID & " and Voucher.lngOperatorID " & strSQLIN
    
    Case 1     '列出当期所有本操作员复核的未记帐的凭证（注意：仅能取消自己复核的凭证，不包括范围）
        strWhere_1 = " (Voucher.lngCheckerID= " & gclsBase.OperatorID & ")  AND (Voucher.blnIsError=0) AND Voucher.lngPostID=0"
        
    Case 2     '列出当期所有已复核未记帐的凭证
        strWhere_1 = " (Voucher.lngCheckerID<>0)  AND (Voucher.blnIsError=0) AND Voucher.lngPostID=0 AND Voucher.lngOperatorID " _
                     & strSQLIN
        
    Case 3     '列出当期所有已记帐的凭证
        strWhere_1 = " Voucher.lngPostID<>0 AND Voucher.lngOperatorID" & strSQLIN
        
    End Select
    
    If Trim(strPureWhere) <> "" Then
       strPureWhere = " and " & strPureWhere & " and " & strWhere_1
    Else
       strPureWhere = " and " & strWhere_1
    End If
    
    strVoucherCon = GetInitWhere(MuliListID, 1)
    
    If Trim(strVoucherCon) <> "" Then
       strPureWhere = strPureWhere & " and voucher.lngvoucherID in (select voucher.lngvoucherID " & _
                  strFrom & " where  " & IIf(Trim(strWhereInFrom) <> "", strWhereInFrom & " and ", " ") & strVoucherCon & ")"
    End If
    
'    strFromOfMe = " From ((((((((((((Voucher INNER JOIN VoucherType ON Voucher.lngVoucherTypeID = VoucherType.lngVoucherTypeID)" & _
'                    " INNER JOIN Template ON Voucher.lngTemplateID = Template.lngTemplateID)" & _
'                    " INNER JOIN Operator ON Voucher.lngOperatorID = Operator.lngOperatorID)" & _
'                    " INNER JOIN VoucherDetail ON Voucher.lngVoucherID = VoucherDetail.lngVoucherID)" & _
'                    " INNER JOIN Account ON VoucherDetail.lngAccountID = Account.lngAccountID)" & _
'                    " INNER JOIN Currencys ON VoucherDetail.lngCurrencyID = Currencys.lngCurrencyID)" & _
'                    " LEFT JOIN Class1 ON VoucherDetail.lngClassID1 = Class1.lngClassID)" & _
'                    " LEFT JOIN Class2 ON VoucherDetail.lngClassID2 = Class2.lngClassID)" & _
'                    " LEFT JOIN Customer  ON VoucherDetail.lngCustomerID = Customer.lngCustomerID)" & _
'                    " LEFT JOIN Department ON VoucherDetail.lngDepartmentID = Department.lngDepartmentID)" & _
'                    " LEFT JOIN Employee  ON VoucherDetail.lngEmployeeID = Employee.lngEmployeeID)" & _
'                    " LEFT JOIN Operator AS Operator_1 ON Voucher.lngCheckerID = Operator_1.lngOperatorID)" & _
'                    " LEFT JOIN Operator AS Operator_2 ON Voucher.lngPostID = Operator_2.lngOperatorID "
    strFromOfMe = " From Voucher,VoucherType,Template,Operator,VoucherDetail,Account,Currencys," & _
                    " Class1,Class2,Customer,Department,Employee,Operator  Operator_1,Operator  Operator_2 " & _
                    " where ((((((((((((  Voucher.lngVoucherTypeID = VoucherType.lngVoucherTypeID)" & _
                    " and Voucher.lngTemplateID = Template.lngTemplateID)" & _
                    " and Voucher.lngOperatorID = Operator.lngOperatorID)" & _
                    " and Voucher.lngVoucherID = VoucherDetail.lngVoucherID)" & _
                    " and VoucherDetail.lngAccountID = Account.lngAccountID)" & _
                    " and VoucherDetail.lngCurrencyID = Currencys.lngCurrencyID)" & _
                    " and VoucherDetail.lngClassID1 = Class1.lngClassID(+))" & _
                    " and VoucherDetail.lngClassID2 = Class2.lngClassID(+))" & _
                    " and VoucherDetail.lngCustomerID = Customer.lngCustomerID(+))" & _
                    " and VoucherDetail.lngDepartmentID = Department.lngDepartmentID(+))" & _
                    " and VoucherDetail.lngEmployeeID = Employee.lngEmployeeID(+))" & _
                    " and Voucher.lngCheckerID = Operator_1.lngOperatorID(+))" & _
                    " and Voucher.lngPostID = Operator_2.lngOperatorID(+) "
    
    strSQL = strSelect & strFromOfMe & strPureWhere & " ORDER BY Voucher.intYear,Voucher.bytPeriod,VoucherType.strVoucherTypeCode, To_Char(Voucher.intVoucherNO,'0000'),VoucherDetail.lngRowID"   '    ,Voucher.lngVoucherID,VoucherDetail.lngRowID"
    Set recTemp = gclsBase.BaseDB.OpenResultset(strSQL, rdOpenStatic) ', dbReadOnly)
    '列表是否为空
    
    If recTemp.EOF Then
        grdList.HighLight = flexHighlightNever      '光标亮条消失
        '按纽变灰
        For i = 0 To 8
            cmdButton(i).Enabled = False
        Next
        cmdButton(4).Enabled = True
        cmdButton(6).Enabled = True
    Else
        grdList.HighLight = flexHighlightAlways     '光标亮条显示
        For i = 0 To 8
            cmdButton(i).Enabled = True
        Next
    End If
    'next sentence made by ozj
    mclsList.ShowAll = True
    Set GetList = recTemp
    Set recTemp = Nothing
End Function


'重画Form
Private Sub RedrawForm()
    Dim lngLeft As Long
    Dim i As Integer
    '重画MSFlexGrid 控件
    With grdList
        .Left = ListFormLeft
        .width = Me.ScaleWidth - ListFormLeft - ListFormRight - lngBottonWidth - 100
        .Height = Me.ScaleHeight - 200 - 255 'ListUpAreaHeight - ListDownAreaHeight
    End With
    
    '重画其余控件
    lngLeft = Me.ScaleWidth - ListFormRight - lngBottonWidth
    For i = 0 To 8
        cmdButton(i).Left = lngLeft
    Next i
    ProgressBar1.Left = ListFormLeft
    ProgressBar1.width = Me.ScaleWidth - ListFormLeft - ListFormRight - lngBottonWidth - 100
    ProgressBar1.top = Me.ScaleHeight - ProgressBar1.Height - ListFormBottom
End Sub


Private Sub cmdButton_Click(Index As Integer)
    Dim i As Integer
    Dim blnFound As Integer '判断是否选择了凭证

    If Not mblnIsFocus Then Exit Sub
    If Index < 4 Then
        blnFound = False
        For i = 1 To (grdList.Rows - 1)
            If grdList.TextMatrix(i, 1) = "√" Then
                blnFound = True
                Exit For
            End If
        Next i
        If blnFound = False Then
           ShowMsg Me.hwnd, "请先选定一张凭证！", vbExclamation + MB_SYSTEMMODAL, Me.Caption
           Exit Sub
        End If
    End If
    
    Select Case Index
    Case 0 '《复核》
        If Sub_Check Then Unload Me
    Case 1 '《复核取消》
        If Sub_UnCheck Then Unload Me
    Case 2 '《记帐》
        If Sub_Post Then Unload Me
    Case 3 '《记帐取消》
        If Sub_UnPost Then Unload Me
    Case 4 '《取消》
        Sub_Cancel
    Case 5 '《全部选择》
        Sub_SelectAll
    Case 6 '《条件选择》
        Sub_Select
    Case 7 '《全部取消》
        Sub_CancelAll
    Case 8 '《打印》
        Sub_Print
   End Select
End Sub

'逐条复核所选记录
Private Function Sub_Check() As Boolean
    Dim lngRow As Long
    Dim lngVoucherID As Long '当前已复核的ID
    Dim iCount As Integer    '复核的张数

    If ShowMsg(Me.hwnd, "您确实要复核所选的凭证吗？", MB_YESNO + MB_ICONQUESTION + MB_DEFBUTTON2 + MB_SYSTEMMODAL, "多张复核") <> IDYES Then Exit Function
    With grdList
        If Not (.Rows > 0) Then
            Exit Function
        End If
        
On Error GoTo CheckErr
        ProgressBar1.Visible = True
        Screen.MousePointer = vbHourglass
        ProgressBar1.Value = 5
        mblnIsFocus = False
        Debug.Print "CheckBEgindate :", time
        gclsBase.BaseWorkSpace.BeginTrans
        lngVoucherID = 0
        iCount = 0
        ProgressBar1.Value = 10
        For lngRow = 1 To .Rows - 1
            If Trim(.TextArray(pos(lngRow, 1))) = "√" Then
                If lngVoucherID <> CLng(.TextArray(pos(lngRow, 0))) Then
                    lngVoucherID = CLng(.TextArray(pos(lngRow, 0)))
                    iCount = iCount + 1
                    '复核
'                    MsgForm.PleaseWait "已复核凭证" & iCount & "张"
                    If Not mclsVoucher.CheckVoucher(lngVoucherID, True, , True) Then GoTo CheckErr
                End If
            End If
            Select Case lngRow
                   Case Is > (1 / 2) * (.Rows)
                        ProgressBar1.Value = 80
                   Case Is > (1 / 3) * (.Rows)
                        ProgressBar1.Value = 70
                   Case Is > (1 / 4) * (.Rows)
                        ProgressBar1.Value = 60
                   Case Is > (1 / 5) * (.Rows)
                        ProgressBar1.Value = 50
                   Case Is > (1 / 6) * (.Rows)
                        ProgressBar1.Value = 40
                   Case Is > (1 / 7) * (.Rows)
                        ProgressBar1.Value = 30
                   Case Is > (1 / 8) * (.Rows)
                        ProgressBar1.Value = 20
            End Select
        Next lngRow
    End With
    ProgressBar1.Value = 90
    gclsBase.BaseWorkSpace.CommitTrans
    Debug.Print "checkbaseEndDate:", time
    ProgressBar1.Value = 100
    ProgressBar1.Visible = False
    Screen.MousePointer = vbDefault
'    Unload MsgForm