Hi
HM so was ähnliches hatte ich neulich auch beim umstieg auf ne neuere ACAD Version. Problematisch waren das Interface Objekt. Und das ganze scheint auch etwas pingeliger geworden zu sein.
Da mir die Interface Objecte ziemlich auf den Geist gegangen sind hab ich sie alle in eine Klasse ausgelagert. Das Thema Interface ist seither Geschichte 
Vielleicht hilft ja folgender Code.
Gruß
Thomas
Function block_definitions_copy_from_drawing_by_list(ByVal strBlockName As String, ByVal strPath As String, Optional delimiter As String = "") As String
Dim strFullDef As String
Dim objBlock As AcadBlock
Dim colBlocks As AcadBlocks
Dim objArray(0) As Object
Dim ACDbx As Object
Dim RESULT As String
Dim CURRBK As String
Dim blks() As String
If delimiter <> "" Then
blks = Split(strBlockName, delimiter)
Else
ReDim blks(0)
blks(0) = strBlockName
End If
Set ACDbx = AINTERFACE.IDoc()
If strPath = "" Then Exit Function
ACDbx.Open strPath
Set colBlocks = ACDbx.BLOCKS
For I = 0 To UBound(blks)
strBlockName = blks(I)
If Trim(strBlockName) <> "" Then
On Error Resume Next
err.Clear
Set objBlock = colBlocks.ITEM(strBlockName) 'Find appropriate block in container file's Blocks Collection
On Error GoTo 0
If err.number = 0 Then
Set objArray(0) = objBlock 'Create object array as required by the CopyObjects Method
ACDbx.CopyObjects objArray, ThisDrawing.BLOCKS 'Copy to current drawing's Blocks Collection
'ACDbx.SaveAs strPath
End If
End If
For Each objBlock In ThisDrawing.BLOCKS
If objBlock.Name = strBlockName Then
objBlock.Name = REPLACE(objBlock.Name, "$", "_")
RESULT = RESULT & objBlock.Name & delimiter
End If
Next
Next
Set ACDbx = Nothing
block_definitions_copy_from_drawing_by_list = RESULT
End Function
CLASS AINTERFACE
Private Type interfaces
Application As Object
AcadLayerStateManager As Object
AxDbDocument As Object
AcCmColor As Object
VLApplication 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
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.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 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 Else
Set INTERFACE = GET_INTERFACE(INAME)
End Select
End Function
------------------
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)
| 
