[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]

Originally Posted by 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

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]

Originally Posted by Butch

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]

Originally Posted by 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 :-)

Can you appload this drawing here?

~'J'~

[Butch]

I saved as 2004 and 2007 .dwg file

p.s. I used the .lsp file

[fixo]

Originally Posted by Butch

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'~