PDA

View Full Version : Autocad VBA Copy Block Definition



Barclay
10-23-2006, 05:09 PM
Hopefully just a quick one.

Say I've got block 'chair'. I want to make a copy of 'chair' that is independent in the blocks list, so I've got 'chair' and 'chair_1'. Both Chair and Chair_1 contain the same linework etc, but if I change anything about chair, it won't effect chair_1.

What I don't know if the command to copy the block.

In autocad form, I'd open the block editor, and then type 'bsaveas', enter the new block name and then save. How do I do this in VBA?

Note: I don't have a direct reference to the blocks original file, so I can't just add another block from the same original reference.

fixo
10-24-2006, 10:18 AM
Hopefully just a quick one.

Say I've got block 'chair'. I want to make a copy of 'chair' that is independent in the blocks list, so I've got 'chair' and 'chair_1'. Both Chair and Chair_1 contain the same linework etc, but if I change anything about chair, it won't effect chair_1.

What I don't know if the command to copy the block.

In autocad form, I'd open the block editor, and then type 'bsaveas', enter the new block name and then save. How do I do this in VBA?

Note: I don't have a direct reference to the blocks original file, so I can't just add another block from the same original reference.

Not sure about I have understood your explanation correctly,
because of it test this code on copy of your certain drawing
This code will be insert in the same location new block added
into database.
Old block will be deleted

HTH

Fatty

~'J'~



Sub CloneNewBlock()
Dim oblkRef As AcadBlockReference
Dim oEnt As AcadEntity, oblock As AcadBlock
Dim varPt
Dim insVpt, insPt(2) As Double
Dim bName As String
Dim i As Long, j As Long, idpairs As Long
Dim expObjs As Variant
i = InputBox("Enter suffix for new block name :", "Create New Block", "1")
On Error GoTo Err_Control
ThisDrawing.SetVariable "DELOBJ", 1
ThisDrawing.Utility.GetEntity oEnt, varPt, "Select block: "
If TypeOf oEnt Is AcadBlockReference Then
Set oblkRef = oEnt
bName = oblkRef.Name & "_" & i
MsgBox "New block name is: " & bName
insVpt = oblkRef.InsertionPoint
For j = 0 To UBound(insVpt)
insPt(j) = insVpt(j)
Next
For Each oblock In ThisDrawing.Blocks
If oblock.Name = bName Then
MsgBox "Block " & bName & " does already exist" & _
vbNewLine & "Exit program"
Exit Sub
End If
Next
expObjs = oblkRef.Explode
Set oblock = ThisDrawing.Blocks.Add(insPt, bName)
ThisDrawing.CopyObjects expObjs, oblock, idpairs
For i = 0 To UBound(expObjs)
expObjs(i).Delete
Next
Dim dblXscl As Double, dblYscl As Double, _
dblZscl As Double, dblRot As Double, _
layName As String
dblXscl = oblkRef.XScaleFactor
dblYscl = oblkRef.YScaleFactor
dblZscl = oblkRef.ZScaleFactor
dblRot = oblkRef.Rotation
layName = oblkRef.Layer
oblkRef.Delete
Set oblkRef = _
ThisDrawing.ActiveLayout.Block.InsertBlock(insPt, bName, dblXscl, dblYscl, dblZscl, dblRot)
oblkRef.Layer = layName
End If

Err_Control:
If Err.Number = 0 Then
MsgBox "Done"
Else
MsgBox Err.Description
End If
End Sub