' change this line to your settings first Const progID As String = "AutoCAD.Application.17" _ Sub testAddToBlock() Dim blkname As String = "UserName" '<-- change block name to suit Dim target As String = "C:\Test\WorkingDrawing.dwg" '<-- change current file name to suit Dim savename As String = "C:\Test\WorkingDrawing3.dwg" '<-- change saveas file name to suit Dim acApp As AcadApplication = Nothing Try acApp = TryCast(Marshal.GetActiveObject(progID), AcadApplication) Catch MsgBox("Cannot create object of type """ & progID & """") Exit Sub End Try Try Dim doc As AcadDocument = acApp.ActiveDocument acApp.Visible = True acApp.WindowState = AcWindowState.acMax doc.Utility.Prompt(Environment.NewLine & "Select objects to copy: ") Dim copyObjs As New Object Dim iPairs As Object = Nothing Dim pfSet As AcadSelectionSet pfSet = doc.PickfirstSelectionSet pfSet.Clear() pfSet.SelectOnScreen(Type.Missing, Type.Missing) Dim objs() As AcadEntity = New AcadEntity(pfSet.Count - 1) {} For i As Long = 0 To pfSet.Count - 1 objs(i) = DirectCast(pfSet.Item(i), AcadEntity) Next copyObjs = objs ' ------------------------------------------------------------'' Dim acdoc As AcadDocument = acApp.Documents.Open(target, False, Nothing) Dim blkexist As Boolean = False For Each blkDef As AcadBlock In acdoc.Blocks If blkDef.Name = blkname Then blkexist = True Exit For End If Next If Not blkexist Then Exit Sub End If Dim lastCnt As Long = acdoc.ModelSpace.Count - 1 'copy object to modelspace doc.CopyObjects(copyObjs, acdoc.ModelSpace, iPairs) doc.SendCommand("(command) ") Dim MyTimer As New System.Timers.Timer() ' add an interval to 2 seconds (2000 milliseconds). MyTimer.Interval = 2000 MyTimer.Enabled = True Dim start As Integer = DateTime.Now.Millisecond MyTimer.Start() Do While DateTime.Now.Millisecond > start + 2000 Loop MyTimer.Stop() MyTimer.Enabled = False MyTimer.Dispose() acdoc.Activate() acdoc.Utility.Prompt(vbLf & "Adding objects to the block definition: ") acdoc.Regen(AcRegenType.acActiveViewport) Dim postCnt As Long = acdoc.ModelSpace.Count - 1 Dim addObjs() As AcadEntity = New AcadEntity(0 To objs.Length - 1) {} Dim addObj As New Object Dim a As Long = 0 For n As Long = lastCnt + 1 To lastCnt + objs.Length ' addObjs(a) = DirectCast(acdoc.ObjectIdToObject(acdoc.ModelSpace.Item(n).ObjectID), AcadEntity)'equivalent addObjs(a) = DirectCast(acdoc.ModelSpace.Item(n), AcadEntity) a += 1 Next addObj = addObjs acdoc.Utility.Prompt(vbLf & "Adding the objects to the block definition: ") Dim blkRec As AcadBlock = DirectCast(acdoc.Blocks.Item(blkname), AcadBlock) Dim nPairs As Object = Nothing acdoc.Utility.Prompt(vbLf & "Perform copy objects to the block definition: ") ''copy object from modelspace to the block definition acdoc.CopyObjects(addObj, blkRec, nPairs) ' delete objects from modelspace at the end For Each delobj As AcadEntity In addObjs delobj.Delete() Next ' ------------------------------------------------------------'' acdoc.SaveAs(savename, AcSaveAsType.ac2004_dwg)'<-- change this line to suit acdoc.Close(True, savename) releaseObject(acdoc) Catch ex As System.Runtime.InteropServices.COMException MsgBox("Problem occurs by reason of:" & vbLf & ex.Message & vbLf & ex.StackTrace) Exit Sub Finally acApp.Eval("MsgBox(""Pokey!"")") acApp.Quit() releaseObject(acApp) End Try End Sub Private Sub releaseObject(ByVal obj As Object) ' this subroutine is copied from Excel tutorial website Try System.Runtime.InteropServices.Marshal.FinalReleaseComObject(obj) ' this line is changed by me If obj IsNot Nothing Then obj = Nothing ' this line is changed by me Catch ex As Exception obj = Nothing Finally GC.Collect() End Try End Sub