📄 bos_wipe3list_plugins.cls
字号:
'判断报销单的类型
' 1有借款单，且是现金'
' 2有借款单，且是银行存款'
' 3没有借款单，直接借款报销'
If lfidSRC <> 0 And lLoanType = "1000201" Then
iVouTplType = 1
ElseIf lfidSRC <> 0 And lLoanType <> "1000201" Then
iVouTplType = 2
ElseIf lfidSRC = 0 Then
iVouTplType = 3
Else
k = k + 1
sInfo = sInfo & "差旅费报销单：" & rs("FBillno") & "中的第" & k & "第分录，不能生成凭证！原因：报销单不在3种报销类型中" & vbCrLf
GoTo begwhile
End If
'------------判断报销单的支出方式iWipeType----------------------------
'modified by lxd in 20060312
'如果iwipetype＝0 默认为 现金
If iWipeType = 0 Then
If lLoanType <> 0 Then
iWipeType = lLoanType
Else
iWipeType = "1000201"
End If
End If
'-----------------------------------------------------------------------
' ' 4有借款单，其预借的金额不够。'
'' 5有借款单，且有剩于金额"
' If lfidSRC <> 0 And cWipeAmt > cLoanamt Then
' iVouTplType = 4
' ElseIf lfidSRC <> 0 And cWipeAmt < cLoanamt Then
' iVouTplType = 5
' End If
'-------------------创建1个凭证分录----------------------------
Set entry = New KFO.Dictionary '借方
Set entryD = New KFO.Dictionary '贷方
'-----------------------------------------------------------
'**************************************************************
'写凭证的借方金额
'**************************************************************
entry("FExplanation") = "差旅费报销单编号：" & sBillNo & vbCrLf & "出差事由：" & sFEvectionCause
entry("FAccountID") = lWipeItem '写会计科目 ＝
entry("FDC") = 1 '先写借方
entry("FAmount") = cWipeAmt '写借方金额 ，等于报销金额
entry("FQuantity") = 0
entry("FUnitPrice") = 0
entry("FMeasureUnitID") = 0
Set mvchdetail = New KFO.Vector
bret = getAccItem(lWipeItem, sAccItem)
'创建核算项目明细
If sAccItem(1) <> "" Then
Set detail = New KFO.Dictionary
detail("FItemClassNumber") = sAccItem(1)
If sAccItem(1) = "002" Then detail("FItemNumber") = sDepId
If sAccItem(1) = "003" Then detail("FItemNumber") = sProposer
mvchdetail.Add detail
End If
If sAccItem(2) <> "" Then
Set detail = New KFO.Dictionary
detail("FItemClassNumber") = sAccItem(2)
If sAccItem(2) = "002" Then detail("FItemNumber") = sDepId
If sAccItem(2) = "003" Then detail("FItemNumber") = sProposer
mvchdetail.Add detail
End If
Set entry("_Details") = mvchdetail
tmpmvchentry.Add entry
'**************************************************************
'写凭证的贷方金额
'**************************************************************
'-------------------根据支出方式取凭证贷方模板----------------------------
bret = getWipeVouEntryInfo(iVouTplType, iWipeType, sVouType())
'-------------------------------------------------------------------------
If iVouTplType <> 3 And iWipeType <> "1000209" Then
entryD("FExplanation") = "差旅费报销单编号：" & sBillNo & vbCrLf & "出差事由：" & sFEvectionCause
entryD("FAccountID") = sVouType(1) '写会计科目 ＝
entryD("FDC") = 0 '先写贷方
entryD("FAmount") = cLoanamt '写贷方金额 ，等于借款金额
entryD("FQuantity") = 0
entryD("FUnitPrice") = 0
entryD("FMeasureUnitID") = 0
Set mvchdetail = New KFO.Vector
bret = getAccItem(CLng(sVouType(1)), sAccItem)
'创建核算项目明细
If sAccItem(1) <> "" Then
Set detail = New KFO.Dictionary
detail("FItemClassNumber") = sAccItem(1)
If sAccItem(1) = "002" Then detail("FItemNumber") = sDepId
If sAccItem(1) = "003" Then detail("FItemNumber") = sProposer
mvchdetail.Add detail
End If
If sAccItem(2) <> "" Then
Set detail = New KFO.Dictionary
detail("FItemClassNumber") = sAccItem(2)
If sAccItem(2) = "002" Then detail("FItemNumber") = sDepId
If sAccItem(2) = "003" Then detail("FItemNumber") = sProposer
mvchdetail.Add detail
End If
Set entryD("_Details") = mvchdetail
tmpmvchentryD.Add entryD
End If
k = k + 1
rs.MoveNext
Wend
'**************************************************************
'根据补领和退还金额 追加一个贷方或借方 entryD("FAmount") = cWipeAmt '写贷方金额 ，限额支票时等于报销款金额
'**************************************************************
If iFSupplyAmtSum > 0 Or iFRefundAmtsum > 0 Or iWipeType = "1000209" Then
bret = getWipeVouEntryInfo(3, iWipeType, sVouType())
Set entryD = New KFO.Dictionary '贷方
entryD("FExplanation") = "差旅费报销单编号：" & sBillNo & vbCrLf & "出差事由：" & sFEvectionCause
entryD("FAccountID") = sVouType(1) '写会计科目 ＝
If iWipeType = "1000209" Then
entryD("FDC") = 0
entryD("FAmount") = iFWipeAmtSum '写贷方金额 ，等于补领金额
Else
If iFSupplyAmtSum > 0 Then
'补写贷方
entryD("FDC") = 0
entryD("FAmount") = iFSupplyAmtSum '写贷方金额 ，等于补领金额
ElseIf iFRefundAmtsum > 0 Then
entryD("FDC") = 1 '补写借方
entryD("FAmount") = iFRefundAmtsum '写贷方金额 ，等于退还金额
End If
End If
entryD("FQuantity") = 0
entryD("FUnitPrice") = 0
entryD("FMeasureUnitID") = 0
Set mvchdetail = New KFO.Vector
bret = getAccItem(CLng(sVouType(1)), sAccItem)
'创建核算项目明细
If sAccItem(1) <> "" Then
Set detail = New KFO.Dictionary
detail("FItemClassNumber") = sAccItem(1)
If sAccItem(1) = "002" Then detail("FItemNumber") = sDepId
If sAccItem(1) = "003" Then detail("FItemNumber") = sProposer
mvchdetail.Add detail
End If
If sAccItem(2) <> "" Then
Set detail = New KFO.Dictionary
detail("FItemClassNumber") = sAccItem(2)
If sAccItem(2) = "002" Then detail("FItemNumber") = sDepId
If sAccItem(2) = "003" Then detail("FItemNumber") = sProposer
mvchdetail.Add detail
End If
Set entryD("_Details") = mvchdetail
If entryD("FDC") = 0 Then
tmpmvchentryD.Add entryD
ElseIf entryD("FDC") = 1 Then
tmpmvchentry.Add entryD
End If
End If
'拼生凭证正确的单据内码
If tmpmvchentry.Size > 0 Or tmpmvchentryD.Size > 0 Then
For j = 1 To tmpmvchentry.Size
mvchentry.Add tmpmvchentry.Item(j)
Next j
For j = 1 To tmpmvchentryD.Size
mvchentry.Add tmpmvchentryD.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_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
'-----------------------------------------------------
'根据科目查找对应的核算项目，最多处理两个，且是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
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -