八、K3 WISE 开发插件《工业单据老单插件中获取登陆用户名》

备注：如果是BOS新单，都有获取用户名的方法。在单据有m_BillInterface.K3Lib.User.UserId，在序时薄有m_ListInterface.K3Lib.User.UserID

工业单据获取用户名，源代码如下：

工程引用：

Class1代码如下：

'定义插件对象接口. 必须具有的声明, 以此来获得事件
Private WithEvents m_BillTransfer   As k3BillTransfer.Bill

Public Sub Show(ByVal oBillTransfer As Object)

    '接口实现
    '注意: 此方法必须存在, 请勿修改
    Set m_BillTransfer = oBillTransfer

End Sub

Private Sub Class_Terminate()

    '释放接口对象
    '注意: 此方法必须存在, 请勿修改
    Set m_BillTransfer = Nothing

End Sub

Private Sub m_BillTransfer_BillInitialize()

'*************** 开始设置菜单 ***************

    m_BillTransfer.AddUserMenuItem "用户自定义 1", "自定义菜单"

'*************** 结束设置菜单 ***************

End Sub

Private Sub m_BillTransfer_UserMenuClick(ByVal Index As Long, ByVal Caption As String)

    'TODO: 请在此处添加代码响应事件 UserMenuClick

    Select Case Caption
    Case "用户自定义 1"
        '此处添加处理 用户自定义 1 菜单对象的 Click 事件
 MsgBox UserName()
    Case Else
    End Select

End Sub

MMTS代码如下：

Option Explicit
'子系统描述,根据自己系统内容替换
Public Const SUBID = "gl"
Public Const SUBNAME = "总帐系统"

'mts share property lockmode
Private Const LockMethod =
Private Const LockSetGet =
'mts share property
Private Const Process =
Private Const Standard = 

'Private m_oSvrMgr As Object 'Server Manager
Private m_oSpmMgr As Object
Public m_oLogin As Object
Private Declare Function CanChangeMtsServer Lib "kdappsvr.dll" () As Long
Private Declare Function GetCurrentProcessId Lib "kernel32" () As Long
Public LoginType As String
Public LoginAcctID As Long

Public Function CheckMts(ByVal CFG As Long, Optional ByVal ChangeUser As Boolean = False) As Long
    CheckMts = False
    If CFG Then
        If Not m_oLogin Is Nothing And Not ChangeUser Then
           CheckMts = True
           Exit Function
        End If

        Dim bChangeMts As Boolean
        bChangeMts = True
        Set m_oLogin = CreateObject("KDLogin.clsLogin")
        If InStr(, LoginType, "Straight", vbTextCompare) >  And Not ChangeUser Then
           If m_oLogin.LoginStraight(SUBID, SUBNAME, LoginAcctID) Then
              CheckMts = True
              Call OpenConnection
           End If
       Else
           If m_oLogin.Login(SUBID, SUBNAME, bChangeMts) Then
              CheckMts = True
              Call OpenConnection
           End If
       End If
    Else
       m_oLogin.Shutdown
       Set m_oLogin = Nothing
    End If
End Function
'登录
'Public Function CheckMts(ByVal CFG As Long, Optional ByVal ChangeUser As Boolean = False) As Long
'    '检查Mts状态
'    CheckMts = False
'    Set m_oLogin = Nothing
'    If CFG Then
'        If Not m_oLogin Is Nothing And Not ChangeUser Then
'           CheckMts = True
'           Exit Function
'        End If
'        LoginAcctID = 1
'        Dim bChangeMts As Boolean
'        bChangeMts = True
'        Set m_oLogin = CreateObject("KDLogin.clsLogin")
''        If InStr(1, LoginType, "Straight", vbTextCompare) > 0 And Not ChangeUser Then
'
'        '直接调用
'        '实现二次开发模块的隐藏登录
'        If m_oLogin.LoginStraight(SUBID, SUBNAME, LoginAcctID) Then
'           CheckMts = True
'           Call OpenConnection
'        End If
''       Else
''
''           '重新登录
''           If m_oLogin.Login(SUBID, SUBNAME, bChangeMts) Then
''              CheckMts = True
''              Call OpenConnection
''           End If
''       End If
'    Else
'       m_oLogin.ShutDown
'       Set m_oLogin = Nothing
'    End If
'End Function

Public Function UserName() As String
If m_oLogin Is Nothing Then
    UserName = GetConnectionProperty("UserName")
Else
    UserName = m_oLogin.UserName
End If
End Function
Public Function PropsString() As String
If m_oLogin Is Nothing Then
    PropsString = GetConnectionProperty("PropsString")
Else
    PropsString = m_oLogin.PropsString
End If
End Function
Public Property Get ServerMgr() As Object
    Set ServerMgr = GetConnectionProperty("KDLogin")
End Property
Public Function IsDemo() As Boolean
If m_oLogin Is Nothing Then
    IsDemo = (GetConnectionProperty("LogStatus") = )
Else
    IsDemo = (m_oLogin.LogStatus = )
End If
End Function
Public Function AcctName() As String
If m_oLogin Is Nothing Then
    AcctName = GetConnectionProperty("AcctName")
Else
    AcctName = m_oLogin.AcctName
End If
End Function
Private Function GetConnectionProperty(strName As String, Optional ByVal bRaiseError As Boolean = True) As Variant

    Dim spmMgr As Object
    'Dim spmGroup As Object
    'Dim spmProp As Object
    'Dim bExists As Boolean

    'Set spmMgr = CreateObject("MTxSpm.SharedPropertyGroupManager.1")
    'Set spmGroup = spmMgr.CreatePropertyGroup("Info", LockSetGet, Process, bExists)

    'Set spmProp = spmGroup.Property(strName)
    'If IsObject(spmProp.Value) Then
    '    Set GetConnectionProperty = spmProp.Value
    'Else
    '    GetConnectionProperty = spmProp.Value
    'End If
    Dim lProc As Long
    lProc = GetCurrentProcessId()
    Set spmMgr = CreateObject("PropsMgr.ShareProps")
    If IsObject(spmMgr.GetProperty(lProc, strName)) Then
        Set GetConnectionProperty = spmMgr.GetProperty(lProc, strName)
    Else
        GetConnectionProperty = spmMgr.GetProperty(lProc, strName)
    End If
End Function
Private Sub OpenConnection()
    'Dim spmMgr As Object
    'Dim spmGroup As Object
    'Dim spmProp As Object
    'Dim bExists As Boolean

    'Set spmMgr = CreateObject("MTxSpm.SharedPropertyGroupManager.1")
    'Set spmGroup = spmMgr.CreatePropertyGroup("Info", LockSetGet, Process, bExists)
    'Set spmProp = spmGroup.CreateProperty("UserName", bExists)
    'spmProp.Value = m_oLogin.UserName
    'Set spmProp = spmGroup.CreateProperty("PropsString", bExists)
    'spmProp.Value = m_oLogin.PropsString
    'Set spmProp = spmGroup.CreateProperty("KDLogin", bExists)
    'spmProp.Value = m_oLogin
    Dim lProc As Long
    lProc = GetCurrentProcessId()
    Set m_oSpmMgr = CreateObject("PropsMgr.ShareProps")
    m_oSpmMgr.addproperty lProc, "UserName", m_oLogin.UserName
    m_oSpmMgr.addproperty lProc, "PropsString", m_oLogin.PropsString
    m_oSpmMgr.addproperty lProc, "LogStatus", m_oLogin.LogStatus
    m_oSpmMgr.addproperty lProc, "AcctName", m_oLogin.AcctName
    m_oSpmMgr.addproperty lProc, "KDLogin", m_oLogin
End Sub
Private Sub CloseConnection()
    'On Error Resume Next

    Dim lProc As Long

    lProc = GetCurrentProcessId()
    m_oSpmMgr.delproperty lProc, "UserName"
    m_oSpmMgr.delproperty lProc, "PropsString"
    m_oSpmMgr.delproperty lProc, "LogStatus"
    m_oSpmMgr.delproperty lProc, "AcctName"
    m_oSpmMgr.delproperty lProc, "KDLogin"

    Set m_oSpmMgr = Nothing
End Sub

已实际测试，可以使用！效果如下：