clist_bosshow.cls

BOS大赛培训认证+-+样例代码

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "CList_BosShow"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Attribute VB_Description = "This is ListEvents Interface Class, made by K3BOSPLUGINSWIZAED"
 
'定义 ListEvents 接口. 必须具有的声明, 以此来获得事件
Private WithEvents m_ListInterface  As ListEvents
Attribute m_ListInterface.VB_VarHelpID = -1
 
Public Sub Show(ByVal oListInterface As Object)
 
    'ListEvents 接口实现
    '注意: 此方法必须存在, 请勿修改
    '要求当前登录人只能查由他自已做的单据
    Set m_ListInterface = oListInterface
    m_ListInterface.ListFilterString = "t_BOS200000001.fbillerID=" & m_ListInterface.K3Lib.User.UserID
 
End Sub

Private Sub Class_Terminate()
 
    '释放接口对象
    '注意: 此方法必须存在, 请勿修改
    Set m_ListInterface = Nothing

End Sub


Private Sub m_ListInterface_MenuBarClick(ByVal BOSTool As K3ClassEvents.BOSTool, Cancel As Boolean)
 
    Dim vectSelect As KFO.Vector
    Dim strIdFilter As String
    Dim bGroup As Boolean
    
    Select Case BOSTool.ToolName
    Case "BillEdit"
        '此处添加处理 BillEdit 菜单对象的 Click 事件
        bBilledit = True
        Call m_ListInterface.LoadSelectedBill(Enu_BillStatusExt_Modify)
        bBilledit = False
         
    
    '因新单下推旧单目前不支持[选单一致性]的处理，目前必须通过插件手工判断,
    Case "mnuBackData", "mnuPushOldBill_1"
        
        '目前的单据流程，新单->外购入库单是不需要处理选单一致性，但考虑到实际应用，此处提供了此种需求的处理代码
        '新单据到(老)外购入库单的选单一致性的处理
        '须处理两种情况,一种是目标单选源单时在源单序事簿选中记录点返回按钮时,另一种是在源单序事簿直接下推目标单时
        If BOSTool.ToolName = "mnuBackData" Then
            Set dctLink = m_ListInterface.DataSrv.dctLink
            If dctLink("FDestClasstypeid") = 1 Then bGroup = True
        Else
            bGroup = True
        End If
        
        If bGroup Then
           '得到所选记录信息
           Set vectSelect = m_ListInterface.GetSelectedBillInfo
           '通过函数得到所有选中记录的单据内码
           strIdFilter = GetSelectBillIDFilter(vectSelect, "Fid")
           '因新单下推旧单目前不支持选单一致性的处理，目前必须通过插件手工判断
           Cancel = CanPushBill(strIdFilter)
        End If
                
        
    Case Else
    End Select

End Sub

Private Sub m_ListInterface_MenuBarInitialize(ByVal oMenuBar As K3ClassEvents.MenuBar)
 
    Dim oTool   As K3ClassEvents.BOSTool
    Dim oBand   As K3ClassEvents.BOSBand
 
'*************** 开始新增 BOS 菜单 ***************
 
    '新增 BillEdit 菜单对象，并设置属性
    Set oTool = oMenuBar.BOSTools.Add("BillEdit")
    With oTool
        .Caption = "单据变更"
        .ToolTipText = "单据变更"
        .Description = "单据变更"
        .ShortcutKey = 0
        .Visible = True
        .Enabled = True
        .BeginGroup = False
        '清除剪贴板信息
        Clipboard.Clear
        '从资源文件从读取预先保存的图片　须注意此处客户内存不足时有可能执行失败
        Clipboard.SetData LoadResPicture(101, vbResBitmap), vbCFBitmap
        .PasteToolFace
    End With
 
    Set oBand = oMenuBar.BOSBands("mnuEdit")
    oBand.BOSTools.InsertBefore "mnuEditStartMultiCheck", oTool '将菜单对象插入指定一级菜单
 
    Set oBand = oMenuBar.BOSBands("BandToolBar")
    oBand.BOSTools.InsertBefore "mnuCaculate", oTool    '将菜单对象插入指定工具栏
 
 
'*************** 结束新增 BOS 菜单 ***************
 

End Sub
'此函数得到所选记录的单据内码的字符串，字符串以","作为间隔符主要是为了在查询SQL中方便使用
Public Function GetSelectBillIDFilter(ByVal vectSelect As KFO.Vector, ByVal strInterIDName As String) As String
    Dim i As Long
    Dim strFilter As String
    For i = vectSelect.LBound To vectSelect.UBound
        If vectSelect(i)(strInterIDName) > 0 Then
           strFilter = strFilter & IIf(i <> 1, ",", "") & CStr(vectSelect(i)(strInterIDName))
        End If
    Next
    GetSelectBillIDFilter = strFilter
End Function
'函数名称:CanPushBill
'描述:新单下推旧单，选单一致性的判断代码，此按钮增加了
'版本:V10.4
'作者: Caibo
'参数:strIdFilter 序时簿被选中行的过滤条件
'返回值: Boolean True:可以下推 False不可以下推
'修改时间: 2006-06-12
Private Function CanPushBill(ByVal strIdFilter As String) As Boolean
    '控制下推的客户必须相同
    Dim rs As ADODB.Recordset
    Dim lDepartment As Long
    CanPushBill = False
    On Error GoTo Err_Handle
    
    '得到所有符合条件的记录集
    Set rs = m_ListInterface.K3Lib.GetData("select FDeptID from t_BOS200000001 where fid in(" & strIdFilter & ")")
    If Not rs.EOF Then

        lDepartment = rs("FDeptID")
        '如果第一个部门和记录集里其它部门有不同的话，则给出提示
        rs.Find "FDeptID<>" & lDepartment
        If Not rs.EOF Then
            If MsgBox(m_ListInterface.K3Lib.LoadKDString("选单的部门不一致，是否继续?"), vbOKCancel, m_ListInterface.K3Lib.LoadKDString("金蝶提示")) = vbCancel Then
               CanPushBill = True
               Exit Function
            End If
        End If
        'If Not rs.BOF Then rs.MoveFirst
           
    End If
    GoTo ExitSub
Err_Handle:
    HandleError Err
ExitSub:
    Set rs = Nothing
End Function

Private Sub m_ListInterface_UnBusinessCheck(Cancel As Boolean)
  Dim rs As ADODB.Recordset
  Dim strsql As String
  '不允许选择超过一条记录
  If m_ListInterface.GetSelectedBillInfo.Size > 1 Then
     MsgBox "多级审核测试,不能选择一条以上记录!"
     Cancel = True
     GoTo HExit
  End If
  '从寄存入库单取出是否有已生成记帐凭证的单据
  strsql = "select 1 from t_BOS200000001 where fvoucherid_id>0 and FID=" & m_ListInterface.GetSelectedBillInfo(1)("FID")
  Set rs = m_ListInterface.K3Lib.GetData(strsql)
  If Not rs.EOF Then
     MsgBox "单据已经生成记帐凭证,不允许反业务审核!"
     Cancel = True
     GoTo HExit
  End If
  '从寄存入库单取出是否有已被外购入库单关联的单据，注意此处是通过已钩稽数量是否大于0来判断寄存入库单是否已关联
  strsql = "select 1 from t_BOS200000001entry2 where FFinishQty>0 and FID=" & m_ListInterface.GetSelectedBillInfo(1)("FID")
  Set rs = m_ListInterface.K3Lib.GetData(strsql)
  If Not rs.EOF Then
     MsgBox "单据已经被其它单据引用,不允许反业务审核!"
     Cancel = True
     GoTo HExit
  End If
  
HExit:
  Set rs = Nothing
  
  
End Sub