备注：如果是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 SubPrivate Sub Class_Terminate() '释放接口对象 '注意: 此方法必须存在, 请勿修改 Set m_BillTransfer = NothingEnd SubPrivate Sub m_BillTransfer_BillInitialize() '*************** 开始设置菜单 *************** m_BillTransfer.AddUserMenuItem "用户自定义 1", "自定义菜单" '*************** 结束设置菜单 *************** End SubPrivate 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 SelectEnd Sub
MMTS代码如下：
Option Explicit'子系统描述,根据自己系统内容替换Public Const SUBID = "gl"Public Const SUBNAME = "总帐系统"'mts share property lockmodePrivate Const LockMethod = 1Private Const LockSetGet = 0'mts share propertyPrivate Const Process = 1Private Const Standard = 0'Private m_oSvrMgr As Object 'Server ManagerPrivate m_oSpmMgr As ObjectPublic m_oLogin As ObjectPrivate Declare Function CanChangeMtsServer Lib "kdappsvr.dll" () As LongPrivate Declare Function GetCurrentProcessId Lib "kernel32" () As LongPublic LoginType As StringPublic LoginAcctID As LongPublic 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(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 IfEnd 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 FunctionPublic Function UserName() As StringIf m_oLogin Is Nothing Then UserName = GetConnectionProperty("UserName")Else UserName = m_oLogin.UserNameEnd IfEnd FunctionPublic Function PropsString() As StringIf m_oLogin Is Nothing Then PropsString = GetConnectionProperty("PropsString")Else PropsString = m_oLogin.PropsStringEnd IfEnd FunctionPublic Property Get ServerMgr() As Object Set ServerMgr = GetConnectionProperty("KDLogin")End PropertyPublic Function IsDemo() As BooleanIf m_oLogin Is Nothing Then IsDemo = (GetConnectionProperty("LogStatus") = 2)Else IsDemo = (m_oLogin.LogStatus = 2)End IfEnd FunctionPublic Function AcctName() As StringIf m_oLogin Is Nothing Then AcctName = GetConnectionProperty("AcctName")Else AcctName = m_oLogin.AcctNameEnd IfEnd FunctionPrivate 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 IfEnd FunctionPrivate 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_oLoginEnd SubPrivate 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 = NothingEnd Sub 
