Програмиране в ACAD / Компютри и Интернет / CAD/CAM

Private Sub cmdStart_Click()
Dim Excel As Object
Dim elem As Object
Dim excelSheet As Object
Dim Array1 As Variant
Dim Count, RowNum As Integer
Dim NumberOfAttributes As Integer

' Start Excel
On Error Resume Next

Set Excel = GetObject(, "Excel.Application")

If Err <> 0 Then
Err.Clear
Set Excel = CreateObject("Excel.Application")

If Err <> 0 Then
MsgBox "Could not load Excel.", vbExclamation
End
End If
End If

On Error GoTo 0

Excel.Visible = True
Excel.Workbooks.Add
Excel.Sheets("Sheet1").Select
Set excelSheet = Excel.ActiveWorkbook.Sheets("Sheet1")

RowNum = 1
Dim Header As Boolean
For Each elem In ThisDrawing.ModelSpace
If StrComp(elem.EntityName, "AcDbPolyline", 1) = 0 Then
RowNum = RowNum + 1
excelSheet.Cells(RowNum, Count + 1).Value = elem.Length

End If
Next elem

NumberOfAttributes = RowNum - 1

If NumberOfAttributes > 0 Then
excelSheet.Range(Cells(1, 1), Cells(1, 100)).Font.Bold = True

'For a specific set of attribute information this could
'be set to fit the exact number of columns.
excelSheet.Columns("A:G").AutoFit
'Rename the worksheet
Sheets("Sheet1").Name = "Attributes"
If Chart.Value = True Then
CreateChart (NumberOfAttributes)
End If
If Memo.Value = True Then
MakeMemos
End If
Else
MsgBox "No attributes found in the current drawing.", vbInformation
Excel.Quit
End If

Unload Me
End Sub

Вижда ми се прекалино сложно да вадиш дължините в Excel, да ги сумираш там и да ги връщаш отново в ACAD с Copy/Paste. Предлагам ти програмка, която изчислява дължините на линии, полилинии, сплайнове и дъги (предварително избрани) и прави МТЕХТ с описани по редове дължините на всички отделни групи примитиви, броя им и общата дължина.
Запиши я като *.LSP файл, зареди я с Tools/Load Application
(sp-long-type)

;сумира дължините на избрани елементи и ги описва
(defun SUM-LONG (/ i sp nab en VL-EN type-en )
(IF (SETQ
I 0
SP NIL
NAB (SSGET)
)
(PROGN
(VL-LOAD-COM)
(REPEAT (SSLENGTH NAB)
(SETQ EN (SSNAME NAB I)
I(1+ I)
VL-EN(vlax-ename->vla-object EN)
type-en (cdr(ASSOC 0 (entget en)))
);SETQ
(IF
(or
(= "LINE" type-en)
(= "LWPOLYLINE" type-en)
(= "ARC" type-en)
(= "SPLINE" type-en)

);or
(SETQ
LONG(vlax-curve-getDistAtParam VL-EN(vlax-curve-getEndParam VL-EN))
SP (APPEND SP (LIST (CONS EN LONG)))
);setq
);if LINE LWPOLYLINE ARC
);REPEAT
);PROGN
);IF NAB
sp
);SUM-LONG
;вади списък на дължините по тип на обекта от набора
(defun sp-long-type ( / sp sp-obj nn obj obj-line )
(if (setq sp (SUM-LONG))
(PROGN
(setq sp-obj nil)
(FOREACH nn sp
(setq obj (cdr(ASSOC 0 (entget (car nn)))))
(if (not (ASSOC obj sp-obj))
(setq sp-obj (APPEND sp-obj (list (list obj 0 0))))
);if
);FOREACH
(FOREACH nn sp
(setq obj (cdr(ASSOC 0 (entget (car nn))))
obj-line (ASSOC obj sp-obj)
obj-line (list (car obj-line)
(+ (nth 1 obj-line)(cdr nn))
(1+ (nth 2 obj-line)))
sp-obj (SUBST obj-line (ASSOC obj sp-obj)sp-obj)
);setq
);FOREACH
);PROGN
);if sp
(if (setq pti (getpoint "\nStart point of text: "))
(text-create sp-obj pti)
);if pti
sp-obj
);sp-long-type
;изписва текст със име, дължина и брой
(defun text-create (sp pti / txt nn all-long all-num )
(if (and sp
pti
);and
(PROGN
(setq txt "" all-long 0.0 all-num 0)
(FOREACH nn sp
(setq txt (strcat txt
(substr(strcat (nth 0 nn) " ")1 20)
(substr(strcat (rtos (nth 1 nn)2 2)" ") 1 10)
(substr(strcat (rtos (nth 2 nn)2 0)" ") 1 10)
"\\P")
all-long (+ all-long (nth 1 nn))
all-num (+ all-num (nth 2 nn)))
);FOREACH
(setq txt (strcat txt(substr(strcat " ОБЩО" " ")1 20)
(substr(strcat(rtos all-long 2 2)" ") 1 10)
(substr(strcat(rtos all-num 2 0)" ") 1 10)))
(COMMAND "mtext" pti (MAPCAR '+ pti (list (* (getvar "textsize")40.0) 10)) txt "")
);PROGN
);if sp
);text-create

Нарочно съм отделил функциите, защото на базата на тях може да се направят и други програми (например да се вадят дължините по слоеве, цвят и т.п.)