Block

Can anyone help me please?

I need to create a block of different entities (line, circle, arc, etc) in drawing.

The help file gives an example to show how to add a block to a single entity, how do i do it for a many entities?

Regards
Lara

 

Just keep adding them:

Sub Ch10_RedefiningABlock()
' Define the block
Dim blockObj As AcadBlock
Dim insertionPnt(0 To 2) As Double
insertionPnt(0) = 0
insertionPnt(1) = 0
insertionPnt(2) = 0
Set blockObj = ThisDrawing.Blocks.Add _
(insertionPnt, "CircleBlock")

' Add a circle to the block
Dim circleObj As AcadCircle
Dim center(0 To 2) As Double
Dim radius As Double
center(0) = 0
center(1) = 0
center(2) = 0
radius = 1
Set circleObj = blockObj.AddCircle(center, radius)
'Add a line to the block
Dim lineObj As AcadLine
Dim sPt(2) As Double
Dim ePt(2) As Double
sPt(0) = 0
sPt(1) = 0
sPt(2) = 0
ePt(0) = 2
ePt(1) = 2
ePt(2) = 0
Set lineObj = blockObj.AddLine(sPt, ePt)
' Insert the block
Dim blockRefObj As AcadBlockReference
insertionPnt(0) = 2
insertionPnt(1) = 2
insertionPnt(2) = 0
Set blockRefObj = ThisDrawing.ModelSpace.InsertBlock _
(insertionPnt, "CircleBlock", 1#, 1#, 1#, 0)
ZoomAll
End Sub

 

Lara,

Help you once...then you can fish for free...hopefully.

Try this(I haven't tested it so you must)

Dim objSS As AcadSelectionSet
Dim objBlkRef As AcadBlockReference
Dim objBlk As AcadBlock
Dim objOfEnts() As Object
Dim I As Integer
Dim dblOrg(2) As Double
Dim varEnts As Variant
Dim varEnts2 As Variant


With ThisDrawing.Utility

' Create new selectionset
Set objSS = ThisDrawing.SelectionSets.Add("MySSName")

' Allow the user to select entities
objSS.SelectOnScreen

' highlight the entities selected
objSS.highlight True

dblOrg(0) = 0: dblOrg(1) = 0: dblOrg(2) = 0
Set objBlk = ThisDrawing.Blocks.Add(dblOrigin, "MyNewBlock")
ReDim objOfEnts(objSS.Count - 1)

For I = 0 To objSS.Count - 1
Set objOfEnts(I) = objSS(I)
Next I

varEnts2 = ThisDrawing.CopyObjects(objOfEnts, objBlk)

End With

' if the selection set was created delete it

If Not objSS Is Nothing then
objSS.Delete
End If

Set objBlkRef = ThisDrawing.ModelSpace.InsertBlock(dblOrg, "MyNewBlock", 1, 1, 1, 0)
Set objBlkRef = Nothing
Set objBlk = Nothing

Hope this helps move you in the right direction.

Regards,

Bob Coward
CADS, Inc

800-366-0946

 

Thanks Bob, its working.