excel如何得到线的长度?

sblisb

我想在excel中操作,得到打开的cad文件中择的线的长度,然后写入excel表.
其中选择效果就象在cad中选菜单下的"工具_查询_列表显示",选择后按空格或回车,得到线的长度就分别写入excel表中A列了.
在网上搜索了两天,得到如下代码,偶vba不好,请哪位高手帮我整合下,谢谢!
3 j/ ^$ m- ?& X! U% z+ h4 }0 O4 Yexcel中操作cad请参考下面的步骤：

在EXCEL VBA编辑器的“工具”菜单中点“引用”，在“引用”对话框中找到ACAD类库，勾选它，确定。见图
6 i3 F  V8 n1 O4 ^* Z4、在EXCEL VBA编辑器Sheet1对象代码窗口写如下代码
Sub A()
8 R, w8 Z; e7 ^, Z; E+ a" U
( A  X: b$ ?1 X0 L, \Dim CAD As AcadApplication '声明一个AutoCAD应用程序对象
Dim DOC As AcadDocument '声明AutoCAD文档对象
Set CAD = New AcadApplication '运行一个新的AutoCAD进程
CAD.Visible = True '使运行的AutoCAD程序可见。如果没有这行，程序将不可见，就是说看不见CAD窗口，只能在Windows任务管理器看到有CAD程序运行
; ?# e, O; I, {& Q9 fSet DOC = CAD.Documents.Open(Sheet1.Cells(1, 1).Value) '按照“Sheet1”工作表第一行第一列单元格的内容打开文件
  i/ D8 u. Z( E: S3 H* M: O8 ]DOC.SendCommand Sheet1.Cells(1, 2).Value '按“Sheet1”工作表第一行第二列单元格的内容向CAD命令行发送命令
sub

;;;=================================================================*
;;;功能：测量线的长度 *
;;;日期：zml84 于 2009-05-21 17:45 *
, w7 n% M& u8 Q! d" v% y(defun C:cd ()
(princ "统计线段长度"
+ e( [  s& z' y6 V9 X" {' D) p(if (setq SS (ssget '((0 . "LINE,ARC,CIRCLE,ELLIPSE,*POLYLINE,SPLINE"))
: D6 ?1 U+ q. f* r8 ~1 M4 S  n)
! e# O7 }/ v! a3 w1 p6 E" _6 c  I)
  S3 F# H' r* h3 G$ F(progn
;;
4 O' x7 Y) O6 x5 ^# {7 C  m(setq LST_LEN '()
2 r4 j# _6 y8 ]( DI 0
; T- j( k2 n& P4 R)
;;逐个统计
) k7 T) _1 z9 H* m8 L: ~4 v(repeat (sslength SS)
(setq EN (ssname SS I)
& S1 Q  R1 {) A2 J% P# yLEN (vlax-curve-getdistatparam
: d% w+ Y# p% r% B/ Z. E6 NEN
5 w" X+ O0 f8 k. {! R0 }(vlax-curve-getendparam EN)
)
  y% |7 X- Z+ \: r4 vLST_LEN (cons LEN LST_LEN)
# h( D5 M, b6 m& Q; N* dI (1+ I)
)
)
. F+ N8 W" q2 ]& o5 l8 ?(setq LST_LEN (reverse LST_LEN))
5 R; a9 P, i4 J9 s2 z;;显示输出
(princ "\n找到个数：")
/ J3 ~- f4 ?4 A8 D  x2 J$ E* Y) c(princ (sslength SS))
(princ "\n单个长度：")
9 l9 p, ]3 Q7 q" x! I0 x(princ LST_LEN)
(princ "\n总计长度：")
& p, M3 F- m; [% }7 u(princ (apply '+ LST_LEN))
* r( ~6 q5 D3 k$ ]+ N% Z3 u)
)
(princ)
6 [8 n; r  J% I)
;;;=================================================================*
! u. S( ~' ^% K# F& Q;;;(alert
;;; "功能：统计线段长度\n命令：\"CD\"\n日期：zml84 于 2009-05-21 17:45"
+ I; Z' S- D  U+ W# g4 o, j$ J% j" {7 ]6 A;;;)
/ y& Q/ v; c! f2 E2 r" t# P% Q2 R(princ)

2 L6 G: j, F5 T; q: P( E5 D
’在AutoCAD中编程序，写到c盘根目录下的“123.xls”Excel表格中

’使用 VBA IDE 中的“工具” “引用”菜单选项，选择 Microsoft Excel 9.0 对象模型
’水平不高，有点罗嗦，楼主可以精简下
’欢迎以后交流，QQ 42123043
% ~) m- ]# m* i% @Public Sub 取坐标()
’把AutoCAD中某一图层“多段线层”中的所有多段线的坐标列出来
Dim PLSet As AcadSelectionSet
Dim pl As AcadLWPolyline

" Z, X8 k% S1 l/ b
- m  g2 v: e; l7 mDim ExcelApp As Excel.Application
Dim ExcelSheet As Object
8 a1 y. U/ O. _& r- M8 ]Dim ExcelWorkbook As Object


* N# b$ L) @$ ^0 oDim pts As Variant

Dim NN As Integer
  j5 c% M: e  C6 h( VDim j As Integer
: ~- j* x) H3 r& W
- C+ @) {/ Q8 FDim pn As Integer
. l! N, Z% k2 h" V! l. C( f7 B
+ a1 g  i; f+ E; C9 {Dim px(0 To 10000) As Double
Dim py(0 To 10000) As Double
Dim pz(0 To 10000) As Double

& O4 |5 O: @  D6 s9 O
+ \) |' A2 W, D6 h/ H5 \7 ADim filtertype(10) As Integer
Dim filterdata(1) As Variant

/ K$ R2 S$ R8 E% }2 @$ p, wfiltertype(0) = 0 ’ 选择线型
7 E# B0 v* I( J" l! vfilterdata(0) = "LWPOLYLINE"
filtertype(1) = 8 ’ 图层标识，可以根据具体情况改动
+ Q1 h  M/ o4 d# S/ \) e8 [filterdata(1) = "多段线层"
- O  i2 [" U$ w( G2 I/ a; g
$ d/ c5 T# V: {8 \) k5 b

5 z; m7 S) }; j4 Q% O" ySet PLSet = ThisDrawing.SelectionSets.Add("pl")
PLSet.SelectOnScreen filtertype, filterdata

6 Z; z, _0 K& ~9 c  n* gNN = 0
j = 0
For Each pl In PLSet

pts = pl.Coordinates
" C" D( e% `9 w, ppn = (UBound(pts) + 1) / 2
" K# g; ^7 ~" S2 l0 Z
For i = 0 To pn - 1
px(i + pn * j) = pts(2 * i)
py(i + pn * j) = pts(2 * i + 1)
Next i
j = j + 1
NN = NN + pn
2 ~% q6 n/ T+ f4 m2 i* s  j- N* RNext pl

; F0 S5 e* b' H3 c. D/ D2 gPLSet.Delete
8 D! T* w( W/ A8 Z6 a- H
8 X6 g  |! e' T
Set ExcelApp = New Excel.Application
* O4 k  C2 K- \. x
# m# g8 ~3 ?- K3 g4 N9 g1 m+ BSet ExcelWorkbook = ExcelApp.Workbooks.Add
% B: e& B) i& K& g1 _6 a) M  O
+ w6 I" P; p1 L2 NSet ExcelSheet = ExcelApp.ActiveSheet
1 T0 S* a2 u" {
. C% t; c) L  }1 e1 ?% ?ExcelWorkbook.SaveAs "c:\123.xls"

ExcelSheet.Cells(1, 1) = "x"
, v' T; T- j7 HExcelSheet.Cells(1, 2) = "y"

For i = 0 To NN - 1
ExcelSheet.Cells(i + 2, 1) = px(i)
1 W; u6 Y3 C7 o5 h7 D. J4 gExcelSheet.Cells(i + 2, 2) = py(i)
6 u6 i% K9 S$ q% ZNext i
4 w1 H$ P8 M4 p4 O
End Sub

其实，从Excel里面操作，完全也可以实现
+ G2 k  P7 k( C: t7 R只需在excel的 VBA IDE 中的“工具” “引用”菜单选项，选择 AutoCAD 2004 Type Library 对象模型
4 G9 {! Z4 o* i+ E然后类似的思路编程即可，大家可以试试！
; z! y9 O( T6 o, x) I" ~" H0 c
获取标注尺寸函数
1 l& _) z# e+ }2 p
1 J0 G* s1 Q5 h) D/ E

Function FixDimMeas(Dimension As AcadDimension) As Long
Dim BlockCount As Long
2 [' A& T9 ?. D9 d, G' B& uDim bz As Long
; d- ^- p3 x) h4 W+ V7 n) {0 b
BlockCount = ThisDrawing.Blocks.Count
6 e5 S* \3 o  Q& \8 f; c'遍历块中的对象，取得标注尺寸
) N3 @3 T* X$ @; S8 a; iDim EntityInBlock As AcadEntity
# J5 d# G/ b0 }" Q2 dFor Each EntityInBlock In ThisDrawing.Blocks(BlockCount - 1)
If EntityInBlock.ObjectName = "AcDbMText" Then
bz = Dimension.Measurement
' J& K' A. t0 o# _, PFixDimMeas = bz '取得标注尺寸
Exit For
6 h8 g5 o% y. @; Y3 LEnd If
) I2 t8 U0 e6 ~8 o6 P  DNext
( H$ z$ ]8 J7 H( h' n/ ?/ E: gEnd Function

sblisb

这段是在cad中执行,写入excel,偶想改成在excel中执行,写入表
) ]  s& x+ a7 S8 C' r

选择CAD线条 EXCEL记录长度
选择“工具”\“引用”项，在弹出的“引用”对话框的“可使用的引用”列表框内，选择“Microsoft Excel 8.0 Object Library"项
# A8 j0 z; l' s
/ h3 C% X9 Q! J; r  O6 ~- T'计算两点之间距离
Public Function GetDistance(ptSt As Variant, ptEn As Variant) As Double
- U$ U8 }2 z' A6 y5 A    Dim x As Double
    Dim y As Double
+ e9 E+ o% f; B: m, v    Dim z As Double
    x = ptSt(0) - ptEn(0)
' I+ B$ {" ?* U! a2 s0 J  C    y = ptSt(1) - ptEn(1)
    z = ptSt(2) - ptEn(2)
& c5 A: {% e) M* k' g" W    GetDistance = Sqr((Sqr((x ^ 2) + (y ^ 2)) ^ 2) + (z ^ 2))
8 c) d& h4 m( t" P. D$ zEnd Function

Private Sub xz()
" D+ j4 w9 s: q4 ? '创建选择集
5 [* y5 T$ z; K/ Q$ O' f% P For JJ = 1 To 10
1 y& s( J$ Z5 N1 s+ f If MsgBox("是否继续选择", vbYesNo) = vbNo Then
2 d( _; ?- t1 d  r5 { Exit For
Else
    On Error Resume Next
    Set myyactiveDoc = ActiveDocument

    Dim SSet As AcadSelectionSet
, u4 y/ N* H3 Q8 P0 ~      Set SSet = myyactiveDoc.SelectionSets.Add("Ehlxz")
) I3 f' ?2 n, [8 C. l4 {% g/ n    If Not IsNull(myyactiveDoc.SelectionSets.Item("Ehlxz")) Then
6 ^9 k. f+ S1 d3 v1 B        Set SSet = myyactiveDoc.SelectionSets.Item("Ehlxz")
8 c+ }% m- g! G/ t1 x+ n* [        SSet.Delete     '及时删除不用的选择集非常重要
    End If
   Set SSet = myyactiveDoc.SelectionSets.Add("Ehlxz")
7 C9 f% n: B" R0 j# ]    SSet.SelectOnScreen
" j; d7 j8 e) A6 w* H) B    '创建点组
    Dim ptArr1() As Variant
    Dim ptArr2() As Variant
    Dim count As Integer
    count = SSet.count
    ReDim ptArr1(count - 1)
( P. W; Z' r# B9 }# n) \# G$ s    ReDim ptArr2(count - 1)
    '错误判断
! Q9 _9 D* }4 h0 e8 C    If count = 0 Then
        MsgBox "未选择任何对象！", vbCritical
4 Q" }1 o2 {8 q6 }4 C: o        Exit Sub
: Z* w; l% M8 ]4 D    End If

9 R2 b: [+ X' }$ o6 c1 b7 j. ~* n    '获得最左侧和下侧的角点
    Dim objEnt As AcadEntity
, E. m  s8 V* V4 A: `    Dim ptTemp As Variant
    Dim i As Integer
2 U4 a" o  q  W. t. h+ w0 o7 H* a    i = 0
$ M- |1 y3 q. N) @5 H$ I    For Each objEnt In SSet
. B( J" e, c" Z8 Q        objEnt.GetBoundingBox ptArr1(i), ptTemp
        i = i + 1
    Next
    '获得最上侧和右侧的角点
; m9 `+ f$ v4 ^% N+ [    i = 0
    For Each objEnt In SSet
        objEnt.GetBoundingBox ptTemp, ptArr2(i)
; b: G/ l& H4 h" M% G- c: c% U        i = i + 1
9 c0 l0 i, h: V  e- T  _: _    Next
( U) O3 [1 f2 q/ ]6 a) n    Dim ptLeftX, ptLeftY, ptRightX, ptRightY
4 n* v7 v. m# d$ ]6 c' M    Dim ptRight, ptTop
   For WWW = 1 To count
      ptLeftX = ptArr1(WWW - 1)(0)
2 _- l$ @( D; G      ptLeftY = ptArr2(WWW - 1)(1)
      ptRightX = ptArr2(WWW - 1)(0)
4 ]/ k0 Z& F" H2 |* Q      ptRightY = ptArr1(WWW - 1)(1)

    Dim pppt1(0 To 2) As Double
    Dim pppt2(0 To 2) As Double
, Z  b  u0 g/ `        pppt1(2) = 0
        pppt2(2) = 0
  N! {; t5 r& U/ I    Dim gzkuan As Double, gzgao As Double
     gzkuan = (ptRightX - ptLeftX - 25 * (Int(Val(HjigeCb.Text)) - 1)) / Int(Val(HjigeCb.Text))
5 Q5 [/ ]. r( v8 V, O& x. m     gzgao = (ptLeftY - ptRightY - 25 * (Int(Val(SjigeCb.Text)) - 1)) / Int(Val(SjigeCb.Text))
. n+ W2 q# `8 I    For j = 1 To Int(Val(HjigeCb.Text))
* J' T2 L7 ~( R. {! Y5 M      For k = 1 To Int(Val(SjigeCb.Text))
        pppt1(0) = ptLeftX + (gzkuan + 25) * (j - 1)
  c/ @' a- U; `1 c* a- c& j         pppt1(1) = ptLeftY - (gzgao + 25) * (k - 1)
: e: L; D! i& N! j& o         pppt2(0) = pppt1(0) + gzkuan
         pppt2(1) = pppt1(1) - gzgao
) I: A2 X' z6 P+ K! J( |
      Next
    Next
         pppt1(0) = ptLeftX
8 W6 a. [- Q8 H: Q$ o5 A: z2 i2 [         pppt1(1) = ptLeftY
- r) \7 {( W3 w1 V, f3 R2 \         pppt2(0) = ptRightX
( T5 C' d' A1 Q- M/ G$ W, Z         pppt2(1) = ptRightY
- e* _* L+ {; l' a1 a2 i% E  Next
    SSet.Delete
    KK = GetDistance(pppt1, pppt2)
'在程序中操作EXCEL表常用命令:
  Dim Excel As Excel.Application
    Dim ExcelSheet   As Object
    Dim ExcelWorkbook   As Object
% u% u' ~  g7 {$ E' Y* D0 K# ?4 ~* o    '创建Excel应用程序实例
0 G1 j  R: l/ R/ B1 F- Q    On Error Resume Next
. P2 j% p1 ~% W; ]3 E    Set Excel = GetObject(, "Excel.Application")
6 R$ a) p* |2 [) N    If Err <> 0 Then
        Set Excel = CreateObject("Excel.Application")
6 ~) C- i6 t6 X           '创建一个新工作簿
         Set ExcelWorkbook = Excel.Workbooks.Add
          '令Excel应用程序可见
  R2 s' C, M. W& E' b           Excel.Visible = True
          '将新创建的工作簿保存为Excel文件
2 Z! i4 e1 T& K% M             ExcelWorkbook.SaveAs "属性表.xls"
6 k6 I( z- N' h1 M. K& j  {    End If
    '确保Sheet1工作表为当前工作表
, v5 ?( ?0 \/ J5 y8 C+ t    Set ExcelSheet = Excel.ActiveSheet
0 ]& G; v( T) W! R# |    Excel.Visible = True
    endrow = ExcelSheet.Range("A65536").End(xlUp).Row + 1
% e% u( v7 M* r3 n+ i4 G    ExcelSheet.Range("A" & endrow) = KK
4 f2 S5 I% e! a2 _    Set Excel = Nothing
- m# ~( N( l# p, ~& q0 e2 W    End If
  Next
: d2 X+ E- e1 k% KEnd Sub
$ M3 d3 V, T7 }. J

woaishuijia

1# sblisb
7 t) u- ?& e' F% h& @" D% d0 y在 Excel VBAIDE 中引用 ACAD 类库,将下面的代码写入 Sheet1 对象代码窗口.
运行代码时必须保证待查询的 ACAD 文档已打开并处于激活状态

1. 
   
2. Sub A()
   
3.     Dim CAD As AutoCAD.AcadApplication, St As AcadState, SS As AcadSelectionSet, Ft(0) As Integer, Fd(0) As Variant, I As Integer
   
4.     On Error GoTo 10
   
5.     '获取ACAD进程
   - U. z. [% G# y6 f: \
6.     '类名称最后的编号按版本
   ) h8 E) }, R- |% a; O
7.     'R14版本为14
   5 N; Z/ \  y/ d) Q  A) j
8.     '2000~2002版本为15
     e9 h- l% l" }) _
9.     '2004~2006版本为16
     g* M) V% x1 B! D( i" F
10.     '2007~2009版本为17
    $ N6 q9 H% ~" h6 M0 G& i, k
11.     '2010~2012版本为18
    " N( J" T1 y7 ~3 n2 j
12.     Set CAD = GetObject(, "AutoCAD.Application.18" )
    $ s9 ]  J; n3 v# x+ z& r& C
13.     '获取当前ACAD进程的状态
    
14.     Set St = CAD.GetAcadState
    , C5 ~% v- K+ w6 v+ k
15.     '当ACAD进程空闲时查询直线长度
    
16.     If St.IsQuiescent Then
    
17.         '创建选择集
    : z3 P8 w# [/ x& w8 m
18.         Set SS = CAD.ActiveDocument.SelectionSets.Add("SS" )
    % W8 u8 A  ^; N* i! n, A
19.         '定义选择集过滤器为只选择直线
    
20.         Fd(0) = "Line"
    7 a; H, H/ N% G, L- D( R6 E! G
21.         '用户在窗口选择
    
22.         SS.SelectOnScreen Ft, Fd
    . W% h; _9 W; L+ {
23.         '逐个提取选择集中直线的长度并写入本工作表A列
    4 ]8 Z( U5 p/ N4 O
24.         For I = 0 To SS.Count - 1
    
25.             Sheet1.Cells(I + 1, 1) = SS(I).Length
    2 w! Y6 l: p* ]3 }4 q
26.         Next
    . T. |6 d0 N' e
27.         '删除用过选择集
    6 \1 p! M3 y; o- k' f4 S
28.         SS.Delete
    9 ~  X, C/ U7 p. N
29.     Else
    ( C5 Z; k- c# \1 f9 M: p" a, M" o
30.         MsgBox "ACAD正忙"
    
31.     End If
    ! v; |6 _/ [5 T) }( [/ M* j1 X
32. 10: If Err Then MsgBox "ACAD没有运行或没有活动文档"
    6 N0 Y7 z7 S, z' t1 f8 O$ |' d
33. End Sub
    " l/ y  G% Y  R" G: P1 _

复制代码

sblisb

谢谢!
能不能帮助改进两点:
6 N, I& _& E. `& A/ s8 t1 数据写入A列时不覆盖A列原有数据.
2 运行程序后自动转到Acad界面,原代码运行后,是在等待状态,还在exce界面,要自己转到Acad界面

279491611

厉害，学习学习

清风香客

果断留印，方便后查。

玉紫玄

学习学习