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
5.代码文件
