金蝶二次开发

MMTS.bas 模块

 

 Option Explicit
'╰?磞瓃,誹╰??甧蠢?
Public SUBID As String
Public SUBNAME As String

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

Public LoginType As String
'Private m_oSvrMgr As Object 'Server Manager
Private m_oSpmMgr As Object
Private m_oLogin As Object
Public m_LanguageType As String

Public LoginAcctID As Long

'糤?ē?瞶?ン獺
Private Const CONST_K3RESLOADER = "K3ResLoader.Loader"
Private Const CONST_K3FRMLOADER = "FrmRes.FrmResLoader"
Private Const CONST_RESFILE = "K3ArAp"
Public g_objResLoader   As Object

Private Declare Function GetCurrentProcessId Lib "kernel32" () As Long
'/********************************************************************/
'/*磞瓃:?﹚怠?方ゅン狦Τ????獺
'/*??:
'/*@ frm Form
'/*?猔:
'/********************************************************************/
Public Function LoadFormResString(frm As Object) As String
    Dim FrmResLoader As Object
    Dim Msgs As KFO.Vector
    Dim i As Long
    Dim errMessage As String
    On Error GoTo HError
   
    Set FrmResLoader = CreateObject(CONST_K3FRMLOADER)
    Set Msgs = FrmResLoader.LoadFrmResStrings(frm, GetPropertyExt("Language"), App.Path, CONST_RESFILE)
   
'    For i = Msgs.LBound To Msgs.UBound
'        errMessage = errMessage + Msgs(i) + vbCrLf
'    Next i
'    LoadFormResString = errMessage
    Set FrmResLoader = Nothing
    Exit Function
HError:
    LoadFormResString = Err.Description
    Set FrmResLoader = Nothing
End Function

'?ē秆猂ㄧ?
Public Function LoadKDString(ByVal strGBText As String) As String
    On Error GoTo errHandler
    Dim Language    As String
   
    Language = GetPropertyExt("Language")
    If Language = "CHS" Then GoTo errHandler
   
    If Len(strGBText) = 0 Then
        LoadKDString = ""
        Exit Function
    End If
   
   
    If g_objResLoader Is Nothing Then
        Set g_objResLoader = CreateObject(CONST_K3RESLOADER)
    End If
   
    If g_objResLoader.ResFileBaseName <> CONST_RESFILE Then
        g_objResLoader.ResFileBaseName = CONST_RESFILE
    End If
   
    If g_objResLoader.LanguageID <> Language Then
        g_objResLoader.LanguageID = Language
    End If
   
    LoadKDString = g_objResLoader.LoadString(Trim$(strGBText))
   
    Exit Function
   
errHandler:
'    LoadKDString = "[⊙]" & strGBText    '狦тぃ???瞶睰﹟ゼЧΘ璶э wdy
    LoadKDString = strGBText
End Function
Public Function LoadKDString2(ByVal strGBText As String) As String
    On Error GoTo errHandler
    Dim Language    As String
   
    Language = GetPropertyExt("Language")
   
    If Len(strGBText) = 0 Then
        LoadKDString2 = ""
        Exit Function
    End If
    If g_objResLoader Is Nothing Then
        Set g_objResLoader = CreateObject(CONST_K3RESLOADER)
    End If
   
    If g_objResLoader.ResFileBaseName <> CONST_RESFILE Then
        g_objResLoader.ResFileBaseName = CONST_RESFILE
    End If
   
    If g_objResLoader.LanguageID <> Language Then
        g_objResLoader.LanguageID = Language
    End If
   
    LoadKDString2 = g_objResLoader.LoadString2(Trim$(strGBText))
   
    Exit Function
   
errHandler:
    Debug.Print strGBText
    LoadKDString2 = "[⊙]" & strGBText    '狦тぃ???瞶睰﹟ゼЧΘ璶э wdy
   
End Function

Public Function LoadLangguage(ByVal ctls As Object)
    Dim ctl As Object
    Dim i As Long
    Dim j As Long
    For Each ctl In ctls
        If TypeName(ctl) = "Label" Or TypeName(ctl) = "CommandButton" _
           Or TypeName(ctl) = "CheckBox" Or TypeName(ctl) = "HPanel" _
           Or TypeName(ctl) = "Frame" Then
            ctl.Caption = MMTS.LoadKDString2(ctl.Caption)
        ElseIf TypeName(ctl) = "vaSpread" Then
            ctl.row = 0
            For i = 1 To ctl.MaxCols
                ctl.Col = i
                ctl.Text = MMTS.LoadKDString2(ctl.Text)
            Next
        ElseIf TypeName(ctl) = "TabStrip" Then
            With ctl
                For i = 1 To .Tabs.Count
                    .Tabs(i).Caption = MMTS.LoadKDString2(.Tabs(i).Caption)
                Next i
            End With
        ElseIf TypeName(ctl) = "ListView" Then
            With ctl
                For i = 1 To .ColumnHeaders.Count
                    .ColumnHeaders(i).Text = MMTS.LoadKDString2(.ColumnHeaders(i).Text)
                Next
            End With
        ElseIf TypeName(ctl) = "Toolbar" Then
            With ctl
                For i = 1 To .Buttons.Count
                    .Buttons(i).Caption = MMTS.LoadKDString2(.Buttons(i).Caption)
                    For j = 1 To .Buttons(i).ButtonMenus.Count
                        .Buttons(i).ButtonMenus(j) = MMTS.LoadKDString2(.Buttons(i).ButtonMenus(j))
                    Next
                Next
            End With
        ElseIf TypeName(ctl) = "SSTab" Then
            With ctl
                For i = 1 To ctl.Tabs
                    ctl.TabCaption(i) = MMTS.LoadKDString2(ctl.TabCaption(i))
                Next
            End With
        End If
    Next
   
End Function

Public Function GetPropertyExt(ByVal sName As String) As String
   
    On Error Resume Next
    Dim i As Integer
    Dim j As Integer
    Dim sTemp As String
    Dim sString As String
    Dim s As String
   
    sString = PropsString
    s = ";"
   
    sTemp = IIf(Right(sString, 1) = s, sString, sString & s)
    sName = sName & "="
   
    i = InStr(1, sTemp, sName, vbTextCompare)     'ぃ?だ?
    If i <> 0 Then
        sTemp = Right(sTemp, Len(sTemp) - i + 1)
        j = InStr(1, sTemp, s)
        If j <> 0 Then
            sTemp = VBA.Left(sTemp, j - 1)
            GetPropertyExt = UCase$(Right(sTemp, Len(sTemp) - Len(sName)))
        End If
    End If
End Function

Public Function CheckMts(CFG As Long) As Long
   '?琩Mts??
'''    CheckMts = False
'''    If CFG Then
'''        Dim bChangeMts As Boolean
'''        bChangeMts = CanChangeMtsServer()
'''        Set m_oLogin = Nothing
'''        Set m_oLogin = CreateObject("KDLogin.clsLogin")
'''        If m_oLogin.Login(SUBID, SUBNAME, bChangeMts) Then
'''            CheckMts = True
'''            Call OpenConnection
'''        End If
'''    Else
'''       m_oLogin.ShutDown
'''       Set m_oLogin = Nothing
'''    End If
    CheckMts = False
    If CFG Then
        Dim bFirst As Boolean
        If m_oLogin Is Nothing Then
           bFirst = True
        End If

        Dim bChangeMts As Boolean
        bChangeMts = False
        Set m_oLogin = Nothing
        Set m_oLogin = CreateObject("KDLogin.clsLogin")
        If InStr(1, LoginType, "Straight", vbTextCompare) > 0 And LoginAcctID <> 0 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
'PropsString = "ConnectString={Provider=SQLOLEDB.1;Integrated Security=SSPI;Persist Security Info=False;Data Source=PCT0504-504;Initial Catalog=Regina};UserName=kingdee;UserID=16456;DBMS Name=Microsoft SQL Server;DBMS Version=2000;SubID=super;AcctType=gy;Setuptype=industry;Language=cht"
'Exit Function
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
Public Function acctId() As String
If m_oLogin Is Nothing Then
    acctId = GetConnectionProperty("AcctID")
Else
    acctId = m_oLogin.acctId
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
    m_oSpmMgr.addproperty lProc, "Setuptype", m_oLogin.SetupType
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"
    m_oSpmMgr.delproperty lProc, "Setuptype"
    Set m_oSpmMgr = Nothing
End Sub
Public Function IsIndustry() As Boolean
    IsIndustry = (UCase(GetConnectionProperty("AcctType")) = "GY")
End Function

'========================================================================
'磞瓃 誹?甅ID?甅?┦
'========================================================================
Public Function GetAcctProp(ByVal lngAcctID As Long, ByVal strKey As String) As Variant
    Dim strProp As String
   
    Dim rs As Object
    Dim oSvrMgr As Object
    Set oSvrMgr = CreateObject("KdSvrMgr.clsAct")
    Set rs = oSvrMgr.GetAccountList()
    Set oSvrMgr = Nothing
    With rs
        If .RecordCount Then .MoveFirst
        Do Until .EOF
            If .Fields("FAcctID") = lngAcctID Then
                strProp = .Fields(strKey).Value
                Exit Do
            End If
            .MoveNext
        Loop
    End With
    rs.Close
    Set rs = Nothing
   
    GetAcctProp = strProp
End Function

'========================================================================
'磞瓃 ?祅??甅
'========================================================================
Public Function NoUILogin(ByVal strServer As String, _
                          ByVal lngAcctID As Long, _
                          ByVal strUserName As String, _
                          ByVal strPassword As String) As Boolean
    NoUILogin = False
   
    Dim lProc As Long
    lProc = GetCurrentProcessId()
   
    Dim oLogin As Object
    Set oLogin = CreateObject("KDLogin.NoUILogin")
    If oLogin.Login(MMTS.SUBID, strServer, lngAcctID, strUserName, strPassword) Then
        Set m_oSpmMgr = CreateObject("PropsMgr.ShareProps")
        m_oSpmMgr.addproperty lProc, "UserName", oLogin.UserName
        m_oSpmMgr.addproperty lProc, "PropsString", oLogin.PropsString
        m_oSpmMgr.addproperty lProc, "LogStatus", 2
        m_oSpmMgr.addproperty lProc, "AcctName", GetAcctProp(lngAcctID, "FAcctName")
        m_oSpmMgr.addproperty lProc, "SetupType", "Industry"
        m_oSpmMgr.addproperty lProc, "AcctType", oLogin.AcctType
       
        Set m_oLogin = CreateObject("KDLogin.clsLogin")
        m_oLogin.SetLoginProp oLogin.PropsString
        m_oSpmMgr.addproperty lProc, "KDLogin", m_oLogin
       
        NoUILogin = True
    End If
    Set oLogin = Nothing
End Function

 

Public Function SetupType() As String
If m_oLogin Is Nothing Then
    SetupType = GetConnectionProperty("SetupType")
Else
    SetupType = m_oLogin.SetupType
End If
End Function

Public Function UserID() As String
    Dim strProps As String
    Dim i As Long
    Dim vUserID
    Dim vValue
    strProps = PropsString
    i = InStr(1, strProps, "UserID=", vbTextCompare)
    If i > 0 Then
        strProps = Right(strProps, Len(strProps) - i + 1)
        vUserID = Split(strProps, ";")
        vValue = Right(vUserID(0), Len(vUserID(0)) - Len("UserID="))
        UserID = vValue
    End If
   
End Function

Public Function LoadString(ByVal MesIndex As Long) As String
    m_LanguageType = GetPropertyExt("Language")
    If Len(CStr(MesIndex)) = 1 Then
        If UCase(m_LanguageType) = UCase("CHS") Then
            LoadString = LoadResString(Val("10" & MesIndex))
        ElseIf UCase(m_LanguageType) = UCase("CHT") Then
            LoadString = LoadResString(Val("20" & MesIndex))
        ElseIf UCase(m_LanguageType) = UCase("EN") Then
            LoadString = LoadResString(Val("30" & MesIndex))
        End If
    ElseIf Len(CStr(MesIndex)) = 2 Then
        If UCase(m_LanguageType) = UCase("CHS") Then
            LoadString = LoadResString(Val("1" & MesIndex))
        ElseIf UCase(m_LanguageType) = UCase("CHT") Then
            LoadString = LoadResString(Val("2" & MesIndex))
        ElseIf UCase(m_LanguageType) = UCase("EN") Then
            LoadString = LoadResString(Val("3" & MesIndex))
        End If
    End If
End Function

 类代码:

Option Explicit

Private WithEvents m_BillTransfer   As k3BillTransfer.Bill
Private m_FItemID As Long     '物料
Private m_profit   As Long    'profitcenter

Public Sub Show(ByVal oBillTransfer As Object)
 
    '接口实现
    '注意: 此方法必须存在, 请勿修改
    Set m_BillTransfer = oBillTransfer
    InitFieldIndex
End Sub
'初始化CtlIndex
Private Sub InitFieldIndex()
 On Error GoTo H_Error
   
    Call GetCtlOrdIdx("FItemID", False, m_FItemID)
    Call GetCtlOrdIdx("FEntrySelfB0172", False, m_profit)
   Exit Sub
H_Error:
     Err.Source = "m_BillTransfer_LoadBillEnd()\" & Err.Source
     MsgBox Err.Source
End Sub

'bOnHead true 为表头字段 false 则为表体字段
Private Function GetCtlOrdIdx(ByVal strFieldName As String, ByVal bOnHead As Boolean, ByRef nCtlIndex As Long) As Boolean
Dim i As Long
Dim vCtl As Variant
vCtl = IIf(bOnHead, m_BillTransfer.HeadCtl, m_BillTransfer.EntryCtl)
For i = LBound(vCtl) To UBound(vCtl)
    If UCase(Trim(vCtl(i).FieldName)) = UCase(strFieldName) Then
        If bOnHead = False Then
            nCtlIndex = vCtl(i).FCtlOrder
        Else
            nCtlIndex = vCtl(i).FCtlIndex
        End If
       
        GetCtlOrdIdx = True
        Exit Function
    End If
Next
End Function

 

Public Function ExecSql(sqlstr As String) As ADOR.Recordset
On Error GoTo EHandler
    Dim ds As ADOR.Recordset
    Dim conn As Object
    Dim k3AppConn As Object
    If k3AppConn Is Nothing Then
        Set k3AppConn = CreateObject("K3MAppConnection.AppConnection")
        Set ds = k3AppConn.Execute(m_BillTransfer.Cnnstring, sqlstr)
        Set k3AppConn = Nothing
    Else
        Set ds = k3AppConn.Execute(m_BillTransfer.Cnnstring, sqlstr)
    End If
    Set ExecSql = ds
   
    Exit Function
EHandler:
    MsgBox "ExecSql错误:" + Err.Description, vbCritical, "金蝶提示"
    Err.Clear
   
End Function

 
 
Public Function ExecNoneQurey(sqlstr As String)
On Error GoTo EHandler
    Dim ds As ADOR.Recordset
    Dim conn As Object
    Dim k3AppConn As Object
    If k3AppConn Is Nothing Then
        Set k3AppConn = CreateObject("K3MAppConnection.AppConnection")
        k3AppConn.Execute m_BillTransfer.Cnnstring, sqlstr
        Set k3AppConn = Nothing
    Else
        Set ds = k3AppConn.Execute(m_BillTransfer.Cnnstring, sqlstr)
    End If
 
   
    Exit Function
EHandler:
    MsgBox "ExecSql错误:" + Err.Description, vbCritical, "金蝶提示"
    Err.Clear
   
End Function
Private Sub Class_Terminate()
 
    '释放接口对象
    '注意: 此方法必须存在, 请勿修改
    Set m_BillTransfer = Nothing

End Sub