frmmain.frm

使用k3组件调用来实现VB与现有金蝶财务软件实现程序凭证接口

Private K3Login As Object '当前连接对象
Private ReturnVoucherID As Long '保存返回的凭证ID

Private Sub CmdConn_Click()
    On Error GoTo Conn_Error
    Dim HasConn As Boolean '当前连接是否成功
    HasConn = False
    If OptConn(0).Value Then '选择登录
        Set K3Login = CreateObject("K3Login.ClsLogin")
        If Not K3Login.CheckLogin Then
            AddString "连接不成功"
            Set K3Login = Nothing
            Exit Sub
        End If
        HasConn = True
    Else '按当前默认登录
        HasConn = False
    End If
    CmdQConn.Enabled = HasConn
    CmdConn.Enabled = Not HasConn
    '显示账套连接信息
    SetStatusBar HasConn
    Exit Sub
Conn_Error:
    AddString "ErrCode:" & Err & " ErrDescription:" & Err.Description
End Sub

Private Sub CmdDoSys_Click()
        Dim retcol As Object
        Select Case CboSysclass.Text
            Case "凭证字查询"
                Set retcol = GLView.VoucherGroupLookup
            Case "凭证字新增"
                Set retcol = GLView.VoucherGroupAdd
            Case "凭证字修改"
                Set retcol = GLView.VoucherGroupEdit(1)
            Case "科目查询"
                Set retcol = GLView.AccountLookup
            Case "科目新增"
                Set retcol = GLView.AccountAdd
            Case "科目修改"
                Set retcol = GLView.AccountEdit(TxtItemNumber.Text)
            Case "币别查询"
                Set retcol = GLView.CurrencyLookup
            Case "币别新增"
                Set retcol = GLView.CurrencyAdd
            Case "币别修改"
                Set retcol = GLView.CurrencyEdit(1)
            Case "核算项目(职员)查询"
                Set retcol = GLView.ItemLookup(3) '核算项目类别t_ItemClass中职员ItemClassID=3
            Case "核算项目(职员)新增"
                Set retcol = GLView.ItemAdd(3)
            Case "核算项目(职员)修改"
                Set retcol = GLView.ItemEdit(TxtItemNumber.Text)
            Case "辅助资料(文化程度)查询"
                Set retcol = GLView.SubMesLookup(23) '文化程度(工业t_Submestype FtypeID=23)
            Case "辅助资料(文化程度)新增"
                Set retcol = GLView.SubMesAdd(23)
            Case "辅助资料(文化程度)修改"
                Set retcol = GLView.SubMesEdit(TxtItemNumber.Text, 23)
        End Select
        If retcol.ReturnOK Then
             If Not retcol.ReturnObject Is Nothing Then
                AddString "功能操作[" & CboSysclass.Text & "]成功"
             End If
        End If
End Sub

Private Sub CmdDoVch_Click()
    Dim Vch As Object, Mode As Long
    Set Vch = CreateObject("Mvedit.MVoucherEdit")
    'Mode值= '新增 0        '显示 1        '修改 2        '审核 3
    If OptVch(0).Value = True Then '凭证新增(界面)
        Mode = 0
        Vch.LoadVoucher Mode, , , , ReturnVoucherID
    ElseIf OptVch(1).Value = True Then '凭证新增(界面数据)
        Mode = 0
        ReturnVoucherID = 0
        Dim Voucher As Object
        Set Voucher = CreateVoucher
        If Voucher Is Nothing Then Exit Sub
        Dim rel As KDVBF.Relevancy
        Set rel = New KDVBF.Relevancy '建立输入对象
        Set rel.EditObject = Voucher '设置凭证数据对象到Rel参数
        rel.MultiEdit = False '是否允许多张凭证编辑
        Vch.LoadVoucher Mode, , rel, , ReturnVoucherID
        MsgVoucher ReturnVoucherID
    ElseIf OptVch(2).Value = True Then '凭证修改(界面)
        If ReturnVoucherID <= 0 Then
            MsgBox "请先新增一张凭证!"
            Exit Sub
         End If
        Mode = 2
        Vch.LoadVoucher Mode, ReturnVoucherID
    ElseIf OptVch(3).Value = True Then '凭证保存(中间层)
        ReturnVoucherID = SaveVoucher
    ElseIf OptVch(4).Value = True Then '凭证删除
        If ReturnVoucherID <= 0 Then
            MsgBox "请先新增一张凭证!"
            Exit Sub
         End If
        If DeleteVoucher(ReturnVoucherID) Then
            AddString "凭证成功删除!"
            ReturnVoucherID = 0
        End If
    End If
    
    Set Vch = Nothing
End Sub

Private Sub CmdExit_Click()
    Unload Me
End Sub

Private Sub CmdPrint_Click()
       Dim a As Object '
       Set a = CreateObject("KDNotation.Notation")
       a.Text = TxtStatus.Text
       a.ShowDialog "鸿元体育中心酒店管理接口"
End Sub

Private Sub CmdQConn_Click()
    On Error GoTo Quit_Error
    If OptConn(0).Value Then '登录取消
        Set K3Login = Nothing
    Else '按当前默认登录
    
    End If
    CmdQConn.Enabled = False
    CmdConn.Enabled = True
    AddString "当前登录已经取消!"
    SetStatusBar
    Exit Sub
Quit_Error:
    AddString "ErrCode:" & Err & " ErrDescription:" & Err.Description
End Sub

Private Sub Form_Load()
    SetStatusBar
    FirstLoad = True
End Sub

Public Sub SetStatusBar(Optional ByVal HasConn As Boolean = False)
    On Error GoTo init_Fail
    If Not HasConn Then '当前没有数据连接
        sb.Panels(2).Text = "当前没有可用的数据连接"
        sb.Panels(3).Text = ""
        sb.Panels(4).Text = ""
        sb.Panels(5).Text = ""
        SSTab.TabVisible(1) = False
        SSTab.TabVisible(2) = False
        Exit Sub
    End If
    SSTab.TabVisible(1) = True
    SSTab.TabVisible(2) = True
    
    If K3Login.IsDemo Then sb.Panels(3).Text = "演示版-"
    sb.Panels(3).Text = sb.Panels(3).Text & Trim$(K3Login.AcctName)
    sb.Panels(2).Text = GLData.SystemProfile.CompanyName
    With GLData.SystemProfile
        sb.Panels(4).Text = .GLGetCurrentYear & "年" & .GLGetCurrentPeriod & "期"
    End With
    sb.Panels(5).Text = SystemData.CurrentUserName
    AddString "账套[" & K3Login.AcctName & "]连接成功,公司名称:" & GLData.SystemProfile.CompanyName
    AddString "当前账套数据连接串[" & K3Login.PropsString & "]"
    'MsgBox K3Login.PropsString   '查看当前账套数据连接串
    Exit Sub
init_Fail:
    AddString "ErrCode:" & Err & " ErrDescription:" & Err.Description
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Set K3Login = Nothing
End Sub

Private Sub SSTab_Click(PreviousTab As Integer)
    Select Case SSTab.Tab
    Case 0 '登录
    Case 1 '凭证
        '填充凭证字列表
        GLView.FillVoucherGroup CboGroup
        If CboGroup.ListCount > 0 Then CboGroup.ListIndex = 0
        TxtNumber.Text = "1"
    Case 2 '基础资料
        With CboSysclass
            .Clear
            .AddItem "凭证字查询"
            .AddItem "凭证字新增"
            .AddItem "凭证字修改"
            .AddItem "科目查询"
            .AddItem "科目新增"
            .AddItem "科目修改"
            .AddItem "币别查询"
            .AddItem "币别新增"
            .AddItem "币别修改"
            .AddItem "核算项目(职员)查询"
            .AddItem "核算项目(职员)新增"
            .AddItem "核算项目(职员)修改"
            .AddItem "辅助资料(文化程度)查询"
            .AddItem "辅助资料(文化程度)新增"
            .AddItem "辅助资料(文化程度)修改"
        End With
        
    End Select
End Sub
'建立界面显示凭证数据
Private Function CreateVoucher() As Object
    Dim Voucher As Object '凭证对象
    Dim VoucherEntrys As Object '凭证分录对象
    Set Voucher = CreateObject("EBCGL.Voucher")
    Voucher.Construct Nothing, Nothing '建立凭证数据对象
    Set VoucherEntrys = Voucher.Entries '设置凭证分录对象
    Voucher.InternalInd = "Super" '机制凭证信息(可选)
    '设置凭证默认日期(可选)
'    Voucher.TransDate = Format(Now, "yyyy-mm-dd") '业务日期
 '   Voucher.VoucherDate = Format(Now, "yyyy-mm-dd") '凭证日期
     Voucher.GroupID = CboGroup.ItemData(CboGroup.ListIndex) '凭证字
     Voucher.Number = Val(TxtNumber.Text) '凭证号
    
    '下面输入凭证分录数据
    '借方分录数据
    Dim Acct1 As Long, Acct2 As Long
    GetRndAccountID Acct1, Acct2
    If Acct1 * Acct2 = 0 Then Exit Function
    VoucherEntrys.Add
    With Voucher.Entries(Voucher.Entries.Count)
        .Explanation = "凭证录入检测-分录1"
        .AccountID = Acct1
        .Amount = 100
        .AmountFor = 100
        .ExchangeRate = 1
        .CurrencyID = 1
        .DC = 1 '借方
    End With
    '贷方分录数据
    VoucherEntrys.Add
    With Voucher.Entries(Voucher.Entries.Count)
        .Explanation = "凭证录入检测-分录1"
        .AccountID = Acct2
        .Amount = 100 '本位币
        .AmountFor = 100 '原币
        .ExchangeRate = 1 '汇率
        .CurrencyID = 1 '币别
        .DC = 0 '贷方
    End With
    Set CreateVoucher = Voucher
End Function
'中间层直接保存凭证
Private Function SaveVoucher() As Long
    On Error GoTo ErrHandle
    Dim Acct1 As Long, Acct2 As Long
    SaveVoucher = 0
    GetRndAccountID Acct1, Acct2
    If Acct1 * Acct2 = 0 Then Exit Function
    Dim Voucher As New kfo.Dictionary
    Dim VchDate As Date
    VchDate = DateSerial(SystemProfile.GLGetCurrentYear, SystemProfile.GLGetCurrentPeriod, 1)
    Voucher("FDate") = VchDate '当前期间凭证日期
    Voucher("FGroup") = CboGroup.Text '凭证字
    Voucher("FNumber") = Val(TxtNumber.Text)      '凭证号

    
    Dim VoucherEntry As New kfo.Vector
    Dim tempEntry As kfo.Dictionary
    Set tempEntry = New kfo.Dictionary
    tempEntry("FExplanation") = "凭证录入检测-分录1"
    tempEntry("FAccountID") = Acct1
    tempEntry("FCurrencyID") = 1
    tempEntry("FDC") = 1
    tempEntry("FAmountFor") = 100
    tempEntry("FAmount") = 100
    VoucherEntry.Add tempEntry
    Set tempEntry = New kfo.Dictionary
    tempEntry("FExplanation") = "凭证录入检测-分录2"
    tempEntry("FAccountID") = Acct2
    tempEntry("FCurrencyID") = 1
    tempEntry("FDC") = 0
    tempEntry("FAmountFor") = 100
    tempEntry("FAmount") = 100
    '==============================================
    '保存带核算项目的部分
    If Not (GetItemofAcct(Acct1) Is Nothing) Then _
        Set VoucherEntry("_Detail") = GetItemofAcct(Acct1)
    
    '==============================================
    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
    MsgVoucher VoucherID
    SaveVoucher = VoucherID
    Exit Function
ErrHandle:
    HandleError Err
End Function
'取得指定的科目的核算项目
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 rsAcct.EOF
            Set Dt = New kfo.Dictionary
            Dt("FItemID") = rsAcct!FItemID
            Dt("FItemClassID") = rsAcct!FItemClassID
            dtVector.Add Dt
        Loop
    End If
    
    Set GetItemofAcct = dtVector
    
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
'显示凭证信息
Private Sub MsgVoucher(ByVal VoucherID As Long)
    On Error Resume Next
    If VoucherID <= 0 Then Exit Sub
    Dim VchSet As Object    'EBCGL.VoucherSet
    Dim Vch As Object   'EBCGL.Voucher
    Set VchSet = CreateObject("EBCGL.VoucherSet")
    Set Vch = VchSet(VoucherID)
    If Not Vch Is Nothing Then AddString "已经生成一张凭证," & vbCrLf & "凭证字号为: " & Vch.Group & " - " & Vch.Number
End Sub
'获取凭证保存的随机科目
Private Function GetRndAccountID(Acct1 As Long, Acct2 As Long) As Boolean
    On Error GoTo ErrHandle
    Dim As1 As Long, As2 As Long
    Dim AcctRs As Object
    '获得科目数据结果集
    Set AcctRs = GLData.AccountSet.Recordset.Clone
    '随机选取符合凭证录入的科目
    AcctRs.Filter = " FDetailID=0 and FDetail=1 and FQuantities=0 and FCurrencyID=1 "
    GetRndAccountID = False
    Acct1 = 0
    Acct2 = 0
    If AcctRs.RecordCount <= 0 Then Exit Function
    Randomize Timer
    As1 = Round(Rnd(1000) * (AcctRs.RecordCount - 1))
    AcctRs.Move As1, 1
    Acct1 = AcctRs!FAccountID
    As2 = Round(Rnd(1000) * (AcctRs.RecordCount - 1))
    AcctRs.Move As2, 1
    Acct2 = AcctRs!FAccountID
    GetRndAccountID = True
    Exit Function
ErrHandle:
End Function

Private Sub AddString(ByVal str As String)
    Dim l As Long
    str = "......" & str
    ListStatus.AddItem str
    l = Len(TxtStatus.Text & vbCrLf)
    TxtStatus.Text = TxtStatus.Text & vbCrLf & str
    TxtStatus.SelStart = l
End Sub