金蝶K3凭证导入二次开发之核算项目和现金流
1.添加组件引用
2.登录验证，获取K/3连接字符串。
Private K3Login As Object '当前连接对象
Private Sub Login()
On Error GoTo Conn_Error
Set K3Login =
CreateObject("K3Login.ClsLogin")
If Not K3Login.CheckLogin Then
AddString
"连接不成功"
Set
K3Login = Nothing
Exit
Sub
End If
Conn_Error:
AddString "ErrCode:"
& Err & " ErrDescription:" & Err.Description
End Sub
3.保存凭证（包括凭证分录，核算科目及现金流）
Private Function SaveVoucher() As Long
On Error GoTo
ErrHandle
Dim Voucher As New
KFO.Dictionary
Dim Dt As New
KFO.Dictionary
Dim dtVector As New
KFO.Vector
Dim VoucherEntry As New
KFO.Vector
Dim tempEntry As
KFO.Dictionary
'当前期间凭证日期
Voucher("FDate") =
"2015/9/1"
'凭证字
Voucher("FGroup") =
"记"
'凭证号 注意不能重复，重复则报错
Voucher("FNumber") =
611
'***********************************************
'添加第一条分录
Set tempEntry = New
KFO.Dictionary
'摘要
tempEntry("FExplanation") = "凭证录入检测-分录1"
'科目ID
t_Account表的FAccountID字段
tempEntry("FAccountID")
= 1020
'币别
tempEntry("FCurrencyID")
= 1
'借方
tempEntry("FDC") =
1
'原币
tempEntry("FAmountFor")
= 100
'本位币
tempEntry("FAmount") =
100
'==============================================
'保存带核算项目的部分
'第一个核算项目
Set Dt = New
KFO.Dictionary
'核算项目ID
t_ItemClass表FSQLTableName对应表的FItemID
Dt("FItemID") =
305
'核算项目类型
t_ItemClass表FItemClassID
Dt("FItemClassID") =
1
dtVector.Add Dt
'第二个核算项目
Set Dt = New
KFO.Dictionary
Dt("FItemID") =
10049
Dt("FItemClassID") =
3
dtVector.Add Dt
Set tempEntry("_Details") = dtVector
' '现金流
' Dim cashFlowDetail As
New KFO.Vector
' Set Dt = New
KFO.Dictionary
'' select * from t_Item where FItemClassID=9
的FitemID
' Dt("FitemID") =
95
'
'顺序号，对应科目所在凭证分录的行号减1
' Dt("FEntryID") =
1
' Dt("FAmountFor") =
600
' Dt("FAmount") =
600
' cashFlowDetail.Add
Dt
'
' Set Dt = New
KFO.Dictionary
' Dt("FitemID") =
95
' Dt("FEntryID") =
2
' Dt("FAmountFor") =
400
' Dt("FAmount") =
400
' cashFlowDetail.Add
Dt
' Set
tempEntry("CashFlow") = cashFlowDetail
'==============================================
VoucherEntry.Add
tempEntry
'***********************************************
'***********************************************
'添加第二条分录
Set tempEntry = New
KFO.Dictionary
tempEntry("FExplanation") = "凭证录入检测-分录2"
tempEntry("FAccountID")
= 1242
tempEntry("FCurrencyID")
= 1
'贷方
tempEntry("FDC") =
0
tempEntry("FAmountFor")
= 100
tempEntry("FAmount") =
100
VoucherEntry.Add
tempEntry
'***********************************************
Set Voucher("_Entries")
= VoucherEntry
Dim Cre As Object,
VoucherID As Long
Set Cre =
CreateObject("EBSGLVoucher.VoucherUpdate")
VoucherID =
Cre.Create(K3Login.PropsString, Voucher)
Set Cre = Nothing
SaveVoucher = VoucherID
‘返回的凭证id
Exit Function
ErrHandle:
HandleError Err
End Function
‘删除凭证
Private Function DeleteVoucher(ByVal VoucherID As Long) As
Boolean
On Error GoTo
ErrHandle
DeleteVoucher =
False
Dim DelV As Object
Set DelV =
CreateObject("EBSGLVoucher.VoucherUpdate")
DeleteVoucher =
DelV.Delete(K3Login.PropString, VoucherID)
Set DelV = Nothing
Exit Function
ErrHandle:
HandleError Err
End Function
'取得指定的科目的核算项目，lAcctID为科目ID
Private Function GetItemofAcct(lAcctID As Long) As
Object
Dim obj As Object
Dim rsAcct As
Object
Dim dtVector As
kfo.Vector
Dim Dt As kfo.Dictionary
Set obj =
CreateObject("EbcglView.GlData")
Set rsAcct =
obj.GetAccountItem(lAcctID)
If rsAcct Is Nothing
Then Exit Function
'将取得核算项目打包
Set dtVector = New
kfo.Vector
If rsAcct.RecordCount
<> 0 Then
rsAcct.MoveFirst
Do While Not rsAcct.EOF
Set Dt =
New kfo.Dictionary
Dt("FItemID") = "输入核算项目ID"
Dt("FItemClassID") = "输入核算项目类型"
dtVector.Add Dt
rsAcct.movenext
Loop
End If
Set GetItemofAcct =
dtVector
End Function
新增凭证带界面
Public Function CreateVoucherUI() As Long
Dim Voucher As Object
'凭证对象
Dim VoucherEntrys As
Object '凭证分录对象
CreateVoucherUI =
-1
On Error GoTo e
Set Voucher =
CreateObject("EBCGL.Voucher")
Voucher.Construct
Nothing, Nothing '建立凭证数据对象
Set VoucherEntrys =
Voucher.Entries '设置凭证分录对象
' Voucher.InternalInd =
dtHead("InternalInd") '机制凭证信息(可选)
'设置凭证默认日期(可选)
'业务日期
' Voucher.TransDate
=””
'凭证日期"
Voucher.VoucherDate =
"2015/9/1"
'凭证字id
t_VoucherGroup表
Voucher.GroupID =
1
'"322" '凭证号
Voucher.Number
=322
'附件数
'Voucher.Attachments
=””
'业务模块
'Voucher.TranType =
“”
'参考信息
'Voucher.Reference =
“”
'增加凭证分录数据
VoucherEntrys.Add
With
Voucher.Entries(1)
'凭证分录摘要
.Explanation = "凭证录入检测-分录1"
'科目ID
.AccountID = 1020
'本位币
.Amount = 100
'原币
.AmountFor = 100
'汇率
'.ExchangeRate = 1
'币别
.CurrencyID = 1
'借方
.DC = 1
'增加一个核算项目
Voucher.Entries(1).Details.Add
'核算项目类型
t_ItemClass表FItemClassID
Voucher.Entries(1).Details(1).ItemClassID =
1
'核算项目ID
t_ItemClass表FSQLTableName对应表的FItemID
Voucher.Entries(1).Details(1).ItemID = 305
'增加第二个核算项目
Voucher.Entries(1).Details.Add
Voucher.Entries(1).Details(2).ItemClassID =
3
Voucher.Entries(1).Details(2).ItemID =
10049
End With
VoucherEntrys.Add
With
Voucher.Entries(2)
.Explanation = "凭证录入检测-分录2"
'"凭证分录摘要
.AccountID = 1111
.Amount = 100
.AmountFor = 100
.CurrencyID = 1
'贷方
.DC = 0
End With
Dim Vch As Object, Mode As Long
Dim ReturnVoucherID As Long
Set Vch =
CreateObject("Mvedit.MVoucherEdit")
'Mode值= '新增 0 '显示 1 '修改 2 '审核 3
'凭证新增(界面数据)
Mode = 0
ReturnVoucherID = 0
If Voucher Is Nothing Then Exit Function
Dim rel As KDVBF.Relevancy
Set rel = New KDVBF.Relevancy '建立输入对象
Set rel.EditObject = Voucher
'设置凭证数据对象到Rel参数
rel.MultiEdit = False '是否允许多张凭证编辑
Vch.LoadVoucher Mode, , rel, ,
ReturnVoucherID
CreateVoucherUI = ReturnVoucherID
Exit Function
e:
CreateVoucherUI =
-1
MsgBox Err.Description,
vbCritical, "错误提示"
End Function
4．其他相关资料介绍
取当前期间年份
select FValue from t_SystemProfile
where FCategory='GL' AND FKEY='CurrentYear'
取当前期间期数
select FValue from t_SystemProfile
where FCategory='GL' AND FKEY='CurrentPeriod'
相关数据表及介绍
t_voucher 凭证主表
t_voucherentry 凭证分录表
t_CashFlowBal 现金流量分录表
t_Account 科目表
select * from t_Item where FItemClassID=9 为现金流量主表项目。
其他详细内容请参考C:\Program
Files\Kingdee\K3ERP\KDSDK\Sample\K3Login&Vch
文章评论