Trouble Copying Objects Between DWGs in AutoCAD VBA

Trouble Copying Objects Between DWGs in AutoCAD VBA

truss_85
Advocate Advocate
25 Views
0 Replies
Message 1 of 1

Trouble Copying Objects Between DWGs in AutoCAD VBA

truss_85
Advocate
Advocate

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
0 Likes
26 Views
0 Replies
Replies (0)