bos_wipe3list_plugins.cls

完成报销系统的业务流程；在报销系统中达到预算控制目的；将历史数据导入金蝶账套生成历史备查数据。

    '如果凭证分录集不为空，则提交中间层组件生成凭证
    Dim VouInfo
    If mvch("_Entries").Size <> 0 Then

 'modify by christin 20060807
        s = GetConnectionProperty("PropsString")
'        s = MMTS.PropsString
'        s = "ConnectString={Provider=SQLOLEDB.1;User ID=sa;Password=;Data Source=KINGDEEKFB;Initial Catalog=AIS20051221092013};UserName=administrator;UserID=16394;DBMS Name=Microsoft SQL Server;DBMS Version=2000;SubID=k3bos;AcctType=gy;Setuptype=Industry;Language=chs;IP=127.0.0.1;MachineName=KINGDEEKFB;UUID=68C61112-D052-4DFC-B43B-DD3028222ACB"
        Set glvch = m_ListInterface.K3Lib.CreateK3Object("EBSGLVoucher.VoucherUpdate")
        VouInfo = glvch.Create(s, mvch)
        '弹出凭证界面修改凭证
        Dim Vch As Object, Mode As Long
        Set Vch = CreateObject("Mvedit.MVoucherEdit")
        Mode = 2
        Vch.LoadVoucher Mode, VouInfo
        Set Vch = Nothing
        '取凭证信息
        sSql = "select t1.*,t2.FName as GroupName from t_voucher  t1 " & _
                            "left join t_Vouchergroup  t2 on t1.FGroupID= t2.FGroupid where FvoucherID=" & VouInfo

        Set rs = m_ListInterface.K3Lib.GetData(sSql)

        If rs.State = adStateOpen And rs.RecordCount = 1 Then

            sInfo = sInfo & "凭证信息－会计期间：" & CStr(rs!FYear) & "." & CStr(rs!FPeriod) & ",凭证字号:" & CStr(rs!GroupName) & " - " & CStr(rs!FNumber)
'            ImportLog12 sInfo
        End If
        '更新单据中的凭证号
        s = "Update t_EP_ER_WipeOff3 set FVouID=" & VouInfo & ", FVouUser=" & m_ListInterface.K3Lib.User.UserID & ",FVouInfo= '" & CStr(rs!GroupName) & " - " & CStr(rs!FNumber) & "' where fid in (" & sfid & ")"

        m_ListInterface.K3Lib.UpdateData s

        If rs.State = adStateOpen Then rs.Close
        Set rs = Nothing
    End If
    
    MsgBox "凭证生成完成！" & vbCrLf & sInfo, vbInformation + vbOKOnly, "金蝶提示"
    ImportLoanVou = True
    Exit Function
ERR:
    Set glVouRs = Nothing
    Set glvch = Nothing
    Set mvch = Nothing
    Set mvchentry = Nothing
    Set entry = Nothing
    Set mvchdetail = Nothing
    Set detail = Nothing
    MsgBox ERR.Number & "-" & ERR.Description, vbOKOnly + vbExclamation, HINTINFO
End Function
'***********************************************************************************
'取凭证模板的分录信息
'lDep           部门
'lWipeItem      报销项目
'iVouTplType    凭证模板类型
'参数 sRet      分录内容
'借款方式  1000201 现金 1000202 支票
'***********************************************************************************
Private Function getVouEntryInfo(lDep As Long, lWipeItem As Long, iVouTplType As Integer, ByRef sRet() As String) As Boolean

    Dim sSql As String
    Dim i As Integer, j As Integer
    Dim tmpRs As New ADODB.Recordset
    Dim tmpRs1 As New ADODB.Recordset
    Dim iCun As Integer
    sSql = "select * from t_EP_ER_VouTypeEntry where FVouTempletType=2  and FDepid= '" & lDep & "' and FWipeItem= '" & lWipeItem & "'" & _
            " and FVouType='" & iVouTplType & "' order by  FVouFdc DESC "
    On Error GoTo ERR

    Set tmpRs = m_ListInterface.K3Lib.GetData(sSql)
    If tmpRs.State = adStateOpen And tmpRs.EOF Then
        getVouEntryInfo = False
        Exit Function
    End If
    ReDim sRet(1 To 5, 1 To tmpRs.RecordCount)
    i = 1
    tmpRs.MoveFirst
    While Not tmpRs.EOF
        sRet(1, i) = iVouTplType ' 凭证模板类型
        sRet(2, i) = tmpRs!FVouFdc   '借贷方向
        sRet(3, i) = tmpRs!FAccID   '科目ID
        '根据科目查找对应的核算项目
        sSql = "select t3.FNumber from t_itemdetailv t1 ,t_account t2,t_itemclass t3 " & _
                "where t1.FDetailid=t2.FDetailID and t1.FItemid=-1  and  t1.fitemclassid= t3.fitemclassid " & _
                " and t2.FAccountid='" & tmpRs!FAccID & "'"
        Set tmpRs1 = m_ListInterface.K3Lib.GetData(sSql)
            If tmpRs1.State = adStateOpen And tmpRs1.RecordCount > 0 Then
                If tmpRs1.RecordCount > 2 Then
                    iCun = 2
                Else
                    iCun = tmpRs1.RecordCount
                End If
                For j = 1 To iCun '只取两个核算项目
                    sRet(3 + j, i) = tmpRs1!FNumber
                    tmpRs1.MoveNext
                Next j
            End If

 
        i = i + 1
        tmpRs.MoveNext
    Wend
    

    getVouEntryInfo = True
    Set tmpRs = Nothing
    Set tmpRs1 = Nothing
    Exit Function
ERR:
    Set tmpRs = Nothing
    Set tmpRs1 = Nothing
    getVouEntryInfo = False

End Function

'取所选单据的凭证号
Private Function getVouid(VouVector As KFO.Vector) As Integer
    Dim sSql As String
    Dim vouid As Long
    If VouVector.Size > 0 Then
        With VouVector
            Dim rs As New ADODB.Recordset
            '取单据信息
            sSql = "select FVouid ,FVouUser from t_EP_ER_WipeOff3 t1 where t1.Fid='" & .Item(1)("Fid") & "'"
            Set rs = m_ListInterface.K3Lib.GetData(sSql)
            If rs.State = adStateOpen And rs.RecordCount = 1 Then
                '判断是否生成过凭证 '判断是否已经审核
                If Not (CStr(rs("FVouUser")) = "" Or CLng(rs("FVouUser") = 0)) <> 0 Then

                    vouid = rs!FVouid
                    rs.Close
                    sSql = "select isnull(count(*),0)  as vouCun from t_voucher where fvoucherid= '" & vouid & "'"
                    Set rs = m_ListInterface.K3Lib.GetData(sSql)
                    If rs!vouCun <> 0 Then
                        getVouid = vouid
                    Else
                        getVouid = 0
                    End If
                Else
                    getVouid = 0
                    
                End If

            End If
        End With
    Else
        getVouid = 0
    End If
    Set rs = Nothing
End Function
'查看时修改单据内的凭证信息
Private Function AlterVouNo(vouid As Long)
    Dim sSql As String
    Dim rs As New ADODB.Recordset
    
    '取凭证信息
    sSql = "select t1.*,t2.FName as GroupName from t_voucher  t1 " & _
                        "left join t_Vouchergroup  t2 on t1.FGroupID= t2.FGroupid where FvoucherID=" & vouid

    Set rs = m_ListInterface.K3Lib.GetData(sSql)

    If rs.State = adStateOpen And rs.RecordCount = 1 Then
        '更新单据中的凭证号，凭证制作人
        
        sSql = "Update t_EP_ER_WipeOff3 set  FVouUser=" & m_ListInterface.K3Lib.User.UserID & _
            ",FVouInfo= '" & CStr(rs!GroupName) & " - " & CStr(rs!FNumber) & "'  where FVouid=" & vouid
         m_ListInterface.K3Lib.UpdateData sSql

    End If
    Set rs = Nothing
End Function

'判断制单人和审核人是否当前用户
Private Function VerUser(SelBillVector As KFO.Vector) As Boolean
    Dim rs As New ADODB.Recordset
    Dim sSql As String
    Dim i As Long
    Dim errStr As String
    errStr = ""
    For i = 1 To SelBillVector.Size
        sSql = "select FBillNo,FBiller,FUser from  t_EP_ER_WipeOff3 where fid= " & SelBillVector.Item(i)("Fid")
         Set rs = m_ListInterface.K3Lib.GetData(sSql)
        If rs.State = adStateOpen And rs.RecordCount = 1 Then
           If m_ListInterface.K3Lib.User.UserID <> rs!FBiller Then
                errStr = errStr & "‘" & rs!FBillNo & "’" & "  "
           End If
        
        End If
    Next i
    
   If errStr <> "" Then
        MsgBox "要删除的差旅费报销单：" & errStr & "不是当前用户制作的！", vbOKOnly + vbInformation, HINTINFO
        VerUser = False
    Else
        VerUser = True
    
    End If
End Function
'***********************************************************************************
'导入凭证  根据新的凭证模板
'参数 VouVector 用户选择的报销单据信息
'
'***********************************************************************************
Private Function ImportWipeVou_new(VouVector As KFO.Vector) As Boolean
    Dim glVouRs As New KFO.Vector
    Dim lFid As Long                            '单据编号
    Dim glvch As Object                         '中间层凭证对象
    Dim mvch As KFO.Dictionary                  '待保存凭证头
    Dim mvchentry As KFO.Vector                 '待保存凭证分录集
    Dim entry As KFO.Dictionary                 '待保存凭证分录
    Dim mvchdetail As KFO.Vector                '核算项目明细集
    Dim detail As KFO.Dictionary                '核算项目明细
    Dim i, iCount As Long, j As Long, k As Long
    Dim vValue      As Variant
    Dim rs As New ADODB.Recordset
    
    Dim sVouType() As String  '凭证模板数组
    Dim sAccItem() As String  '凭证科目所带核算项目数组
    
    Dim sDepId As String         '部门编码
    Dim sProposer As String      '申请人编码
    Dim lWipeItem As Long       '报销项目
    Dim lLoanType As Long       '借款方式
    Dim sBillNo As String       '单据编码
    Dim cWipeAmt As Currency    '报销金额
    Dim cLoanamt As Currency    '借款金额
    Dim lfidSRC As Long         '源单内码
    Dim iVouTplType As Integer  '凭证模板类型
    Dim iWipeType As String    '支出方式
    Dim iFSupplyAmtSum As Currency '补领金额
    Dim iFRefundAmtsum As Currency '退还金额
    Dim iFWipeAmtSum As Currency '报销总额
    Dim sFEvectionCause As String  '出差事由
    
    Dim sSql As String
    Dim sInfo As String          '最后提示信息
    Dim sfid As String          '要更新单据内码集
    Dim tmpmvchentry As KFO.Vector '临时保存一张单据中的分录集
    Dim bret As Boolean
    Dim sErr As String
    Dim tmpRs As New ADODB.Recordset

    On Error GoTo ERR
    sInfo = ""
   

    '此处添加处理 生成凭头
    Set mvch = New KFO.Dictionary
    '日期取当前会计期间
    Dim sYear As String
    Dim sPeriod As String
    sYear = m_ListInterface.K3Lib.GetData("select FValue from t_systemprofile where FCategory='GL' and FKey='CurrentYear'")("FValue")
    sPeriod = m_ListInterface.K3Lib.GetData("select FValue from t_systemprofile where FCategory='GL' and FKey='CurrentPeriod'")("FValue")
    mvch("FDate") = getDate(sYear, sPeriod)

    mvch("FGroupID") = "1"


    '初始化凭证分录集********************************
    Set mvchentry = New KFO.Vector
    '***********************************************
    With VouVector
    i = 1
begFor: While i <= VouVector.Size
            '取单据编号
            lFid = .Item(i)("Fid")
            '判断是否生成过凭证, '判断是否已经审核
            sSql = "select FVouUser,FVouid,FBillno,FUser from t_EP_ER_WipeOff3 t1 where t1.Fid='" & lFid & "'"
            Set rs = m_ListInterface.K3Lib.GetData(sSql)
            If rs.State = adStateOpen And rs.RecordCount > 0 Then
                sInfo = sInfo & "差旅费报销单：" & rs("FBillno") & "生成凭证"
                If Not (CStr(rs("FVouUser")) = "" Or CLng(rs("FVouUser") = 0)) <> 0 Then
                    sSql = "select isnull(count(*),0)  as vouCun from t_voucher where fvoucherid= '" & rs!FVouid & "'"
                    Set tmpRs = m_ListInterface.K3Lib.GetData(sSql)
                    If tmpRs!vouCun <> 0 Then
                        i = i + 1
                        sInfo = sInfo & "失败！原因: 已经生成凭证。" & vbCrLf
                        GoTo begFor
                    End If
                    If rs.State = adStateOpen Then tmpRs.Close
                End If
                If CLng(rs("FUser")) = 0 Then
                     i = i + 1
                     sInfo = sInfo & "失败！原因: 单据还没有审核。" & vbCrLf
                     GoTo begFor
                End If

            End If
            If rs.State = adStateOpen Then rs.Close

            '取单据信息
            sSql = "select t11.FSupplyAmtSum,t11.FRefundAmtsum,t11.FWipeAmtSum,t2.Fnumber as DepNum,t3.Fnumber as ProposerNum,* from t_EP_ER_WipeOff3Entry3  t1" & _
                    " Inner join t_EP_ER_WipeOff3 t11 on t1.fid=t11.fid " & _
                    " left join t_item t2 on t2.Fitemclassid=2 and  t1.FDivideDep =t2.Fitemid " & _
                    " left join t_item t3 on t3.Fitemclassid=3 and  t11.FProposer =t3.Fitemid " & _
                    " where t1.Fid='" & lFid & "'order by FEntryID"
                    
            Set rs = m_ListInterface.K3Lib.GetData(sSql)
            '单据存在继续
            If rs.State = adStateOpen And rs.RecordCount > 0 Then
                iFSupplyAmtSum = CNulls(rs("FSupplyAmtSum"), 0)
                iFRefundAmtsum = CNulls(rs("FRefundAmtsum"), 0)
                iFWipeAmtSum = CNulls(rs("FWipeAmtSum"), 0)
                '-------------------初始化一张单据的凭证分录集----------------------------
                Set tmpmvchentry = New KFO.Vector
                Set tmpmvchentryD = New KFO.Vector
                '--------------------------------------------------------------------------
                k = 1
                rs.MoveFirst
begwhile:      While k <= rs.RecordCount
                    '部门 ,申请人，报销项目，借款方式，单据编号，报销金额，借款金额,源单内码 ,
                    sDepId = rs("DepNum")
                    sProposer = rs("ProposerNum")
                    lWipeItem = rs("FWipeItem")
                    lLoanType = rs("FLoanType")
                    sBillNo = rs("FBillno")
                    cWipeAmt = rs("FWipeAmt")
                    cLoanamt = rs("FLoanAmt")
                    lfidSRC = rs("FID_SRC")
                    iWipeType = rs("FWipeType")  '支出方式
                    sFEvectionCause = CNulls(rs("FEvectionCause"), "") '出差事由