excel如何得到线的长度?

sblisb

我想在excel中操作,得到打开的cad文件中择的线的长度,然后写入excel表.
其中选择效果就象在cad中选菜单下的"工具_查询_列表显示",选择后按空格或回车,得到线的长度就分别写入excel表中A列了.
* L4 j& M0 F$ ?( g, U在网上搜索了两天,得到如下代码,偶vba不好,请哪位高手帮我整合下,谢谢!
excel中操作cad请参考下面的步骤：
' ]' ?. [9 I, n# b% N

在EXCEL VBA编辑器的“工具”菜单中点“引用”，在“引用”对话框中找到ACAD类库，勾选它，确定。见图
4、在EXCEL VBA编辑器Sheet1对象代码窗口写如下代码
Sub A()
' y7 q- i' G% q
Dim CAD As AcadApplication '声明一个AutoCAD应用程序对象
8 U0 [& Y, Y2 R. ~2 [+ H4 y( FDim DOC As AcadDocument '声明AutoCAD文档对象
Set CAD = New AcadApplication '运行一个新的AutoCAD进程
0 A* a* S3 t( I' ?CAD.Visible = True '使运行的AutoCAD程序可见。如果没有这行，程序将不可见，就是说看不见CAD窗口，只能在Windows任务管理器看到有CAD程序运行
& X( I0 a: _6 g& m2 `: e# y: X" eSet DOC = CAD.Documents.Open(Sheet1.Cells(1, 1).Value) '按照“Sheet1”工作表第一行第一列单元格的内容打开文件
DOC.SendCommand Sheet1.Cells(1, 2).Value '按“Sheet1”工作表第一行第二列单元格的内容向CAD命令行发送命令
2 c% c6 J( ~4 H; r+ Xsub

;;;=================================================================*
;;;功能：测量线的长度 *
4 n' L% R: A' J; g/ c5 |6 o;;;日期：zml84 于 2009-05-21 17:45 *
- k  S6 c: ^  S; _/ O- ]5 A2 g/ J* o(defun C:cd ()
(princ "统计线段长度"
4 Z/ n) ]; p! C6 Y/ e& X(if (setq SS (ssget '((0 . "LINE,ARC,CIRCLE,ELLIPSE,*POLYLINE,SPLINE"))
% u/ V2 M1 K! ^& r9 t. v. o)
)
(progn
;;
1 Z/ I; X) N2 A(setq LST_LEN '()
8 c" |4 w" m5 }6 `; n5 fI 0
)
$ N9 ]; a! y0 t( @' D- t1 A;;逐个统计
(repeat (sslength SS)
/ N9 [" s1 T/ v2 A0 z5 B5 K(setq EN (ssname SS I)
; \, k) R/ `; `5 ]+ NLEN (vlax-curve-getdistatparam
EN
(vlax-curve-getendparam EN)
)
LST_LEN (cons LEN LST_LEN)
I (1+ I)
)
)
7 u5 q, x) J/ V- `# ^. b+ E, l(setq LST_LEN (reverse LST_LEN))
;;显示输出
/ \$ B' Q  x$ q) S(princ "\n找到个数：")
! `9 z. @6 {5 f; Z(princ (sslength SS))
(princ "\n单个长度：")
; ]4 L4 e2 o; Z; O4 R(princ LST_LEN)
3 r; ]8 R  u: o: F# _! U& C9 b3 E! M(princ "\n总计长度：")
(princ (apply '+ LST_LEN))
)
)
(princ)
! H* }) L* V5 k5 _1 B( B* a)
;;;=================================================================*
;;;(alert
;;; "功能：统计线段长度\n命令：\"CD\"\n日期：zml84 于 2009-05-21 17:45"
: s) T( i, T, V;;;)
(princ)

* ]* S$ I0 A4 L; c& V
$ M- [, C5 f2 Y+ v2 X’在AutoCAD中编程序，写到c盘根目录下的“123.xls”Excel表格中
- v- Q3 d- p2 M; s

’使用 VBA IDE 中的“工具” “引用”菜单选项，选择 Microsoft Excel 9.0 对象模型
’水平不高，有点罗嗦，楼主可以精简下
8 y3 y3 z  T1 u! F% K& a’欢迎以后交流，QQ 42123043
Public Sub 取坐标()
) l& H$ a( [: L& D# g# A’把AutoCAD中某一图层“多段线层”中的所有多段线的坐标列出来
Dim PLSet As AcadSelectionSet
% ?3 w! E8 [4 C" gDim pl As AcadLWPolyline
" _9 O. k  Y4 @! I; k# h
4 {' l8 A: `  V* Z7 ], x2 L9 y
Dim ExcelApp As Excel.Application
Dim ExcelSheet As Object
Dim ExcelWorkbook As Object
+ z  u, Q( a5 s% k2 @

Dim pts As Variant

Dim NN As Integer
Dim j As Integer

- _0 X9 E6 \$ d/ p2 f+ L" O* YDim pn As Integer

8 w9 v7 F( ^- WDim px(0 To 10000) As Double
Dim py(0 To 10000) As Double
Dim pz(0 To 10000) As Double

5 F, }: @' m; n' ?4 }2 E
+ A" i3 I% V9 `) h/ S" MDim filtertype(10) As Integer
Dim filterdata(1) As Variant

+ k$ ^4 i( G$ Z1 }/ A9 wfiltertype(0) = 0 ’ 选择线型
filterdata(0) = "LWPOLYLINE"
filtertype(1) = 8 ’ 图层标识，可以根据具体情况改动
9 P4 ]! [6 t. o  v( afilterdata(1) = "多段线层"

4 `6 y$ X9 J2 Z6 ]

  k: g8 d3 ]" @3 F2 G8 q/ }* NSet PLSet = ThisDrawing.SelectionSets.Add("pl")
$ m' M. ^% N. T9 f7 GPLSet.SelectOnScreen filtertype, filterdata
9 P+ L# n: I# e) u% A8 r/ r
1 ]/ I" s6 c( l" U. sNN = 0
j = 0
For Each pl In PLSet

pts = pl.Coordinates
* ~' {( F' `9 [pn = (UBound(pts) + 1) / 2

For i = 0 To pn - 1
% z& m0 g( G3 [% Q" Opx(i + pn * j) = pts(2 * i)
4 C, V; P) l: ppy(i + pn * j) = pts(2 * i + 1)
1 h0 O, I3 s" z4 Q0 ANext i
j = j + 1
NN = NN + pn
Next pl

% z7 b2 T4 Z; O: N1 j: SPLSet.Delete

5 a& a1 O6 ]! h+ |2 m
Set ExcelApp = New Excel.Application

0 J! V/ R% y0 G3 L9 f( sSet ExcelWorkbook = ExcelApp.Workbooks.Add
; ], c' d1 S! m2 H4 ^+ T; Q
Set ExcelSheet = ExcelApp.ActiveSheet

ExcelWorkbook.SaveAs "c:\123.xls"

2 C/ H& h* \# \4 |/ dExcelSheet.Cells(1, 1) = "x"
) h4 \3 \5 Q  M1 `8 r" kExcelSheet.Cells(1, 2) = "y"

$ }/ P& F3 J$ B! V% p; {For i = 0 To NN - 1
ExcelSheet.Cells(i + 2, 1) = px(i)
& p7 }% e7 X, H# kExcelSheet.Cells(i + 2, 2) = py(i)
Next i

End Sub

其实，从Excel里面操作，完全也可以实现
只需在excel的 VBA IDE 中的“工具” “引用”菜单选项，选择 AutoCAD 2004 Type Library 对象模型
- w. g! D+ {- F4 b5 {. y然后类似的思路编程即可，大家可以试试！

获取标注尺寸函数

Function FixDimMeas(Dimension As AcadDimension) As Long
6 d$ h. D7 f; ~Dim BlockCount As Long
Dim bz As Long
* S4 d' N& r/ d# `# q
BlockCount = ThisDrawing.Blocks.Count
  E& l) g& M( B'遍历块中的对象，取得标注尺寸
: Q8 L- J- U0 pDim EntityInBlock As AcadEntity
3 W- u% D2 m0 L% ^" B3 uFor Each EntityInBlock In ThisDrawing.Blocks(BlockCount - 1)
If EntityInBlock.ObjectName = "AcDbMText" Then
! Y/ H3 l$ S, u& V+ ?bz = Dimension.Measurement
FixDimMeas = bz '取得标注尺寸
Exit For
End If
( T( V; J8 i8 G* P( K6 fNext
End Function

sblisb

这段是在cad中执行,写入excel,偶想改成在excel中执行,写入表

选择CAD线条 EXCEL记录长度
+ J; d! r& ?5 z5 a7 H0 h选择“工具”\“引用”项，在弹出的“引用”对话框的“可使用的引用”列表框内，选择“Microsoft Excel 8.0 Object Library"项
: t+ n0 S+ O0 l* x: \: @: [/ ~
'计算两点之间距离
5 V: X% l  h* p% \Public Function GetDistance(ptSt As Variant, ptEn As Variant) As Double
' t! K& X/ b3 Z    Dim x As Double
) v1 p1 Q  `, _& y    Dim y As Double
    Dim z As Double
    x = ptSt(0) - ptEn(0)
    y = ptSt(1) - ptEn(1)
    z = ptSt(2) - ptEn(2)
    GetDistance = Sqr((Sqr((x ^ 2) + (y ^ 2)) ^ 2) + (z ^ 2))
End Function

! T2 y4 d# U9 CPrivate Sub xz()
'创建选择集
For JJ = 1 To 10
If MsgBox("是否继续选择", vbYesNo) = vbNo Then
Exit For
. [/ q3 ~1 F3 ^, @2 I  s5 pElse
5 s/ L; S+ G+ y5 g' n+ Z    On Error Resume Next
8 O2 q. _1 w+ {( }- |) p    Set myyactiveDoc = ActiveDocument

( s  C$ U% B7 \4 v; s    Dim SSet As AcadSelectionSet
      Set SSet = myyactiveDoc.SelectionSets.Add("Ehlxz")
: G3 |8 ^" M! ~8 q0 C    If Not IsNull(myyactiveDoc.SelectionSets.Item("Ehlxz")) Then
+ ?2 ^, T: s4 h2 Q9 B& u% x        Set SSet = myyactiveDoc.SelectionSets.Item("Ehlxz")
        SSet.Delete     '及时删除不用的选择集非常重要
% z( d- _- q, h3 ~    End If
   Set SSet = myyactiveDoc.SelectionSets.Add("Ehlxz")
- l2 Z9 R  Z3 a; G7 N    SSet.SelectOnScreen
    '创建点组
    Dim ptArr1() As Variant
$ g. N! ~, J- U" u% z    Dim ptArr2() As Variant
; _, v2 {6 F3 ~& O    Dim count As Integer
" i8 k9 v* u& |$ @& d# H/ P- P    count = SSet.count
( p7 m) S) }8 y( S. D    ReDim ptArr1(count - 1)
! q# r; m/ A8 \2 F: z" u7 n    ReDim ptArr2(count - 1)
    '错误判断
" f' {  @" }1 j; O: X4 t    If count = 0 Then
        MsgBox "未选择任何对象！", vbCritical
9 q2 i8 u- o( j4 f' W) M        Exit Sub
) D% V2 P- z7 m    End If
6 A2 ?3 H6 `. k; m* q
    '获得最左侧和下侧的角点
    Dim objEnt As AcadEntity
. a. n  q6 \- a8 Z& B6 T' L3 ^    Dim ptTemp As Variant
# a! L0 |- q+ a2 Q    Dim i As Integer
. e* P( H9 `9 U' n    i = 0
    For Each objEnt In SSet
        objEnt.GetBoundingBox ptArr1(i), ptTemp
4 r: |$ f- \0 L# m: }( g        i = i + 1
6 C; ]) P  O) x" b% j; C( B: ~    Next
    '获得最上侧和右侧的角点
9 ^( T# |& G2 O/ g/ I" x" w    i = 0
    For Each objEnt In SSet
        objEnt.GetBoundingBox ptTemp, ptArr2(i)
        i = i + 1
    Next
    Dim ptLeftX, ptLeftY, ptRightX, ptRightY
$ u- R8 ~" U' Y6 F; }& t    Dim ptRight, ptTop
& D: C9 t9 `0 ~2 F( C* M   For WWW = 1 To count
6 v* R6 o: i! X$ M/ n      ptLeftX = ptArr1(WWW - 1)(0)
      ptLeftY = ptArr2(WWW - 1)(1)
, P9 X0 C$ N' v: E      ptRightX = ptArr2(WWW - 1)(0)
  I9 j* u, u9 U. l; V3 o; u5 M      ptRightY = ptArr1(WWW - 1)(1)
/ B/ a+ s: I; I% x. Z) t
$ u% a0 [* @5 A' v    Dim pppt1(0 To 2) As Double
$ Q2 a& v1 P. x/ g* t: R$ P    Dim pppt2(0 To 2) As Double
. \) x: ]$ S! ]7 A* P' E. A6 X( \        pppt1(2) = 0
5 f) `. w$ n, a' ^) G  \" v& }# e        pppt2(2) = 0
- E% @0 N% T: O! D    Dim gzkuan As Double, gzgao As Double
     gzkuan = (ptRightX - ptLeftX - 25 * (Int(Val(HjigeCb.Text)) - 1)) / Int(Val(HjigeCb.Text))
/ J7 l! P/ s) [, f! p     gzgao = (ptLeftY - ptRightY - 25 * (Int(Val(SjigeCb.Text)) - 1)) / Int(Val(SjigeCb.Text))
    For j = 1 To Int(Val(HjigeCb.Text))
5 T( z: P7 f* ^, ~      For k = 1 To Int(Val(SjigeCb.Text))
        pppt1(0) = ptLeftX + (gzkuan + 25) * (j - 1)
         pppt1(1) = ptLeftY - (gzgao + 25) * (k - 1)
& V5 `" N5 y1 h( F2 {$ I6 S         pppt2(0) = pppt1(0) + gzkuan
         pppt2(1) = pppt1(1) - gzgao
" i; p* ]  ?) _; w
0 J" e! L4 f) N      Next
7 a) l# H; P7 S2 e9 ~) {    Next
         pppt1(0) = ptLeftX
4 S# S& w/ i5 i" C  j+ B- O$ A7 V( t" g         pppt1(1) = ptLeftY
4 {; j2 j" |" s! i5 x3 |1 [7 N         pppt2(0) = ptRightX
         pppt2(1) = ptRightY
  Next
    SSet.Delete
" x2 Z  T) H/ K0 V3 \) C# F1 \    KK = GetDistance(pppt1, pppt2)
'在程序中操作EXCEL表常用命令:
3 d+ E+ w; b  L1 x  Dim Excel As Excel.Application
* I6 s  n/ S4 U0 e0 B  {) D. K5 `9 u: ]    Dim ExcelSheet   As Object
    Dim ExcelWorkbook   As Object
1 i  G; w6 o# Q. k: z5 P7 \    '创建Excel应用程序实例
    On Error Resume Next
' z- k0 L/ M4 L    Set Excel = GetObject(, "Excel.Application")
    If Err <> 0 Then
0 |+ [% G5 ]- t# u" |# M( Z& P" U$ ?        Set Excel = CreateObject("Excel.Application")
           '创建一个新工作簿
+ U& _& X0 V% }) X. z         Set ExcelWorkbook = Excel.Workbooks.Add
% M; V  Y$ b0 Z2 l          '令Excel应用程序可见
           Excel.Visible = True
: h4 C  ]% }9 f          '将新创建的工作簿保存为Excel文件
9 _9 H% \) W- w# ]             ExcelWorkbook.SaveAs "属性表.xls"
% i  c* F" J7 k5 g$ ~0 _' o    End If
    '确保Sheet1工作表为当前工作表
0 {: {; l' l, ?1 D% r" M+ ?6 x* B    Set ExcelSheet = Excel.ActiveSheet
* h6 w' {  R3 j; S% q4 Z    Excel.Visible = True
: l/ d! m4 M% V: p3 u; W7 P7 A    endrow = ExcelSheet.Range("A65536").End(xlUp).Row + 1
4 {& @( L! ~0 T" z    ExcelSheet.Range("A" & endrow) = KK
: n* o2 d0 U; T6 G    Set Excel = Nothing
    End If
! O9 s/ F" d" S1 ]* I' C$ U  Next
End Sub

. y. Z6 ^3 G2 N1 _

woaishuijia

1# sblisb
4 l3 {" o3 H! f% f; Z在 Excel VBAIDE 中引用 ACAD 类库,将下面的代码写入 Sheet1 对象代码窗口.
运行代码时必须保证待查询的 ACAD 文档已打开并处于激活状态

1. 
   
2. Sub A()
   4 \, R3 j" i4 T" c2 S, P4 @
3.     Dim CAD As AutoCAD.AcadApplication, St As AcadState, SS As AcadSelectionSet, Ft(0) As Integer, Fd(0) As Variant, I As Integer
   ' U& r2 y+ c* i: c9 ]5 W
4.     On Error GoTo 10
   
5.     '获取ACAD进程
   & F7 ^) `# L, ^" D9 ]7 u8 ~' G) E
6.     '类名称最后的编号按版本
   ! Y9 d8 x! f& {6 J1 k5 y& ?& d
7.     'R14版本为14
   
8.     '2000~2002版本为15
   
9.     '2004~2006版本为16
   4 |" \% d: a9 Q- }/ m2 v
10.     '2007~2009版本为17
    # G. M+ B, @. Y+ \/ \  P$ J
11.     '2010~2012版本为18
    
12.     Set CAD = GetObject(, "AutoCAD.Application.18" )
    & S& Q3 J6 O* ~& y) U# g. a. _+ R
13.     '获取当前ACAD进程的状态
    
14.     Set St = CAD.GetAcadState
    9 d1 K, _' S% w7 I2 c0 Q# O
15.     '当ACAD进程空闲时查询直线长度
    
16.     If St.IsQuiescent Then
    
17.         '创建选择集
    1 v) X1 U! B# Q
18.         Set SS = CAD.ActiveDocument.SelectionSets.Add("SS" )
    , M6 }- h+ D! ^: h  G
19.         '定义选择集过滤器为只选择直线
    
20.         Fd(0) = "Line"
    
21.         '用户在窗口选择
    9 }! U  G# z+ J
22.         SS.SelectOnScreen Ft, Fd
    1 i9 f# X4 o5 x& y
23.         '逐个提取选择集中直线的长度并写入本工作表A列
    - a5 |& b, p, r# z: D; P$ `
24.         For I = 0 To SS.Count - 1
    6 ]: B5 v2 d8 U! K7 F7 F' a2 Y
25.             Sheet1.Cells(I + 1, 1) = SS(I).Length
    
26.         Next
    
27.         '删除用过选择集
    
28.         SS.Delete
    
29.     Else
    ' a; `0 j' }+ J, y( p
30.         MsgBox "ACAD正忙"
    ! ?# q* _$ i# V+ S  Q8 t6 }
31.     End If
    - k, j- J( k6 f! W" P
32. 10: If Err Then MsgBox "ACAD没有运行或没有活动文档"
    
33. End Sub
    8 i+ E2 r2 Z4 M' S, P% g; L& e

复制代码

sblisb

谢谢!
) l+ Z* i$ ]3 Q& C. X能不能帮助改进两点:
1 数据写入A列时不覆盖A列原有数据.
* p, S0 A& {% V, a) c* s: u2 运行程序后自动转到Acad界面,原代码运行后,是在等待状态,还在exce界面,要自己转到Acad界面

279491611

厉害，学习学习

清风香客

果断留印，方便后查。

玉紫玄

学习学习