excel如何得到线的长度?

sblisb

我想在excel中操作,得到打开的cad文件中择的线的长度,然后写入excel表.
其中选择效果就象在cad中选菜单下的"工具_查询_列表显示",选择后按空格或回车,得到线的长度就分别写入excel表中A列了.
在网上搜索了两天,得到如下代码,偶vba不好,请哪位高手帮我整合下,谢谢!
excel中操作cad请参考下面的步骤：
; {7 H4 S# `' A! A& O+ Q

在EXCEL VBA编辑器的“工具”菜单中点“引用”，在“引用”对话框中找到ACAD类库，勾选它，确定。见图
4、在EXCEL VBA编辑器Sheet1对象代码窗口写如下代码
Sub A()
7 _% [# s  `' n  v
! \7 k& }  l: [0 T* E) pDim CAD As AcadApplication '声明一个AutoCAD应用程序对象
Dim DOC As AcadDocument '声明AutoCAD文档对象
3 `- h2 {8 ]+ [7 T' Y2 L. b) p, ASet CAD = New AcadApplication '运行一个新的AutoCAD进程
4 r% }$ k7 j, }) p' p# ICAD.Visible = True '使运行的AutoCAD程序可见。如果没有这行，程序将不可见，就是说看不见CAD窗口，只能在Windows任务管理器看到有CAD程序运行
% n" }. c" R) F9 ^) X3 k; h/ ~Set DOC = CAD.Documents.Open(Sheet1.Cells(1, 1).Value) '按照“Sheet1”工作表第一行第一列单元格的内容打开文件
DOC.SendCommand Sheet1.Cells(1, 2).Value '按“Sheet1”工作表第一行第二列单元格的内容向CAD命令行发送命令
sub

;;;=================================================================*
;;;功能：测量线的长度 *
7 \" n5 A5 o2 l: N5 l;;;日期：zml84 于 2009-05-21 17:45 *
# \# [! [" g1 ~4 ]% Y(defun C:cd ()
(princ "统计线段长度"
+ S  `3 f, E( s; U3 }( r(if (setq SS (ssget '((0 . "LINE,ARC,CIRCLE,ELLIPSE,*POLYLINE,SPLINE"))
)
' P$ K4 D2 q+ M4 q9 P)
(progn
;;
(setq LST_LEN '()
I 0
)
5 U6 D, i# Q8 @: a;;逐个统计
(repeat (sslength SS)
(setq EN (ssname SS I)
' Y0 [2 i1 F4 a% c  z- zLEN (vlax-curve-getdistatparam
. n9 l" D! B/ Z, OEN
; N2 a: m- C- a" a(vlax-curve-getendparam EN)
' m" H, H6 n7 a0 p+ n, K: X)
7 ~6 M' ]  q/ @0 lLST_LEN (cons LEN LST_LEN)
I (1+ I)
+ a7 W, O2 C, l3 A)
)
& m6 F4 r# X/ Q+ m1 ]; S, Z(setq LST_LEN (reverse LST_LEN))
, ~) j- w0 q8 U/ o( z/ K! W. t;;显示输出
  V; F* H4 x* P, R* D) _$ p6 m(princ "\n找到个数：")
$ ]2 i7 j& `: q8 L. R8 N+ i(princ (sslength SS))
+ S& p: f# [3 Y& [+ s4 I2 ](princ "\n单个长度：")
2 Z$ W4 A* j2 A) @2 D4 R; \9 s# t(princ LST_LEN)
4 Q# b7 Y  A7 i* R! B2 c8 J(princ "\n总计长度：")
(princ (apply '+ LST_LEN))
( g/ H  ^. h0 H)
; d/ [' r& l. h( ~% R8 `) a- K)
) j6 f+ z7 ?2 v, M  }1 a9 {. B3 I! Q(princ)
)
;;;=================================================================*
3 j1 G; S4 c3 E9 K4 N5 M;;;(alert
" R- ~- B% B% q3 h$ U4 F+ A;;; "功能：统计线段长度\n命令：\"CD\"\n日期：zml84 于 2009-05-21 17:45"
+ P9 A& G: |! I/ v8 k/ B4 p, p" q;;;)
! L* G. |& B5 z0 a6 u(princ)

  F# M/ Y3 }8 D2 Z, r- L: Z7 g
’在AutoCAD中编程序，写到c盘根目录下的“123.xls”Excel表格中
, d  x& M" m' d% `) L0 M* x) H1 |

’使用 VBA IDE 中的“工具” “引用”菜单选项，选择 Microsoft Excel 9.0 对象模型
’水平不高，有点罗嗦，楼主可以精简下
’欢迎以后交流，QQ 42123043
Public Sub 取坐标()
! v" I( m4 M1 j& x! c  h’把AutoCAD中某一图层“多段线层”中的所有多段线的坐标列出来
Dim PLSet As AcadSelectionSet
6 d, f9 E+ v1 A, G( XDim pl As AcadLWPolyline
, E# T" u3 D" M/ g6 D* V
5 C( ?* ^+ P" a! q& s
Dim ExcelApp As Excel.Application
) V% Y3 o; o1 c3 P& L6 yDim ExcelSheet As Object
Dim ExcelWorkbook As Object
' i" y7 E- Z1 ?

" h3 s) g* M2 N% gDim pts As Variant
+ A3 A/ u* P# E8 y" m. d: Y* e5 }
Dim NN As Integer
Dim j As Integer
$ T! A' u$ ^* K
Dim pn As Integer
+ A1 G+ U0 P* [8 D2 g* ~
Dim px(0 To 10000) As Double
Dim py(0 To 10000) As Double
% T6 S9 o* X$ _4 |  Q3 X* lDim pz(0 To 10000) As Double

( L, g, u4 Y/ F' [- ^
Dim filtertype(10) As Integer
9 R& H$ n8 o  Y  k) p! `Dim filterdata(1) As Variant
, g, x1 {8 K/ j6 k7 z, w0 N
filtertype(0) = 0 ’ 选择线型
filterdata(0) = "LWPOLYLINE"
" t) c: A0 Z) Ofiltertype(1) = 8 ’ 图层标识，可以根据具体情况改动
filterdata(1) = "多段线层"
# Z5 e" V( N/ P

' I' A) W4 [0 o# i& L) ~
5 H5 S, q' R0 M0 ]: VSet PLSet = ThisDrawing.SelectionSets.Add("pl")
5 X% E2 h0 `& N5 a. n7 D# ~$ cPLSet.SelectOnScreen filtertype, filterdata

NN = 0
# u) m  o  O  Bj = 0
For Each pl In PLSet

3 W% Q! M+ ~( b( F3 v3 fpts = pl.Coordinates
pn = (UBound(pts) + 1) / 2
+ \, o% s1 U, Z1 m
$ S% x% O9 ?; p/ Q; K$ XFor i = 0 To pn - 1
px(i + pn * j) = pts(2 * i)
4 v% \. K2 Q) F* h6 j+ Z* e" c& Ppy(i + pn * j) = pts(2 * i + 1)
Next i
j = j + 1
NN = NN + pn
Next pl

7 P+ [( q  ?3 _PLSet.Delete
7 |  ]7 c8 b4 v% L
* `) r9 ?: v2 \8 k! S" t3 w) D8 s
Set ExcelApp = New Excel.Application
  L8 T$ p  ?" h4 v& k: d! H, X
7 {! N" g; U5 o7 G1 F' @1 k' uSet ExcelWorkbook = ExcelApp.Workbooks.Add

Set ExcelSheet = ExcelApp.ActiveSheet

ExcelWorkbook.SaveAs "c:\123.xls"
2 g4 S+ X% _$ A* G: ~9 o% W
+ [( [: U: Q" p. A; AExcelSheet.Cells(1, 1) = "x"
: t7 j6 P9 ~3 E- `! P+ [9 N" ^ExcelSheet.Cells(1, 2) = "y"
1 l/ D& E! v; B) p* m9 N1 @$ M
For i = 0 To NN - 1
" D0 Y/ X9 u: m0 X# mExcelSheet.Cells(i + 2, 1) = px(i)
ExcelSheet.Cells(i + 2, 2) = py(i)
8 p$ b% D' e% E; |8 y1 a/ cNext i
9 m9 ]* f% d/ q" h! o
% Y8 R; i! s, ]. [End Sub

其实，从Excel里面操作，完全也可以实现
7 ~" h6 ~. U+ R7 \) g只需在excel的 VBA IDE 中的“工具” “引用”菜单选项，选择 AutoCAD 2004 Type Library 对象模型
6 }2 b: D* o6 B- P然后类似的思路编程即可，大家可以试试！
: N. K0 d8 j9 z
* i# \0 N# A0 I! A  J5 r# T# \获取标注尺寸函数

# i; @+ Q# J& W" U6 ^; ^! ]6 H* l

Function FixDimMeas(Dimension As AcadDimension) As Long
Dim BlockCount As Long
Dim bz As Long
+ Y+ T8 F6 ?% p* ^; ?4 Y2 @
BlockCount = ThisDrawing.Blocks.Count
+ U" N- p  H3 h& G7 Y'遍历块中的对象，取得标注尺寸
9 }* W' N  C5 c% c- Y/ uDim EntityInBlock As AcadEntity
For Each EntityInBlock In ThisDrawing.Blocks(BlockCount - 1)
If EntityInBlock.ObjectName = "AcDbMText" Then
bz = Dimension.Measurement
5 Z% }1 G* N0 m( R- R! J  k3 _1 u; ~$ a" tFixDimMeas = bz '取得标注尺寸
Exit For
End If
0 t" }- q4 D' \Next
End Function

sblisb

这段是在cad中执行,写入excel,偶想改成在excel中执行,写入表
" @1 p: |1 z$ z/ @

选择CAD线条 EXCEL记录长度
选择“工具”\“引用”项，在弹出的“引用”对话框的“可使用的引用”列表框内，选择“Microsoft Excel 8.0 Object Library"项

'计算两点之间距离
Public Function GetDistance(ptSt As Variant, ptEn As Variant) As Double
    Dim x As Double
. `& B& m9 }4 n% D: {3 O    Dim y As Double
    Dim z As Double
    x = ptSt(0) - ptEn(0)
3 l. x  Y3 [9 _1 A# G, `    y = ptSt(1) - ptEn(1)
* O7 n3 N0 M$ }# g/ M# z1 z4 _3 B$ y    z = ptSt(2) - ptEn(2)
    GetDistance = Sqr((Sqr((x ^ 2) + (y ^ 2)) ^ 2) + (z ^ 2))
End Function

Private Sub xz()
'创建选择集
For JJ = 1 To 10
If MsgBox("是否继续选择", vbYesNo) = vbNo Then
. H! Y3 V0 n8 V9 a4 ]7 H1 R+ z Exit For
9 T3 t2 R2 \. l5 J9 e6 u" `0 g2 {Else
    On Error Resume Next
5 S& T, g1 F9 T4 V  V8 o    Set myyactiveDoc = ActiveDocument
1 U1 ?) r& d  H" o! g
    Dim SSet As AcadSelectionSet
8 Y" F/ B6 L. @* x3 n& N. o      Set SSet = myyactiveDoc.SelectionSets.Add("Ehlxz")
    If Not IsNull(myyactiveDoc.SelectionSets.Item("Ehlxz")) Then
        Set SSet = myyactiveDoc.SelectionSets.Item("Ehlxz")
        SSet.Delete     '及时删除不用的选择集非常重要
    End If
   Set SSet = myyactiveDoc.SelectionSets.Add("Ehlxz")
0 _& G  {1 L9 B. q( t& V0 t1 \    SSet.SelectOnScreen
3 a. a: _. M& @- j) \- m# \4 u3 [    '创建点组
9 _; _# t0 k4 n7 \    Dim ptArr1() As Variant
    Dim ptArr2() As Variant
' H; t) H& q. G. F0 M& H    Dim count As Integer
+ @9 s8 }# _, @# _1 p    count = SSet.count
    ReDim ptArr1(count - 1)
/ g& w, S# T7 |/ @    ReDim ptArr2(count - 1)
    '错误判断
) q/ f6 G0 T5 X; J" V6 H    If count = 0 Then
        MsgBox "未选择任何对象！", vbCritical
        Exit Sub
5 Q; ~% U/ }( \9 M    End If
- I  g5 H# m6 G3 H
0 y* d6 x8 z8 r: S: \9 m    '获得最左侧和下侧的角点
    Dim objEnt As AcadEntity
    Dim ptTemp As Variant
; ^6 D/ v7 l! {/ E7 }    Dim i As Integer
1 Y4 e4 n% s: K) |2 F. e$ Z* ]    i = 0
/ R. B/ _$ b9 z$ b    For Each objEnt In SSet
& D6 L% l0 L. L        objEnt.GetBoundingBox ptArr1(i), ptTemp
        i = i + 1
" ^/ P/ y0 D+ H- j2 r4 R. o    Next
. e& r; G. @, e, i+ s: x0 o    '获得最上侧和右侧的角点
4 n% r% b* c6 _$ T. Z; ^( v& }- G    i = 0
    For Each objEnt In SSet
$ X0 ^9 U5 x5 p4 b* p) l, F        objEnt.GetBoundingBox ptTemp, ptArr2(i)
        i = i + 1
- n4 ?7 u7 R+ X4 m/ u* c3 j5 p    Next
. l# m; L. j; ^4 i. |, `    Dim ptLeftX, ptLeftY, ptRightX, ptRightY
$ W. Q$ r, X; X! j6 S* w& }    Dim ptRight, ptTop
   For WWW = 1 To count
      ptLeftX = ptArr1(WWW - 1)(0)
      ptLeftY = ptArr2(WWW - 1)(1)
      ptRightX = ptArr2(WWW - 1)(0)
/ Z4 u7 k3 k- z% X, T& d      ptRightY = ptArr1(WWW - 1)(1)

7 K2 ^- r, M. s, ?; g& \    Dim pppt1(0 To 2) As Double
; P9 R! t& d5 V1 a4 Y3 M( X1 J    Dim pppt2(0 To 2) As Double
        pppt1(2) = 0
        pppt2(2) = 0
    Dim gzkuan As Double, gzgao As Double
9 u9 q% {( E* Y( r     gzkuan = (ptRightX - ptLeftX - 25 * (Int(Val(HjigeCb.Text)) - 1)) / Int(Val(HjigeCb.Text))
& U! J! H/ n0 x' {0 N& k1 U7 c     gzgao = (ptLeftY - ptRightY - 25 * (Int(Val(SjigeCb.Text)) - 1)) / Int(Val(SjigeCb.Text))
    For j = 1 To Int(Val(HjigeCb.Text))
$ e# p/ D. f% u: f      For k = 1 To Int(Val(SjigeCb.Text))
        pppt1(0) = ptLeftX + (gzkuan + 25) * (j - 1)
         pppt1(1) = ptLeftY - (gzgao + 25) * (k - 1)
0 N. \" R8 k1 p& n5 v* ~3 [         pppt2(0) = pppt1(0) + gzkuan
5 E7 F: z- L$ V  V& p         pppt2(1) = pppt1(1) - gzgao

      Next
    Next
' a0 c. U+ b5 j         pppt1(0) = ptLeftX
- G# j2 }& N5 i( u% v5 |2 z         pppt1(1) = ptLeftY
3 d6 v; E* W" v9 D         pppt2(0) = ptRightX
0 y) e. ]. g5 T. k2 i! o         pppt2(1) = ptRightY
# t: O, w9 U3 l# B% F2 M9 r  Next
1 ?+ A3 w3 {. Z1 [! U    SSet.Delete
+ z5 Y; w4 W( s6 Z% C: v- u    KK = GetDistance(pppt1, pppt2)
'在程序中操作EXCEL表常用命令:
  Dim Excel As Excel.Application
# w( e0 _& t$ P2 l. Z    Dim ExcelSheet   As Object
    Dim ExcelWorkbook   As Object
( B$ ?9 O$ w. Z3 l- q0 F1 e# s    '创建Excel应用程序实例
    On Error Resume Next
    Set Excel = GetObject(, "Excel.Application")
- O$ x6 I1 W; H    If Err <> 0 Then
        Set Excel = CreateObject("Excel.Application")
) k' p( P" ^6 X9 w/ h% x           '创建一个新工作簿
% {* B# J4 W1 c( O" x2 f9 @9 }         Set ExcelWorkbook = Excel.Workbooks.Add
" p5 Z5 m: D- j/ B7 R6 C# B          '令Excel应用程序可见
           Excel.Visible = True
          '将新创建的工作簿保存为Excel文件
9 I" {' L9 f6 c' Q% p/ a! P             ExcelWorkbook.SaveAs "属性表.xls"
    End If
    '确保Sheet1工作表为当前工作表
    Set ExcelSheet = Excel.ActiveSheet
    Excel.Visible = True
    endrow = ExcelSheet.Range("A65536").End(xlUp).Row + 1
    ExcelSheet.Range("A" & endrow) = KK
' U3 x+ F6 p5 E  M! w2 Z4 L9 o. ~! z    Set Excel = Nothing
. Z6 I, @0 J6 h/ @& a# R; g    End If
  Next
End Sub
% P1 z5 m7 e- Q% x( ?# g/ J4 p0 T4 ^8 t
: I+ G: Y6 r) ^) ?; C5 P

woaishuijia

1# sblisb
% C* w- \0 }$ ~' w$ P+ e  {, |" P在 Excel VBAIDE 中引用 ACAD 类库,将下面的代码写入 Sheet1 对象代码窗口.
; I, \6 D1 B/ V7 A) I( {/ C! C+ D. b! u运行代码时必须保证待查询的 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进程
   
6.     '类名称最后的编号按版本
   ; r, x' ~0 S3 `+ t- W
7.     'R14版本为14
   
8.     '2000~2002版本为15
   
9.     '2004~2006版本为16
   
10.     '2007~2009版本为17
    
11.     '2010~2012版本为18
    : }' O5 S0 _' [% b# d
12.     Set CAD = GetObject(, "AutoCAD.Application.18" )
    + q5 F& `  S3 N$ t0 l5 u  w
13.     '获取当前ACAD进程的状态
    
14.     Set St = CAD.GetAcadState
    
15.     '当ACAD进程空闲时查询直线长度
    ; h* \1 i! E% ~% \% ~
16.     If St.IsQuiescent Then
    5 W) v9 F% b3 Y7 ?# u
17.         '创建选择集
    : y: q, H  \- n$ c& A$ z6 W5 }0 ~
18.         Set SS = CAD.ActiveDocument.SelectionSets.Add("SS" )
    
19.         '定义选择集过滤器为只选择直线
    * Q. [: u  o  [/ L( G
20.         Fd(0) = "Line"
    
21.         '用户在窗口选择
    
22.         SS.SelectOnScreen Ft, Fd
    
23.         '逐个提取选择集中直线的长度并写入本工作表A列
    
24.         For I = 0 To SS.Count - 1
    ' ~$ i& C- M+ F
25.             Sheet1.Cells(I + 1, 1) = SS(I).Length
    $ Z/ ?7 [; |4 }6 K  F
26.         Next
    
27.         '删除用过选择集
    ' w1 ?7 J+ K7 {# o5 x
28.         SS.Delete
    % @, u& M; Q4 K$ {0 {
29.     Else
    
30.         MsgBox "ACAD正忙"
    
31.     End If
    
32. 10: If Err Then MsgBox "ACAD没有运行或没有活动文档"
    
33. End Sub
    " W( `/ ^# |9 T6 H% M7 c+ Y

复制代码

sblisb

谢谢!
( e. L5 W) y8 z- r. b; @  i* P) c能不能帮助改进两点:
1 数据写入A列时不覆盖A列原有数据.
; C0 ?. l* C* G3 A5 p' L. `2 运行程序后自动转到Acad界面,原代码运行后,是在等待状态,还在exce界面,要自己转到Acad界面

279491611

厉害，学习学习

清风香客

果断留印，方便后查。

玉紫玄

学习学习