Jump to content

Auto cad --> excel


jackseel

Recommended Posts

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

Link to comment
Share on other sites

  • Replies 30
  • Created
  • Last Reply

Top Posters In This Topic

  • SEANT

    13

  • jackseel

    8

  • xxfaxx

    6

  • rkmcswain

    1

Top Posters In This Topic

Posted Images

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

Link to comment
Share on other sites

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

Link to comment
Share on other sites

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.

Reference.jpg

Link to comment
Share on other sites

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

Link to comment
Share on other sites

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 

Link to comment
Share on other sites

Thank you so muchhh...friend seant..

 

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

 

 

Thanks againnnn

Link to comment
Share on other sites

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

Link to comment
Share on other sites

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

Link to comment
Share on other sites

  • 3 weeks later...

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

 

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

Thank you.

Link to comment
Share on other sites

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. :D

Link to comment
Share on other sites

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

 

:oops: 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.

Link to comment
Share on other sites

That and the fact I rarely actually finish my code. :D

 

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.

Link to comment
Share on other sites

  • 10 years later...

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

Link to comment
Share on other sites

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?

Link to comment
Share on other sites

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.
Note: Your post will require moderator approval before it will be visible.

Guest
Unfortunately, your content contains terms that we do not allow. Please edit your content to remove the highlighted words below.
Reply to this topic...

×   Pasted as rich text.   Restore formatting

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.


×
×
  • Create New...