备注：如果是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
已实际测试，可以使用！效果如下：