Auto cad vba block and rectangular arry

[Anonymous]

hello everyone,

I tried to write a program (with autocad VBA) that import a group of entities (by DXF file) and do rectangular array by user values.

at this moment i have program that get the entities but i did not success to make a block from the entities that i import In order to perform the rectangular array command.

if can some one help me the write the code that can select all the entities i have on the screen and make block from them and after make the rectangular array.

I think i have the selection part too but when i tried the add that entities to the block  it didn't success.

Any help will be appreciated

this is the code that i have for this moment

******************************************************************************************************************************
Dim objSS3 As AcadSelectionSet
Set objSS3 = ThisDrawing.SelectionSets.Add("objSS3")
objSS3.Select acSelectionSetAll

If (Not (objSS3 Is Nothing)) Then
objSS3.Clear
Else
Err.Clear
Set objSS3 = ThisDrawing.SelectionSets.Add("objSS3")
End If

' Define the block
Dim blockObj As AcadBlock
Dim insertionPnt(0 To 2) As Double
insertionPnt(0) = (Val(TextBox1.Text) / 2)
insertionPnt(1) = (Val(TextBox2.Text) / 2)
insertionPnt(2) = 0

' Add the block to the blocks collection
Set blockObj = ThisDrawing.Blocks.Add(insertionPnt, "Pattren")
MsgBox blockObj.Name & " has been added." & vbCr

Set blockObj = ThisDrawing.Blocks.Add(InsertionPoint, "sset3")

******************************************************************************************************************************

this is the error and what i got in the model space 

[grobnik]

Hi,

I read you question but I do not understand well where did you get the insertion point block value (see textBox)...

I guess you have to make a debug before inserting a block, for example block exist, coordinates are correct and so on.

[Anonymous]

hi grobnik.

i run the debugger and it say nothing.

i get the values from the user from box (i post only the relevant part of the code).

[grobnik]

Hi thank you for your reply,

I'm very sorry but I'm very hard to understand.

For example:

what is the functionality of 

objSS3.Select acSelectionSetAll

on special way before inserting a new block, as you required with

Set blockObj = ThisDrawing.Blocks.Add(InsertionPoint, "sset3")

which kind of object you would like to retrive, I guess info for inserting "sset3" block ?

But if you select all object in the drawing and not made a selection specific how you can get info for inserting sset3 ?.

Next question is:

- you got the same error on inserting Set blockObj = ThisDrawing.Blocks.Add(insertionPnt, "Pattren"), and again insertion point will be the same for all blocks ?.

Probably it's not clear for me entire project.

Regards

[Anonymous]

hey friend

as you can see in the picture i attach i have a ungroup\block entities in two different layers that imported.

the problem i want to solve is how i can that this items and make rectangular array with them.

i tried two ways without get a solution.

the first way was select all the objects i have on the drawing after the import and make block and do the array on the block (i saw at the rectangular array method that block and be used)

and the second way is import the entities as a block.

if you have any idea for solution for this case it is welcome

thank you very much for your help.

[grobnik]

Hi 

I tried to modify your code and now the block creation with all object inside model space should work

On Error Resume Next

Dim objSS3 As AcadSelectionSet
Set objSS3 = ThisDrawing.SelectionSets.Add("objSS3")

If Err.Number <> 0 Then
    Set objSS3 = ThisDrawing.SelectionSets.Item("objSS3")
    objSS3.Clear
End If

objSS3.Select acSelectionSetAll


' Define the block
Dim blockObj As AcadBlock
Dim insertionPnt(0 To 2) As Double
insertionPnt(0) = 0 '(Val(TextBox1.Text) / 2)
insertionPnt(1) = 0 '(Val(TextBox2.Text) / 2)
insertionPnt(2) = 0

' Add the block to the blocks collection

Set blockObj = ThisDrawing.Blocks.Add(insertionPnt, "Pattren")
ThisDrawing.CopyObjects objSS3, blockObj

'MsgBox blockObj.Name & " has been added." & vbCr

'Set blockObj = ThisDrawing.Blocks.Add(InsertionPoint, "sset3")
objSS3.Clear

probably the missing part was

ThisDrawing.CopyObjects objSS3, blockObj

after procedure running and come back to your drawing and will try to insert a block Pattren you should have a block with all object in the model space.

Concerning the array I will help you more later....

Let me know

[Anonymous]

hey friend,

First at all thanks you very much for your help.

I tried to run the code you returned to me and for some reason I still get an error 😞

[grobnik]

It's very strange, I tried with a simple two different square, and it's works.

Try to make a debug of objss3 it should contain all object inside modelspace so you should view more "items" inside, if not there is something inside selection set.

If you can send me a typical your dwg where you need to create array.

Let me know

[grobnik]

this is the result ObjSS3, and BlockObJ are containing the same number of objects

and attached simple dwg crated with tow squares on different layers, and block created

[grobnik · Accepted solution]

Hi I tried the below code ant it's running.

I'm suggesting to save as DWG the dxf imported file before to create block and so on with VBA code.

Inside the procedure you can find the array section, where I'm still working because I have some problems with reference and some other issues.

See attached file with you part and block created.

Sub TestBlockArray()
On Error Resume Next

Dim objSS3 As AcadSelectionSet
Set objSS3 = ThisDrawing.SelectionSets.Add("objSS3")

If Err.Number <> 0 Then
    Set objSS3 = ThisDrawing.SelectionSets.Item("objSS3")
    objSS3.Clear
End If

objSS3.Select acSelectionSetAll


' Define the block
Dim blockObj As AcadBlock
Dim insertionPnt(0 To 2) As Double
insertionPnt(0) = 0 '(Val(TextBox1.Text) / 2)
insertionPnt(1) = 0 '(Val(TextBox2.Text) / 2)
insertionPnt(2) = 0

' Add the block to the blocks collection

Set blockObj = ThisDrawing.Blocks.Add(insertionPnt, "Pattren")
ThisDrawing.CopyObjects objSS3, blockObj

MyBlock = ThisDrawing.ModelSpace.InsertBlock(insertionPnt, "Pattren", 1, 1, 1, 0)

Dim numberOfRows As Long
Dim numberOfColumns As Long
Dim numberOfLevels As Long
Dim distanceBwtnRows As Double
Dim distanceBwtnColumns As Double
Dim distanceBwtnLevels As Double
numberOfRows = 5
numberOfColumns = 5
numberOfLevels = 1
distanceBwtnRows = 700
distanceBwtnColumns = 700
distanceBwtnLevels = 1
retObj = MyBlock.ArrayRectangular(numberOfRows, numberOfColumns, numberOfLevels, distanceBwtnRows, distanceBwtnColumns, distanceBwtnLevels)

'MsgBox blockObj.Name & " has been added." & vbCr
'Set blockObj = ThisDrawing.Blocks.Add(InsertionPoint, "sset3")
ThisDrawing.Regen acAllViewports
objSS3.Clear
End Sub