excel如何得到线的长度?

sblisb

我想在excel中操作,得到打开的cad文件中择的线的长度,然后写入excel表.
" J( j6 G- m" i, c8 H其中选择效果就象在cad中选菜单下的"工具_查询_列表显示",选择后按空格或回车,得到线的长度就分别写入excel表中A列了.
' u1 o6 }& f. {+ U" y在网上搜索了两天,得到如下代码,偶vba不好,请哪位高手帮我整合下,谢谢!
0 B6 }1 G+ x5 G) m8 L, h4 Xexcel中操作cad请参考下面的步骤：

在EXCEL VBA编辑器的“工具”菜单中点“引用”，在“引用”对话框中找到ACAD类库，勾选它，确定。见图
) W) o; c% B+ M* p0 ?$ Z4、在EXCEL VBA编辑器Sheet1对象代码窗口写如下代码
8 s% ~+ D) X$ q% C3 @3 ASub A()

( k9 t+ `5 ?1 P' N9 Y% P2 u- mDim CAD As AcadApplication '声明一个AutoCAD应用程序对象
' T3 H3 {) h$ q2 g' r7 bDim DOC As AcadDocument '声明AutoCAD文档对象
Set CAD = New AcadApplication '运行一个新的AutoCAD进程
5 a$ I8 S* i, W5 w0 y# B' L8 xCAD.Visible = True '使运行的AutoCAD程序可见。如果没有这行，程序将不可见，就是说看不见CAD窗口，只能在Windows任务管理器看到有CAD程序运行
Set DOC = CAD.Documents.Open(Sheet1.Cells(1, 1).Value) '按照“Sheet1”工作表第一行第一列单元格的内容打开文件
: i- Y& P; |* C" P4 cDOC.SendCommand Sheet1.Cells(1, 2).Value '按“Sheet1”工作表第一行第二列单元格的内容向CAD命令行发送命令
sub

;;;=================================================================*
6 v4 Y" ?+ I1 J6 |  y9 Z;;;功能：测量线的长度 *
;;;日期：zml84 于 2009-05-21 17:45 *
+ y* {' w# ^$ k" O- A. M(defun C:cd ()
  I2 ^) `. j$ X1 i(princ "统计线段长度"
+ m8 x/ w4 m# b" D+ z+ e(if (setq SS (ssget '((0 . "LINE,ARC,CIRCLE,ELLIPSE,*POLYLINE,SPLINE"))
)
$ h  @9 J  y: G+ [)
# \" L3 @2 U0 H% x4 n, L( N) s" K(progn
;;
(setq LST_LEN '()
I 0
)
2 J2 w- b0 ]9 v- a. a;;逐个统计
' U* k+ k; z" W7 ^8 C% ?(repeat (sslength SS)
) r7 k0 k) u3 j# \1 j+ J: l* T/ N(setq EN (ssname SS I)
' D+ T) }5 a9 w9 {4 x7 nLEN (vlax-curve-getdistatparam
EN
/ \5 q2 L; Z3 n9 {0 y$ n(vlax-curve-getendparam EN)
, L! @$ I+ l& n+ n$ Z)
LST_LEN (cons LEN LST_LEN)
0 \7 n0 y$ r$ z0 n) R/ {6 Q" \I (1+ I)
) \+ b0 x8 H- ^( Q3 U# f# \! p)
# R* n" s6 H3 }7 U)
( d6 _/ F4 E1 U  k; _(setq LST_LEN (reverse LST_LEN))
$ Q2 t" P. y! b. B;;显示输出
5 i- o+ g+ W3 Q; L/ F$ M" q8 K(princ "\n找到个数：")
(princ (sslength SS))
(princ "\n单个长度：")
, V7 b4 H- t- o# j. k(princ LST_LEN)
, c( ~5 F0 o9 X4 w) t& b(princ "\n总计长度：")
(princ (apply '+ LST_LEN))
)
)
/ \+ M. B, ?7 l+ J: W) f0 Y(princ)
)
;;;=================================================================*
;;;(alert
;;; "功能：统计线段长度\n命令：\"CD\"\n日期：zml84 于 2009-05-21 17:45"
0 Q+ O2 B0 N) d% a$ |. e8 [1 q) T7 |;;;)
) S' B& ]; N9 Y- o( H7 E1 f3 I3 `(princ)

! u3 S' h' T, B& r. w) F, d’在AutoCAD中编程序，写到c盘根目录下的“123.xls”Excel表格中
+ _4 D, H$ d, b) R9 {* |

’使用 VBA IDE 中的“工具” “引用”菜单选项，选择 Microsoft Excel 9.0 对象模型
) T5 A% j5 S- p; Q( O8 Z6 Y* r’水平不高，有点罗嗦，楼主可以精简下
/ [  w: t5 n+ L6 W* c3 |; I  W7 S. a’欢迎以后交流，QQ 42123043
! j- Q/ m3 }8 `! S4 K0 N$ f$ WPublic Sub 取坐标()
’把AutoCAD中某一图层“多段线层”中的所有多段线的坐标列出来
Dim PLSet As AcadSelectionSet
) j9 K9 |& X  D# W4 Q/ cDim pl As AcadLWPolyline


, E7 L) k, h" |+ T( c( TDim ExcelApp As Excel.Application
Dim ExcelSheet As Object
; u' B& W3 w- }8 |$ SDim ExcelWorkbook As Object
7 U( n6 j; }1 f& r' ^% \4 [
2 P% ^3 G  O; R
Dim pts As Variant
) F# B9 ?, a# a" ]- g) l; }/ I
Dim NN As Integer
# E; |$ i8 O/ h# HDim j As Integer
% X3 P: q' T7 m) \% [3 D
4 i% `" x$ H4 d/ y! E% _! j: L# z1 ODim pn As Integer

4 f7 U4 l  P2 J5 Q) ~Dim px(0 To 10000) As Double
. @5 q: I5 ^$ C: Z; J6 pDim py(0 To 10000) As Double
4 O& |" k6 R3 A% }: `# sDim pz(0 To 10000) As Double
) H& C6 a2 @5 k  g' F* C

: o' ?$ I& }" u) w$ _) ]# l4 t+ [2 HDim filtertype(10) As Integer
Dim filterdata(1) As Variant

filtertype(0) = 0 ’ 选择线型
4 s$ n) k9 [1 _/ Hfilterdata(0) = "LWPOLYLINE"
filtertype(1) = 8 ’ 图层标识，可以根据具体情况改动
- e) N% Q& l+ `( v/ Tfilterdata(1) = "多段线层"

& w, T9 W& \3 q" }, G
& Y% d. k. [; p1 _1 J7 N
Set PLSet = ThisDrawing.SelectionSets.Add("pl")
PLSet.SelectOnScreen filtertype, filterdata

NN = 0
j = 0
For Each pl In PLSet
% a# m4 t/ ^& v' n, Q. s, O
pts = pl.Coordinates
' P: z1 O/ n" \) apn = (UBound(pts) + 1) / 2

For i = 0 To pn - 1
9 }  j( k4 b+ }$ T& Y, Lpx(i + pn * j) = pts(2 * i)
py(i + pn * j) = pts(2 * i + 1)
) O3 z3 n* Y" k' ^9 jNext i
j = j + 1
NN = NN + pn
2 h+ S) z! Q2 P1 ^5 N+ T0 sNext pl

PLSet.Delete


9 O- D1 E# J' T) _  aSet ExcelApp = New Excel.Application

Set ExcelWorkbook = ExcelApp.Workbooks.Add
" L6 \+ e6 C/ |$ j; T; L. c
Set ExcelSheet = ExcelApp.ActiveSheet

! n4 S0 S. a- O) h' |% hExcelWorkbook.SaveAs "c:\123.xls"
5 i0 [/ z; B% I4 R: r& C) O5 v  h8 K
ExcelSheet.Cells(1, 1) = "x"
, m! E' e9 D0 D- c- u7 qExcelSheet.Cells(1, 2) = "y"

For i = 0 To NN - 1
ExcelSheet.Cells(i + 2, 1) = px(i)
ExcelSheet.Cells(i + 2, 2) = py(i)
+ y5 U" R# T  ~: t% RNext i
8 c1 q& C# ]) V. {
. S9 G$ [& M: o" h2 S% h( KEnd Sub

其实，从Excel里面操作，完全也可以实现
只需在excel的 VBA IDE 中的“工具” “引用”菜单选项，选择 AutoCAD 2004 Type Library 对象模型
, K8 {3 T. D! C* X) L+ P5 q然后类似的思路编程即可，大家可以试试！

0 E5 g& |* H& L+ z获取标注尺寸函数

Function FixDimMeas(Dimension As AcadDimension) As Long
0 [2 K  s7 k! }( W0 ^5 P0 kDim BlockCount As Long
  F1 P9 J+ {6 I/ A5 L: M2 c3 l3 RDim bz As Long

BlockCount = ThisDrawing.Blocks.Count
' x) Q3 q' F1 G1 P/ ?+ Y'遍历块中的对象，取得标注尺寸
Dim EntityInBlock As AcadEntity
For Each EntityInBlock In ThisDrawing.Blocks(BlockCount - 1)
If EntityInBlock.ObjectName = "AcDbMText" Then
bz = Dimension.Measurement
4 X: H0 y1 U3 `4 b4 NFixDimMeas = bz '取得标注尺寸
* A7 N, g  ]% {% H9 _Exit For
3 Y5 i- g- k2 p( G# ]4 r, DEnd If
Next
End Function

sblisb

这段是在cad中执行,写入excel,偶想改成在excel中执行,写入表
0 M+ [! Y7 C& R9 H) R, N; [7 k4 j, L

选择CAD线条 EXCEL记录长度
2 L+ q# _) n, J" e. y6 O; }& _选择“工具”\“引用”项，在弹出的“引用”对话框的“可使用的引用”列表框内，选择“Microsoft Excel 8.0 Object Library"项

$ p9 W2 `7 x2 z6 {$ S$ b'计算两点之间距离
Public Function GetDistance(ptSt As Variant, ptEn As Variant) As Double
    Dim x As Double
3 j* |$ d5 D/ `6 f    Dim y As Double
$ H' c& o% s- e3 \; }7 ~8 u  K    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))
. ?( o( n5 i1 D- C) T. uEnd Function

Private Sub xz()
'创建选择集
For JJ = 1 To 10
) _: y# ]( C' E, c  N If MsgBox("是否继续选择", vbYesNo) = vbNo Then
9 @7 S3 z0 z9 m" i/ Y, S. E  Q Exit For
' `" H: q: N7 t  z7 }2 C( UElse
- X# e8 L" m) [1 U    On Error Resume Next
; m9 |! ?3 s9 V2 ~; L- v( F    Set myyactiveDoc = ActiveDocument
* G$ B, A/ h! F
    Dim SSet As AcadSelectionSet
      Set SSet = myyactiveDoc.SelectionSets.Add("Ehlxz")
    If Not IsNull(myyactiveDoc.SelectionSets.Item("Ehlxz")) Then
        Set SSet = myyactiveDoc.SelectionSets.Item("Ehlxz")
$ a/ h& ?/ T4 Y  q2 Y' y+ J        SSet.Delete     '及时删除不用的选择集非常重要
- g2 L/ V1 `! ?4 B% o, w) E" v    End If
8 N! k/ @8 U8 J+ h% a! ]8 V   Set SSet = myyactiveDoc.SelectionSets.Add("Ehlxz")
    SSet.SelectOnScreen
    '创建点组
' Q# j  P7 P  \( B# Z    Dim ptArr1() As Variant
    Dim ptArr2() As Variant
8 ~4 `$ v4 x- l. b" [4 W# l    Dim count As Integer
    count = SSet.count
; D# Q& T4 y$ e+ \    ReDim ptArr1(count - 1)
  m- D4 f5 W/ K. g+ O! u: G: F    ReDim ptArr2(count - 1)
    '错误判断
    If count = 0 Then
        MsgBox "未选择任何对象！", vbCritical
        Exit Sub
    End If

  X0 G( H  c) I2 V# U    '获得最左侧和下侧的角点
    Dim objEnt As AcadEntity
    Dim ptTemp As Variant
    Dim i As Integer
/ S' E: }7 m7 r6 r, [8 ]. j2 o    i = 0
# M1 T" }- J- c+ Q. k: M/ p    For Each objEnt In SSet
        objEnt.GetBoundingBox ptArr1(i), ptTemp
        i = i + 1
* \5 \& R1 ~+ J8 N( F& `    Next
, q# P5 p! C1 f/ U) ^; d* ~, Z    '获得最上侧和右侧的角点
( j; Z7 [" a* x0 Z4 s, P+ A    i = 0
5 K  m- l" ?& J* Z0 `    For Each objEnt In SSet
        objEnt.GetBoundingBox ptTemp, ptArr2(i)
6 w8 z7 W/ m1 J6 R, i        i = i + 1
2 S$ [' r+ ?% M; w8 e    Next
, X' g: x" m6 k, O    Dim ptLeftX, ptLeftY, ptRightX, ptRightY
8 Z4 l( s* k4 U& `$ _    Dim ptRight, ptTop
   For WWW = 1 To count
# t& X2 `7 `' X  D1 }) T+ f      ptLeftX = ptArr1(WWW - 1)(0)
      ptLeftY = ptArr2(WWW - 1)(1)
      ptRightX = ptArr2(WWW - 1)(0)
% Y& L  m) G1 o6 f9 d5 @) u( N      ptRightY = ptArr1(WWW - 1)(1)
% T2 F3 ~* Y& r
    Dim pppt1(0 To 2) As Double
, }+ y3 s( P3 U& g' z1 ]* f  s    Dim pppt2(0 To 2) As Double
        pppt1(2) = 0
        pppt2(2) = 0
  Q- Y7 L8 ?: M; w% x1 x" O    Dim gzkuan As Double, gzgao As Double
     gzkuan = (ptRightX - ptLeftX - 25 * (Int(Val(HjigeCb.Text)) - 1)) / Int(Val(HjigeCb.Text))
) |" @+ H' J; i: T( a     gzgao = (ptLeftY - ptRightY - 25 * (Int(Val(SjigeCb.Text)) - 1)) / Int(Val(SjigeCb.Text))
    For j = 1 To Int(Val(HjigeCb.Text))
, G- o5 @8 w( i" z3 i      For k = 1 To Int(Val(SjigeCb.Text))
4 e% u) F  X1 F& T+ ?" d( x        pppt1(0) = ptLeftX + (gzkuan + 25) * (j - 1)
0 V/ m# ], u/ n* W9 e) @4 [* @         pppt1(1) = ptLeftY - (gzgao + 25) * (k - 1)
% w/ |9 |2 b4 p5 h& k+ C0 I. y         pppt2(0) = pppt1(0) + gzkuan
" r/ r6 i# N: X: p7 i6 y7 K6 n9 }         pppt2(1) = pppt1(1) - gzgao

      Next
0 p8 }3 [5 D" S& b2 R1 N. I; A/ D    Next
         pppt1(0) = ptLeftX
         pppt1(1) = ptLeftY
         pppt2(0) = ptRightX
. ~% ^! J6 Q( u3 i1 M         pppt2(1) = ptRightY
- P6 r- a6 x4 U6 i( e' v4 J; s  Next
    SSet.Delete
    KK = GetDistance(pppt1, pppt2)
'在程序中操作EXCEL表常用命令:
1 j! M; X" d1 f  Z2 n7 h  Dim Excel As Excel.Application
+ ?! `1 n4 A3 d; _$ c+ I  }    Dim ExcelSheet   As Object
    Dim ExcelWorkbook   As Object
3 @& r  o7 j( A0 R/ r7 D    '创建Excel应用程序实例
    On Error Resume Next
$ t+ E; T- }: {" N4 X3 G. x" h    Set Excel = GetObject(, "Excel.Application")
    If Err <> 0 Then
        Set Excel = CreateObject("Excel.Application")
           '创建一个新工作簿
" a2 ?* t$ c, E% m8 B         Set ExcelWorkbook = Excel.Workbooks.Add
) B* q( X8 N" }7 D5 u- {( H4 B* C# t          '令Excel应用程序可见
           Excel.Visible = True
          '将新创建的工作簿保存为Excel文件
             ExcelWorkbook.SaveAs "属性表.xls"
* f0 a( t; ^/ o. @    End If
* ~" P7 ~& h) o. a$ f( @    '确保Sheet1工作表为当前工作表
    Set ExcelSheet = Excel.ActiveSheet
5 [* S' ~& w6 `% }7 C3 T; h7 ]    Excel.Visible = True
    endrow = ExcelSheet.Range("A65536").End(xlUp).Row + 1
1 b$ c1 Y/ T& r% q3 J. r    ExcelSheet.Range("A" & endrow) = KK
    Set Excel = Nothing
% L/ X1 x6 {: [* G  Q    End If
) P# e  \+ h* `% A  Next
" @6 Z* K  J! ?' {8 Y1 ?End Sub

woaishuijia

1# sblisb
& Y/ d) ]% `( z" ~! D在 Excel VBAIDE 中引用 ACAD 类库,将下面的代码写入 Sheet1 对象代码窗口.
运行代码时必须保证待查询的 ACAD 文档已打开并处于激活状态

1. 
   . U& W/ G2 m9 Y. h, ]
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
     ^  v1 a- r5 B
4.     On Error GoTo 10
   5 c5 D7 J# J" O( p
5.     '获取ACAD进程
   ; f- J6 l9 S* t4 y4 F' W* [
6.     '类名称最后的编号按版本
   ( F( D# U9 ]/ t1 g# K
7.     'R14版本为14
   0 U" Z$ v: o! ?8 O9 M; \# y
8.     '2000~2002版本为15
   8 S( `% ^0 F  n
9.     '2004~2006版本为16
   ! g! o; D  S, \$ U  i; L" B
10.     '2007~2009版本为17
    ! |+ G8 a7 g' O  R' ?% D
11.     '2010~2012版本为18
    ) Q$ @) T9 h( k; h# g, Z; Z
12.     Set CAD = GetObject(, "AutoCAD.Application.18" )
    " D8 x, R' U; H5 n6 y  ~2 W, W( r4 Q
13.     '获取当前ACAD进程的状态
    5 D2 i5 S6 K  i4 ~( N
14.     Set St = CAD.GetAcadState
    
15.     '当ACAD进程空闲时查询直线长度
    
16.     If St.IsQuiescent Then
    
17.         '创建选择集
    0 Z) a5 @; M# |: l/ A( b
18.         Set SS = CAD.ActiveDocument.SelectionSets.Add("SS" )
    / Z3 x9 X" K9 {: ^3 u8 C
19.         '定义选择集过滤器为只选择直线
    
20.         Fd(0) = "Line"
    
21.         '用户在窗口选择
    
22.         SS.SelectOnScreen Ft, Fd
      ?! X( ], ?, D9 U6 }
23.         '逐个提取选择集中直线的长度并写入本工作表A列
    
24.         For I = 0 To SS.Count - 1
    
25.             Sheet1.Cells(I + 1, 1) = SS(I).Length
    ; O* h# o( M* L. e; c2 Z
26.         Next
    
27.         '删除用过选择集
    ) z8 i. s# P) l2 c" @$ f
28.         SS.Delete
    & v4 o& D/ [7 [& t8 s; W
29.     Else
    1 j: p- ^( @0 h- e
30.         MsgBox "ACAD正忙"
    
31.     End If
    
32. 10: If Err Then MsgBox "ACAD没有运行或没有活动文档"
    
33. End Sub
    6 I4 F2 @) X: I# Y3 T; O& D' i' W

复制代码

sblisb

谢谢!
  m. T6 O  ~  K6 t$ Q* A能不能帮助改进两点:
1 数据写入A列时不覆盖A列原有数据.
/ k' Z7 w) F7 Y, s, E/ N2 运行程序后自动转到Acad界面,原代码运行后,是在等待状态,还在exce界面,要自己转到Acad界面

279491611

厉害，学习学习

清风香客

果断留印，方便后查。

玉紫玄

学习学习