bos_wipe2list_plugins.cls

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

                    End If
                    '5有借款单，且有剩于金额" 借方多加一个现金分录
                    If iVouTplType = 5 Then
                        Set entry = New KFO.Dictionary
                        entry("FExplanation") = "支出证明单，单据编号：" & sBillNo
                        entry("FAccountID") = 1000
                        entry("FDC") = 1
                        entry("FAmount") = cLoanamt - cWipeAmt
                        entry("FQuantity") = 0
                        entry("FUnitPrice") = 0
                        entry("FMeasureUnitID") = 0
                        Set mvchdetail = New KFO.Vector
                        Set entry("_Details") = mvchdetail
                       tmpmvchentry.Add entry
'                        mvchentry.Add entry
                    End If
                    
                     k = k + 1
                     rs.MoveNext
                Wend
                '拼生凭证正确的单据内码
                If tmpmvchentry.Size > 0 Then
                    For j = 1 To tmpmvchentry.Size
                        mvchentry.Add tmpmvchentry.Item(j)
                    Next j
            
                   If sfid = "" Then
                       sfid = sfid & CStr(lFid)
                   Else
                       sfid = sfid & "," & CStr(lFid)
                   End If
                   sInfo = sInfo & "支出证明单：" & sBillNo & "生成凭证成功！" & vbCrLf
                Else
                    sInfo = sInfo & "支出证明单：" & sBillNo & "生成凭证失败！原因如上" & ERR.Description & vbCrLf
             
                End If
            End If
            If rs.State = adStateOpen Then rs.Close
            i = i + 1
         Wend
         
        Set mvch("_Entries") = mvchentry
    End With
    Dim s As String

    '如果凭证分录集不为空，则提交中间层组件生成凭证
    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_WipeOff2 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_WipeOff2 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_WipeOff2 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_WipeOff2 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
'-----------------------------------------------------
'根据科目查找对应的核算项目，最多处理两个，且是002（部门） 和003（职员）
'-----------------------------------------------------
Private Function getAccItem(AccID As Long, ByRef sRet() As String) As Boolean
    Dim tmpRs1 As New ADODB.Recordset
    Dim iCun As Integer
    Dim j As Integer
    '根据科目查找对应的核算项目
    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 (t3.fnumber=002 or t3.fnumber=003)" & _
            " and t2.FAccountid='" & AccID & "'"
    Set tmpRs1 = m_ListInterface.K3Lib.GetData(sSql)
    ReDim sRet(1 To 2)
    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(j) = tmpRs1!FNumber
            tmpRs1.MoveNext
        Next j
    End If
    
    Set tmpRs1 = Nothing
End Function

'***********************************************************************************
'取报销凭证模板的分录信息
'iVouTplType    凭证模板类型 1 有借款单，且是现金  2 有借款单，且是银行存款  3 没有借款单
'iWipeType      支出方式
'参数 sRet      分录内容
'支出方式  1000201 现金 >＝1000202 支票
'***********************************************************************************
Private Function getWipeVouEntryInfo(iVouTplType As Integer, iWipeType As String, ByRef sRet() As String) As Boolean
    Dim sSql As String
    Dim i As Integer, j As Integer
    Dim tmpRs As New ADODB.Recordset
    Dim iCun As Integer
    ReDim sRet(1)
    sSql = "select * from t_EP_ER_WipeVouTypeEntry1 where FVouWipeType='" & iVouTplType & "'and FWipeType='" & iWipeType & "'"
    
    Set tmpRs = m_ListInterface.K3Lib.GetData(sSql)
    If tmpRs.State = adStateOpen And tmpRs.EOF Then
        getWipeVouEntryInfo = False
        Exit Function
    End If
    
    sRet(1) = tmpRs!FAccID

    Set tmpRs = Nothing
    
End Function


Private Sub m_ListInterface_MenuBarInitialize(ByVal oMenuBar As K3ClassEvents.MenuBar)
    Dim oTool   As K3ClassEvents.BOSTool
    Dim oBand   As K3ClassEvents.BOSBand

    '新增 makeVou 菜单对象，并设置属性
    Set oTool = oMenuBar.BOSTools.Add("makeVou")
    With oTool
        .Caption = "凭证"
        .ToolTipText = "凭证"
        .Description = "凭证"
        .ShortcutKey = 0
        .Visible = True
        .Enabled = True
        .BeginGroup = True
        .ToolPicture = App.Path & "\vou.ICO"
        .SetPicture 0, vbButtonFace
    End With

    Set oBand = oMenuBar.BOSBands("BandToolBar")
    oBand.BOSTools.InsertAfter "mnuCaculate", oTool    '将菜单对象插入指定工具栏
 
End Sub