---

Servus,
Ich hab schon wieder eine Frage und zwar:
Ich will von einer Bibliothekszeichnung aus jeweils einen einzelnen Block in die aktuell geöffnete Zeichnung einfügen.
Kann mir einer sagen was der Fehler ist? Beim Debuggen markiert er mir die Set Block =..... Zeile.

Sub Ausprobieren()
Dim dblEinfügePunkt(0 To 2) As Double
Dim Block As AcadBlockReference
Dim Blockort As String: Blockort = "C:\Users\Wolfgang\Desktop\Arbeitsplatz Wolfgang_ Benutzerdefiniert\Bibliothekszeichnung\Bibliothekszeichnung.dwg|Rahmen A0 quer"
dblEinfügePunkt(0) = 0: dblEinfügePunkt(1) = 0: dblEinfügePunkt(2) = 0
Set Block = ThisDrawing.ModelSpace.InsertBlock(dblEinfügePunkt, Blockort, 1, 1, 1, 0)
End Sub

Schonmal Danke.

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Hab inzwischen festgestell, das es funktioniert wenn ich die ganze Zeichnung als Block einfüge, also das "|Rahmen A0 quer" weg lasse.
Weiß jemand, wie ich das schreiben muss, damit ich einen einzelnen Block aus der Zeichnung ansprechen kann?

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Nur mal so zum Nachdenken:
Kennst Du die CopyObjects Methode?
Deine Bibliothekszeichnung als 2. Dokument im Hintergrund öffnen, Block in die Zeichnung kopieren (Block-Collection) und RefBlock in den Modellspace einfügen, wäre doch das einfachste, anstatt die komplette Bibliothek und hinterher bereinigen zu müssen.

Andererseits, wenn ich Rahmen A0 lese. Ist das ein komplettes Layout? Dann könnte man sich den Umweg über den Block sparen und gleich ein neues Layout kopieren. Ihr werdet doch hoffentlich keinen Plotrahmen im Modellbereich erzeugen?

Grüße
Klaus

[Diese Nachricht wurde von KlaK am 17. Feb. 2013 editiert.]

[Diese Nachricht wurde von KlaK am 17. Feb. 2013 editiert.]

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

@ Klak,

nein das machen wir nicht keine Angst.
Ich versuche jetzt mit deinem Vorschlag die Zeichnung im Hintergrund zu öffnen und bin dabei auf die Möglichkeit gestoßen sie mit ObjectDbx zu öffnen und mein Code beginnt wie folgt:

Sub Ausprobieren3()
Dim objDbx As AxDbDocument
Set objDbx = ThisDrawing.Application.GetInterfaceObject("ObjectDBX.AxDbDocument.18")

Ich hab auch den Verweis auf die ObjectDbx Library 18 gesetzt. Er findet auch die Anwendung sagt mir aber bei meiner Setanweisung, dass die Typen unverträglich sind.
Ich wüsst allerdings nicht als was ich objDbx sonst deklarieren soll als als AxDbDocument.
Kennst du dich damit aus?
Kannst du oder jemand mir helfen?

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Sorry, mit ObjectDBX habe ich noch nichts gemacht, mir reicht es z.Z. noch die Zeichnungen von "innen" zu steuern.

Also ganz einfach zwei Zeichnungen gleichzeitig zu öffnen und dann die Bearbeitung zu machen.
Hab Dir mal aus der Hilfe ein Beispiel kopiert:

Code:

---

Sub Ch4_Copy_to_New_Drawing()
    Dim DOC0 As AcadDocument
    Dim circleObj1 As AcadCircle, circleObj2 As AcadCircle
    Dim centerPoint(0 To 2) As Double
    Dim radius1 As Double, radius2 As Double
    Dim radius1Copy As Double, radius2Copy As Double
    Dim objCollection(0 To 1) As Object
    Dim retObjects As Variant

    ' Definieren des Circle-Objekts
    centerPoint(0) = 0: centerPoint(1) = 0: centerPoint(2) = 0
    radius1 = 5#: radius2 = 7#
    radius1Copy = 1#: radius2Copy = 2#

    ' Hinzufügen von zwei Kreisen zur aktuellen Zeichnung
    Set circleObj1 = ThisDrawing.ModelSpace.AddCircle _
                    (centerPoint, radius1)
    Set circleObj2 = ThisDrawing.ModelSpace.AddCircle _
                    (centerPoint, radius2)
    ThisDrawing.Application.ZoomAll

    ' Speichern des Zeigers auf die aktuelle Zeichnung
    Set DOC0 = ThisDrawing.Application.ActiveDocument

    ' Kopieren der Objekte
    '
    ' Zu kopierende Objekte zunächst in eine mit
    ' CopyObjects kompatible Form bringen
    Set objCollection(0) = circleObj1
    Set objCollection(1) = circleObj2

    ' Eine neue Zeichnung erstellen und auf ihren Modellbereich zeigen
    Dim Doc1MSpace As AcadModelSpace
    Dim DOC1 As AcadDocument

    Set DOC1 = Documents.Add
    Set Doc1MSpace = DOC1.ModelSpace

    ' Kopieren der Objekte in den Modellbereich der neuen Zeichnung. A
    ' Auflistung der neuen (kopierten) Objekte wird zurückgegeben.
    retObjects = DOC0.CopyObjects(objCollection, Doc1MSpace)

    Dim circleObj1Copy As AcadCircle, circleObj2Copy As AcadCircle

    ' Neu erstellte Objektauflistung aufrufen und neue
    ' Eigenschaften auf die Kopien anwenden
    Set circleObj1Copy = retObjects(0)
    Set circleObj2Copy = retObjects(1)

    circleObj1Copy.radius = radius1Copy
    circleObj1Copy.Color = acRed
    circleObj2Copy.radius = radius2Copy
    circleObj2Copy.Color = acRed

    ThisDrawing.Application.ZoomAll

    MsgBox "Kreise kopiert."
End Sub

---

Ähnlich kannst Du auch Blöcke von einer in eine andere kopieren.
Für ganze Layouts gäbe es die CopyFrom - Methode
Ein Beispiel findest Du hier
Müßtest nur statt einer zwei Zeichnungen setzen.

Viel Spaß
Klaus

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Hi der debugger spinnt der Fehler ist nicht dort 
Dlockdefinitionen werden in einer tabelle innerhalb einer Zeichnung verwaltet.
Das vba element heisst acadblockdefinition.
wenn du also aus einer libraryzeichnung solch einen block einfuegen willst musst du die entsprechende blockdfinition dort finden und kopieren. Danach kann man Refrenzen erstellen.

Wer es rustikal mag - die ganze zeichnung als block einfuegen und loeschen.
Die Block Definitionen bleiben bis zum naechsten purge erhalten.

Anbei ein paar zeilen code ...
Diese routine erstellt solch eine librarydatei aus einer existierenden Zeichnung.
Die if 1=2 zeile kommentiert etwas aus was dynamische bloecke loescht, da diese ja auch mit normalem namen
hineinkopiert werden.

Public Function block_definition_copy_to_drawing(blockname As String, Filename As String, Optional globallib As Boolean = False) As Variant

    If Not FileExists(Filename) Then Call document_create(Filename)

    '  Dim blo As AcadBlockReference

    Dim objSelSet As AcadSelectionSet
    Dim objTarget As AcadDocument
    Dim currentdrawing As AcadDocument
    Set currentdrawing = ThisDrawing
    'Dim documents As AcadDocuments
    Dim Document As AcadDocument
    Dim objOrgEnts() As Object
    Dim destEnts As Variant
    Dim intCnt As Long
    Dim blo As AcadBlock

    Dim strFullDef As String
    Dim objBlock As AcadBlock
    Dim colBlocks As AcadBlocks
    Dim objArray(0) As Object

    Set colBlocks = ThisDrawing.BLOCKS

    Set objBlock = colBlocks.item(blockname)
    Set objArray(0) = objBlock

    blockname = UCase(Trim(blockname))
    If globallib Then
        If LIBACDBXFILE = "" Then
            Call LIBACDBX_open(Filename)
        End If
    Else
        Dim ACDbx As Object
        Set ACDbx = GetAcDbxDoc()
        ACDbx.Open Filename
    End If

    On Error Resume Next
    Err.Clear
    Set objBlock = ACDbx.BLOCKS.item(blockname)
    If Err.number = 0 Then objBlock.Delete

    If 1 = 2 Then

        For Each objBlock In ACDbx.BLOCKS
            If Left(objBlock.name, 1) <> "*" Then
                If UCase(Trim(objBlock.name)) = blockname Then
                    'Debug.Print "del " & objBlock.name
                    objBlock.Delete
                    Exit For
                End If
            End If
        Next
    End If

    If globallib Then
        R = ThisDrawing.CopyObjects(objArray, LIBACDBX.modelspace)
    Else
        R = ThisDrawing.CopyObjects(objArray, ACDbx.modelspace)
    End If
    If Not globallib Then
        ACDbx.SaveAs Filename
    End If
End Function

------------------
wer es nicht versucht, hat schon verlorn

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

bissi was vergessen 

Function block_def_exists(blockname As String, Optional BLOCK As AcadBlock = Nothing) As Boolean

    On Error Resume Next
    Err.Clear
    Set BLOCK = ThisDrawing.BLOCKS.item(blockname)
    If Not BLOCK Is Nothing Then block_def_exists = True
    If Err.number <> 0 Then block_def_exists = False
    Set BLOCK = Nothing
    On Error GoTo 0
End Function

Sub LIBACDBX_open(Filename As String)
    If LIBACDBXFILE <> "" Then
        MsgBox "LIB " & Filename & "seems to be open"
    End If
    Set LIBACDBX = GetAcDbxDoc()
    LIBACDBX.Open Filename
    LIBACDBXFILE = Filename
    LIBACDBXCONTENT = ""
End Sub
Sub LIBACDBX_close()
    If LIBACDBXFILE <> "" Then
        LIBACDBX.SaveAs LIBACDBXFILE
        LIBACDBXFILE = ""
        LIBACDBX = Nothing
    End If
End Sub

------------------
wer es nicht versucht, hat schon verlorn

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP