VBA
Discuss AutoCAD ActiveX and VBA (Visual Basic for Applications) questions here.
cancel
Showing results for 
Show  only  | Search instead for 
Did you mean: 

Excel VBA for Cad polyline Select and bring area back to excel with inner text

4 REPLIES 4
SOLVED
Reply
Message 1 of 5
bit_Cad2018
2620 Views, 4 Replies

Excel VBA for Cad polyline Select and bring area back to excel with inner text

Hi friends,

I require area of closed polygon and text written with in it (closed polygon) in excel


Please check attach sample drawing and excel

 

i have area export to excel vba code please see

 

Option Explicit

Sub PickLwPolysAndGetData()

'for Excel sheet managing purposes
Dim MySht As Worksheet
Dim MyCell As Range

'for Autocad application managing purposes
Dim ACAD As AcadApplication
Dim ThisDrawing As AcadDocument
Dim LWPoly As AcadLWPolyline
Dim mtext As AcadMText

' for selection set purposes
Dim ssetObj As AcadSelectionSet
Dim gpCode(0) As Integer
Dim dataValue(0) As Variant

'for general variables managing purposes
Dim iRow As Long
Dim LWArea As Double, LWPerimeter As Double, LWLayer As Variant, amtext As Variant


' Autocad Session handling
On Error Resume Next
Set ACAD = GetObject(, "AutoCAD.Application")
On Error GoTo 0
If ACAD Is Nothing Then
Set ACAD = New AcadApplication
ACAD.Visible = True
End If
Set ThisDrawing = ACAD.ActiveDocument

' selecting LwPolylines on screen by selelection set filtering method
' managing potential selection set exsistence
On Error Resume Next
Set ssetObj = ThisDrawing.SelectionSets.Item("LWPolySSET")
If Err Then Set ssetObj = ThisDrawing.SelectionSets.Add("LWPolySSET")
On Error GoTo 0
ssetObj.Clear

'setting filtering critera
gpCode(0) = 0
dataValue(0) = "LWPOLYLINE"

'selecting LWPolylines
ssetObj.SelectOnScreen gpCode, dataValue

' processing LWPolylines

If ssetObj.Count > 0 Then

' writing sheet headings
Set MySht = ActiveSheet
Set MyCell = MySht.Cells(1, 1)
With MyCell
.Offset(0, 0).Value = "LWPoly nr"
.Offset(0, 1).Value = "Layer"
.Offset(0, 2).Value = "Area"
.Offset(0, 3) = "Length"
End With

'clearing previous written data
iRow = MySht.Cells(MySht.Rows.Count, 1).End(xlUp).Row
If iRow > 1 Then MyCell.Offset(1, 0).Resize(iRow - 1, 3).Clear

'retrieving LWPolys data and writing them on worksheet
iRow = 1
For Each LWPoly In ssetObj
'retrieving LWPoly data
With LWPoly
LWArea = .Area
LWPerimeter = .Length
LWLayer = .Layer

End With

 

 

' writing LWPoly data
With MyCell
.Offset(iRow, 0).Value = "LWPoly nr." & iRow
.Offset(iRow, 1).Value = LWLayer
.Offset(iRow, 2).Value = LWArea
.Offset(iRow, 3).Value = LWPerimeter

End With
iRow = iRow + 1
Next LWPoly

End If

' cleaning up before ending
ssetObj.Delete
Set ssetObj = Nothing
Set ThisDrawing = Nothing
Set ACAD = Nothing

End Sub

Tags (3)
4 REPLIES 4
Message 2 of 5
RICVBA
in reply to: bit_Cad2018

you could use SelectionSet object and filter Text object elements inside or crossing a polyline

 

see this link for the AutoCAD ActiveX "SelectByPolygon" method help topic

 

for instance the following function would yield "True" if a single text object is inside or crossing the passed polyline, along with its text string in its "textInPoly" string argument

 

Function GetTextInsidePoly(acPoly As AcadLWPolyline, textInPoly As String) As Boolean
    Dim ssetObj As AcadSelectionSet
    Dim coords As Variant, iCoord As Long
    
    With acPoly
        With .Document
            On Error Resume Next
            Set ssetObj = .SelectionSets.Item("mySset")
            If Err Then Set ssetObj = .SelectionSets.Add("mySset")
            On Error GoTo 0
            ssetObj.Clear
        End With
        coords = .Coordinates
    End With
    
    ReDim pointsArray(0 To 3 * (UBound(coords) + 1) * 0.5 - 1) As Double
    Do
        pointsArray(iCoord) = coords(2 * iCoord / 3)
        pointsArray(iCoord + 1) = coords(2 * iCoord / 3 + 1)
        iCoord = iCoord + 3
    Loop While iCoord < UBound(pointsArray)
    
    Dim gpCode(0) As Integer
    Dim dataValue(0) As Variant

    gpCode(0) = 0
    dataValue(0) = "TEXT"
    
    With ssetObj
        .SelectByPolygon acSelectionSetCrossingPolygon, pointsArray, gpCode, dataValue
        
        Select Case .Count
            Case 0
                MsgBox "No text inside polyline!"
            Case 1
                textInPoly = .Item(0).TextString
                GetTextInsidePoly = True
            Case Else
                ' here you need to seek for the "actual" text object of interest (may be the one whose insertion point is inside the polyline
        End Select
    End With
End Function

So that in your main code you could have a code block like:

        If GetTextInsidePoly(LWPoly, txt) Then
            MsgBox txt ' you can change this line to something that writes the txt string into an excel cell
        End If

As you can see, the case of more than one text objects being "captured" by the function is to be developed

Should it actually be a need of yours, maybe the following links could be of any help:

https://forums.autodesk.com/t5/visual-basic-customization/how-to-determine-if-a-point-is-inside-a-re... 

https://www.cadtutor.net/forum/topic/28634-point-in-polygon-vba/ 

Message 3 of 5
bit_Cad2018
in reply to: RICVBA

SIR I DON'T KNOW ABOUT CODE OR VBA. I HAD USED CODE "THE SWAMP" SITE. CAN YOU PLEASE ADD TEXT INSIDE POLYGON EXPORT IN EXCEL WITH AREA.

 

SORRY FOR MY BAD ENGLISH

Message 4 of 5
Ed.Jobe
in reply to: bit_Cad2018

It might be hard to find someone with the time to do everything for you if you don't want to learn to program.

Ed


Did you find this post helpful? Feel free to Like this post.
Did your question get successfully answered? Then click on the ACCEPT SOLUTION button.
How to post your code.

EESignature

Message 5 of 5
bit_Cad2018
in reply to: Ed.Jobe

sorry sir
i tried many time to add code in above code but i failed many times.


Forgive me if i hurt you

my English not so good. So misunderstood your

 

 

sorry for late reply

Can't find what you're looking for? Ask the community or share your knowledge.

Post to forums  

”Boost