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

在EXCEL VBA编辑器的“工具”菜单中点“引用”，在“引用”对话框中找到ACAD类库，勾选它，确定。见图& _8 W1 f  c" m9 }# ?
4、在EXCEL VBA编辑器Sheet1对象代码窗口写如下代码
% h1 m) s4 Q# H; a% USub A()+ ^- R" v/ ^" L2 I6 v3 B& ~

+ d' C- L" K0 m0 }2 l5 i* }Dim CAD As AcadApplication '声明一个AutoCAD应用程序对象
: i  E# M0 l; mDim DOC As AcadDocument '声明AutoCAD文档对象7 x, D/ X9 i; ~3 g) V( S
Set CAD = New AcadApplication '运行一个新的AutoCAD进程. S0 ]7 K( O7 i. A% A; }. D) d
CAD.Visible = True '使运行的AutoCAD程序可见。如果没有这行，程序将不可见，就是说看不见CAD窗口，只能在Windows任务管理器看到有CAD程序运行2 L4 R; V0 r7 M3 @, a. z  n
Set DOC = CAD.Documents.Open(Sheet1.Cells(1, 1).Value) '按照“Sheet1”工作表第一行第一列单元格的内容打开文件
( E9 \  T3 a" a7 }DOC.SendCommand Sheet1.Cells(1, 2).Value '按“Sheet1”工作表第一行第二列单元格的内容向CAD命令行发送命令
. Z% r. N9 a; Vsub

;;;=================================================================*7 Q: R5 C6 b5 M( C
;;;功能：测量线的长度 *
& D- m" t9 ^8 T2 b;;;日期：zml84 于 2009-05-21 17:45 *
! |* H* o/ h5 ~. }$ A* q5 K9 H+ S(defun C:cd ()
8 F/ e2 U4 a) `( H(princ "统计线段长度"
8 `' N- r8 V7 S9 h(if (setq SS (ssget '((0 . "LINE,ARC,CIRCLE,ELLIPSE,*POLYLINE,SPLINE"))! c1 {2 t% ?9 Z5 Z; ^" h% Z
)) I/ X2 D; N  D4 _# m- _( }: ]
)
6 _: C) v+ T6 N* w$ E; |/ F(progn
- Z6 {; _9 t9 R: R3 w% Q: e;;- X; x1 _- Z4 z" w4 l
(setq LST_LEN '()/ x3 k' r2 f1 {3 c& b7 _( T0 v: v
I 0% y+ N8 F. ~# U" m
)' D+ g+ B' R$ _4 _  s2 P' j
;;逐个统计  T* d' N' f3 A. t9 t
(repeat (sslength SS): s% U3 K- D0 F) s2 t  H. a# ^. _9 H" O
(setq EN (ssname SS I)6 }, t' m; U! V+ K- Q
LEN (vlax-curve-getdistatparam
; J5 B: _5 R$ g' r$ _EN
9 g7 w0 `* D+ Y9 O! T6 s# t(vlax-curve-getendparam EN)& m  N9 p) R- ~9 `2 b# B
)3 b5 {7 H; Z- a: i
LST_LEN (cons LEN LST_LEN)
! s: c6 `" P  a$ h- E* pI (1+ I)# t% `# T* g* o8 U$ w+ b
)
8 u& z2 h% E$ m3 w- q* ]3 t)
0 r1 h6 a" l) p. j$ d(setq LST_LEN (reverse LST_LEN))# Y3 `1 m4 d1 U" y7 e! C
;;显示输出- ?- y7 \. M6 L$ H$ y3 b
(princ "\n找到个数：")
! o  {; k/ b( Z/ k; U+ l5 d, `2 M(princ (sslength SS))0 P" ?; C" V. q' H; Q1 P) l* F
(princ "\n单个长度：")0 k5 V0 D+ Q, N8 J" F0 D0 a5 T
(princ LST_LEN)
, {0 S+ T* |, {, k' Z(princ "\n总计长度：")/ N9 M4 I0 F! h
(princ (apply '+ LST_LEN))% B; C! x& f# C  Q# [3 b  n! x
)
6 U" z# ^8 p/ }, `( R# u! Y& W)" g6 @5 |1 \+ }. n
(princ)5 T! e$ A8 \0 k6 i# V
)4 r  m' F  C* @7 D
;;;=================================================================*
: G% I" f/ s% x) [& `% Q( `0 q;;;(alert  E/ t. H7 W" d1 T$ J+ S% P
;;; "功能：统计线段长度\n命令：\"CD\"\n日期：zml84 于 2009-05-21 17:45"1 \1 u0 ?# |! j+ q/ H3 K& c! s: Y5 ?
;;;)$ U  w" }5 q8 |5 ^2 e0 G
(princ)

’使用 VBA IDE 中的“工具” “引用”菜单选项，选择 Microsoft Excel 9.0 对象模型) X- y% l' n- C8 {) S1 D
’水平不高，有点罗嗦，楼主可以精简下5 k6 m5 J# u1 u/ N; [
’欢迎以后交流，QQ 421230439 L; T3 F$ W6 e' o2 S
Public Sub 取坐标()
2 i& C1 W" [2 `9 p, i2 E5 ?% e’把AutoCAD中某一图层“多段线层”中的所有多段线的坐标列出来% `+ c) k6 a7 n/ Q4 ~! P3 D) P/ D
Dim PLSet As AcadSelectionSet3 U- V% w7 v+ K7 r% v3 Z/ b
Dim pl As AcadLWPolyline" k! M% J# {( X( o9 G) f

% l5 b! m* y+ q3 ?$ u6 v  N" f) B
# [# _5 C. K) D/ Q, F) ]: G2 \" tDim ExcelApp As Excel.Application
0 R8 N- P9 d; @0 ~# p) m3 d! M  tDim ExcelSheet As Object7 B( y0 @. n9 ~: S0 R7 c
Dim ExcelWorkbook As Object
& S+ d7 {$ [- b4 Q5 B7 a; q3 L3 s2 E! z& N

, J3 A6 `& b- N) A) ^; `( wDim pts As Variant4 m8 w+ P3 m$ v4 O- `
. k2 e+ W( Q2 `
Dim NN As Integer
) i2 |. g3 i" F; lDim j As Integer
' p9 ]8 j$ D1 V3 ~5 g2 ~7 O
/ t0 {) H2 C) Q+ w. R2 sDim pn As Integer
( J/ P& J/ H+ }$ D/ X7 O& C: i7 @& |
Dim px(0 To 10000) As Double
* A, A- t, a( T3 Z; B; }7 @Dim py(0 To 10000) As Double& i& C6 p& \. M! d5 @5 \- n/ J
Dim pz(0 To 10000) As Double
- r6 I7 b8 V: t& v9 ]) X
: E. ^3 i( _4 b' I% w& f! S, k- m% o1 C+ ^' Y7 V- X9 l4 f
Dim filtertype(10) As Integer
7 I3 T0 `6 F' ^  u; _. I) GDim filterdata(1) As Variant
, K% t& H+ m8 `! L# W5 B# g$ v8 R
6 B7 k! L4 E+ F. q1 Ifiltertype(0) = 0 ’ 选择线型/ @, R  e9 G: a+ J% l( B
filterdata(0) = "LWPOLYLINE"
! t& s. y. W& R7 f9 v6 O  `filtertype(1) = 8 ’ 图层标识，可以根据具体情况改动
: ?3 [0 F* K, b2 K: Q" }filterdata(1) = "多段线层"2 H3 y8 d9 G8 R; D+ D7 A
0 m: U- D1 F& G

4 |# G& J7 i3 O5 W/ ]2 E$ i5 f! D# F; F; T* L; B
Set PLSet = ThisDrawing.SelectionSets.Add("pl")
9 A! E& B* v& g' yPLSet.SelectOnScreen filtertype, filterdata
  Q3 P" n1 V# y. b: i- X% o( N, n+ K' P; ?) \
NN = 0
  S7 L* ?3 j0 b+ Z) Y1 m, h2 x6 Jj = 0
7 q* W  Q+ |# M8 D5 KFor Each pl In PLSet+ _6 n  O) ^, Z) m. B
: a  J% P$ M. z6 Z4 {4 W2 v, `8 A
pts = pl.Coordinates
5 }' r$ |* _0 _! A0 opn = (UBound(pts) + 1) / 2
9 Q3 S% h  C" Z  s' H# s6 ~) Q- F1 r
For i = 0 To pn - 1
  K9 K% P* c, V! X! d& wpx(i + pn * j) = pts(2 * i)
! j/ V3 L! R# I9 l* C4 ~py(i + pn * j) = pts(2 * i + 1)/ q: w% t3 j' z2 R
Next i
8 s( X* N: O0 b! M2 _! Tj = j + 1
. u% a' k0 D0 U4 XNN = NN + pn: w+ j+ ^8 i; U" T. R% k! `9 }
Next pl
4 C/ ~# h! g% o  ^0 p7 B
/ w( {) P$ Y  F* ~3 H" P( MPLSet.Delete
/ B" c1 O4 v% E3 r4 G) l1 f
+ b) F2 b8 R$ D1 v' K. }0 d  b! N
Set ExcelApp = New Excel.Application0 Y& U  X6 X& [4 G
4 s) _+ D& z4 z' j- v2 H
Set ExcelWorkbook = ExcelApp.Workbooks.Add
" h$ @7 a7 @" G, J% m- v+ x9 }( w' K& |/ D# l
Set ExcelSheet = ExcelApp.ActiveSheet
3 \# D) a; Y1 b2 f8 e2 E
3 s. Q( ?. O* [% ]ExcelWorkbook.SaveAs "c:\123.xls"
* i% P8 w) Y7 e- j4 F
. W, s: T$ P8 S& q. ^* a3 aExcelSheet.Cells(1, 1) = "x". o  c* z+ A; v! b
ExcelSheet.Cells(1, 2) = "y"
: r! K- N: S5 Y5 B( A- N% b+ ]% ]2 F) U# }7 s9 c
For i = 0 To NN - 1
' K- l( h# K' j$ O: fExcelSheet.Cells(i + 2, 1) = px(i)$ {' x" R" h1 A; [! c" _$ s9 P0 a
ExcelSheet.Cells(i + 2, 2) = py(i)
! C1 f& H$ O# H! ^6 i& M+ w0 U$ xNext i
  a) g3 u) ^$ B& l" u# A: N9 y& g, G* s
End Sub

Function FixDimMeas(Dimension As AcadDimension) As Long
' Y3 Z5 k; Y6 X  ADim BlockCount As Long
0 T. E: y$ T! |5 a; u# `7 r9 R* xDim bz As Long
9 F$ n2 Q4 x' b3 J, m
+ ^9 M3 f0 V5 o4 }+ t+ |# S8 Q' M; K/ ?BlockCount = ThisDrawing.Blocks.Count
1 F2 @3 w+ c" W% |. V  G6 [% p'遍历块中的对象，取得标注尺寸$ ?1 _9 T! a+ K5 {) T- ?$ d
Dim EntityInBlock As AcadEntity2 c: n$ u2 \- p+ P5 o  i- [
For Each EntityInBlock In ThisDrawing.Blocks(BlockCount - 1)
  n0 n" X) B+ H' WIf EntityInBlock.ObjectName = "AcDbMText" Then
4 ~' }3 I7 _/ l- Cbz = Dimension.Measurement
  O0 U$ X# A# M3 ^) v: L- I6 QFixDimMeas = bz '取得标注尺寸
; @" n3 P. ~/ q& w* rExit For
- D! N! L1 f# t7 W* Z$ ~0 C; m; S7 BEnd If5 L* }6 m+ Y3 q- v" c' O
Next& v7 Q( H# d" A6 ]$ L" g
End Function

选择CAD线条 EXCEL记录长度
- \* f( {7 H2 O- y! T3 D选择“工具”\“引用”项，在弹出的“引用”对话框的“可使用的引用”列表框内，选择“Microsoft Excel 8.0 Object Library"项4 d* g$ n9 I! Z0 X  _) e

, I" b- r  ~" f' v  Q4 q5 E'计算两点之间距离% w) r' b  m: i! M/ Z4 K4 I
Public Function GetDistance(ptSt As Variant, ptEn As Variant) As Double
6 _6 I  [2 ]+ w& d    Dim x As Double7 i/ `$ J! ^, V0 d% B
    Dim y As Double: a6 C# j& x$ c9 Q- f  u: }. Q1 M4 Z
    Dim z As Double  |: V  O3 L; e) r  w5 F: |" j& M
    x = ptSt(0) - ptEn(0): h% ^0 S( D! D3 X$ Y) {
    y = ptSt(1) - ptEn(1)
# [# L% s$ c- T* W5 c    z = ptSt(2) - ptEn(2)
$ N! D8 I6 \2 J5 @) }    GetDistance = Sqr((Sqr((x ^ 2) + (y ^ 2)) ^ 2) + (z ^ 2))
8 h+ d  k9 L& Z( h% b" C( c2 PEnd Function
/ l& y, V" o- w3 X$ Q) D5 R
. P+ _: i& r. d2 gPrivate Sub xz()
+ o: {7 ~; R+ }/ X4 U# c% W4 \ '创建选择集* V, N5 L1 C" d: l
For JJ = 1 To 105 Z+ b1 }! A9 K7 [6 {
If MsgBox("是否继续选择", vbYesNo) = vbNo Then
" F2 d3 i# t. n* E' T% ?3 C. Z+ y Exit For
( u5 e. F' x2 |8 L1 A3 QElse& B. w3 T# T1 S3 t
    On Error Resume Next
# \( D; I, b* @( y6 ?8 w  R    Set myyactiveDoc = ActiveDocument; _; y4 T# a& ]" l
: v2 R* D; X9 X6 Z( R1 X
    Dim SSet As AcadSelectionSet
# \" R- A. K1 e; w+ j      Set SSet = myyactiveDoc.SelectionSets.Add("Ehlxz")( G$ V! A  O8 _# _
    If Not IsNull(myyactiveDoc.SelectionSets.Item("Ehlxz")) Then2 Y, g. p- O+ }4 D6 R+ w
        Set SSet = myyactiveDoc.SelectionSets.Item("Ehlxz")$ d3 x' e  ?/ W3 n6 L2 B/ K
        SSet.Delete     '及时删除不用的选择集非常重要, I( M* ?) Z$ c2 z- A9 l6 R
    End If
. C# a4 v' I, k- F1 R) o   Set SSet = myyactiveDoc.SelectionSets.Add("Ehlxz")
2 e' B/ J- C3 u* d    SSet.SelectOnScreen
  b* Y8 T3 J8 Y- B7 o, O2 Z    '创建点组4 U- R# G9 y0 J  i
    Dim ptArr1() As Variant0 J" D" k! P9 a1 A
    Dim ptArr2() As Variant8 Q+ ^0 l2 q) ~5 x7 P* D! e, k& i
    Dim count As Integer) }' l5 q# V0 Y9 l! z9 H1 h
    count = SSet.count
# S3 f. H  `2 W, O. F2 H: K, n: K    ReDim ptArr1(count - 1)- t- ~( u/ i/ |  ^+ z7 M, K* c
    ReDim ptArr2(count - 1). F; x8 X0 `" f. H# }
    '错误判断
$ Z* F( H- ]* c! V, g    If count = 0 Then! b6 k8 V* t: z! W" m# X% Z9 R% y
        MsgBox "未选择任何对象！", vbCritical
: E& T) n) t' G7 W: ?3 z        Exit Sub
  `! i' d+ H3 n0 t    End If0 y' l0 d# U( g) F+ }

) R* f1 v3 \8 M: y# H    '获得最左侧和下侧的角点
# r' M, v8 `/ u$ E! C2 q    Dim objEnt As AcadEntity
4 {6 `( L' }& V4 D( d0 u    Dim ptTemp As Variant
9 p5 C" n* G  _: y    Dim i As Integer
0 K: s  x' @1 F; J0 k6 I/ I    i = 0- z1 Y6 X. F3 G. d6 H: {
    For Each objEnt In SSet9 m0 `2 N9 B( B
        objEnt.GetBoundingBox ptArr1(i), ptTemp. Z' i2 s( n* v5 i/ y0 n
        i = i + 14 f! E' [; R7 M0 G7 S. R
    Next
7 F: p9 p" n" N3 M    '获得最上侧和右侧的角点! J/ y5 U" k6 _# Z. Y, c
    i = 0
+ s4 T6 W/ ~% r    For Each objEnt In SSet! |# c5 v; t. g5 T9 _6 p: s
        objEnt.GetBoundingBox ptTemp, ptArr2(i)
, c5 a8 ~( L  K) S3 y        i = i + 1- ^( `; E! C  z0 L2 I+ i
    Next/ g; y1 H5 r# S# |+ @
    Dim ptLeftX, ptLeftY, ptRightX, ptRightY
  m/ |1 q* S) ~, N; h: [) s# D    Dim ptRight, ptTop2 `+ I/ g' v1 _7 Z" d- E
   For WWW = 1 To count
8 T6 ?  ~# n9 t) K      ptLeftX = ptArr1(WWW - 1)(0)4 B2 o5 x; b* p/ ~$ b5 N
      ptLeftY = ptArr2(WWW - 1)(1)
6 Z/ i) f+ K& t# t4 d      ptRightX = ptArr2(WWW - 1)(0)6 q* i6 g* X! k0 p
      ptRightY = ptArr1(WWW - 1)(1)
9 F( h' u/ q  C: n. C% i7 h! ]/ P  n
/ J* X* G, H; p$ P4 P6 z    Dim pppt1(0 To 2) As Double+ R- e# D+ e' O, Y. F
    Dim pppt2(0 To 2) As Double+ T/ O1 n0 q4 C5 Z. D0 E' f
        pppt1(2) = 08 ?9 n3 B3 `9 b* L* C
        pppt2(2) = 0% r8 \, r6 u$ i: c' F# L
    Dim gzkuan As Double, gzgao As Double
  Y6 @1 x7 `+ ~: y9 q     gzkuan = (ptRightX - ptLeftX - 25 * (Int(Val(HjigeCb.Text)) - 1)) / Int(Val(HjigeCb.Text))
/ B/ w5 k0 f0 o5 b7 o     gzgao = (ptLeftY - ptRightY - 25 * (Int(Val(SjigeCb.Text)) - 1)) / Int(Val(SjigeCb.Text)), i2 b  T- }- H1 A4 V) [  c
    For j = 1 To Int(Val(HjigeCb.Text))5 H! o! |4 ]" p+ w
      For k = 1 To Int(Val(SjigeCb.Text))& I% T: |  Q7 c/ g# F7 U, k
        pppt1(0) = ptLeftX + (gzkuan + 25) * (j - 1)
% M9 ~2 z6 S5 D         pppt1(1) = ptLeftY - (gzgao + 25) * (k - 1): _- F0 K& Q+ T+ k* K
         pppt2(0) = pppt1(0) + gzkuan
9 I- _2 F( Y4 a7 F$ F' t  K: }         pppt2(1) = pppt1(1) - gzgao
( Q* k. ?9 h0 `. G9 L1 ]; V! E
, k0 |; a$ \; `# D      Next/ D5 [* R0 ]5 V9 E, N9 v4 y, z5 {
    Next. O; h1 G/ b+ t% i) K5 C/ d
         pppt1(0) = ptLeftX" m9 v% |# t0 {8 f3 {6 e0 y5 A
         pppt1(1) = ptLeftY
3 G- O1 w& b* g) ~         pppt2(0) = ptRightX
7 \0 ]5 o$ \  ^' x6 o         pppt2(1) = ptRightY3 F( O/ S# S+ r# G
  Next
& s. O4 u/ B3 e' g) J. k    SSet.Delete
9 I) Z9 B5 ~3 N5 [# |0 ?6 A    KK = GetDistance(pppt1, pppt2)
$ q+ B' P8 f1 f; Z5 [; w'在程序中操作EXCEL表常用命令:. n5 D6 ?- q8 ^
  Dim Excel As Excel.Application
0 g/ I0 V9 D, E    Dim ExcelSheet   As Object: r: P6 o, w& r  S2 j' f# n  A
    Dim ExcelWorkbook   As Object9 S. ^. v2 y! Q: Q
    '创建Excel应用程序实例3 U8 r: K$ _3 J2 `" W( A3 C
    On Error Resume Next  \( n# L3 F( d/ Q. A
    Set Excel = GetObject(, "Excel.Application")
8 `% k7 w% C  x- v    If Err <> 0 Then, Z0 V- _8 X% x* r' U) y3 G
        Set Excel = CreateObject("Excel.Application"); _1 I; A/ }+ v( \0 [9 u  Y& p* j- y
           '创建一个新工作簿7 T9 N# b+ f; v8 q) e- [
         Set ExcelWorkbook = Excel.Workbooks.Add
) Q( k% W) t7 G% f          '令Excel应用程序可见5 e+ B, a6 r5 [4 S
           Excel.Visible = True
% ^- x$ j5 M0 N          '将新创建的工作簿保存为Excel文件5 M/ c2 N5 g$ O$ Z0 l
             ExcelWorkbook.SaveAs "属性表.xls"
; c: I/ V8 S8 y# ~+ D5 a# U0 U    End If* d0 M, c8 k: {: t9 b
    '确保Sheet1工作表为当前工作表; O& t' _+ f; a3 R1 W9 Q
    Set ExcelSheet = Excel.ActiveSheet; S- j$ e0 {) _  z
    Excel.Visible = True
! U. b0 q+ x6 i, `( v- Y# U    endrow = ExcelSheet.Range("A65536").End(xlUp).Row + 13 ?( g# V7 Y2 _9 [
    ExcelSheet.Range("A" & endrow) = KK
+ Q- `) W: W/ n7 ]5 k  U1 p    Set Excel = Nothing" c( P$ g/ D$ ]4 u% T, |- U
    End If; e2 \, r) [) N) y  F: ]
  Next
# Z5 P( u1 Y0 c3 w8 dEnd Sub4 P9 p2 ~/ g! C' k. ?8 z! {% X
, F3 O$ Q" @+ Y' m! i