---

Hallo Zusammen

Wie kann ich Objekte, die ich in VBA erstellt habe, in einen Block (in VBA) einfügen?

Danke schon im Vorraus für Lösungen!

Merci Kai

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

---

Hier hast du zwei Funktionen, die solten dir weiterhelfen

Code:

---

'Adds the specified objects to a given block definition
Public Sub AddObjectsToBlock(blkRef As AcadBlockReference, entArray() As AcadEntity, Optional delObj As Boolean = True)
'Beispiel für Aufruf: AddObjectsToBlock blkRef, ents, False
'1. Existing block references will not show a change unitl you regen the drawing
'2. You can use the ssArray function to add an entire selection set at once.
    Dim blkDef As AcadBlock, origin(0 To 2) As Double, i As Long
   
    origin(0) = 0: origin(1) = 0: origin(2) = 0
   
    Set blkDef = ThisDrawing.Blocks(blkRef.Name)
   
    For i = LBound(entArray) To UBound(entArray)
        entArray(i).Move blkRef.insertionPoint, origin
    Next
   
    ThisDrawing.CopyObjects entArray, blkDef
   
    If delObj Then
        For i = LBound(entArray) To UBound(entArray)
            entArray(i).Delete
        Next
    End If

End Sub

'Returns a variant array containing every item in a selection set
'Arguments: A selection set
'Example: ThisDrawing.ModelSpace.AddRegion ssArray(mySS)
'1. This is quite useful for creating blocks from a selection set.
Public Function ssArray(SS As AcadSelectionSet)

    Dim retVal() As AcadEntity, i As Long
   
    ReDim retVal(0 To SS.Count - 1)
   
    For i = 0 To SS.Count - 1
        Set retVal(i) = SS.Item(i)
    Next
   
    ssArray = retVal

End Function

---

------------------
Roland

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

---

Quellcode.txt

Hallo Zusammen

Ich habe den Quellcode beigefügt.
Es funktioniert eigentlich alles ausser den Block erstellen.
Im Quellcode findet Ihr die Funktion "Blockerstellen".
Ich wäre euch wircklich dankbar, wenn jemand dieses Problem lösen könnte.

Vielen Dank für eure Mithilfe

[Diese Nachricht wurde von Heron83 am 28. Oktober 2003 editiert.]

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

---

Was soll denn dieses Programm können?
Du erzeugst Objekte irgendwo im Raum und möchtest aus diesen Objekten dann einen Block erstellen?
Wozu erzeugst ein SelectionSet? Du hast die Objekte ja schon dem Array zugewiesen.

Code:

---

    Function Blockerstellen()
    Dim Block As AcadBlock
    Dim ObjList(3) As AcadEntity
    Dim sSet As AcadSelectionSet, ToPoint(2) As Double
   
    On Error Resume Next
   
      Set Block = ThisDrawing.Blocks.Add(startPnt, "test")
   
      Set ObjList(0) = Flansch1
      Set ObjList(1) = Flansch2
      Set ObjList(2) = Zylinder
      Set ObjList(3) = Attribut
     
      CopyObjects ObjList, Block, IdPairs
      FromPoint = Object.insertionPoint
      For i = 0 To UBound(IdPairs)
        If IdPairs(i).IsPrimary = True Then
            Set Obj = ObjectIdToObject(IdPairs(i).value)
            Obj.Move FromPoint, ToPoint
        End If
   
    End Function

---

------------------
Roland

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

---

Ja genau ich erzeuge jrgendwo im Raum meine Objekte und will sie in den Block hinein setzten. Mein Programm soll ein Bauteil erstellen und dieses muss mit Attributen in der Attributsextraktion ersichtlich sein. Darum muss ich einen Block erstellen mit diesen Objekten. Am Schluss sollte ich nur noch das Makro aufrufen und die Attributsextraktion anwenden, damit ich eine komplette Stückliste erhalte. Ich wusste nicht das SelectionSet überflüssig ist! Diese Blöcke zu erstellen ist ja wirklich kompliziert. Wenn ich die Objekte kenne kann ich nicht einfach diesen Array in den Block einfügen?

------------------
Gruss Kai

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

---

Doch, so hab ich es ja auch geändert. s.o.

------------------
Roland

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

---

Vielen Dank mit eurer Hilfe konnte ich mein Problem lösen.
Ich musste einfach ein Paar Zeilen löschen.
Ich musste nur diese Zeile eingeben:

Set Block2 = ThisDrawing.CopyObjects(ObjList, Block, IdPairs)

------------------
Gruss Kai

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