Message 1 of 1
Trouble Copying Objects Between DWGs in AutoCAD VBA
- Mark as New
- Bookmark
- Subscribe
- Mute
- Subscribe to RSS Feed
- Permalink
- Report
I haven't been coding for a while.
I am trying to write an AutoCAD VBA script to copy objects from one DWG to another. I want to filter LINE and TEXT objects on specific layers and recreate them in the target DWG. The selection works and I can access the objects in VBA, but when I try to add them to the target DWG using AddLine, AddText nothing appears in the target. Can anyone help me what am I missing?
Option Explicit
Sub dwg_list_copy_deneme()
Dim acadApp As AcadApplication
Dim targetDoc As AcadDocument
Dim sourceDoc As AcadDocument
Dim selSet As AcadSelectionSet
Dim filterType(1) As Integer
Dim filterData(1) As Variant
Set acadApp = ThisDrawing.Application
Set targetDoc = ThisDrawing
' Open source DWG
Set sourceDoc = acadApp.Documents.Open("E:\Kochisar\AsBuilt\KOÇHİSAR İŞ SONU TÜM DOSYALAR\DWG - Copy\new block.dwg")
On Error Resume Next
sourceDoc.SelectionSets.Item("SS1").Delete
On Error GoTo 0
Set selSet = sourceDoc.SelectionSets.Add("SS1")
filterType(0) = 0: filterData(0) = "TEXT,LINE"
filterType(1) = 8: filterData(1) = "PR_ENK_EKSEN1,PR_ENK_KM,PR_ENK_Z,PR_ENK_Z,PR_PROFIL,PR_OLCEK"
selSet.Select acSelectionSetAll, , , filterType, filterData
Dim i As Long
For i = 0 To selSet.Count - 1
Dim ent As AcadEntity
Set ent = selSet.Item(i)
Select Case ent.ObjectName
Case "AcDbLine"
Dim ln As AcadLine
Dim newLine As AcadLine
Dim startPt(0 To 2) As Double
Dim endPt(0 To 2) As Double
Set ln = ent
startPt(0) = CDbl(ln.startPoint(0))
startPt(1) = CDbl(ln.startPoint(1))
startPt(2) = 0
endPt(0) = CDbl(ln.endPoint(0))
endPt(1) = CDbl(ln.endPoint(1))
endPt(2) = 0
Set newLine = targetDoc.ModelSpace.AddLine(startPt, endPt)
Case "AcDbText"
Dim txt As AcadText
Set txt = ent
Dim newText As AcadText
Dim insPt(0 To 2) As Double
insPt(0) = CDbl(txt.insertionPoint(0))
insPt(1) = CDbl(txt.insertionPoint(1))
insPt(2) = CDbl(txt.insertionPoint(2))
Set newText = targetDoc.ModelSpace.AddText(txt.textString, insPt, txt.height)
End Select
Next i
sourceDoc.Close False
MsgBox selSet.Count & " object created!"
End Sub