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

在EXCEL VBA编辑器的“工具”菜单中点“引用”，在“引用”对话框中找到ACAD类库，勾选它，确定。见图
" y7 S; I( X' P  r4 \4、在EXCEL VBA编辑器Sheet1对象代码窗口写如下代码
9 c* J: Z& ^. t# FSub A()2 v* T2 u6 q1 {; E7 P4 M& g
0 p$ W' Y5 y5 {' F: D
Dim CAD As AcadApplication '声明一个AutoCAD应用程序对象
$ d' h& h. B& o% |# y; xDim DOC As AcadDocument '声明AutoCAD文档对象  U) S# r: r- B
Set CAD = New AcadApplication '运行一个新的AutoCAD进程1 P; q1 I# U7 R  {! n: L! I
CAD.Visible = True '使运行的AutoCAD程序可见。如果没有这行，程序将不可见，就是说看不见CAD窗口，只能在Windows任务管理器看到有CAD程序运行
; q) G' s. S, |Set DOC = CAD.Documents.Open(Sheet1.Cells(1, 1).Value) '按照“Sheet1”工作表第一行第一列单元格的内容打开文件
2 q: I3 n* e4 F! R; rDOC.SendCommand Sheet1.Cells(1, 2).Value '按“Sheet1”工作表第一行第二列单元格的内容向CAD命令行发送命令
6 j* F8 e& h# t) X  q0 qsub

;;;=================================================================*
8 I( @* {# r& X6 D. C;;;功能：测量线的长度 *
+ G9 E3 ~' a& T0 u0 Q4 E;;;日期：zml84 于 2009-05-21 17:45 *
6 R3 \  [$ {) T9 w(defun C:cd ()
4 h  V! a- I" Q; l(princ "统计线段长度"7 n. d$ {8 ]9 M6 n. t
(if (setq SS (ssget '((0 . "LINE,ARC,CIRCLE,ELLIPSE,*POLYLINE,SPLINE")); K4 I% U+ y0 w3 E$ T3 @! J7 Z$ B
)6 R8 ?5 S' j( j: f
)
7 F" l( K3 I7 e+ s4 z! \(progn
9 T2 H" w( O4 T+ N;;4 e+ e0 {5 Y% g3 |. Z: C
(setq LST_LEN '(); o/ S: s# r8 K1 j$ Q
I 0
/ M. S5 t1 @/ y( k1 Q% L, _' o)+ A; k- s( n. [) ]2 c9 x
;;逐个统计
' t. d) o% }& Z; {9 M3 y- L(repeat (sslength SS)
3 U! c/ f: S2 F9 D2 l(setq EN (ssname SS I)% z$ ]* G# {( f5 C2 y/ U0 D6 J- D
LEN (vlax-curve-getdistatparam  m* o% i/ X" O$ \
EN* d5 M7 A3 C. J. M) r
(vlax-curve-getendparam EN)
0 ?: O' `. ^6 X* {, @5 M7 {)
; ]4 Y( I& [& h/ PLST_LEN (cons LEN LST_LEN)  u, \) C9 p( V6 _
I (1+ I)9 H9 t$ c8 [8 W4 [4 ^# ]
)
  ?8 ?; Z! B/ X$ H: |: J* c! d)
& \6 V: q' U. ]- w8 Z' l(setq LST_LEN (reverse LST_LEN))6 S! @, x6 ]9 P0 ?5 d9 `" c+ u& ?
;;显示输出' ?  r5 v. Y" ~6 M0 W" u& f6 A
(princ "\n找到个数：")
+ c7 O7 _+ k1 Z9 }+ d- e- |3 |(princ (sslength SS))* j$ y1 q; m% e% l
(princ "\n单个长度：")- P, F$ q8 Q6 K2 j5 F
(princ LST_LEN)0 n) V2 p8 h8 I/ ~7 U
(princ "\n总计长度：")
- @0 F& Z/ h2 j0 q  L' @/ K/ n(princ (apply '+ LST_LEN))/ B! C# h0 h, M4 S
)3 B) e) q6 M% h4 a# w
)
! S( o! X+ l/ c+ z7 T5 o(princ)
. @# O- c: E4 ~2 ], K8 W& Y9 `)
" T* k' L: M0 m  U  H+ w;;;=================================================================*2 y6 F0 D4 {+ f( h6 q# O4 U
;;;(alert
  C0 i1 c4 N6 ~;;; "功能：统计线段长度\n命令：\"CD\"\n日期：zml84 于 2009-05-21 17:45"
+ O; ]  d4 _7 R1 d5 L;;;)5 _% B, m8 g! S. j
(princ)

’使用 VBA IDE 中的“工具” “引用”菜单选项，选择 Microsoft Excel 9.0 对象模型
# Z+ `4 y- w4 |* s) v$ i; C’水平不高，有点罗嗦，楼主可以精简下
3 j7 B2 M, O6 F/ G+ C# W" t& z# s- V’欢迎以后交流，QQ 42123043
9 J& Z4 W. f, yPublic Sub 取坐标()
0 K/ J) R2 L% I( Z’把AutoCAD中某一图层“多段线层”中的所有多段线的坐标列出来
1 t5 Y, d. K$ ~% K" _9 [$ vDim PLSet As AcadSelectionSet
2 U7 a9 Y& ~# \& C- K2 |8 z, RDim pl As AcadLWPolyline. e3 P5 r2 }6 j# w; ~& z$ \

0 s, T4 o: z( J) w- i( o
* }# q% t: m' A" z: {5 c2 u8 xDim ExcelApp As Excel.Application6 _+ B& i* e1 C. Y7 }7 x# a/ m5 U
Dim ExcelSheet As Object; g, @8 ^9 Z6 h9 ]! D2 ~! S* g
Dim ExcelWorkbook As Object
) Y7 W! @& v6 n
" K) e- f4 o- ~( k+ j* c  u9 s% _7 B/ F
Dim pts As Variant
; g8 S0 w; I- A& z2 b- m9 D8 E9 V) ]
Dim NN As Integer
3 g, \" I* T# `$ m$ FDim j As Integer
+ n- a, x: Y1 r7 v1 G0 P
( P! x0 S8 O' e9 X/ B  K0 l4 VDim pn As Integer9 z$ Y: p, x; S* \) G  E, o

6 ~4 y1 h6 r3 b. z1 d( {8 HDim px(0 To 10000) As Double
: j: R+ C2 ^5 ^Dim py(0 To 10000) As Double
% @+ k( w  `) ]* L  P! eDim pz(0 To 10000) As Double% a, F$ J& U2 e+ p

2 t" s5 @( g  D$ W4 m5 y/ V+ i; {# p0 p4 \; ]2 o' _
Dim filtertype(10) As Integer- s2 M7 ]3 L- [
Dim filterdata(1) As Variant
" \5 ]3 J( y& k2 A; q2 W* K" S6 B
filtertype(0) = 0 ’ 选择线型
! \7 R* L! K+ M: S" D/ j3 Kfilterdata(0) = "LWPOLYLINE". O  J1 z. W- d8 M) y2 n3 Z
filtertype(1) = 8 ’ 图层标识，可以根据具体情况改动9 L( z5 c7 l. }* _3 L0 Q! z# v
filterdata(1) = "多段线层"
, J3 T! Y: u. J& ^) ?. P. k  S5 j' Y, d4 G% M, I, Q
* V7 ^# w! U  T# |, u" Z8 y

* n  O: w: K% Y7 GSet PLSet = ThisDrawing.SelectionSets.Add("pl")
1 M( _* G2 ^# L5 N  Q7 e' DPLSet.SelectOnScreen filtertype, filterdata4 j5 r/ \1 ]. e
7 Q. z, m( A; T2 a0 i: s+ O
NN = 0
9 U# N, |3 E! b- Fj = 0- w& [/ Q( M6 u9 `3 C) P  K# l
For Each pl In PLSet
2 z: B; A' d) F& v5 @# u
& H, [! r& R# \' A) ~+ xpts = pl.Coordinates6 t) K% N) f6 X% W7 s5 ^. z6 B) o
pn = (UBound(pts) + 1) / 2
' b5 |$ D* G4 H  {. H: T) x% ^2 ]6 B, y  [4 o/ O* F1 O8 Z
For i = 0 To pn - 13 _- ]3 \: g& q6 U1 O
px(i + pn * j) = pts(2 * i)
" a1 s% d) q6 u& Bpy(i + pn * j) = pts(2 * i + 1)4 `6 q; E* n* H7 d! Z( b3 }
Next i9 D' g& f! o* n3 S
j = j + 1
' V3 ~5 M- I; r7 G) MNN = NN + pn
) o4 N  O' ]' vNext pl
6 W* q. ]( _0 d( d* B5 _% W+ Y- D3 L7 P/ O+ ]& Q
PLSet.Delete
4 H/ H& k( R( y' k3 J/ W
+ a) n: y1 f9 k" g7 H
0 M, l- k* ]2 t# f' q4 k& k* WSet ExcelApp = New Excel.Application7 L/ \3 D) u6 @
' h" e- ~0 J1 H% H! X9 Q
Set ExcelWorkbook = ExcelApp.Workbooks.Add
7 z# m; Y) ~3 o% C- f) ^3 ~
  T) A2 e* E& b& X5 _2 d( W6 z1 b" C( FSet ExcelSheet = ExcelApp.ActiveSheet4 p- T$ N7 w7 e

. i  [+ l" C8 H7 qExcelWorkbook.SaveAs "c:\123.xls"7 Y( w) ]  s2 L" k- S

% P' o/ Z9 A9 @+ l9 YExcelSheet.Cells(1, 1) = "x"  p7 [3 ?1 p2 ]6 x
ExcelSheet.Cells(1, 2) = "y"8 o5 W9 H* P% _0 u6 t
; v- W  \0 O- D8 J6 f5 J9 @
For i = 0 To NN - 1
2 t( X& T9 Y! B/ [# M# p$ _% kExcelSheet.Cells(i + 2, 1) = px(i)
8 s7 Y$ K6 K; u9 B! c7 A9 ~ExcelSheet.Cells(i + 2, 2) = py(i). T4 Q1 d- N% ^; N
Next i
* c) g' l. ?) W6 K  Y) s! [2 N- L
End Sub

Function FixDimMeas(Dimension As AcadDimension) As Long$ l1 n" e* \9 H! q6 V4 E
Dim BlockCount As Long% S) G$ v& R" m6 [4 S* ]; `
Dim bz As Long
7 \- ?+ \$ I+ b3 Y* Y
% y6 O( p; t# h' ]BlockCount = ThisDrawing.Blocks.Count0 R2 ?8 k( ^" X
'遍历块中的对象，取得标注尺寸
3 D3 J. @2 o8 m  W  NDim EntityInBlock As AcadEntity
9 l) A$ L% a6 F' g" ]For Each EntityInBlock In ThisDrawing.Blocks(BlockCount - 1)
  x$ H2 K3 Z5 FIf EntityInBlock.ObjectName = "AcDbMText" Then
9 H9 A. \: E0 N2 w+ abz = Dimension.Measurement
: c; N* B- q' b* Q. UFixDimMeas = bz '取得标注尺寸
. I% n7 J) t! w0 n1 OExit For
7 ?8 s/ i, x) Y. c- \End If
& s* c4 {9 H0 j" A( u) K* bNext1 k$ p% T; ?7 m$ G( r% i  d6 l
End Function

选择CAD线条 EXCEL记录长度
9 I& A4 Y3 G+ t! h选择“工具”\“引用”项，在弹出的“引用”对话框的“可使用的引用”列表框内，选择“Microsoft Excel 8.0 Object Library"项4 G" j0 G- E& ~1 e0 q/ U
- \4 ^3 T* i. G8 |
'计算两点之间距离# J/ x" Y- {6 n' H
Public Function GetDistance(ptSt As Variant, ptEn As Variant) As Double" k) G$ n$ Q. V: T* h% ]
    Dim x As Double
( |5 a: g3 c: N4 b    Dim y As Double6 j/ Y. E3 H% X
    Dim z As Double
$ L9 l' A& c- S+ p" X5 ~    x = ptSt(0) - ptEn(0)
% p8 F0 c- @3 s) ?5 H1 j, r5 n    y = ptSt(1) - ptEn(1)( R! u0 d* N' s: x- b" z, J
    z = ptSt(2) - ptEn(2)
$ A. A$ `* _, k# W0 N7 u2 K& ~    GetDistance = Sqr((Sqr((x ^ 2) + (y ^ 2)) ^ 2) + (z ^ 2))+ I/ F+ i" o7 k, N& M( ?8 i
End Function, E! g3 E# Z% w" C

8 Q  E# d  q0 q# VPrivate Sub xz()
% _, B' Y, z8 [5 v# ^; \4 ~ '创建选择集
" B7 Q( c$ _4 ~+ ~ For JJ = 1 To 107 K4 h- p, j% _$ C$ b# H
If MsgBox("是否继续选择", vbYesNo) = vbNo Then# l5 |9 m3 C" L; Y
Exit For
" G9 D3 D5 Q. j* M/ [+ X* fElse
8 v) w) P8 J3 H3 q0 w1 L; X1 a    On Error Resume Next
0 ]& r) x/ a7 R    Set myyactiveDoc = ActiveDocument
; _5 Q* Y  v. W* @/ ]1 w4 N8 r% c' c/ f, b( @9 ^& P) n
    Dim SSet As AcadSelectionSet$ A( v  u* ^  L" n9 Y" Z  L
      Set SSet = myyactiveDoc.SelectionSets.Add("Ehlxz")
0 ]% n# b0 I4 l5 s% c1 h6 p& K' N# P    If Not IsNull(myyactiveDoc.SelectionSets.Item("Ehlxz")) Then
- y7 }% v3 ]- E8 j0 z! q6 {5 L        Set SSet = myyactiveDoc.SelectionSets.Item("Ehlxz"): t4 |, u7 Z) l0 y# W* o' z
        SSet.Delete     '及时删除不用的选择集非常重要4 a' W4 p& l1 ]: U1 a! f( @3 M
    End If
: m: ?' R4 g+ f   Set SSet = myyactiveDoc.SelectionSets.Add("Ehlxz")
6 O2 T. M6 y6 n7 R' o    SSet.SelectOnScreen& ^7 ]% r7 _3 C3 R
    '创建点组
  Z7 n5 m9 T/ \2 X/ ]' P    Dim ptArr1() As Variant
" Z5 W. Z: X& G1 y1 `' y    Dim ptArr2() As Variant$ ^' d% N  d! W8 g$ q/ E( C
    Dim count As Integer
5 O( L- n7 p; s    count = SSet.count$ L' S# _' g$ e% G
    ReDim ptArr1(count - 1); p$ X9 N& C" x: A- L) _
    ReDim ptArr2(count - 1)) d* ]$ h) w1 N% {& }# q
    '错误判断( i3 x: e( f# m
    If count = 0 Then: h: @! @) r/ i; h
        MsgBox "未选择任何对象！", vbCritical; U! u7 c8 K  I9 p
        Exit Sub
* J6 {" F% e2 _$ Y    End If
" a% w6 Y+ U, E' Q8 M/ f8 y5 g" {5 N4 |9 d& l. i6 Q3 m
    '获得最左侧和下侧的角点/ v! t5 }) x0 G+ m
    Dim objEnt As AcadEntity
  u0 s2 i9 |1 N+ Q% w    Dim ptTemp As Variant
7 r8 `) T+ B( m; }    Dim i As Integer% r( b! g* m# n0 s: |
    i = 0
8 I0 n7 e6 _7 |3 m- e" x    For Each objEnt In SSet' ^0 o" e' Y7 P9 G, k
        objEnt.GetBoundingBox ptArr1(i), ptTemp/ F( ]9 t# G& }/ x# o: v3 N; ^
        i = i + 1
" R6 I9 n7 Q. T# r) Q& }% Y# ]    Next
  j1 j$ I9 o  p$ p1 o- C: S! Z; Y4 w    '获得最上侧和右侧的角点) N2 d5 V& j3 y
    i = 0
5 Q; i& q( R6 A7 T0 ]) R    For Each objEnt In SSet5 M" L0 G. ]- e' }* \: {0 U( _4 O
        objEnt.GetBoundingBox ptTemp, ptArr2(i)
% F3 f) u  }# V! m6 ~) B1 q8 u8 l        i = i + 1
* }! V3 A/ B" Z    Next
6 h& c( ~: [. i* ~) s; @7 @    Dim ptLeftX, ptLeftY, ptRightX, ptRightY
' S& e+ }" a1 C/ a6 X6 R    Dim ptRight, ptTop% G  a+ f0 K/ e  S8 V8 n& B2 a6 U
   For WWW = 1 To count: |. L9 [" B7 x' W. {% A/ v
      ptLeftX = ptArr1(WWW - 1)(0)
9 v/ n6 y/ x, L8 S! v& }# w* J      ptLeftY = ptArr2(WWW - 1)(1)) b" ?( P+ S& \. H
      ptRightX = ptArr2(WWW - 1)(0)5 T& I, S9 ~+ f6 _  W
      ptRightY = ptArr1(WWW - 1)(1)/ m% J: \$ O) F

, ~* G. O4 ]0 z" ]  N    Dim pppt1(0 To 2) As Double
2 B( ?( t0 D9 w3 Q. @0 r    Dim pppt2(0 To 2) As Double' K' r# q; h: _3 Q9 D$ t, H
        pppt1(2) = 0
1 T0 `) s2 d& H# L        pppt2(2) = 08 V, I5 p/ F! _/ ~3 |+ {6 A- h# O
    Dim gzkuan As Double, gzgao As Double
5 p+ D) \4 {; t     gzkuan = (ptRightX - ptLeftX - 25 * (Int(Val(HjigeCb.Text)) - 1)) / Int(Val(HjigeCb.Text))
5 a# r5 |9 W1 i, W; Q- C     gzgao = (ptLeftY - ptRightY - 25 * (Int(Val(SjigeCb.Text)) - 1)) / Int(Val(SjigeCb.Text))& l8 o2 G# A4 a; Q+ F
    For j = 1 To Int(Val(HjigeCb.Text))2 S  h/ i& i- H, w& l5 k, f
      For k = 1 To Int(Val(SjigeCb.Text)): P# Q& b( Y- P2 R) N, t
        pppt1(0) = ptLeftX + (gzkuan + 25) * (j - 1); W8 m% F' A  M" R9 S( ]
         pppt1(1) = ptLeftY - (gzgao + 25) * (k - 1)6 o# H4 f+ U) L9 F
         pppt2(0) = pppt1(0) + gzkuan
! T  S) Z  q" E" ?  R$ n         pppt2(1) = pppt1(1) - gzgao& ]8 |% l, _+ y3 D

/ Z) z' u( w' d7 \) I. q      Next2 b: F5 Z- B0 B; w1 H
    Next# A' ~) {4 |4 U* ?
         pppt1(0) = ptLeftX
) L& T  j: g2 Z" C6 E- R$ A% Z# W         pppt1(1) = ptLeftY% v; Z# M0 z$ o& H4 f2 Z2 Z
         pppt2(0) = ptRightX
1 r% j/ c1 k) N5 N6 g- A6 N' @         pppt2(1) = ptRightY0 ?, `" q* g, B9 ]' s
  Next1 C  X7 w1 A8 d& Z5 ?+ S# F
    SSet.Delete
7 g5 t; E) P4 I+ e    KK = GetDistance(pppt1, pppt2)
3 k; O# n0 b2 v0 {* F'在程序中操作EXCEL表常用命令:
1 M" T. B: n6 {8 H- ~: Y  Dim Excel As Excel.Application" d* u' o8 j9 m/ y$ ~. u
    Dim ExcelSheet   As Object: U+ d  X8 o# C# w/ [
    Dim ExcelWorkbook   As Object
& j' r8 A+ ?4 t! Y- W' L    '创建Excel应用程序实例
- s* Z( @% \; `8 ~9 r' C; o    On Error Resume Next4 f9 Q3 \! O9 J; N" n% M
    Set Excel = GetObject(, "Excel.Application"): p$ Y: ]( `+ N1 y; C9 Z3 \
    If Err <> 0 Then
9 p) d. H2 U; m  `( \9 E/ k        Set Excel = CreateObject("Excel.Application")
4 f/ ]8 H/ ?. S/ u& y  \3 f           '创建一个新工作簿
* r$ r/ m+ Y( B. N$ G9 B         Set ExcelWorkbook = Excel.Workbooks.Add
# u. k$ r) a/ R& v          '令Excel应用程序可见. e/ Q. C2 O: J  X" [
           Excel.Visible = True
$ m8 s/ @4 h8 ]5 z* V/ q          '将新创建的工作簿保存为Excel文件( A0 O3 Z; i5 z. B" P! C6 q& V: h
             ExcelWorkbook.SaveAs "属性表.xls"8 T8 s: ^4 A% G% \
    End If
/ x# ^2 m5 M. f- m    '确保Sheet1工作表为当前工作表# ?1 a0 A8 G4 e+ r
    Set ExcelSheet = Excel.ActiveSheet
1 C# P2 Z" z4 X( |) ]4 J    Excel.Visible = True
$ i% S( q( a+ P: w8 S# a5 u    endrow = ExcelSheet.Range("A65536").End(xlUp).Row + 1
  N" m8 u7 f7 |) Y, {7 U    ExcelSheet.Range("A" & endrow) = KK
1 N# Z6 g  m& n    Set Excel = Nothing
( i% O. {4 p+ }$ \& _7 b# ^# Z    End If. a6 @5 b2 u; D0 M) _
  Next6 n  u6 q! ~! D
End Sub$ P( `: B( c" t5 T) q- U) Y

. p3 |2 [0 w9 `) `/ o/ [8 v+ k