Dimension values to Excel

[Butch]

Hi guys!

Im stuck with this boring routine of reading dimension values and typing them in Excel columns for furtegr calculations.

My dimenison are alinged in one horizontal line (see picture; blue line represents how would values had to be arranged in Excel).

Is there anyway I could select all the dimesnions at once and copy the values in Excel column?

You can see the picture attach of what I had in mind. Is something like this possible?

Maybe another insanly/impossible great thing would be, selecting hatch and coping its area value to excel.

Anyway, if anything of this is possible I would appricate it:)

[fixo]

Hi guys!

Im stuck with this boring routine of reading dimension values and typing them in Excel columns for furtegr calculations.

My dimenison are alinged in one horizontal line (see picture; blue line represents how would values had to be arranged in Excel).

Is there anyway I could select all the dimesnions at once and copy the values in Excel column?

You can see the picture attach of what I had in mind. Is something like this possible?

Maybe another insanly/impossible great thing would be, selecting hatch and coping its area value to excel.

Anyway, if anything of this is possible I would appricate it:)

 

I have similar one on what you need on VBA

Just change file name

Option Explicit

Sub SortDims()

   Dim oSset As AcadSelectionSet
   Dim oEnt As AcadEntity
   Dim oDim As AcadDimension
   Dim oDimAln As AcadDimAligned
   Dim oDimRot As AcadDimRotated
   Dim eCnt As Integer
   Dim iCnt As Integer
   Dim rCnt As Integer
   Dim iNdx As Integer
   Dim insPnt() As Double
   Dim fcode(0) As Integer
   Dim fdata(0) As Variant
   Dim dxfCode, dxfdata

   fcode(0) = 0: fdata(0) = "DIMENSION"
   dxfCode = fcode
   dxfdata = fdata
   Set oSset = ThisDrawing.PickfirstSelectionSet
   oSset.Clear
   oSset.SelectOnScreen dxfCode, dxfdata

   iCnt = oSset.Count

   ReDim SelPnt(0 To iCnt - 1, 0 To 3) As Variant
   eCnt = 0

   For Each oEnt In oSset

       Set oDim = oEnt

       insPnt = oDim.TextPosition
       SelPnt(eCnt, 0) = insPnt(0)
       SelPnt(eCnt, 1) = insPnt(1)
       SelPnt(eCnt, 2) = insPnt(2)
       If TypeOf oDim Is AcadDimAligned Then
           Set oDimRot = oEnt
           SelPnt(eCnt, 3) = oDimRot.Measurement
       ElseIf TypeOf oDim Is AcadDimRotated Then
           Set oDimRot = oEnt
           SelPnt(eCnt, 3) = oDimRot.Measurement
       End If
       eCnt = eCnt + 1
   Next oEnt

   ReDim sortPnt(0 To iCnt - 1, 0 To 3) As Variant
   sortPnt = ColSort(SelPnt, 1)
   Dim xlApp As Excel.Application
   Dim xlBook As Workbook
   Dim xlSheet As Worksheet
   Dim strFilePath As String

   strFilePath = "C:\ExtractDims.xls" '<-- must be exist

   On Error Resume Next
   Err.Clear
   Set xlApp = GetObject(, "Excel.Application")
   If Err <> 0 Then
       Err.Clear
       Set xlApp = CreateObject("Excel.Application")
       If Err <> 0 Then
           MsgBox "Cannot start Excel", vbExclamation
           End
       End If
   End If
   xlApp.Visible = True

   On Error GoTo 0

   Dim CheckOpen As Boolean
   Dim OpenCnt As Long
   Dim strFilePath_Name As String
   For OpenCnt = 1 To xlApp.Workbooks.Count
       If xlApp.Workbooks(OpenCnt).FullName = strFilePath Then
           CheckOpen = True
           strFilePath_Name = xlApp.Workbooks(OpenCnt).Name
       ElseIf CheckOpen = True Then
           CheckOpen = True
       Else
           CheckOpen = False
       End If
   Next

   If CheckOpen Then
       Set xlBook = xlApp.Workbooks(strFilePath_Name)
       Set xlSheet = xlBook.Worksheets(1)
   Else
       Set xlBook = xlApp.Workbooks.Open(strFilePath)
       Set xlSheet = xlBook.Worksheets(1)
   End If
   Dim irow As Long
   irow = 1
   
   With xlSheet
       .Range("A:A").NumberFormat = "0.00#"
       For iNdx = 0 To UBound(sortPnt, 1)
           .Cells(irow, 1) = CStr(sortPnt(iNdx, 3))
           irow = irow + 1
       Next iNdx

   End With

End Sub
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
' written by Fatty T.O.H. (c)2006 * all rights removed              '
' SourceArr - two dimensional array                                 '
' iPos - physical position of item in the sublist (starting from 1) '
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
Public Function ColSort(SourceArr As Variant, iPos As Integer) As Variant

   Dim Check As Boolean
   ReDim tmpArr(UBound(SourceArr, 2)) As Variant
   Dim iCount As Integer
   Dim jCount As Integer
   Dim nCount As Integer

   iPos = iPos - 1
   Check = False

   Do Until Check
       Check = True
       For iCount = LBound(SourceArr, 1) To UBound(SourceArr, 1) - 1
           If SourceArr(iCount, iPos) > SourceArr(iCount + 1, iPos) Then
               For jCount = LBound(SourceArr, 2) To UBound(SourceArr, 2)
                   tmpArr(jCount) = SourceArr(iCount, jCount)
                   SourceArr(iCount, jCount) = SourceArr(iCount + 1, jCount)
                   SourceArr(iCount + 1, jCount) = tmpArr(jCount)
                   Check = False
               Next
           End If
       Next
   Loop

   ColSort = SourceArr

End Function

 

~'J'~

[Butch]

Fixo, what the hell is that?

How do I activate it, and how to use it?

[fixo]

Fixo, what the hell is that?

How do I activate it, and how to use it?

1 Copy code and paste it into Notepad

2 Save as .bas file say "modDimToExcel.bas"in the folder you need

3 Open Acad

4 Press Alt+F11

VBA editor window will be appears

5 Click File->Import and select saved file "modDimToExcel.bas"

6 Then go to Run->Run macro

7 Go to Acad window and select dimensions by window

or with another method

Excel file will be appears

8 Save it manually

Amen

Or do you want to do it with Lisp?

 

PS This will not work in 2010 version

 

~'J'~

[fixo]

The same thing on Lisp

 

(defun C:dx (/ *error* abks aexc asht col data dim_data elist en i row row_data ss tmp xbks xcel xshs)

(vl-load-com)
 
(defun *error*	(msg)
 (if
   (vl-position
     msg
     '("console break"
"Function cancelled"
"quit / exit abort"
)
     )
    (princ "Error!")
    (princ msg)
    )

 )
(if (setq ss (ssget (list (cons 0 "dimension"))))

 (progn
   (setq i -1)
   (repeat (sslength ss)
     (setq en	  (ssname ss (setq i (1+ i)))
    elist (entget en)
    tmp	  (cons (cdr (assoc 11 elist)) (cdr (assoc 42 elist)))
    data  (cons tmp data))
     )

   (setq dim_data (vl-sort data
		    (function (lambda (e1 e2) (< (caar e1) (caar e2))))))
   (alert "Close Excel File Only")
   (setq aexc (vlax-get-or-create-object "Excel.Application")
  xbks (vlax-get-property aexc "Workbooks")
  abks (vlax-invoke-method xbks "Add")
  xshs (vlax-get-property abks "Sheets")
  asht (vlax-get-property xshs "Item" 1)
  xcel (vlax-get-property asht "Cells")
  )
   (vla-put-visible aexc :vlax-true)
   (setq row 0
  col 1)


   (repeat (length dim_data)
     (setq row_data (car dim_data))
     (setq row (1+ row))
     (vlax-put-property
xcel
"Item"
row
col
(vl-princ-to-string (cdr row_data))
)
     (setq dim_data (cdr dim_data))
     )

   (vlax-invoke-method
     abks
     'SaveAs
     "C:\\ImportDims.xls"
     -4143
     nil
     nil
     :vlax-false
     :vlax-false
     1
     2
     )

   (vlax-release-object xcel)
   (vlax-release-object asht)
   (vlax-release-object xshs)
   (vlax-release-object abks)
   (vlax-release-object xbks)
   (vlax-release-object aexc)
   (setq aexc nil)
   (gc)
   (gc)
   )
 (*error* nil)
 )
 (princ)
 )
(prompt "\n\t\t>>>\tType DX to execute\t<<<\n")
 (princ)

 

~'J'~

[Butch]

OK!

Ill give it a run and will get back to you :-)

Thanx in advance :-)

[Butch]

Fixo its working, but theres a little problem.

eg. the values in acad says 3,14m, when copied to excel it says 313.992

Its a little extra work in Excel no problem, but can the values be the same in Acad and in Excel?

Thanx :-)

[fixo]

Fixo its working, but theres a little problem.

eg. the values in acad says 3,14m, when copied to excel it says 313.992

Its a little extra work in Excel no problem, but can the values be the same in Acad and in Excel?

Thanx :-)

 

Can you appload this drawing here?

 

~'J'~

[Butch]

I saved as 2004 and 2007 .dwg file

 

p.s. I used the .lsp file

dim2007.dwg

dim2004.dwg

[fixo]

I saved as 2004 and 2007 .dwg file

 

p.s. I used the .lsp file

 

It's strange

This lisp works good on my end

I have Excel2003 on my machine installed

See attachment

Check Excel file - perhaps there are

some formulas into the cells was embedded

Another thought

Try to change this line:

(vl-princ-to-string (cdr row_data))

on:

(rtos (cdr row_data) 2 2)

 

~'J'~

[Butch]

Now I get dates!

for egsample value of 3,14, I get marz.14

2,55 --> Feb.55

 

:-(

[fixo]

Now I get dates!

for egsample value of 3,14, I get marz.14

2,55 --> Feb.55

 

:-(

 

Aha, problem is in the NumberFormat properties

Change on this piece of code

 

   [color=blue](vlax-put-property xcel  "NumberFormat"
     (vlax-make-variant "0.00" ;<--"0.00" change on what you need (see patterns in Excel-Format cell)
     )[/color]
   
   (repeat (length dim_data)
     (setq row_data (car dim_data))
     (setq row (1+ row))
     (vlax-put-property
xcel
"Item"
row
col
(vl-princ-to-string (cdr row_data))
)
     (setq dim_data (cdr dim_data))
     )

   (vlax-invoke-method
     abks
     'SaveAs etc. etc.

 

~'J'~

[jalucerol]

Great work! I have a similar problem with vba and Text... I have found the solution for my problem here.

[fixo]

Great work! I have a similar problem with vba and Text... I have found the solution for my problem here.

 

Glad if that helps

Cheers

 

~'J'~

[Butch]

Fixo, I dont understand :-(

Can you type the whole code please.

 

p.s. could this also be done on measuring closed polyline areas?

[fixo]

Fixo, I dont understand :-(

Can you type the whole code please.

 

p.s. could this also be done on measuring closed polyline areas?

 

here is complete code

(defun C:dx (/ *error* abks aexc asht col data dim_data elist en i row row_data ss tmp xbks xcel xshs)

(vl-load-com)
 
(defun *error*	(msg)
 (if
   (vl-position
     msg
     '("console break"
"Function cancelled"
"quit / exit abort"
)
     )
    (princ "Error!")
    (princ msg)
    )

 )
(if (setq ss (ssget (list (cons 0 "dimension"))))

 (progn
   (setq i -1)
   (repeat (sslength ss)
     (setq en	  (ssname ss (setq i (1+ i)))
    elist (entget en)
    tmp	  (cons (cdr (assoc 11 elist)) (cdr (assoc 42 elist)))
    data  (cons tmp data))
     )

   (setq dim_data (vl-sort data
		    (function (lambda (e1 e2) (< (caar e1) (caar e2))))))
   (alert "Close Excel File Only")
   (setq aexc (vlax-get-or-create-object "Excel.Application")
  xbks (vlax-get-property aexc "Workbooks")
  abks (vlax-invoke-method xbks "Add")
  xshs (vlax-get-property abks "Sheets")
  asht (vlax-get-property xshs "Item" 1)
  xcel (vlax-get-property asht "Cells")
  )
   (vla-put-visible aexc :vlax-true)
   (vlax-put-property aexc "UseSystemSeparators" :vlax-false) 
   (vlax-put-property aexc "DecimalSeparator" (vlax-make-variant "." )
   (setq row 0
  col 1)
   ;;added:
   [color=red](vlax-put-property xcel  "NumberFormat"
     (vlax-make-variant "0.00" 
     )[/color]
   
   (repeat (length dim_data)
     (setq row_data (car dim_data))
     (setq row (1+ row))
     (vlax-put-property
xcel
"Item"
row
col
(vl-princ-to-string (cdr row_data))
)
     (setq dim_data (cdr dim_data))
     )

   (vlax-invoke-method
     abks
     'SaveAs
     "C:\\ImportDims.xls"
     -4143
     nil
     nil
     :vlax-false
     :vlax-false
     1
     2
     )

   (vlax-release-object xcel)
   (vlax-release-object asht)
   (vlax-release-object xshs)
   (vlax-release-object abks)
   (vlax-release-object xbks)
   (vlax-release-object aexc)
   (setq aexc nil)
   (gc)
   (gc)
   )
 (*error* nil)
 )
 (princ)
 )
(prompt "\n\t\t>>>\tType DX to execute\t<<<\n")
 (princ)

 

about measuring of closed polyline areas this will not work

there is need to write another routine

Not clearly enough for me what do mean

Start a new thread please and attach the sample drawing

for testing

 

~'J'~

[Butch]

I doesnt work here :-(

I have Auticad 2007 and Excel 2003.

I attached the .dwg file and excel file.

Only the first value is correct :-(

a1.dwg

[fixo]

I doesnt work here :-(

I have Auticad 2007 and Excel 2003.

I attached the .dwg file and excel file.

Only the first value is correct :-(

 

This worked just fine for me with your drawing too

I can't help you with this problem

Perhaps case is on Excel

 

~'J'~

[mdbdesign]

Oleg, can dimension data be extracted to excel in fraction format???

[Butch]

Veyr frustrating :-(

Fixo, when you activeate the dx.lsp then select dimesnions and hit enetr do you get an message "close Excel file only"?

I hit OK then and Excel opens.

Does this happens also to you?

Can you write in Excel numer 10000 and number pi (3,14) decimal comma is used.

If I write 3.14 with decimal point in Excel I egt year dates! In this case marz.14

There must be something wrong with this marks! , and .