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

在EXCEL VBA编辑器的“工具”菜单中点“引用”，在“引用”对话框中找到ACAD类库，勾选它，确定。见图" ?6 l' n" [( \3 T( ]5 a: ~
4、在EXCEL VBA编辑器Sheet1对象代码窗口写如下代码
  a8 D3 k' C% e8 v1 n6 LSub A()
& S7 Y/ Z2 F5 o9 m% Z( c1 u" A8 E1 U8 o9 T3 n
Dim CAD As AcadApplication '声明一个AutoCAD应用程序对象
" I+ D: H/ p& UDim DOC As AcadDocument '声明AutoCAD文档对象
! _: {4 ~" Z; H. v+ Z9 mSet CAD = New AcadApplication '运行一个新的AutoCAD进程
- u3 J7 ?! `& c9 SCAD.Visible = True '使运行的AutoCAD程序可见。如果没有这行，程序将不可见，就是说看不见CAD窗口，只能在Windows任务管理器看到有CAD程序运行
+ J0 C' n/ R6 e0 L! d, uSet DOC = CAD.Documents.Open(Sheet1.Cells(1, 1).Value) '按照“Sheet1”工作表第一行第一列单元格的内容打开文件
  [+ @# y' O9 P3 f) i; NDOC.SendCommand Sheet1.Cells(1, 2).Value '按“Sheet1”工作表第一行第二列单元格的内容向CAD命令行发送命令: F$ ?5 `- G5 w/ {
sub

;;;=================================================================*
# Z1 J' _; f: x- B; b  {;;;功能：测量线的长度 *
+ B$ G' L" |; z6 u8 _3 m;;;日期：zml84 于 2009-05-21 17:45 *
* c9 X* K, z% x  `. g& e( e(defun C:cd ()' |' Y  h/ s# m% S
(princ "统计线段长度"
" A7 m% i& K: D6 i1 j$ Z- w0 g(if (setq SS (ssget '((0 . "LINE,ARC,CIRCLE,ELLIPSE,*POLYLINE,SPLINE"))* k% \' E( O) m' H
)9 \0 v: N7 g4 x* p0 a
)
9 C5 u- x8 ~0 h, X(progn
0 g' ~/ H1 T* x& `  };;$ r- s' _6 b3 [* O5 d0 D
(setq LST_LEN '()5 t' `+ I' F" n. K; v- i2 m
I 0
. z" `- t; W, X  b0 x1 V)! h3 ^* V$ G# q
;;逐个统计4 P$ q/ P  Z$ q
(repeat (sslength SS)3 v& A6 ~% y- L  S$ B8 _$ N, J, H
(setq EN (ssname SS I)" J5 C% ]) q! K  Y, x8 _6 x( v3 L  l
LEN (vlax-curve-getdistatparam
5 l* v! t2 z+ ^( o6 j0 bEN
+ {0 [) i/ }- `( H: a8 b& v" s(vlax-curve-getendparam EN)& ]+ w/ c( x3 B; K
)' v$ Z& f$ ~8 e) i
LST_LEN (cons LEN LST_LEN)
5 |% |& G! A( s6 x3 G# y: T6 ~I (1+ I)0 C8 M% u9 M% D
)
- o3 M$ K+ c5 T3 e, @% B) 7 j) S) G% J$ v$ _5 F
(setq LST_LEN (reverse LST_LEN))  U" b. ?/ ]& l6 r+ q) j
;;显示输出
2 X4 ^5 B$ ~+ v& d8 y(princ "\n找到个数：")/ ?2 V" k" {7 e# U8 g  H+ f
(princ (sslength SS))9 p9 D: z; [+ |1 d8 r' i4 v+ l
(princ "\n单个长度：")
1 z7 E1 W" }+ P# m3 }: Z(princ LST_LEN)- e9 i2 j' M( f8 W( H9 u6 T+ r
(princ "\n总计长度：")+ `7 A! V. F4 z/ T, t' x- u, ?
(princ (apply '+ LST_LEN))& G( v: f  K7 P. T6 P% P
)
4 L% U7 V' L, w- K) T! j0 g" J)
& J: l. [$ \8 t( o; _2 {/ `(princ)
* K# J7 z6 B6 U+ O- \; ])
/ w3 m7 X- @7 d9 y3 Z: j! ~;;;=================================================================*7 Z5 u& s/ h: a* {2 S
;;;(alert
0 O" z3 q; ?3 `) A8 c9 W;;; "功能：统计线段长度\n命令：\"CD\"\n日期：zml84 于 2009-05-21 17:45"
; j( k+ K+ |% A- ^4 g;;;)
, z! h8 z% ~7 i- \! @(princ)

’使用 VBA IDE 中的“工具” “引用”菜单选项，选择 Microsoft Excel 9.0 对象模型9 ^  \0 W$ O& r- u: t6 N! J
’水平不高，有点罗嗦，楼主可以精简下# i8 C, A3 k+ z  W/ j0 M
’欢迎以后交流，QQ 42123043
  O4 b8 ^: O  Y+ TPublic Sub 取坐标()
, J8 H/ v3 ]5 n2 e’把AutoCAD中某一图层“多段线层”中的所有多段线的坐标列出来
6 o! I9 F( b1 y. a3 q$ Z$ @Dim PLSet As AcadSelectionSet
" v7 J/ q0 `) Z; D1 x3 R* `Dim pl As AcadLWPolyline
  N" y1 l. A% O. A
) L! t8 t4 d) d6 R
, x, w. ]1 w$ G9 V$ J: O" |& eDim ExcelApp As Excel.Application7 C2 S# r3 D8 Z7 Y# G8 @& l
Dim ExcelSheet As Object
  I! S4 K& }( k( A: p  Y5 ^3 y3 hDim ExcelWorkbook As Object
- k  v/ g- }. K  t" R) f- f' f% R, k9 e8 E7 p* E5 L8 F/ v2 M
7 C% z0 S$ ?9 v, A
Dim pts As Variant
0 Z2 J9 t/ ~9 T9 `0 F
9 k( E. D7 e% \7 TDim NN As Integer; M; j  E& x8 \; y1 k% B/ i/ ]7 W
Dim j As Integer
4 {6 C* B- f+ l$ ^' B: v
( o* N. I3 Q: ~. F7 _Dim pn As Integer/ d2 D4 n6 J/ b' T
5 x- P: ?* u+ i9 \$ j5 q2 x7 A3 c2 f3 e
Dim px(0 To 10000) As Double
. f' P  ]4 C7 A1 QDim py(0 To 10000) As Double
! Y1 F) p4 `$ eDim pz(0 To 10000) As Double
5 ?2 d6 O; X2 d( E. Q% f
" n, V/ H7 o! L" [
) g6 P! c1 C3 F: B" Q- A& iDim filtertype(10) As Integer
2 v5 S: R9 e# D+ w$ v8 n' a- |& aDim filterdata(1) As Variant: q; L4 Y. }+ w- J# X

. h' p# g% U- ?filtertype(0) = 0 ’ 选择线型
- t; w0 d- J, j) k( g- ^* hfilterdata(0) = "LWPOLYLINE"
0 V6 y$ B+ G9 f; yfiltertype(1) = 8 ’ 图层标识，可以根据具体情况改动
( b( v5 |  m! X% `( Xfilterdata(1) = "多段线层"9 L% ]$ F: ?( C- ?0 L
8 Z5 R- ^" u( @0 |' ~
' l3 v7 Q. Q& l. r0 B
6 J9 U4 B" F5 x) X
Set PLSet = ThisDrawing.SelectionSets.Add("pl")7 T* d6 i* M0 F/ |, w- T% M2 N
PLSet.SelectOnScreen filtertype, filterdata8 O, n) L" a9 T& Z4 F$ p% P

# A  q, e0 L' J, P5 ]4 A; Z/ j6 t# WNN = 03 l5 x% B" N) r0 D3 K0 R& o
j = 0/ ?6 {, A9 p3 d9 c, V3 @+ q1 P
For Each pl In PLSet' p, @! E5 U/ g+ Y- E
' k# ~- u& i: p5 ~# p; }4 ^
pts = pl.Coordinates3 m% \6 f; C, ?
pn = (UBound(pts) + 1) / 2
+ S  W, r. F% Y
  ~4 s  j4 \5 U9 R- _2 ?For i = 0 To pn - 1
/ E3 I+ r( v/ epx(i + pn * j) = pts(2 * i)
& m2 v3 j) b: ]2 A) n1 vpy(i + pn * j) = pts(2 * i + 1)7 b4 Q" ~& h5 @3 L) \% U3 i
Next i, G$ v. G; s& J, I8 \# e! ]7 s
j = j + 1. l+ R: }( m% |. X9 i+ d
NN = NN + pn, V4 |: E& d8 F( W0 i4 u
Next pl
& ^* K) A7 ]% T- T  X
; r& @! Z# d% ~PLSet.Delete6 f& v# K$ _7 f6 I( e
3 \( Z: Y' H+ ~: ^2 j6 e

/ `2 L8 V1 o3 xSet ExcelApp = New Excel.Application
" ?& Z. p6 [- X% O5 j7 A9 R) Y3 }7 Z
Set ExcelWorkbook = ExcelApp.Workbooks.Add
: ~: j  u% ^2 A  v# C8 ^
" I2 w; f. \: D2 {* d  A$ ~8 v7 Q1 tSet ExcelSheet = ExcelApp.ActiveSheet% C4 v* a. O% {/ E
+ z5 `8 [4 |8 l
ExcelWorkbook.SaveAs "c:\123.xls"0 a2 u5 T3 a( i( |; ]% j. H- e

* g8 q- O* h% P( V3 x# E& oExcelSheet.Cells(1, 1) = "x"; k3 i7 T' v' M
ExcelSheet.Cells(1, 2) = "y"4 H0 d7 y: ?/ {5 U7 x2 O: B
. P' d* E$ T/ S& ^
For i = 0 To NN - 1
3 h% e. t: X% P2 {ExcelSheet.Cells(i + 2, 1) = px(i)% ]) s( K0 q% `, i
ExcelSheet.Cells(i + 2, 2) = py(i)
. i4 @& k( j7 Z; sNext i8 S; g% d  ~; w0 M$ O* r" J6 ]# I
; e  w. |( \+ Y2 x
End Sub

Function FixDimMeas(Dimension As AcadDimension) As Long
# _8 _/ Q6 I2 U& e! J5 a* r, `Dim BlockCount As Long$ m" V$ M+ f7 N2 V2 Z
Dim bz As Long
/ f& k: B$ ~) X+ ?0 Y# B7 u5 h& \1 L% D0 `
BlockCount = ThisDrawing.Blocks.Count/ s9 }: k3 P. r
'遍历块中的对象，取得标注尺寸
- S! }, r% V; U9 xDim EntityInBlock As AcadEntity- R" ~2 u! O2 e: s* _
For Each EntityInBlock In ThisDrawing.Blocks(BlockCount - 1)# _4 K+ W9 L" J, p: G
If EntityInBlock.ObjectName = "AcDbMText" Then
0 v( j, s- l" G4 k5 v6 X# R9 ?) xbz = Dimension.Measurement# u9 [5 b% g1 H
FixDimMeas = bz '取得标注尺寸
+ z9 @' T. j/ ^) ^Exit For
8 `' n" w8 D  L7 D! }End If
! J  q8 k( }. tNext. W3 [2 N" ~: ?
End Function

选择CAD线条 EXCEL记录长度
+ b- k; w7 x9 [选择“工具”\“引用”项，在弹出的“引用”对话框的“可使用的引用”列表框内，选择“Microsoft Excel 8.0 Object Library"项
- ?* Y* n# j3 z7 a1 k% Z/ P2 t
; u/ J5 p6 |- [. _9 ?'计算两点之间距离
# Q: |( v$ ^( T% l% iPublic Function GetDistance(ptSt As Variant, ptEn As Variant) As Double
" v. f' r' I- t4 n' E: ~9 ?    Dim x As Double
$ u2 N9 {' Y+ q" `; l9 ?0 @    Dim y As Double- Z! R7 D8 I. H
    Dim z As Double# ^. ?. L9 ^6 i1 x! ]# Z
    x = ptSt(0) - ptEn(0)6 v, O# f9 ^# F( `, f2 O9 }
    y = ptSt(1) - ptEn(1)
5 |* _: U" L! I    z = ptSt(2) - ptEn(2)2 B8 H$ |- |7 C4 G* c/ i3 a* b
    GetDistance = Sqr((Sqr((x ^ 2) + (y ^ 2)) ^ 2) + (z ^ 2))
6 w0 Q) e+ j  v* pEnd Function
( C; w) a4 R8 D( ^
, e. c0 G2 V7 N5 O8 ^( fPrivate Sub xz()
$ v8 Q; E$ y. R  k- o0 i '创建选择集
5 V) i7 `9 v+ T- |: o+ f* J For JJ = 1 To 10
7 _8 \# \4 H9 Y2 ~ If MsgBox("是否继续选择", vbYesNo) = vbNo Then- g/ Q2 H: c: ^$ P/ w9 O( z! @
Exit For6 [- ]0 D. R/ E" D9 O, P/ U
Else3 }  y. H2 J5 e' Q2 W+ s
    On Error Resume Next
: U! N9 r  x$ ]" Q, x1 b. U  I    Set myyactiveDoc = ActiveDocument
1 h1 H" k9 m4 c1 d% M' O6 N3 q+ [5 B1 B
    Dim SSet As AcadSelectionSet
9 O9 ~3 R* k+ W* P9 n, F- v      Set SSet = myyactiveDoc.SelectionSets.Add("Ehlxz")7 u& R8 L6 ?2 H( r" L" g
    If Not IsNull(myyactiveDoc.SelectionSets.Item("Ehlxz")) Then) ^7 n6 O& a' b& a
        Set SSet = myyactiveDoc.SelectionSets.Item("Ehlxz")8 I( g/ i+ R8 E
        SSet.Delete     '及时删除不用的选择集非常重要. O0 X7 u; G+ _+ d% ?+ o) m) |7 I
    End If' d2 s8 ~! |" W% M) E
   Set SSet = myyactiveDoc.SelectionSets.Add("Ehlxz")
1 g! R; N4 ~4 y    SSet.SelectOnScreen
) Q: a9 c1 T  Z* p    '创建点组
0 O1 G9 |& ?, t' {3 z    Dim ptArr1() As Variant' m3 `% M+ ~, a7 ]
    Dim ptArr2() As Variant
' v- D8 s6 |" U$ Y; p    Dim count As Integer" Z& p& N4 l5 D- E$ m9 Z% z
    count = SSet.count5 ]8 f% O9 O( R0 q; Q- A& O5 O% b0 T
    ReDim ptArr1(count - 1)! Z. _% F; c/ l* V, m+ q
    ReDim ptArr2(count - 1)# \6 |+ p$ g/ k; D7 S* N
    '错误判断
" x7 T7 k. P' T. J/ ?# M( J+ X    If count = 0 Then* q6 Z* x6 l* E% r* S
        MsgBox "未选择任何对象！", vbCritical
2 P/ S9 D4 D# `        Exit Sub! H2 ]3 n: I& j, ?
    End If4 U. I/ C. L9 v( y& e* H
! [, ~, j8 d6 y
    '获得最左侧和下侧的角点0 E' `1 T1 ]' W$ J
    Dim objEnt As AcadEntity% n. M1 G0 Y* B1 [1 o
    Dim ptTemp As Variant! A8 Y/ m& Q$ e! B8 J6 P; Z/ ?. V8 L
    Dim i As Integer2 W* O) p: Q/ {/ c6 \( _: b
    i = 0
( H; @. |  ?8 N    For Each objEnt In SSet
" p' N& Y" `+ b0 a) q0 _        objEnt.GetBoundingBox ptArr1(i), ptTemp# K$ r$ m$ V; A5 ~2 L
        i = i + 1. M. G# X# m8 K/ s: J" W9 w
    Next
/ w0 ?+ V0 x4 o6 U; b    '获得最上侧和右侧的角点9 E0 ~' L$ g! S/ q6 B! m! @" |0 A5 Y
    i = 0
9 X1 y+ f8 H" S; h' F8 o2 R' M+ ~    For Each objEnt In SSet
, x, p3 m0 _9 v# R% P# [        objEnt.GetBoundingBox ptTemp, ptArr2(i): C$ r- D$ Y% Q' U% }
        i = i + 1- T; _& `: u8 Q, Q  u+ ]: z
    Next
& ?. ]8 O4 C5 v* l% E3 f    Dim ptLeftX, ptLeftY, ptRightX, ptRightY  h* U* Y/ s# j* B; k3 z
    Dim ptRight, ptTop9 l& G$ y2 M. ?. m0 [% t0 v
   For WWW = 1 To count0 u7 k$ O( z0 w
      ptLeftX = ptArr1(WWW - 1)(0)
  s2 g. ?! ]! K0 a3 P! n) f      ptLeftY = ptArr2(WWW - 1)(1)
: _9 @' u3 ~. \; {+ ^8 q$ p8 R1 f( C. l      ptRightX = ptArr2(WWW - 1)(0), M2 X" J  _$ {" l3 M$ u+ q
      ptRightY = ptArr1(WWW - 1)(1)
( ~$ g/ `9 B$ z0 b7 x+ t0 n
, n9 u" W, l2 I8 q: d- s    Dim pppt1(0 To 2) As Double- @  {, U' H2 w; A1 {
    Dim pppt2(0 To 2) As Double! r, ?8 @  c, d9 o5 f' T9 R' s5 k
        pppt1(2) = 0& h. x4 ^: f: }0 q5 a1 ^3 L; k
        pppt2(2) = 0
) q8 M5 S7 m$ Q; S; C$ O    Dim gzkuan As Double, gzgao As Double
. f) h+ O* s5 d7 a     gzkuan = (ptRightX - ptLeftX - 25 * (Int(Val(HjigeCb.Text)) - 1)) / Int(Val(HjigeCb.Text)): l  ^- J; R3 I' V- F& h
     gzgao = (ptLeftY - ptRightY - 25 * (Int(Val(SjigeCb.Text)) - 1)) / Int(Val(SjigeCb.Text))
' c3 W& S1 P$ G: h: [    For j = 1 To Int(Val(HjigeCb.Text))
) c  z  F4 i9 g: O& g6 _2 u/ W      For k = 1 To Int(Val(SjigeCb.Text))
: s' C1 L) u, @4 Q        pppt1(0) = ptLeftX + (gzkuan + 25) * (j - 1)
  M* V- L) u4 L' U% V         pppt1(1) = ptLeftY - (gzgao + 25) * (k - 1)$ d0 Q. ~* Q3 z9 B6 e
         pppt2(0) = pppt1(0) + gzkuan
$ l. O, F2 c, Y. ^, [: T$ l; P  {         pppt2(1) = pppt1(1) - gzgao
* G; b, w  c% E+ m* o" ]
/ B  T! {7 K6 K- X5 g7 N5 `+ c: s: }7 Y      Next
& I5 v4 t# N7 n/ {1 Y7 ^' H/ l$ Q- `! m    Next  {% Z  l& Z" Z9 K2 K! b& _6 K
         pppt1(0) = ptLeftX! K( D( Q' L: V
         pppt1(1) = ptLeftY) Z; k( a& u; i4 u" D$ j% w
         pppt2(0) = ptRightX
( D5 s6 S1 k$ c3 V3 C" e         pppt2(1) = ptRightY9 @8 r9 t/ m- D
  Next8 o9 Y; b6 Y# v! `8 S
    SSet.Delete2 B) w/ M, Z- S9 Y& u; W
    KK = GetDistance(pppt1, pppt2). u" B; W( a+ F
'在程序中操作EXCEL表常用命令:0 R3 k0 _# q+ ?$ E& _7 t) ]
  Dim Excel As Excel.Application
3 q$ I, u' ^2 V. ^9 ~, e8 u8 r" V    Dim ExcelSheet   As Object8 P3 `3 |: K0 I" ]& b" Z" a& \* a
    Dim ExcelWorkbook   As Object( z/ d4 L; y2 b6 w7 `1 a
    '创建Excel应用程序实例' @7 _0 @/ j+ l- I7 L  O0 P" D
    On Error Resume Next
7 Q  @7 Y" l5 {6 j) B# `: j    Set Excel = GetObject(, "Excel.Application")0 A" N1 f0 V+ h( n; M8 e
    If Err <> 0 Then9 ~8 @' ^7 l. F
        Set Excel = CreateObject("Excel.Application")
0 s+ F' H! M! Z/ o; u% n/ A           '创建一个新工作簿& D, H8 v. T7 M1 N, s0 E( Y, z
         Set ExcelWorkbook = Excel.Workbooks.Add2 j9 C' P# t7 ~/ g( c$ J
          '令Excel应用程序可见8 v5 m3 u. N* _/ J5 P$ a- G+ S  e
           Excel.Visible = True/ }4 v  [9 P" I8 m' c3 ]' V, d
          '将新创建的工作簿保存为Excel文件
2 o6 U* h) g' h8 }& J  o             ExcelWorkbook.SaveAs "属性表.xls"$ n2 Y- X, c% ~  V7 o) d
    End If
# T% r5 h% f: K, D+ X6 c& |    '确保Sheet1工作表为当前工作表
: i) M1 ~, @: k* q- j    Set ExcelSheet = Excel.ActiveSheet
5 l+ o' x$ C6 K3 \3 _, O    Excel.Visible = True
' ?# c% t2 _) Y2 S5 R7 i    endrow = ExcelSheet.Range("A65536").End(xlUp).Row + 15 Z! a+ b# b$ I9 o
    ExcelSheet.Range("A" & endrow) = KK
; _! y- l! B: f$ u* H    Set Excel = Nothing- T2 M3 \% n+ ?( ~0 i
    End If% F7 M+ ^+ Q" T, @
  Next: F4 Y& H, o+ y% `
End Sub9 [6 Q" N) i; ~+ @4 ]

* I0 c8 \$ V# [" b! U- W