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