八、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 = 1
Private Const LockSetGet = 0
'mts share property
Private Const Process = 1
Private Const Standard = 0

'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(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 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") = 2)
Else
    IsDemo = (m_oLogin.LogStatus = 2)
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

 

已實際測試，可以使用！效果如下：