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

在EXCEL VBA编辑器的“工具”菜单中点“引用”，在“引用”对话框中找到ACAD类库，勾选它，确定。见图
; J9 k' q, y; X4 l" d/ V4 A4 v4、在EXCEL VBA编辑器Sheet1对象代码窗口写如下代码& p8 e4 `2 P$ e7 t5 L4 n! P0 A
Sub A()
" G: x8 \! N) [- h9 g: I) r
8 x8 u- R6 q' e. EDim CAD As AcadApplication '声明一个AutoCAD应用程序对象. D. g1 s, \4 o" ?& ], i" X
Dim DOC As AcadDocument '声明AutoCAD文档对象
$ `1 c# {! k* q4 x  |Set CAD = New AcadApplication '运行一个新的AutoCAD进程
7 \# J  D: e0 _  A6 D' S6 zCAD.Visible = True '使运行的AutoCAD程序可见。如果没有这行，程序将不可见，就是说看不见CAD窗口，只能在Windows任务管理器看到有CAD程序运行
% w$ L- I7 H4 X8 O  j" A8 pSet DOC = CAD.Documents.Open(Sheet1.Cells(1, 1).Value) '按照“Sheet1”工作表第一行第一列单元格的内容打开文件
1 ~& G, |. F2 q1 v6 ?DOC.SendCommand Sheet1.Cells(1, 2).Value '按“Sheet1”工作表第一行第二列单元格的内容向CAD命令行发送命令7 I7 Y+ W* h: J5 J3 G& J
sub

;;;=================================================================*
8 t5 M* P9 r9 };;;功能：测量线的长度 *
5 T1 m+ f0 A: ]1 m# w;;;日期：zml84 于 2009-05-21 17:45 *: h, e- {( P0 H
(defun C:cd ()+ c2 P( K. K! O! p
(princ "统计线段长度"
" x$ Z0 i5 T& y% s5 h, s+ t! R4 P(if (setq SS (ssget '((0 . "LINE,ARC,CIRCLE,ELLIPSE,*POLYLINE,SPLINE"))0 P  G. s) D) F  y; }& p
)
$ J% i: B! x: Y2 z8 v% W  ~9 D)) J" y! Q% x6 z
(progn
  ]5 ~- q1 {6 c3 _, l;;
( w8 ], d& K9 ?  ?; r2 P(setq LST_LEN '()
5 v. o8 U1 L2 n* P) C& Y; n2 NI 0
8 `4 v6 P4 C) A! W4 I)
' \1 c5 ]0 P5 Y5 s: X;;逐个统计
+ J1 P) C5 o1 n' f" x# `" m. U(repeat (sslength SS)
/ c$ z  z/ ]( @& x1 Q, j2 ?(setq EN (ssname SS I)& X$ N  y% m  B! m% I
LEN (vlax-curve-getdistatparam
+ [& f8 q7 `& W2 [0 B# q4 U8 {EN1 C) J9 U0 p, h4 t& c7 g
(vlax-curve-getendparam EN)& j9 q# ^, z8 X
)) K6 q9 Q) W4 ~( |) x: B
LST_LEN (cons LEN LST_LEN)
2 h9 u5 t4 P. A$ m; MI (1+ I)
/ e+ I" P% R, v( h)! y0 `+ N4 a& b* J
)
+ F9 J+ s) Z/ U+ t. q& {* S% |(setq LST_LEN (reverse LST_LEN))* J  O& P. O6 [3 _' b
;;显示输出# z3 ~: k  @7 q0 ^7 D4 o8 r- B' d
(princ "\n找到个数：")
) A( C# x7 i$ [+ a7 ]" B(princ (sslength SS))% n. H; G  B! b2 x* O
(princ "\n单个长度：")
) W% Q+ e3 ~( W(princ LST_LEN)
/ Z9 _; c: p+ O* b4 z( N% S2 w, f(princ "\n总计长度：")7 ~( c1 u+ f' A( R# e' [
(princ (apply '+ LST_LEN)); G' x: m/ U$ S/ Q* Z0 k
)4 ^, q: L" ]; ^% g
)
0 x2 }1 i, |, j(princ)' f8 a( s# S7 c, {) |
)
! `  J: H) `" U- R;;;=================================================================*
# h) `9 s( F0 X$ R* @( s;;;(alert
+ n7 i; ~4 O! Y% Z0 O;;; "功能：统计线段长度\n命令：\"CD\"\n日期：zml84 于 2009-05-21 17:45"& C9 f: t) ~+ G' j; X
;;;)
1 p' B( h: T& L3 I(princ)

’使用 VBA IDE 中的“工具” “引用”菜单选项，选择 Microsoft Excel 9.0 对象模型+ H( W- q: ?7 o- s' h/ o8 `) X" ^# v
’水平不高，有点罗嗦，楼主可以精简下
+ }- {) D4 F% \, T6 {- d’欢迎以后交流，QQ 421230435 A9 I% D' E! ~  k6 w/ \
Public Sub 取坐标()
  ~' H9 A/ E$ U’把AutoCAD中某一图层“多段线层”中的所有多段线的坐标列出来- t$ r& ~! v- s- c% u
Dim PLSet As AcadSelectionSet& S# Z, S+ u: i! n
Dim pl As AcadLWPolyline, [3 T6 u4 W1 V5 O
1 r6 E# B* s* l: E5 k( K/ `" x

5 X) S2 d; y% M& p- B' X' a' d; rDim ExcelApp As Excel.Application
3 \0 W1 R1 q+ k4 z( Z( G, C$ ~Dim ExcelSheet As Object% O6 y! W% Q& \9 T" W3 g  b
Dim ExcelWorkbook As Object
5 s8 p  n) Z* l# h# Y- F
) z7 n* X  p) c! x
, K( u1 s" E- X% E) d; ~Dim pts As Variant8 G- ?! L3 ]/ G( ~# [! f/ k" a! T
  `9 v! B* J; J2 B: g  l
Dim NN As Integer
, b; m6 d) t/ d: D, p& V1 Y% `, ~2 m" YDim j As Integer
5 M/ C8 Q& Q6 u- T4 ]" s0 V* s
0 a. n$ f. b: g7 c( n3 j$ H. `! K! bDim pn As Integer
$ J1 a5 n4 t$ {1 z" Z. Y* c' J* m: B  ^  ^& h5 B$ T  w; b
Dim px(0 To 10000) As Double
: B! U4 J9 D& g/ m/ f, eDim py(0 To 10000) As Double
1 |- n8 m( `4 Y  D7 ADim pz(0 To 10000) As Double* y7 A. n# P& u- x

4 @9 v. ~; l! G; J5 y0 \+ ]/ q6 d6 F- y
Dim filtertype(10) As Integer! c, g- i$ M# E2 ^8 Q7 [" r
Dim filterdata(1) As Variant% d9 q: a  Q& i7 m

: x* w7 T, X0 \" u' B7 [' `/ Gfiltertype(0) = 0 ’ 选择线型
4 R; P& p# [# |9 I; P3 C& bfilterdata(0) = "LWPOLYLINE"
9 \6 v2 a- W# ^! mfiltertype(1) = 8 ’ 图层标识，可以根据具体情况改动
% I3 O  ~- S3 |filterdata(1) = "多段线层"- `) ^6 w4 d, H7 P  m$ @

+ \3 t9 z3 a8 ]9 Q
/ D1 b5 X- L  c7 Z' y7 k; i5 s) l  T
Set PLSet = ThisDrawing.SelectionSets.Add("pl")5 }; y5 k% \% I! y# c  Y
PLSet.SelectOnScreen filtertype, filterdata
0 [. n8 A/ V" s8 D2 F0 v1 a; m8 a9 Q/ l5 s' M
NN = 0
/ @) {2 \9 n# v0 q1 Pj = 0
1 t) Z; T5 y8 i9 @! c: AFor Each pl In PLSet
- n4 }" W4 Q2 g* Z8 Q0 q" o3 I5 t( f+ @5 c; M/ s, ?
pts = pl.Coordinates2 v7 V4 M  I1 r; C6 p2 ]
pn = (UBound(pts) + 1) / 2
% w$ Y) {4 r6 S9 P/ M* f0 _
; A$ Q0 s* \" N4 T1 t3 t: T: FFor i = 0 To pn - 1" }3 |7 n* ^' _4 q
px(i + pn * j) = pts(2 * i)0 G2 I3 x% i& L. P6 v0 q
py(i + pn * j) = pts(2 * i + 1)
0 V, L, s; M) l+ l& L, @% W* s, }; nNext i9 K3 R" I) }( c$ d
j = j + 1  s& C* c+ \, J$ O1 z& U% K
NN = NN + pn; q  I$ f( d7 a/ T
Next pl' P% b- m" h/ X5 s  {, _. ?
0 I" [" U/ X! u7 @5 q- P: ]
PLSet.Delete) o; Y3 [: P2 v3 x. K/ O

$ w) d, n) ^' R/ ^& S, ]6 p# W% x4 o, F" [6 z4 a3 G  f# j  `; S' ]
Set ExcelApp = New Excel.Application
7 y) E# H# r3 w# p0 N0 ~* n* g# t! d% a- U1 F& |# ?
Set ExcelWorkbook = ExcelApp.Workbooks.Add" I0 V# G! a3 ~

4 @" _3 p! O' I. T# \Set ExcelSheet = ExcelApp.ActiveSheet
6 F# x$ `" \" q7 ]
% v) n% n& T5 Z! |% z2 uExcelWorkbook.SaveAs "c:\123.xls"
* }9 @2 Z! ?  _8 t; L: K' j0 _
: @7 a2 I. {9 o5 Z! K1 IExcelSheet.Cells(1, 1) = "x"
; o7 b/ J7 h# J  l. K$ O( Z8 Y' ~ExcelSheet.Cells(1, 2) = "y"4 K; j( s' z! I% h. z" m
, G* a8 O& V: t. R9 `5 t
For i = 0 To NN - 1
/ I$ _6 \# m  EExcelSheet.Cells(i + 2, 1) = px(i)
; k& {2 z' K! U- AExcelSheet.Cells(i + 2, 2) = py(i)- \0 g8 Q3 _% U" @; {" s
Next i& f0 h1 ^3 N$ Z% l: Y) Y$ a4 O: W

$ p! \% P  w" p! L/ YEnd Sub

Function FixDimMeas(Dimension As AcadDimension) As Long  U, A/ e+ b. D4 s2 X
Dim BlockCount As Long
$ E, Z" C. _( zDim bz As Long
6 E- W0 f. L& X3 f4 V- w
3 B, ~8 r! s' M+ [) X# P6 `BlockCount = ThisDrawing.Blocks.Count
7 A* j- n# p% G4 N, a: v6 l8 }& t'遍历块中的对象，取得标注尺寸& p* h$ r5 d% d* Q4 M7 ]) R* ]& V) _
Dim EntityInBlock As AcadEntity
  m7 I) I% t% s: y5 q& p3 B/ YFor Each EntityInBlock In ThisDrawing.Blocks(BlockCount - 1)
) L9 P9 \, o) f& DIf EntityInBlock.ObjectName = "AcDbMText" Then
& X$ x0 J7 f' @* zbz = Dimension.Measurement8 e. d( S+ Y) d
FixDimMeas = bz '取得标注尺寸( n8 I: e1 Y* n8 V3 O' o2 W
Exit For
- }. F+ t6 {0 g! dEnd If
1 j/ p5 v% B9 P" u, bNext& Q0 j) V0 G7 {  D
End Function

选择CAD线条 EXCEL记录长度
# B( k' i; a- A选择“工具”\“引用”项，在弹出的“引用”对话框的“可使用的引用”列表框内，选择“Microsoft Excel 8.0 Object Library"项
+ z9 g; e% o" B% d  k/ a+ N% L7 b- l
'计算两点之间距离6 V) `& ~% U: U  \
Public Function GetDistance(ptSt As Variant, ptEn As Variant) As Double
8 z1 k* ~; |4 C. {" K' }" v    Dim x As Double/ _) l' g& D. h7 S
    Dim y As Double
* y+ p; _/ U# D. ?) F6 n# j6 ~    Dim z As Double
. J( A! a4 g) U6 m# E    x = ptSt(0) - ptEn(0)
* }! l1 g0 z1 h; _: H    y = ptSt(1) - ptEn(1)
% |5 Z$ Y3 `! b% u2 F7 B: q    z = ptSt(2) - ptEn(2)
  s% \( ^% R0 Z3 |  _: E    GetDistance = Sqr((Sqr((x ^ 2) + (y ^ 2)) ^ 2) + (z ^ 2))
# E+ j  k: s# W; D- _1 B; iEnd Function
8 L/ `- z' w% u# w ( _9 M" e1 x6 J# h% N
Private Sub xz()
% i' \' {1 h5 [4 I6 q+ O '创建选择集
' ]: S9 H1 m; i1 [- [6 h' X For JJ = 1 To 10
$ M$ z9 s4 P6 s/ H7 C' E% i If MsgBox("是否继续选择", vbYesNo) = vbNo Then" |5 W) Z, k& W4 y! _
Exit For
" P5 T  N( p  s) rElse4 X) K" E: d1 T- a, D7 p% Q
    On Error Resume Next0 T) H. h3 M+ M* W/ T3 c
    Set myyactiveDoc = ActiveDocument% @& a# i' @% f

4 G1 `6 A8 ?' w4 v8 v1 @: o2 Z; g    Dim SSet As AcadSelectionSet
3 u# E4 k- K3 [! p1 i      Set SSet = myyactiveDoc.SelectionSets.Add("Ehlxz")
2 I# p5 z% F' U; w" p' u% q/ x! b    If Not IsNull(myyactiveDoc.SelectionSets.Item("Ehlxz")) Then; f% w9 \7 k8 n+ o
        Set SSet = myyactiveDoc.SelectionSets.Item("Ehlxz"); d* z2 q4 M9 m+ T: t
        SSet.Delete     '及时删除不用的选择集非常重要
) K7 M1 m9 v6 P2 c) l    End If
! F) V" }, h+ e( e   Set SSet = myyactiveDoc.SelectionSets.Add("Ehlxz"); E1 {/ Y- `- N- a  G; ^
    SSet.SelectOnScreen0 e9 W4 \# ~+ V; n) G& b+ ^
    '创建点组8 L* N( A2 z* C! R& h- v
    Dim ptArr1() As Variant
" r  Q; H4 X6 z8 {( C: G6 J" \    Dim ptArr2() As Variant
0 f$ {4 F. X. r( P4 n$ Y! y    Dim count As Integer/ y! O7 Y: f2 h9 E2 \2 x
    count = SSet.count! [8 E. T% \4 e8 r$ E) z
    ReDim ptArr1(count - 1)
& C9 w/ r- K1 ?' W5 ?    ReDim ptArr2(count - 1)6 N' R/ w5 a) C1 }4 |5 e" g
    '错误判断, C  U1 _' B$ Q8 h+ S
    If count = 0 Then# a* x7 L+ `, x8 B8 U. o
        MsgBox "未选择任何对象！", vbCritical" e- g& \" P# v) G" G
        Exit Sub. f5 s+ J7 D1 H* E$ H0 Z
    End If
- A* B, \" L* \& N* k- t( {  k0 _6 n2 m: p7 A2 L
    '获得最左侧和下侧的角点) n* E) Q% p7 k$ a
    Dim objEnt As AcadEntity
) u3 d9 ~: R: I3 f    Dim ptTemp As Variant
- E# t: K8 W! ?4 _: }6 b3 u) k. `    Dim i As Integer
2 n8 B- i" \8 t8 x# D    i = 0
! Q7 U2 Q/ s. @! c# P    For Each objEnt In SSet: A- ]8 j# @3 K0 u% ]
        objEnt.GetBoundingBox ptArr1(i), ptTemp. E2 \0 G' `' d( m6 D
        i = i + 1
+ B2 x% H+ D6 j/ F( @    Next
# s5 h5 \8 x" I% n$ c  ~! {    '获得最上侧和右侧的角点; T; z  k4 S, E) o% t
    i = 0
4 F9 A9 V$ m% T  U6 X1 D    For Each objEnt In SSet
4 b+ {3 h* E7 g. F2 q/ ~        objEnt.GetBoundingBox ptTemp, ptArr2(i)- t6 A, o/ b1 u( v
        i = i + 1
8 O' A. X1 }( z9 }6 g    Next
5 |  ~* m# |! g! G  N) E0 N9 \    Dim ptLeftX, ptLeftY, ptRightX, ptRightY, R( V7 E0 I% |" g: t0 s- N
    Dim ptRight, ptTop  Z0 c  U9 D3 n: }$ K4 U
   For WWW = 1 To count" I0 p6 ]+ [* h* Q7 u" f) d
      ptLeftX = ptArr1(WWW - 1)(0)/ p# e5 C0 L+ e, s: Y5 i3 k
      ptLeftY = ptArr2(WWW - 1)(1)
) n! w5 ]3 l1 y$ m      ptRightX = ptArr2(WWW - 1)(0)% W; m2 N7 I' b; j! P9 \9 }4 ]
      ptRightY = ptArr1(WWW - 1)(1)
! F+ V/ k& k8 O) X8 C
( o  y+ i* ]: _4 Z$ a, W# u- k    Dim pppt1(0 To 2) As Double8 O: C; t% a- }( I/ \' M
    Dim pppt2(0 To 2) As Double
2 s& E  J, z% d        pppt1(2) = 0, h8 D, Y& ?7 d# ?5 K
        pppt2(2) = 0
/ g1 U2 d5 O' h4 ^4 [* O; ?    Dim gzkuan As Double, gzgao As Double; a5 b/ w; M: f$ |+ f. b
     gzkuan = (ptRightX - ptLeftX - 25 * (Int(Val(HjigeCb.Text)) - 1)) / Int(Val(HjigeCb.Text))- u! X& f0 \. K- V( D  J; n9 g- f( x
     gzgao = (ptLeftY - ptRightY - 25 * (Int(Val(SjigeCb.Text)) - 1)) / Int(Val(SjigeCb.Text))" i6 }3 j5 |/ j' b
    For j = 1 To Int(Val(HjigeCb.Text))
% r8 L# q  A  }7 W+ m  T+ O* C# a. X      For k = 1 To Int(Val(SjigeCb.Text))
2 a% t6 O7 b$ |, }! |        pppt1(0) = ptLeftX + (gzkuan + 25) * (j - 1)
2 m. _& U! I, o, t! A, Z         pppt1(1) = ptLeftY - (gzgao + 25) * (k - 1)2 `) x, y, W$ I' L# E) I( g! j) R
         pppt2(0) = pppt1(0) + gzkuan/ B% |) j! Z) K
         pppt2(1) = pppt1(1) - gzgao
2 A5 x- D% p, G7 a8 B& ~
6 |* U* a1 `2 ~( U) V3 v/ @      Next
# g" b* H. e% n, @  d- u7 }- H' T    Next- w! k. J% \8 o; ?$ d
         pppt1(0) = ptLeftX6 E! q' {5 o' o. x
         pppt1(1) = ptLeftY1 t" N2 Z4 }- g& J
         pppt2(0) = ptRightX
8 `' ]& `# c, b/ j6 X         pppt2(1) = ptRightY7 _. ]2 n4 ?+ w& D  ~; @% B
  Next: e, i9 `4 C; h8 e
    SSet.Delete7 @( Q; M& M) r# Z
    KK = GetDistance(pppt1, pppt2)
/ x- u- ]9 y. P1 i; s9 ~: z  M'在程序中操作EXCEL表常用命令:
& n2 E; |" R& W: }. V  Dim Excel As Excel.Application
1 d7 U3 \. \4 C  ^3 V. ^8 w. t    Dim ExcelSheet   As Object- x# r  @. F# a
    Dim ExcelWorkbook   As Object
4 c; Y) I; P5 r! k5 Y    '创建Excel应用程序实例
5 q3 z/ W! H, e5 C& ^0 W3 h    On Error Resume Next) ~$ N' o$ D7 I$ T
    Set Excel = GetObject(, "Excel.Application")
! S) w' w! j- ?' g5 v    If Err <> 0 Then
* p  Z4 U4 U! [9 [6 i3 C        Set Excel = CreateObject("Excel.Application")
) F9 H6 \7 I" @4 J$ Z1 W           '创建一个新工作簿2 O7 `2 y# A( E: _7 \3 t
         Set ExcelWorkbook = Excel.Workbooks.Add& m$ C: M4 f7 U. q- H5 Q: f  [
          '令Excel应用程序可见
, Q. }. |  w) S& Y! X2 _2 v' l           Excel.Visible = True
( l' V* s: s' Q. k$ B" q. [$ o          '将新创建的工作簿保存为Excel文件
2 n# q4 j" s% D" u$ g             ExcelWorkbook.SaveAs "属性表.xls", R! g! y7 r. t
    End If9 w5 B7 p& J3 T: F) h9 K
    '确保Sheet1工作表为当前工作表  d. Y/ s3 Q$ e. D" O0 ]
    Set ExcelSheet = Excel.ActiveSheet) P/ C: Z  q7 u1 P7 E
    Excel.Visible = True  `; M+ O/ r" l9 {: Q
    endrow = ExcelSheet.Range("A65536").End(xlUp).Row + 1$ z- w3 N  r- q; D5 v
    ExcelSheet.Range("A" & endrow) = KK- P9 q0 W/ J7 u& R, v" D8 U# N* B
    Set Excel = Nothing
% r; ]' Q8 g( l- T) X9 s  a    End If' w5 x+ V% h8 I3 Q
  Next; [8 u7 ^5 X# E1 [8 s4 l1 F  ?2 L3 n
End Sub( U5 n7 _; Q( A! `8 u, m) Q

% k1 }2 v1 n( m  S- s