[已答复] excel如何得到线的长度?

在EXCEL VBA编辑器的“工具”菜单中点“引用”，在“引用”对话框中找到ACAD类库，勾选它，确定。见图
! m+ E5 ^# Q2 ^: `' u4、在EXCEL VBA编辑器Sheet1对象代码窗口写如下代码- U7 X+ H8 u; V- w" C
Sub A()
2 {0 V% W: d6 K$ H: n  [" [5 h. S* q' p2 f+ Y7 r
Dim CAD As AcadApplication '声明一个AutoCAD应用程序对象
9 R& a; X0 R& Q1 y! bDim DOC As AcadDocument '声明AutoCAD文档对象# D* O. B2 l  |: s
Set CAD = New AcadApplication '运行一个新的AutoCAD进程
! e5 N: Z  Z  b6 X& yCAD.Visible = True '使运行的AutoCAD程序可见。如果没有这行，程序将不可见，就是说看不见CAD窗口，只能在Windows任务管理器看到有CAD程序运行- k  R' j1 {' E2 l! u
Set DOC = CAD.Documents.Open(Sheet1.Cells(1, 1).Value) '按照“Sheet1”工作表第一行第一列单元格的内容打开文件  z8 e7 _* h$ q* [* K
DOC.SendCommand Sheet1.Cells(1, 2).Value '按“Sheet1”工作表第一行第二列单元格的内容向CAD命令行发送命令: V- O0 \; A/ x& |  M$ v
sub

;;;=================================================================*4 f4 a( B1 q; y/ b% U0 R& `4 x4 L8 @
;;;功能：测量线的长度 *+ |2 @: ]$ f6 ]( v9 U
;;;日期：zml84 于 2009-05-21 17:45 *
0 u& e! r+ }* r+ s0 e(defun C:cd ()- ~' [( g& ^4 G! U1 y
(princ "统计线段长度"
$ U* d# T+ i& D5 d(if (setq SS (ssget '((0 . "LINE,ARC,CIRCLE,ELLIPSE,*POLYLINE,SPLINE"))" k4 S5 w. [* e
); S+ q% H! E# f3 {: i; b
)1 G& L7 @) b' e; T, t
(progn2 P% x9 b) l  H/ e9 {& G
;;8 ?9 r3 o- e* K( c4 G, F
(setq LST_LEN '()/ E" b6 Z% P; k( E  ^! `
I 0, ?) o+ o, x9 k& u7 l$ l
)* k" P# L8 S4 z, x  A7 p
;;逐个统计3 W) p+ S* D3 Z% |
(repeat (sslength SS)
1 w# f! S' S1 p" D2 w1 Y(setq EN (ssname SS I)( i- _5 q' S; Q  C+ [$ v
LEN (vlax-curve-getdistatparam
- ~2 _2 {4 D# u/ fEN2 i* v5 d# ~- E: a1 }1 n+ B) r
(vlax-curve-getendparam EN)
+ E  h/ U/ J( n8 b)
+ r1 H" @  c& ~6 t. d4 \4 ~/ |; _LST_LEN (cons LEN LST_LEN)
  M6 T" I5 a4 uI (1+ I)2 O' C8 @. c/ n4 y6 |  n6 B
)4 ?4 r# s8 ~7 k9 L
) ; w. r/ f0 }8 o4 P
(setq LST_LEN (reverse LST_LEN)); e9 ?$ K4 T( c5 t$ O/ ^
;;显示输出
3 z; M, G0 W) I1 m$ l" V  v) T(princ "\n找到个数：")- K- S( Z# K2 q( M, |- t: k
(princ (sslength SS)), C1 R5 P# w1 \2 I) Z: }) I  N& D
(princ "\n单个长度：")
0 D  l1 _- B/ B0 D! D; U$ @9 t) U(princ LST_LEN)% N4 G- ^# I5 t* a$ ?4 ~4 p8 @4 a
(princ "\n总计长度：")
4 A9 m$ E: e- t0 O(princ (apply '+ LST_LEN))
/ \, B0 i% Y, G; I)) ]5 K3 G# r9 F2 q; F
)
5 {4 h$ U) n! f( }2 C: J% q(princ)
9 V% b" @1 m( H/ d% [). x1 U; }. K8 |
;;;=================================================================*
; o, B  }% c$ a) X  F. x;;;(alert
3 l5 B4 j8 l# y8 l;;; "功能：统计线段长度\n命令：\"CD\"\n日期：zml84 于 2009-05-21 17:45"! [1 h+ H4 O) ?: r
;;;): p* H6 J& g- t7 }
(princ)

’使用 VBA IDE 中的“工具” “引用”菜单选项，选择 Microsoft Excel 9.0 对象模型+ ?, \# g9 L( t# p9 |
’水平不高，有点罗嗦，楼主可以精简下" U  X" `7 I% \; p( ~' r
’欢迎以后交流，QQ 421230432 r6 l9 z/ q' H& g! X# Z
Public Sub 取坐标()) I3 K5 v: q' f
’把AutoCAD中某一图层“多段线层”中的所有多段线的坐标列出来
# G: K% D7 c: G% jDim PLSet As AcadSelectionSet
3 E- R, `% D* Z( G/ CDim pl As AcadLWPolyline6 ?$ S0 l2 X$ U. z' e- q

! l) d, F( R9 A" Z: `0 e: c9 S5 s, M- z! H( V8 |
Dim ExcelApp As Excel.Application# c7 S# l! D! ]
Dim ExcelSheet As Object; e: b  \8 H- K! E
Dim ExcelWorkbook As Object
+ |7 u5 p( u4 m$ o! v" P! H* n  [7 b$ V+ ]

- R/ v, i: D  x7 b% C4 F1 MDim pts As Variant
: K4 g9 q8 [- W% _' F- ?' C5 W! R- i/ n9 F. t2 m6 J& C3 ]
Dim NN As Integer1 w# e: P7 M7 Y
Dim j As Integer
/ P# B# g% c3 W9 }, e8 h$ l! o- z0 ^2 {8 n, T  W/ c
Dim pn As Integer5 e* N, o3 l3 ?
/ Z' k1 k& {! U+ ^
Dim px(0 To 10000) As Double
3 k0 {, {& ~. c" ~* GDim py(0 To 10000) As Double) ]% }+ Y. s+ G; ?
Dim pz(0 To 10000) As Double. U: O6 e5 d3 R

/ m6 Y, C# p& V( }6 V! |3 T& Q
' a/ M% ~$ g! P5 {9 u$ ODim filtertype(10) As Integer
' l" K- I, K5 rDim filterdata(1) As Variant
  c$ _0 l  Q- i- {/ ]% j+ ]( G
4 t5 Y/ y+ w- ~' R9 h, s5 Ofiltertype(0) = 0 ’ 选择线型
" E3 `' |( Z, T' I+ [filterdata(0) = "LWPOLYLINE"
! k. t7 s* c& d, X7 p/ V! Dfiltertype(1) = 8 ’ 图层标识，可以根据具体情况改动) B/ a; a0 q5 T6 ~( }' E% f8 Q
filterdata(1) = "多段线层"8 V8 ?7 N# a- i) U, g

, }6 O( {. U: a' O# e  J* o5 ~% v/ B* I7 o
4 n8 y. o$ S/ D5 k% j& I) l
Set PLSet = ThisDrawing.SelectionSets.Add("pl")& A4 M: |, u  h) I' U, U
PLSet.SelectOnScreen filtertype, filterdata
" B: e. c; {8 n; n7 X* V
+ ]; e/ P3 R! y# v4 L. }" xNN = 0$ X* c* W# y" z: [
j = 0
. j/ q4 e" s+ |4 x% Q; \' RFor Each pl In PLSet4 |( u; d6 T( R, i/ z

- P2 Z" P! O0 m0 L3 Zpts = pl.Coordinates
9 r5 r' v8 z& xpn = (UBound(pts) + 1) / 2
5 g4 P+ _3 V1 y6 `3 ?/ o/ J3 Q8 m5 G9 E; B0 i5 ^
For i = 0 To pn - 1" O! S1 Q+ j8 U2 X
px(i + pn * j) = pts(2 * i)) l5 f* C( s, g- |- A2 d8 a  Q( A
py(i + pn * j) = pts(2 * i + 1)$ c, Q, o* o( Z
Next i7 h0 r5 e5 k- K; m% q
j = j + 1
2 |3 V  d9 l, v! Z8 H/ x4 N+ D! [( X0 kNN = NN + pn+ N- d/ s4 c# N& g, {
Next pl
2 n9 i  d6 L) h3 [% ?% Y: D4 @: R0 G" E6 v0 i. F
PLSet.Delete) u. F& f* P, W' a
' V, C/ i3 k" F2 ^+ ?) a
8 A0 W4 X  _, M
Set ExcelApp = New Excel.Application
1 B' [- m, m" ]( R1 |7 m: c4 e& k  Z6 }# @
Set ExcelWorkbook = ExcelApp.Workbooks.Add
8 p& K  w; y9 r2 _3 Q; O: p
- J6 n$ ?/ ^: b& c: X, e, k* @$ x4 bSet ExcelSheet = ExcelApp.ActiveSheet7 A2 S4 W5 v, k! ]+ x3 R
+ X) ]/ j& {5 T; d$ K  v9 b, z0 @
ExcelWorkbook.SaveAs "c:\123.xls"5 E; _- t- N0 E

. a) P4 S% |2 @  I. dExcelSheet.Cells(1, 1) = "x"; K( |$ [2 s7 c0 U6 f4 l
ExcelSheet.Cells(1, 2) = "y"
+ m3 }. k* q; T& j' }! y
- D9 \- T4 Z' c5 H! D. }+ PFor i = 0 To NN - 1  y& b* E& x8 K+ |5 i3 a
ExcelSheet.Cells(i + 2, 1) = px(i)7 O2 {9 ~/ y7 N- Q0 \* M- X
ExcelSheet.Cells(i + 2, 2) = py(i)
! q. ]8 {8 L- t% fNext i1 A1 I3 {8 B3 U3 v$ I

. z# ~; t- P, t5 u. V/ F. {6 b3 T0 ZEnd Sub

Function FixDimMeas(Dimension As AcadDimension) As Long
8 r% ~9 g1 X! D4 w  E6 O) [5 ~Dim BlockCount As Long6 j+ z0 t! y, _" G0 A7 @
Dim bz As Long
# g) R) X  {& e' m) P7 J9 @$ @6 L
BlockCount = ThisDrawing.Blocks.Count
1 J) v+ O* T  V8 I, i) y. ~6 D% J'遍历块中的对象，取得标注尺寸
1 d& E( B7 o" P4 U$ s; XDim EntityInBlock As AcadEntity
& {9 X' u1 o$ @$ D; p( dFor Each EntityInBlock In ThisDrawing.Blocks(BlockCount - 1)
) o1 X  S( ?0 P# T; EIf EntityInBlock.ObjectName = "AcDbMText" Then8 x3 A4 Y: v0 U  M
bz = Dimension.Measurement
) |2 N0 q7 Q# zFixDimMeas = bz '取得标注尺寸0 n& i" j: t/ |3 `+ a1 W8 k
Exit For
& W& O( [- W9 u' U" QEnd If" o# k" p1 r3 i( Q- `  s1 [7 C# P
Next7 T; a8 T6 N6 j% H. ?5 O# \
End Function

选择CAD线条 EXCEL记录长度 , q( [( O# i" l2 B9 ~/ y0 P, S: {; s
选择“工具”\“引用”项，在弹出的“引用”对话框的“可使用的引用”列表框内，选择“Microsoft Excel 8.0 Object Library"项+ ?* Z$ z4 z; n: @' L7 U+ [" c

8 i  v' z7 O& {( E& O, Z'计算两点之间距离3 ?# U6 ^5 z7 m6 o! H7 r
Public Function GetDistance(ptSt As Variant, ptEn As Variant) As Double
: a- ]) A4 y) n0 y( @! b* _0 A    Dim x As Double" Q) z- V$ ~; h: V
    Dim y As Double9 u9 J$ @& y$ ?9 x1 a0 {' E
    Dim z As Double) {/ x) k* Y9 V) Q- [8 H5 y
    x = ptSt(0) - ptEn(0)
6 U9 k6 D0 v5 P9 w, a    y = ptSt(1) - ptEn(1)' R6 y) V/ [- m7 q$ T9 j7 y
    z = ptSt(2) - ptEn(2): p2 e, i$ t" Y# l8 B6 b
    GetDistance = Sqr((Sqr((x ^ 2) + (y ^ 2)) ^ 2) + (z ^ 2))& _6 J% }$ h% Q9 `
End Function
: l7 e- a) y; n. @; R5 } 4 k9 I" x0 X) o% D
Private Sub xz()5 G. n& F6 o' f) Q
'创建选择集. W* P8 T( z7 s
For JJ = 1 To 10
# ~( _) A& m! T& A3 n5 Y If MsgBox("是否继续选择", vbYesNo) = vbNo Then
+ q% u9 c# [; I' h  N( q- N Exit For- n! P) H0 M1 @, ]0 q
Else
% C; G1 T& }1 {; t    On Error Resume Next
( S7 e' l. R+ Z    Set myyactiveDoc = ActiveDocument
8 {2 T7 V, Z; X# [& V* m: M8 O8 k" L5 ^+ ]  I
    Dim SSet As AcadSelectionSet# n5 ]7 b6 o; t
      Set SSet = myyactiveDoc.SelectionSets.Add("Ehlxz")) w) F, s  z: R3 e% c# k/ {
    If Not IsNull(myyactiveDoc.SelectionSets.Item("Ehlxz")) Then/ g/ X9 b, N1 l8 d7 [8 A
        Set SSet = myyactiveDoc.SelectionSets.Item("Ehlxz")
& A% O- M4 ~$ ~! F% }5 j9 r        SSet.Delete     '及时删除不用的选择集非常重要( f1 K/ U# C' y- _* `
    End If4 q9 g9 B+ {8 t$ P. J
   Set SSet = myyactiveDoc.SelectionSets.Add("Ehlxz")
" w0 p$ [: D8 O# J8 m+ C    SSet.SelectOnScreen, A( ]* D' t# `, s: c
    '创建点组
* C7 I% V' p+ v4 [9 g4 D0 L5 h    Dim ptArr1() As Variant! \1 A8 `  U( S7 d
    Dim ptArr2() As Variant9 d2 W3 I: d% r/ ?5 V$ A2 k: @
    Dim count As Integer* l4 t' p4 g% u' N7 d3 u, N7 D8 H
    count = SSet.count
4 j) \( H: L3 a' |  {( y9 K    ReDim ptArr1(count - 1)
) P5 j2 K3 [2 t" C    ReDim ptArr2(count - 1)* c" g; ]' h$ O* p, @% M6 {9 r4 P
    '错误判断: k  C: v( s+ p
    If count = 0 Then& \% H9 P* u% O; N! r
        MsgBox "未选择任何对象！", vbCritical3 h2 ^8 W- s( C" ^( x
        Exit Sub
, k4 i/ o$ L5 w. Z    End If
4 S* G! M0 d  q9 ~5 w) D& o3 M5 E" g# u" t" ^' K
    '获得最左侧和下侧的角点
& ]+ ~! f8 b, o* F$ U    Dim objEnt As AcadEntity' w4 j1 |; S' b' `
    Dim ptTemp As Variant
! o! b" q2 j$ r- a% B    Dim i As Integer
. H, ~7 Q2 c' ~4 y* y    i = 0
* i( z) `- [, q6 s6 w  T* A    For Each objEnt In SSet2 _* I+ g+ w5 t6 g
        objEnt.GetBoundingBox ptArr1(i), ptTemp
) @- ?* N. q" E4 C$ R' n9 A        i = i + 1) r7 f  g/ ?8 x6 F6 D1 L& O, I4 M
    Next
- w/ C4 Y+ A% r9 ?6 Y$ y    '获得最上侧和右侧的角点
- l! g9 b' H% Y& `    i = 0
5 |+ l8 C* Y. Z# e6 E) G    For Each objEnt In SSet
/ L8 p1 o) q! C+ j) `, ]' {% E9 t        objEnt.GetBoundingBox ptTemp, ptArr2(i)3 W  ^, ~/ U7 C; E
        i = i + 1
" U. d7 H) H+ K; ]  d; W- D    Next7 b! N/ K8 R0 s
    Dim ptLeftX, ptLeftY, ptRightX, ptRightY
& v0 f+ s, A- J+ Z) _+ i    Dim ptRight, ptTop
* Y/ `* |* y+ Y  s3 M- s& N   For WWW = 1 To count
' K3 |. ~' `& `6 K      ptLeftX = ptArr1(WWW - 1)(0)% m3 v- I, O, Y- F" q
      ptLeftY = ptArr2(WWW - 1)(1)7 j* o: p5 I2 T' c- K+ E" ]
      ptRightX = ptArr2(WWW - 1)(0)! Y& y+ i# I3 R- w
      ptRightY = ptArr1(WWW - 1)(1)1 Q. G) |( i1 i

3 Z6 _( T3 k! ?0 l& B" y    Dim pppt1(0 To 2) As Double
% x7 F- ]& o! J# N- w. K/ B& H    Dim pppt2(0 To 2) As Double
( @- e( C$ H2 F: {0 T# q        pppt1(2) = 0, D0 d% f2 D% r) h5 C, n0 `+ t
        pppt2(2) = 0
4 o. }6 `6 L, x    Dim gzkuan As Double, gzgao As Double8 b" ]+ r( V3 H+ ?# a: r/ u; p
     gzkuan = (ptRightX - ptLeftX - 25 * (Int(Val(HjigeCb.Text)) - 1)) / Int(Val(HjigeCb.Text))' ]% {& L  \! H: F5 Z/ }. d
     gzgao = (ptLeftY - ptRightY - 25 * (Int(Val(SjigeCb.Text)) - 1)) / Int(Val(SjigeCb.Text))
! ?( n" X1 T1 j& q7 ?    For j = 1 To Int(Val(HjigeCb.Text))
2 p2 g2 ^# t# j) z+ U" C      For k = 1 To Int(Val(SjigeCb.Text)): r9 r8 H: a9 Q
        pppt1(0) = ptLeftX + (gzkuan + 25) * (j - 1)/ z- u9 B2 v& |) A8 w5 ~
         pppt1(1) = ptLeftY - (gzgao + 25) * (k - 1)
# \6 r* e# r" f% N0 ?) m& d         pppt2(0) = pppt1(0) + gzkuan. g6 ^& y, W8 @3 D" K; U9 X
         pppt2(1) = pppt1(1) - gzgao
0 j0 t( K, \! P4 O( R! B, Y* l5 M# n; E" h7 P4 J. i
      Next
9 J3 b, M$ ?# _- ]/ o    Next
# C$ z- \2 l4 e% ~) [$ G8 ~         pppt1(0) = ptLeftX4 J4 x" U6 N% b! W1 K
         pppt1(1) = ptLeftY$ ]0 ~' D2 k' K+ D# e5 F
         pppt2(0) = ptRightX# ^" Y4 s# K' e: n3 m- r
         pppt2(1) = ptRightY
6 D3 x" K6 n( h, h. z  Next* Y1 c8 h9 X+ a" p. s2 e1 S
    SSet.Delete
6 u7 O' d4 `% i3 `4 ?) C- f    KK = GetDistance(pppt1, pppt2)& X- y- a% d8 N/ o5 T
'在程序中操作EXCEL表常用命令:
( M9 b/ v/ \; ]- e) m# q) r  Dim Excel As Excel.Application* H" x7 s# i! ^5 F+ |; ]& `; T3 M
    Dim ExcelSheet   As Object
. @4 [' R- f1 @' a$ O* B    Dim ExcelWorkbook   As Object, n* g; F8 g) C- Y
    '创建Excel应用程序实例
# w! v9 N$ S7 r) Y    On Error Resume Next: j) j1 h2 ^# s5 V1 K( f
    Set Excel = GetObject(, "Excel.Application")& `7 K5 T' h4 o( \8 q' r& m
    If Err <> 0 Then* V: |! r$ G4 [6 M* D, w
        Set Excel = CreateObject("Excel.Application"); V# S- v0 U" G$ U! d4 h) G$ W
           '创建一个新工作簿$ O  x9 [' H. ?0 m" d
         Set ExcelWorkbook = Excel.Workbooks.Add
3 o/ |7 x& ?) h          '令Excel应用程序可见  U4 o, k8 U% A  K! h, d# a: N0 s
           Excel.Visible = True
8 b( ~0 L' J+ {          '将新创建的工作簿保存为Excel文件
" Q' v' g7 U" W/ Y/ D             ExcelWorkbook.SaveAs "属性表.xls"
1 ^$ a" ~2 `* I! O" M2 x* x  I    End If
' t4 D& C8 `, u2 s    '确保Sheet1工作表为当前工作表
  f# ~2 T4 e! ?3 R    Set ExcelSheet = Excel.ActiveSheet
* f' E& x) ~; Y2 p4 J% [2 y    Excel.Visible = True
1 Y$ }$ ^1 t5 C4 o    endrow = ExcelSheet.Range("A65536").End(xlUp).Row + 1: k0 O9 r: [( f
    ExcelSheet.Range("A" & endrow) = KK
# N; b4 H) C' c    Set Excel = Nothing
$ W4 |6 E0 I$ U  k4 X    End If& Z; a6 x9 E  W& f; c2 l
  Next' K" ~0 N# x4 E# s% V3 V' H
End Sub
- _5 N; o2 N6 b
& Q. x+ K! b6 T2 E7 E. z( }- O