金蝶二次开发
2016-02-24 13:19
721 查看
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
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
内容来自用户分享和网络整理，不保证内容的准确性，如有侵权内容，可联系管理员处理 
相关文章推荐
- bzoj1833 数字计数
- AJAXdemo_sync.html Async = false
- [数据结构]One-Dimensional Life Game
- 让使用了SQLite的.NET应用自适应32位/64位系统
- ICPCCamp 2016 Day 6 - Spb SU and Spb AU Contest(Colored path-dp)
- 使用POI读取xls和xlsx
- sublime text ctags 不能正常跳转 can't find any relevent
- 主主+ lvs keepalived 配置文件
- C++设计模式-1简单工厂模式
- AFNetworking 3.0迁移指南
- java中Overload（重载）和Override（重写、覆盖）
- c语言入门之项目3.9——输出一个“空”三角形
- AJAXdemo.html
- bootstrapValidator不触发校验
- php empty和isset的比较
- MySQL主从复制结构中常用参数
- 排序——插入排序（insertionsort）
- 网络虚拟化是否需要额外的网络架构？
- Spring Mvc提交form表单上传文件
- SET SQL_MODE="NO_AUTO_VALUE_ON_ZERO"