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

在EXCEL VBA编辑器的“工具”菜单中点“引用”，在“引用”对话框中找到ACAD类库，勾选它，确定。见图: ?- F& H. U# f. a
4、在EXCEL VBA编辑器Sheet1对象代码窗口写如下代码
. l- r$ S; o' o7 A, T5 aSub A()
# W# D3 `9 z$ H- a+ j+ a* R8 y3 B: T3 S9 o: f
Dim CAD As AcadApplication '声明一个AutoCAD应用程序对象; I# n. h3 z# S; N8 C# E
Dim DOC As AcadDocument '声明AutoCAD文档对象
& o* @8 U5 x' RSet CAD = New AcadApplication '运行一个新的AutoCAD进程
) g5 E4 s  B2 W& TCAD.Visible = True '使运行的AutoCAD程序可见。如果没有这行，程序将不可见，就是说看不见CAD窗口，只能在Windows任务管理器看到有CAD程序运行
! n0 \+ B* a  u, eSet DOC = CAD.Documents.Open(Sheet1.Cells(1, 1).Value) '按照“Sheet1”工作表第一行第一列单元格的内容打开文件
( Z/ G) l3 k) g( ZDOC.SendCommand Sheet1.Cells(1, 2).Value '按“Sheet1”工作表第一行第二列单元格的内容向CAD命令行发送命令
, Z* _9 p4 L8 jsub

;;;=================================================================*0 P/ @1 o- L$ a% a0 R$ O& y
;;;功能：测量线的长度 *7 A" `; C! }' U+ X$ i, t
;;;日期：zml84 于 2009-05-21 17:45 *
. g# N" G' r: i  |. r. g(defun C:cd ()
2 v( s1 E# u& e9 c4 ^# }, a(princ "统计线段长度". O" U+ ^1 i  @8 l  f
(if (setq SS (ssget '((0 . "LINE,ARC,CIRCLE,ELLIPSE,*POLYLINE,SPLINE"))
+ m9 _* N/ u4 k5 L, i# |3 f)  U3 y* y& V0 J- d+ n
)
4 O3 q" V; v3 K5 Q, w. o; Y8 _" J(progn
, w- \- O( L/ x: a;;
4 @7 `4 O/ |4 \; a2 O2 K(setq LST_LEN '()
2 b0 `9 g& O4 A0 [) Y, XI 07 I7 @3 ~5 Y) k( o+ s
)
. L' u8 s3 ]7 O9 U& C# Y;;逐个统计* k$ r$ [* \; u$ j9 P* m
(repeat (sslength SS)
9 }- ]0 {" O4 n' Y(setq EN (ssname SS I)/ t, o- [' w  u3 H7 {4 b
LEN (vlax-curve-getdistatparam2 g& g- I* ^( V; ?) O2 j1 f
EN
: c) }& }# q2 g5 n9 e# a- y(vlax-curve-getendparam EN), x! Q* K! |* n% \! Z. ]& H
)
9 x8 e8 J* t/ MLST_LEN (cons LEN LST_LEN)! V  ^! s& k  [' b
I (1+ I)5 O& A, |" L$ i
)! i- B2 \1 E/ u- p; [6 g$ }; S2 E
) 3 w& ^: K- j1 g. x; @8 ]' m) O
(setq LST_LEN (reverse LST_LEN))" }, F$ X$ J/ V/ a0 S4 ?) a2 r4 Z
;;显示输出) D+ w' @% @. \2 g# U
(princ "\n找到个数：")
+ O. K9 B" Z) J# Y5 S(princ (sslength SS))4 c4 a* ]5 S8 @* y; H+ W; z
(princ "\n单个长度：")
, [- s. D" e+ M9 S) F, g(princ LST_LEN)  @4 X! g/ n- B# m9 i/ X2 j" M  y
(princ "\n总计长度："). C, T3 o" L/ j5 @' X0 I1 m
(princ (apply '+ LST_LEN))9 a, l  ]: M- g. {5 B! @
)
' R/ Y7 P8 s& y* K% y. x' p)! P& l% r- J" O  l; L/ _
(princ)- R, `$ p) _* ], P& B
)9 }1 ^2 a/ W5 B/ A4 T0 r) `; j
;;;=================================================================*( r$ f8 R, z- N% G6 ~# ?
;;;(alert
" ]" x" ^- E, E& s! l;;; "功能：统计线段长度\n命令：\"CD\"\n日期：zml84 于 2009-05-21 17:45"
9 s& B0 k# s% @4 t;;;)
5 @) t* @8 E3 ]4 X% _(princ)

’使用 VBA IDE 中的“工具” “引用”菜单选项，选择 Microsoft Excel 9.0 对象模型) ]2 N$ u/ F5 V' Q# l' w
’水平不高，有点罗嗦，楼主可以精简下" K$ \1 b: t6 I6 D% m9 e% C
’欢迎以后交流，QQ 42123043/ Q3 l5 \: ?3 n2 @* m1 J
Public Sub 取坐标()6 u" W/ R& Y2 r2 D/ {
’把AutoCAD中某一图层“多段线层”中的所有多段线的坐标列出来! ^( e1 {2 ]: H9 H
Dim PLSet As AcadSelectionSet
4 F% k2 U$ I; B( R6 mDim pl As AcadLWPolyline) @2 f0 a) b1 W5 R# Q) n

! x% f% c9 M1 y  ]. ?% e' F- {7 i( P$ i& j
Dim ExcelApp As Excel.Application
( f7 u" B5 T' j/ q- u* yDim ExcelSheet As Object
5 w+ m" ~1 ]7 k: h& D; M* VDim ExcelWorkbook As Object
% L+ Z8 ?) j6 L, _* F
' ?# l( }  F: L! d/ L
  y, D+ y; M7 d1 K. w; |9 TDim pts As Variant
: x+ ]/ D# H. s& a+ N
, e; |( [! c0 g3 ~Dim NN As Integer0 l1 l9 {0 Z% @0 K" f
Dim j As Integer
% [- R, z+ Y4 I2 S( F
0 U* T5 l$ O: A3 _! x+ H$ hDim pn As Integer3 h  Q( @8 c9 z
4 f  F) V! Y1 z' V2 f- n, x: L3 ~
Dim px(0 To 10000) As Double
6 d3 |* M7 h. Z% |2 p/ wDim py(0 To 10000) As Double% P: p5 M; }+ W$ H0 Q, I! a
Dim pz(0 To 10000) As Double
# c: C- R! q7 I2 }$ S3 N- g- D
( ^2 N" s$ Z* B' D) P- ]2 I" q2 K- [# B( g9 _+ s
Dim filtertype(10) As Integer
7 G+ O8 M. G% U% x8 `Dim filterdata(1) As Variant( g* w& S. h4 l6 H; L$ {0 f
: t( |. |4 X) Q, W
filtertype(0) = 0 ’ 选择线型  V4 m5 Z7 }4 @
filterdata(0) = "LWPOLYLINE": |: Q; F& r2 f; C: V
filtertype(1) = 8 ’ 图层标识，可以根据具体情况改动
/ R/ L" z5 y6 C  [$ K  X! Efilterdata(1) = "多段线层"
; _3 G% c6 o8 A+ O' O, O" k; F) v1 Q  H! |; I  |% ~; v" @
6 O, e$ M- @3 D' m; q
1 Q/ `' A: \$ I3 Q
Set PLSet = ThisDrawing.SelectionSets.Add("pl")1 l0 j! p9 n; [: {  B0 o; X
PLSet.SelectOnScreen filtertype, filterdata
; M2 w! U3 a3 Y; n
( r2 R. R% b, UNN = 01 I/ [' A  `- Q( ?
j = 0
1 W3 }0 E: G* |For Each pl In PLSet9 Y6 {; O0 i9 r/ z
1 B* @6 v( E2 g/ L: t
pts = pl.Coordinates
; X9 I) f: x) Hpn = (UBound(pts) + 1) / 2
$ J% l8 Q1 y+ M, \2 P: w
8 m  L3 k2 ~( h9 I4 V5 ?( {For i = 0 To pn - 1: |  P1 R' ~4 F% ^6 w" X
px(i + pn * j) = pts(2 * i)
4 ^  t6 ?& Q9 B, b) V* p% Wpy(i + pn * j) = pts(2 * i + 1)
8 P: g& j0 D- K6 I9 fNext i
8 p0 j% s' b; l4 q: U7 R- q6 C8 Hj = j + 19 d: ^+ I! Z; I
NN = NN + pn& F' j3 C: U( g  g( @1 B
Next pl, T# O) ?! q% {" N6 r0 p
4 t+ M$ a8 Q2 ?( E) D8 |9 K
PLSet.Delete
' e% C: l: ]2 a0 T8 A* z
* C$ o5 g7 }/ {  b& m$ h6 u0 f
7 A9 }2 v0 w; [Set ExcelApp = New Excel.Application
+ F3 j4 o, j, l; f4 b6 p* X4 w, U+ K9 a$ X
Set ExcelWorkbook = ExcelApp.Workbooks.Add
( y& o& O0 E/ x' f0 @' z6 B9 r
* q- c: A" k/ I2 K& l6 PSet ExcelSheet = ExcelApp.ActiveSheet/ f3 j  j0 `3 L5 I0 O0 e
) k0 |( a& H4 R" [$ a
ExcelWorkbook.SaveAs "c:\123.xls"
& k* W( G9 e6 f4 y0 [2 W' X7 W5 I1 O  @' ^1 h
ExcelSheet.Cells(1, 1) = "x"0 D3 V' _1 E/ U# d
ExcelSheet.Cells(1, 2) = "y"' q& N3 D& W1 _1 u. o) R1 A

( H1 o" a  B9 }+ K( i3 TFor i = 0 To NN - 1
# |; n, h( I( z) g- H/ m* ~ExcelSheet.Cells(i + 2, 1) = px(i)
' v3 K& W6 n4 H* H( W0 b. h# iExcelSheet.Cells(i + 2, 2) = py(i)
0 L. x/ U' d3 K6 _: u& {. T2 dNext i' z; `( ~& O( N1 E3 G- D
6 e7 i' O: j) I! g4 r0 E; N2 U& I
End Sub

Function FixDimMeas(Dimension As AcadDimension) As Long  [0 E. p$ c& c) V& p& K
Dim BlockCount As Long5 {4 J6 D, z4 j4 P: V9 @. Z( u! X
Dim bz As Long. G. R% \6 m% s- N

  a5 r" o+ u1 v) H4 m4 D1 J7 v% {3 vBlockCount = ThisDrawing.Blocks.Count2 f: R3 H- Z6 @* P1 f0 |, y6 l! c
'遍历块中的对象，取得标注尺寸- w3 v( U  [. k. ]5 H- h
Dim EntityInBlock As AcadEntity
7 \  m" M" Y% {% \6 \For Each EntityInBlock In ThisDrawing.Blocks(BlockCount - 1)
7 @- [! B$ c$ Y1 _9 V! ~' lIf EntityInBlock.ObjectName = "AcDbMText" Then& e! Q2 l8 R% ^: x
bz = Dimension.Measurement
5 o: C0 @2 I5 A' ?/ PFixDimMeas = bz '取得标注尺寸
# Y9 Y9 A4 L% X5 N+ X; jExit For   O! \( }. I# }  K. I! K
End If
9 O; D# B2 X8 `$ a. x# w) g$ MNext
8 D& h8 q0 O( X. U4 `. H+ j: sEnd Function

选择CAD线条 EXCEL记录长度 4 L+ v  \* Q: ?: Q! p
选择“工具”\“引用”项，在弹出的“引用”对话框的“可使用的引用”列表框内，选择“Microsoft Excel 8.0 Object Library"项7 m# v- b# r& O7 x$ s

2 z: a0 J+ g% n'计算两点之间距离" l( D6 ]" {# v( R! q
Public Function GetDistance(ptSt As Variant, ptEn As Variant) As Double
1 g& j- K9 i  s$ b$ I( U: i    Dim x As Double- E# X' I6 o5 [3 b1 T4 K% r
    Dim y As Double, ^! j0 q3 K1 d5 S2 `
    Dim z As Double! X( ?9 a; S- F$ a1 c/ a
    x = ptSt(0) - ptEn(0)
: w% ?- O* g: x" I7 P: P    y = ptSt(1) - ptEn(1)
( r. x2 p6 p( _$ t6 Y% p; I    z = ptSt(2) - ptEn(2)4 M" y9 K7 x, {  T" A
    GetDistance = Sqr((Sqr((x ^ 2) + (y ^ 2)) ^ 2) + (z ^ 2))9 k; k; X; l; A6 q9 D
End Function
. z' |# k3 s% D- N9 y . `! H) n: E1 E# g& u# N9 s
Private Sub xz()
) j. H* F$ [) i+ _2 n '创建选择集. s# X! X2 q) U. q5 ~" y
For JJ = 1 To 10
0 d* a/ _( T0 z' v If MsgBox("是否继续选择", vbYesNo) = vbNo Then4 d: t3 a. F; x) L# ~
Exit For9 B1 t! P0 g# T' l3 B+ A
Else
5 {3 _# d! o8 W2 `$ Q    On Error Resume Next
- t+ u* ]' {% ?5 h: a2 W' q. ?    Set myyactiveDoc = ActiveDocument
- W& a7 N. _2 `* r0 P) Q0 ], b4 l/ R& e
    Dim SSet As AcadSelectionSet
, d, u$ p8 L  [* B- {- q+ \      Set SSet = myyactiveDoc.SelectionSets.Add("Ehlxz")
) [! v, P( I8 u0 u6 ~    If Not IsNull(myyactiveDoc.SelectionSets.Item("Ehlxz")) Then% l# W1 w  c, H4 T  F
        Set SSet = myyactiveDoc.SelectionSets.Item("Ehlxz")4 ~7 q; i7 w2 c
        SSet.Delete     '及时删除不用的选择集非常重要2 E0 F8 @" C" L; s/ e. d( u
    End If0 h6 G. C/ y9 Q$ {& z4 B4 ]
   Set SSet = myyactiveDoc.SelectionSets.Add("Ehlxz"): @/ \" U  X8 M
    SSet.SelectOnScreen
' p# M: R  g* _7 F9 m% Z( z    '创建点组' u4 S! x9 j" M# ~8 ~
    Dim ptArr1() As Variant! K1 e% I( I& z6 k
    Dim ptArr2() As Variant
7 I' j, V( l& t( X    Dim count As Integer
) C, [& F1 b# @6 Q* }    count = SSet.count
# i8 U3 V! J0 Z% a: C. F    ReDim ptArr1(count - 1)
/ i+ j! v- n, @) V    ReDim ptArr2(count - 1)
3 s3 ]6 t, |+ G4 K) F    '错误判断
& ?) k0 ~2 O& g/ e    If count = 0 Then' a7 _6 a" u* B# Q
        MsgBox "未选择任何对象！", vbCritical
# S3 w) T8 s* N. ^+ _        Exit Sub. L% q" v7 L$ j5 a* f
    End If5 D0 E, @5 @1 e' ?0 R# m- j2 r
! u  l, M& \  R4 P9 X  g: Z
    '获得最左侧和下侧的角点4 Z7 l7 Q# A" j' L
    Dim objEnt As AcadEntity
; p3 w1 I$ \9 n7 c: [    Dim ptTemp As Variant
. d# v: N. D  i  Q/ W    Dim i As Integer- \0 R6 r! u4 G
    i = 00 P3 y7 q7 K. w$ u7 X# o
    For Each objEnt In SSet
% Y- V$ `; G( D9 y        objEnt.GetBoundingBox ptArr1(i), ptTemp8 d: a4 \" U5 L0 ?
        i = i + 1+ ?& j5 o* ^+ X' S
    Next% ]% z8 T* @5 H0 W0 x
    '获得最上侧和右侧的角点4 Q( f  z0 _. K
    i = 0& n6 F! N% D1 X: J0 z
    For Each objEnt In SSet, f( G9 [" ]3 P+ M  Z. n$ l/ [) g
        objEnt.GetBoundingBox ptTemp, ptArr2(i)/ A4 R0 s2 ?+ t4 h% p
        i = i + 13 ?0 `; _% ~% B% S& @
    Next5 x8 H6 R/ @% u- p+ O6 y# b& ?9 q
    Dim ptLeftX, ptLeftY, ptRightX, ptRightY
, a4 W/ m) C$ q& a& g    Dim ptRight, ptTop5 v7 {! J1 ?2 q
   For WWW = 1 To count' E0 y+ N% Y* H' A
      ptLeftX = ptArr1(WWW - 1)(0)
1 U8 F8 d) H: |' {% f      ptLeftY = ptArr2(WWW - 1)(1): B( v- h! a1 d1 U( c1 C0 G* Q' {" ]
      ptRightX = ptArr2(WWW - 1)(0)/ I1 |* \" {! \& N" O
      ptRightY = ptArr1(WWW - 1)(1)
5 D6 V- ?. X4 b& N
$ C! l& u5 H# d! e6 J    Dim pppt1(0 To 2) As Double
* l9 ~) N% O  V3 `    Dim pppt2(0 To 2) As Double
  \; h* t, n( Z; b/ s        pppt1(2) = 0
% c& \8 j: e' F! z, y/ c        pppt2(2) = 0
. e& b4 n, W. |" g: a/ w2 E. q    Dim gzkuan As Double, gzgao As Double
2 k2 B9 L& a  v( ~! Z& ^- f     gzkuan = (ptRightX - ptLeftX - 25 * (Int(Val(HjigeCb.Text)) - 1)) / Int(Val(HjigeCb.Text))# f8 n; d5 H' I6 k( g
     gzgao = (ptLeftY - ptRightY - 25 * (Int(Val(SjigeCb.Text)) - 1)) / Int(Val(SjigeCb.Text))
7 [+ n- _$ I: \) I$ W' a6 q    For j = 1 To Int(Val(HjigeCb.Text))
; ~: R# K3 a$ h, B2 V      For k = 1 To Int(Val(SjigeCb.Text))
; h, z, t' d% p. L        pppt1(0) = ptLeftX + (gzkuan + 25) * (j - 1)
) Z$ V. e: r# \4 N! |1 l: T: w1 F1 C3 z         pppt1(1) = ptLeftY - (gzgao + 25) * (k - 1)
. I& V: y) u1 \" [         pppt2(0) = pppt1(0) + gzkuan
& k1 T1 O. T# w$ H% V3 Y/ S         pppt2(1) = pppt1(1) - gzgao
. ~4 _- w0 b  r5 Q1 q2 o! J! B4 i$ F9 \$ j; K1 o+ c% @( n7 h% }. V# o
      Next
( q/ @: v; |8 _5 p    Next: `  @1 ~  @5 t; ^& B1 M  @
         pppt1(0) = ptLeftX' {1 j6 j( n+ ~& h  h* N: m. k
         pppt1(1) = ptLeftY7 ~0 y2 j8 {& ]! W
         pppt2(0) = ptRightX
* Z4 `! z+ \  |6 }/ `5 }8 R         pppt2(1) = ptRightY
4 K/ W+ W; _5 M/ f6 f: U. u  Next
% y3 E: ^1 w2 y0 [. ?    SSet.Delete
# \. y2 u+ r, \- l& X    KK = GetDistance(pppt1, pppt2), U0 L0 ]: @) n
'在程序中操作EXCEL表常用命令:8 B+ J2 B9 H% ^/ R
  Dim Excel As Excel.Application
  u: E) x3 e6 b) N    Dim ExcelSheet   As Object
6 a8 ]- g0 y+ f8 Z% j) _3 U* n    Dim ExcelWorkbook   As Object
* d1 c; p# f: u8 h6 D- @; L, r    '创建Excel应用程序实例
0 X. [* g* X8 v7 n9 u$ d    On Error Resume Next
+ P/ H4 G9 |7 P    Set Excel = GetObject(, "Excel.Application")
2 E5 w% b: t7 V    If Err <> 0 Then4 b; ]2 k; O) @& B" p- @
        Set Excel = CreateObject("Excel.Application")
& w* D/ H) W, w( S0 N5 [" J! k           '创建一个新工作簿
+ O3 n0 U' {3 Z2 c6 A         Set ExcelWorkbook = Excel.Workbooks.Add  ^/ L" F+ n, Q( ]7 G% x
          '令Excel应用程序可见
- U& ^( z3 N5 a3 q           Excel.Visible = True9 I! c& ~; ~  X- {3 y
          '将新创建的工作簿保存为Excel文件
" t0 l3 F' |% j  k             ExcelWorkbook.SaveAs "属性表.xls"
8 J; z# M0 w8 {' L8 [    End If. J  ~0 M5 _1 y8 u& M' e1 _- Q0 P0 M
    '确保Sheet1工作表为当前工作表
! J# E& J& k' E  P    Set ExcelSheet = Excel.ActiveSheet3 o7 l8 m! N3 p3 m7 g/ x7 J
    Excel.Visible = True/ l3 b# |- j  W# @/ _
    endrow = ExcelSheet.Range("A65536").End(xlUp).Row + 1
% c* B1 K) [  I" c" U  R8 i    ExcelSheet.Range("A" & endrow) = KK
4 c6 w/ k/ n; ~; [) c    Set Excel = Nothing/ M! A0 m0 D" E6 r8 T% C: [, w
    End If
0 r  z' I/ R1 E1 G8 {, r" m: C/ C  Next: \* q! q# m9 |
End Sub, |4 E" H) N: G7 M7 x

/ y/ u% @) {  N( |6 B* P' b