Leidiges Thema ging mir auch mal auf den Sack
Letale Lösung:
Eine Klasse für alle Interface und Ruhe ist
Läuft ohne Änderungen etc mit jeder ACAD Version auch der neuesten mit 64 bit
Lieben Gruß
Thomas
CLASS ACADINTERFACE:
Private Type interfaces
applicaTION As Object
AcadLayerStateManager As Object
AxDbDocument As Object
AcCmColor As Object
VLApplication As Object
IAcadObject As Object
appName As String
AppNameVertical As String
VBE As Object
INITIALIZED As Boolean
End Type
Private PINTERFACE As interfaces
Function GET_INTERFACE(INTERFACE As String) As Object
Dim strAcadVersion As String
With PINTERFACE.applicaTION
strAcadVersion = MID(.version, 1, 2)
If CInt(strAcadVersion) < 16 Then
Set GET_INTERFACE = AcadApplication.GetInterfaceObject(INTERFACE)
Else
On Error Resume Next
If INTERFACE = "AutoCAD.Application" Then
Set GET_INTERFACE = AutoCAD.applicaTION
Exit Function
End If
If INTERFACE = "VL.Application" Then
Call CreateObject("VL.Application")
End If
If INTERFACE = "AutoCAD.IAcadObject" Then
Set GET_INTERFACE = GetInterfaceObject(INTERFACE)
End If
Set GET_INTERFACE = GetInterfaceObject(INTERFACE)
If GET_INTERFACE Is Nothing Then
Set GET_INTERFACE = GetInterfaceObject(INTERFACE & "." & strAcadVersion)
End If
End If
End With
End Function
Private Sub Class_Initialize()
Dim strname As String
If PINTERFACE.INITIALIZED = True Then Exit Sub
Set PINTERFACE.applicaTION = applicaTION
Set PINTERFACE.AcadLayerStateManager = GET_INTERFACE("AutoCAD.AcadLayerStateManager")
Set PINTERFACE.AxDbDocument = GET_INTERFACE("ObjectDBX.AxDbDocument")
Set PINTERFACE.AcCmColor = GET_INTERFACE("AutoCAD.AcCmColor")
Set PINTERFACE.VLApplication = GET_INTERFACE("VL.Application")
Set PINTERFACE.applicaTION = GET_INTERFACE("AutoCAD.Application")
Set PINTERFACE.IAcadObject = GET_INTERFACE("AutoCAD.IAcadObject")
Set PINTERFACE.VBE = applicaTION.VBE
PINTERFACE.appName = PINTERFACE.applicaTION.CAPTION
strname = PINTERFACE.applicaTION.CAPTION
PINTERFACE.AppNameVertical = left(strname, InStr(1, strname, " -"))
PINTERFACE.INITIALIZED = True
End Sub
Public Sub Init()
Call Class_Initialize
End Sub
Public Property Get IColor() As Object
If Not PINTERFACE.INITIALIZED Then Call Class_Initialize
Set IColor = PINTERFACE.AcCmColor
End Property
Public Property Get IVBE() As Object
If Not PINTERFACE.INITIALIZED Then Call Class_Initialize
Set IVBE = PINTERFACE.VBE
End Property
Public Property Get Ilayer() As Object
If Not PINTERFACE.INITIALIZED Then Call Class_Initialize
Set Ilayer = PINTERFACE.AcadLayerStateManager
End Property
Public Property Get ILisp() As Object
If Not PINTERFACE.INITIALIZED Then Call Class_Initialize
Set ILisp = PINTERFACE.VLApplication
End Property
Public Property Get Iapp() As Object
If Not PINTERFACE.INITIALIZED Then Call Class_Initialize
Set Iapp = PINTERFACE.applicaTION
End Property
Public Property Get IDoc() As Object
If Not PINTERFACE.INITIALIZED Then Call Class_Initialize
Set IDoc = PINTERFACE.AxDbDocument
End Property
Public Property Get iobj() As Object
If Not PINTERFACE.INITIALIZED Then Call Class_Initialize
Set iobj = PINTERFACE.IAcadObject
End Property
Public Property Get IAppName() As String
If Not PINTERFACE.INITIALIZED Then Call Class_Initialize
IAppName = PINTERFACE.appName
End Property
Public Property Get IAppNameVertical() As String
If Not PINTERFACE.INITIALIZED Then Call Class_Initialize
IAppNameVertical = PINTERFACE.AppNameVertical
End Property
Public Function INTERFACE(INAME As String) As Object
Dim testname As String
Set INTERFACE = Nothing
If Not PINTERFACE.INITIALIZED Then Call Class_Initialize
Select Case LCase(INAME)
Case "acadlayerstatemanager"
INTERFACE = PINTERFACE.AcadLayerStateManager
Case "axdbdocument"
INTERFACE = PINTERFACE.AxDbDocument
Case "accmcolor"
INTERFACE = PINTERFACE.AcCmColor
Case "vlapplication"
INTERFACE = PINTERFACE.VLApplication
Case "application"
INTERFACE = PINTERFACE.applicaTION
Case "iacadobject"
INTERFACE = PINTERFACE.IAcadObject
Case Else
Set INTERFACE = GET_INTERFACE(INAME)
End Select
End Function
'-------------------------------------------------------------
Initialisieren:
in irgendeinem Modul:
Public AINTERFACE As New ACADINTERFACES
'---------------------------------------------
Initialisieren: IM Startup EINMAL
Kann man auch jedes mal aufrufen. Die Klasse weis wenn sie bereits initialisiert ist und macht dann nix
sub INIT
AINTERFACE.Init
end sub
Benutzung: z.B. für Farben
Sub testinterfaces(entity as acadentity)
'OPTIONAL -> AINTERFACE.Init falss man die klasse nirgendwo initialisiert hat
Dim COLOR As AcadAcCmColor
Set COLOR = AINTERFACE.IColor
Call COLOR.SetRGB(241, 162, 14)
entity.TRUECOLOR = COLOR
End Sub
------------------
Wer es nicht versucht, hat schon verlorn 
Und bei 3 Typos gibts den vierten gratis !
<<< for sale !
Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP
Foren auf CAD.de (alle Foren)
| 
- 
