Autocad VBA Copy Block Definition

[Barclay]

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]

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