Auto cad --> excel

February 25, 2007

hi

I need the help.that, how can i get the polyline length/area in a excel sheet automatically..

Because, when i am taking the area/length measurement by polyline, i have to copy from the list and paste to the excel cell manually..So, this is taking the lot of time for the measurement of more polylines..

Pls help me friendsssssss

Thanks in advance

February 25, 2007

If you are willing to make a small purchase, take a look at AutoCELL @ http://www.dotsoft.com/autocell.htm

What you are asking for can also be coded in lisp or VBA if you are comfortable doing this or know someone who is.

February 26, 2007

Thank you for your reply ..rkmcswain

Pls help me, anyone, who knows the lisp or VBA for for my need...

Thanks

February 26, 2007

Here is some VBA code cannibalized from a larger routine (i.e., may need further tweaking) that basically does what you request. It automatically selects all closed polylines - Lightweight, 2D (fit or splined) - and sends information to a generic excel file.

The VBAIDE must have a reference set for your version of Excel.

Option Explicit

Sub PutPLProps2XL()
  If ClosedPLSS Then
     Dim objSS As AcadSelectionSet
     Dim entEntity As AcadEntity
     Dim objExcel As Excel.Application
     Dim objRange As Excel.Range
     Dim entLWPoly As AcadLWPolyline
     Dim ent2DPoly As AcadPolyline
     Dim intCount As Integer
     On Error GoTo errhandler
     Set objExcel = GetObject(, "Excel.Application")
     On Error GoTo 0
     Set objRange = objExcel.ActiveWorkbook.ActiveSheet.Range("A1")
     objRange.value = "Pline Type"
     objRange.Offset(0, 1).value = "Length"
     objRange.Offset(0, 2).value = "Area"
        Set objSS = ThisDrawing.SelectionSets.Item("TempSSet")
        For intCount = 0 To objSS.count - 1
           Set entEntity = objSS.Item(intCount)
           If entEntity.ObjectName = "AcDbPolyline" Then
              Set entLWPoly = entEntity
              objRange.Offset(intCount + 1, 0).value = "LWPolyline"
              objRange.Offset(intCount + 1, 1).value = entLWPoly.Length
              objRange.Offset(intCount + 1, 2).value = entLWPoly.Area
           Else
              Set ent2DPoly = entEntity
              objRange.Offset(intCount + 1, 0).value = "2DPolyline"
              objRange.Offset(intCount + 1, 1).value = ent2DPoly.Length
              objRange.Offset(intCount + 1, 2).value = ent2DPoly.Area
           End If
        Next
  End If
  Exit Sub
errhandler:
  Set objExcel = CreateObject("Excel.Application")
  Resume Next
End Sub

Function ClosedPLSS() As Boolean
  Dim intCode(19) As Integer
  Dim varData(19) As Variant
  ClosedPLSS = False
  intCode(0) = -4: varData(0) = "<Or"
     intCode(1) = -4: varData(1) = "<And"
        intCode(2) = 0: varData(2) = "POLYLINE" 'or closed PLINES's
        intCode(3) = -4: varData(3) = "&="
        intCode(4) = 70: varData(4) = 1
        intCode(5) = -4: varData(5) = "&"
        intCode(6) = 70: varData(6) = 135
        intCode(7) = -4: varData(7) = "<Not"
           intCode( = -4: varData( = "&="
           intCode(9) = 70: varData(9) = 8
        intCode(10) = -4: varData(10) = "Not>"
     intCode(11) = -4: varData(11) = "And>"
     
     intCode(12) = -4: varData(12) = "<And"
        intCode(13) = 0: varData(13) = "LWPOLYLINE" 'or closed LWP's
        intCode(14) = -4: varData(14) = "&="
        intCode(15) = 70: varData(15) = 1
        intCode(16) = -4: varData(16) = "&"
        intCode(17) = 70: varData(17) = 129
     intCode(18) = -4: varData(18) = "And>"
  intCode(19) = -4: varData(19) = "Or>"
  
  If FilteredSS(intCode, varData) > 0 Then ClosedPLSS = True
End Function

Private Sub SSPrep()
Dim SSS As AcadSelectionSets
  'choose a selection set name for temporary storage and
  'ensure that it does not currently exist
  On Error Resume Next
  Set SSS = ThisDrawing.SelectionSets
     If SSS.count > 0 Then
        SSS.Item("TempSSet").Delete
     End If
End Sub

Function FilteredSS(Optional grpCode As Variant, Optional dataVal As Variant) As Integer
  Dim TempObjSS As AcadSelectionSet
  SSPrep
  Set TempObjSS = ThisDrawing.SelectionSets.Add("TempSSet")
        'generate selection set
     TempObjSS.Select acSelectionSetAll, , , grpCode, dataVal
  FilteredSS = TempObjSS.count
End Function

February 27, 2007

Thank you for your reply....

I try your vba but, it shows error... i thing, the reason is excel version...

I am using the Excel 2002 and auto cad 2004..so, pls help me for this version..

Thanks & regards

February 27, 2007

A reference to the proper vesion of Excel can be set through Tools-Reference menu item (as illustrated). I'm using Excel 2003 so, presumably, you would select the "Microsoft Excel 10.0 Object Library"

If that was not the cause of the error, post the actual error message and we'll try to work it out.

February 27, 2007

Now, it is working friend.....thanks youuuuuuuuuuuuuu....

February 27, 2007

Dear friend Seant...

Pls help on here...

Your coding is working welll.

But, i need the coding for.....

"Display the selected polyline/s properties (such as layer name, area, length) in a excel sheet..."

Pls help in this.......

THANKSSSSSSS

February 28, 2007

The code below also records the Layer property of the Plines. A few thing were re-arranged for the new sequence of properties. I also repaired the errorhandler section.

One note: This routine indescriminately records all closed Plines. A "selected" Pline would require modified code.

Given that this is a "Tutor" based site, perhaps you should show me how to record the Plines linetype. See how the two code examples changed and the effect in Excel. Now add linetype (.linetype) to the list. Don't hesitate to ask if there are any questions.

 Option Explicit

Sub PutPLProps2XL()
  If ClosedPLSS Then
     Dim objSS As AcadSelectionSet
     Dim entEntity As AcadEntity
     Dim objExcel As Excel.Application
     Dim objRange As Excel.Range
     Dim entLWPoly As AcadLWPolyline
     Dim ent2DPoly As AcadPolyline
     Dim intCount As Integer
     On Error GoTo errhandler
     Set objExcel = GetObject(, "Excel.Application")
     On Error GoTo 0
     Set objRange = objExcel.ActiveWorkbook.ActiveSheet.Range("A1")
     objRange.value = "Layer"
     objRange.Offset(0, 1).value = "Pline Type"
     objRange.Offset(0, 2).value = "Length"
     objRange.Offset(0, 3).value = "Area"
        Set objSS = ThisDrawing.SelectionSets.Item("TempSSet")
        For intCount = 0 To objSS.count - 1
           Set entEntity = objSS.Item(intCount)
           If entEntity.ObjectName = "AcDbPolyline" Then
              Set entLWPoly = entEntity
              objRange.Offset(intCount + 1, 0).value = entLWPoly.Layer
              objRange.Offset(intCount + 1, 1).value = "LWPolyline"
              objRange.Offset(intCount + 1, 2).value = entLWPoly.Length
              objRange.Offset(intCount + 1, 3).value = entLWPoly.Area
           Else
              Set ent2DPoly = entEntity
              objRange.Offset(intCount + 1, 0).value = ent2DPoly.Layer
              objRange.Offset(intCount + 1, 1).value = "2DPolyline"
              objRange.Offset(intCount + 1, 2).value = ent2DPoly.Length
              objRange.Offset(intCount + 1, 3).value = ent2DPoly.Area
           End If
        Next
  End If
  Set objExcel = Nothing
  Exit Sub
errhandler:
  Err.Clear
  Set objExcel = CreateObject("Excel.Application")
  With objExcel
     .Workbooks.Add
     .Visible = True
     .WindowState = xlMinimized
  End With
  Resume Next
End Sub
Function ClosedPLSS() As Boolean
  Dim intCode(19) As Integer
  Dim varData(19) As Variant
  ClosedPLSS = False
  intCode(0) = -4: varData(0) = "<Or"
     intCode(1) = -4: varData(1) = "<And"
        intCode(2) = 0: varData(2) = "POLYLINE" 'or closed PLINES's
        intCode(3) = -4: varData(3) = "&="
        intCode(4) = 70: varData(4) = 1
        intCode(5) = -4: varData(5) = "&"
        intCode(6) = 70: varData(6) = 135
        intCode(7) = -4: varData(7) = "<Not"
           intCode( = -4: varData( = "&="
           intCode(9) = 70: varData(9) = 8
        intCode(10) = -4: varData(10) = "Not>"
     intCode(11) = -4: varData(11) = "And>"
     
     intCode(12) = -4: varData(12) = "<And"
        intCode(13) = 0: varData(13) = "LWPOLYLINE" 'or closed LWP's
        intCode(14) = -4: varData(14) = "&="
        intCode(15) = 70: varData(15) = 1
        intCode(16) = -4: varData(16) = "&"
        intCode(17) = 70: varData(17) = 129
     intCode(18) = -4: varData(18) = "And>"
  intCode(19) = -4: varData(19) = "Or>"
  
  If FilteredSS(intCode, varData) > 0 Then ClosedPLSS = True
End Function
Private Sub SSPrep()
Dim SSS As AcadSelectionSets
  'choose a selection set name for temporary storage and
  'ensure that it does not currently exist
  On Error Resume Next
  Set SSS = ThisDrawing.SelectionSets
     If SSS.count > 0 Then
        SSS.Item("TempSSet").Delete
     End If
End Sub

Function FilteredSS(Optional grpCode As Variant, Optional dataVal As Variant) As Integer
  Dim TempObjSS As AcadSelectionSet
  SSPrep
  Set TempObjSS = ThisDrawing.SelectionSets.Add("TempSSet")
        'generate selection set
     TempObjSS.Select acSelectionSetAll, , , grpCode, dataVal
  FilteredSS = TempObjSS.count
End Function

March 1, 2007

Thank you so muchhh...friend seant..

I will use this coding and sent the feed back and additional needs soon..

Thanks againnnn

March 7, 2007

Hi seant

I try your vba coding, but that showing all polylines...

I need..."Display the properties of selected polyline (layer wise) in a excel sheet..

I got one lisp file (name :- "zone") for polyline measurement from here..it gives the total area/length of selected polyline (layerwise)..

Could you make a vba coding accoring this lisp coding plssssssssss?

Here i add the lisp coding, which I got form here...........

; Area and Length Measurement of Polylines by Layer

; Works with both Lightweight (optimized) Polylines and old-format Polylines

; The PLINETYPE system variable is unaffected

;

; David Watson 1995, updated 2003

;

(defun c:zone ( / ssl aret pert)

(princ "\nPick any object on the required layer\n")

(setq ssl (ssget))

(if (= ssl nil)(princ "\n*** Nothing was selected! ***\n\n")

(progn

(setq lay (cdr (assoc 8 (entget (ssname ssl 0)))))

(setq ssl (ssget "X" (list (cons 8 lay))))

(princ (strcat "\nLayer " lay " selected"))

(initget "Length Area")

(setq res (getkword "\nWould you like to measure Length/ : "))

(if (= res "Length")(mlen)(meas))

);end progn

);end if

(princ)

);END ZONE

(defun meas ()

(setq len (sslength ssl))

(setq alen (sslength ssl))

(setq aret 0)

(setq count 0)

(setq nop 0)

(setq ope 0)

(while (/= len count)

(setq pnt (ssname ssl count))

(setq ple (cdr (assoc 0 (entget pnt))))

(if (and (/= ple "LWPOLYLINE")(/= ple "POLYLINE"))

(progn

(setq nop (+ 1 nop))

(setq alen (- alen 1))

(princ "\nNon polyline filtered\n")

);END PROGN

(progn

(setq plc (cdr (assoc 70 (entget pnt))))

(if (= plc 0)

(progn

(setq ope (+ 1 ope))

(princ "\nWarning! *** Polyline is not closed\n")

);END PROGN

);END IF

(command "area" "e" pnt)

(setq are (getvar "area"))

(setq aret (+ are aret))

);END PROGN

);END IF

(setq count (+ count 1))

);END WHILE

(if (= nop 0)(princ "\nAll chosen objects were polylines")(princ (strcat "\n" (itoa nop) " non polyline objects were filtered")))

(if (= ope 0)(princ "\nAll polylines were closed")(princ (strcat "\n" (itoa ope) " polylines were not closed")))

(princ (strcat "\nTotal area for layer " lay " = " (rtos aret 2 0) "m2 or "(rtos (/ aret 10000) 2 2) " Ha in " (itoa alen) " areas"))

(princ)

);END MEAS

(defun mlen ()

(setq len (sslength ssl))

(setq alen (sslength ssl))

(setq pert 0)

(setq count 0)

(setq nop 0)

(while (/= len count)

(setq pnt (ssname ssl count))

(setq ple (cdr (assoc 0 (entget pnt))))

(if (and (/= ple "LWPOLYLINE")(/= ple "POLYLINE"))

(progn

(setq nop (+ 1 nop))

(setq alen (- alen 1))

(princ "\nNon polyline filtered\n")

);END PROGN

(progn

(command "area" "e" pnt)

(setq per (getvar "perimeter"))

(setq pert (+ per pert))

);END PROGN

);END IF

(setq count (+ count 1))

);END WHILE

(if (= nop 0)(princ "\nAll chosen objects were polylines")(princ (strcat "\n" (itoa nop) " non polyline objects were filtered")))

(princ (strcat "\nTotal length for layer " lay " = " (rtos pert 2 1) "m or " (rtos (/ pert 0.3048) 2 0) " feet in " (itoa alen) " lengths" ))

(princ)

);END MLEN

March 7, 2007

Here is an updated routine to add the feature like that of the Lisp code. I hope it is helpful.

An observation should be made about this web site and the “Helpfulness” of all of its members. It’s quite clear that we all enjoy helping out where we can. This is a site based on teaching and learning, however, so the ultimate goal is to help others learn the various aspects of AutoCAD.

With regard to Lisp or VBA, a level of helpfulness and responsiveness too high could help a person not learn programming.

The routine accompanying this message may not be suited for a tutorial in VBA (or maybe it is), but it should allow for specific coding questions. I’ll do what I can to answer those questions if you need to make further modifications to the code.

   Option Explicit

Sub PutPLProps2XL()
Dim strLayName As String
  strLayName = GetObjectLayer()
  If strLayName <> "" Then
     If ClosedPLSS(strLayName) Then
        Dim objSS As AcadSelectionSet
        Dim entEntity As AcadEntity
        Dim objExcel As Excel.Application
        Dim objRange As Excel.Range
        Dim entLWPoly As AcadLWPolyline
        Dim ent2DPoly As AcadPolyline
        Dim intCount As Integer
           On Error GoTo errHandler
           Set objExcel = GetObject(, "Excel.Application")
           On Error GoTo 0
           Set objRange = objExcel.ActiveWorkbook.ActiveSheet.Range("A1")
           objRange.value = "Layer"
           objRange.Offset(0, 1).value = "Pline Type"
           objRange.Offset(0, 2).value = "Length"
           objRange.Offset(0, 3).value = "Area"
              Set objSS = ThisDrawing.SelectionSets.Item("TempSSet")
              For intCount = 0 To objSS.count - 1
                 Set entEntity = objSS.Item(intCount)
                 If entEntity.ObjectName = "AcDbPolyline" Then
                    Set entLWPoly = entEntity
                    objRange.Offset(intCount + 1, 0).value = entLWPoly.Layer
                    objRange.Offset(intCount + 1, 1).value = "LWPolyline"
                    objRange.Offset(intCount + 1, 2).value = entLWPoly.Length
                    objRange.Offset(intCount + 1, 3).value = entLWPoly.Area
                 Else
                    Set ent2DPoly = entEntity
                    objRange.Offset(intCount + 1, 0).value = ent2DPoly.Layer
                    objRange.Offset(intCount + 1, 1).value = "2DPolyline"
                    objRange.Offset(intCount + 1, 2).value = ent2DPoly.Length
                    objRange.Offset(intCount + 1, 3).value = ent2DPoly.Area
                 End If
              Next
     Set objExcel = Nothing
     End If
  End If
  Exit Sub
errHandler:
  Err.Clear
  Set objExcel = CreateObject("Excel.Application")
  With objExcel
     .Workbooks.Add
     .Visible = True
     .WindowState = xlMinimized
  End With
  Resume Next
End Sub
Function ClosedPLSS(strLayName As String) As Boolean
  Dim intCode(21) As Integer
  Dim varData(21) As Variant
  ClosedPLSS = False
  intCode(0) = -4: varData(0) = "<Or"
     intCode(1) = -4: varData(1) = "<And"
        intCode(2) = 0: varData(2) = "POLYLINE" 'or closed PLINES's
        intCode(3) = -4: varData(3) = "&="
        intCode(4) = 70: varData(4) = 1
        intCode(5) = -4: varData(5) = "&"
        intCode(6) = 70: varData(6) = 135
        intCode(7) = -4: varData(7) = "<Not"
           intCode( = -4: varData( = "&="
           intCode(9) = 70: varData(9) = 8
        intCode(10) = -4: varData(10) = "Not>"
        intCode(11) = 8: varData(11) = strLayName
     intCode(12) = -4: varData(12) = "And>"
     
     intCode(13) = -4: varData(13) = "<And"
        intCode(14) = 0: varData(14) = "LWPOLYLINE" 'or closed LWP's
        intCode(15) = -4: varData(15) = "&="
        intCode(16) = 70: varData(16) = 1
        intCode(17) = -4: varData(17) = "&"
        intCode(18) = 70: varData(18) = 129
        intCode(19) = 8: varData(19) = strLayName
     intCode(20) = -4: varData(20) = "And>"
  intCode(21) = -4: varData(21) = "Or>"
  
  If FilteredSS(intCode, varData) > 0 Then ClosedPLSS = True
End Function
Private Sub SSPrep()
Dim SSS As AcadSelectionSets
  'choose a selection set name for temporary storage and
  'ensure that it does not currently exist
  On Error Resume Next
  Set SSS = ThisDrawing.SelectionSets
     If SSS.count > 0 Then
        SSS.Item("TempSSet").Delete
     End If
End Sub

Function FilteredSS(Optional grpCode As Variant, Optional dataVal As Variant) As Integer
  Dim TempObjSS As AcadSelectionSet
  SSPrep
  Set TempObjSS = ThisDrawing.SelectionSets.Add("TempSSet")
        'generate selection set
     TempObjSS.Select acSelectionSetAll, , , grpCode, dataVal
  FilteredSS = TempObjSS.count
End Function

Function GetObjectLayer() As String
Dim ent As AcadEntity
Dim varPickPT As Variant
  On Error GoTo errHandler
  ThisDrawing.Utility.GetEntity ent, varPickPT, "Select an entity on a layer with which to focus: "
  GetObjectLayer = ent.Layer
  Exit Function
errHandler:
  GetObjectLayer = ""
End Function

March 8, 2007

Thank youuuuuu...

March 26, 2007

SEANT,

I try use your code with VB ver. 6.3 ,Excell 2003 and this message appear :

"User-defined type not defined" at line Dim objExcel As Excel.Application

As you see am begginer with VB.What can i do ?

Thank you.

March 26, 2007

With regard to Lisp or VBA, a level of helpfulness and responsiveness too high could help a person not learn programming.

That's why I try to just point people in the right direction rather than do the code for them. That and the fact I rarely actually finish my code.

March 27, 2007

SEANT,

I try use your code with VB ver. 6.3 ,Excell 2003 and this message appear :

"User-defined type not defined" at line Dim objExcel As Excel.Application

As you see am begginer with VB.What can i do ?

Thank you.

See post #6 in this thread. It may be related to the problem you describe.

You say you're using VB 6.3; do you mean Autocad VBA 6.3 or VB6. If it is the latter, you're will likely run into a few more problems with the code above as all of the Autocad objects will need modification.

March 27, 2007

That and the fact I rarely actually finish my code.

By that, I assume you mean "Bulletproof the code for Public Consumption."

I'm tempted to post a Poll in Customisation to determine the extent programmers go to make their code un-breakable. Most of the users of anything I've written have direct access to me so I tended to be lax. Lately, I'm tightening the error handling but the process can double the time of development to get truely unbreakable code.

February 7, 2018

I have a problem

when i try to use it i get an error "Compile Error:Variable not defined"

and this part of the code gets highlighted with yellow

"Function FilteredSS(Optional grpCode As Variant, Optional dataVal As Variant) As Integer"

i already did what you said in the post #6

February 7, 2018

It has been a long time since I fired up the ol' VBAIDE. I copy and pasted the code, and set the appropriate references (Microsoft Excel 16.0 Object Library) and the code seems to run fine.

Is it possible that when you transferred the routine that some part of the code did not get copied along?

February 7, 2018

nope, i cheked it twice

im using autocad 2017 and excel 2010. maybe there is the problem.

This post is from 2007 so.

Sign In

Auto cad --> excel

Recommended Posts

jackseel

Top Posters In This Topic

Popular Days

Top Posters In This Topic

Popular Days

Posted Images

rkmcswain

jackseel

SEANT

jackseel

SEANT

jackseel

jackseel

SEANT

jackseel

jackseel

SEANT

jackseel

gio

dbroada

SEANT

SEANT

xxfaxx

SEANT

xxfaxx

Join the conversation

Tutorials

Forums

Activity