excel如何得到线的长度?

sblisb

我想在excel中操作,得到打开的cad文件中择的线的长度,然后写入excel表.
* `* n; t+ c# M: G6 E9 B& c3 K5 L其中选择效果就象在cad中选菜单下的"工具_查询_列表显示",选择后按空格或回车,得到线的长度就分别写入excel表中A列了.
# Y+ L. E4 ^" m  X在网上搜索了两天,得到如下代码,偶vba不好,请哪位高手帮我整合下,谢谢!
' U) T7 W, M' c3 g' t" Sexcel中操作cad请参考下面的步骤：

在EXCEL VBA编辑器的“工具”菜单中点“引用”，在“引用”对话框中找到ACAD类库，勾选它，确定。见图
1 c* c7 ?, N2 E) b4、在EXCEL VBA编辑器Sheet1对象代码窗口写如下代码
7 u0 A7 z2 }/ z/ c5 w2 |8 M5 ]& H% w3 oSub A()
+ H, A& i  I% \
3 B; V" \1 }) J3 ?6 m/ G- aDim CAD As AcadApplication '声明一个AutoCAD应用程序对象
8 F3 h9 o% J: F/ S2 U  ADim DOC As AcadDocument '声明AutoCAD文档对象
& d7 ]5 f; F; {8 b+ ESet CAD = New AcadApplication '运行一个新的AutoCAD进程
9 a8 {  b! J8 _' x" d4 r  w( NCAD.Visible = True '使运行的AutoCAD程序可见。如果没有这行，程序将不可见，就是说看不见CAD窗口，只能在Windows任务管理器看到有CAD程序运行
7 i1 a" F/ ~* C, _Set DOC = CAD.Documents.Open(Sheet1.Cells(1, 1).Value) '按照“Sheet1”工作表第一行第一列单元格的内容打开文件
DOC.SendCommand Sheet1.Cells(1, 2).Value '按“Sheet1”工作表第一行第二列单元格的内容向CAD命令行发送命令
sub

;;;=================================================================*
: l  d4 b! ]4 b. y: A;;;功能：测量线的长度 *
6 G: D1 v9 K" K+ |5 V0 j; V, \9 e;;;日期：zml84 于 2009-05-21 17:45 *
(defun C:cd ()
(princ "统计线段长度"
# b+ G) P; ~9 H(if (setq SS (ssget '((0 . "LINE,ARC,CIRCLE,ELLIPSE,*POLYLINE,SPLINE"))
+ R8 b" Z3 g, u4 g4 J% r- a)
* n) C4 @7 ~! c+ U6 A/ n6 H& _)
(progn
;;
(setq LST_LEN '()
I 0
# K8 `& `: G/ f' A1 e% k)
# B- E& W. b. I. x2 _7 [) a. ];;逐个统计
(repeat (sslength SS)
( g) o% W: v2 c2 p& a8 q(setq EN (ssname SS I)
LEN (vlax-curve-getdistatparam
$ P  b5 _" p8 X( |; e4 aEN
(vlax-curve-getendparam EN)
7 u2 e# d5 L+ @: h)
. C- R* y+ f4 `, t1 ]LST_LEN (cons LEN LST_LEN)
I (1+ I)
)
/ u; @* x) J' U6 I% e)
8 e1 G  x' Y  _; @" @(setq LST_LEN (reverse LST_LEN))
' o2 F8 K8 x" T;;显示输出
9 Q. b; @6 w% \" R* ^(princ "\n找到个数：")
(princ (sslength SS))
& f- m/ q7 s- \(princ "\n单个长度：")
(princ LST_LEN)
(princ "\n总计长度：")
1 S( t9 y8 @0 B  F' Q' [2 w+ ~(princ (apply '+ LST_LEN))
)
9 t% g0 ?  H  ]6 R! Z)
(princ)
)
;;;=================================================================*
5 g, N3 P6 R0 [5 x;;;(alert
  q) i! G, r* D8 S" ?;;; "功能：统计线段长度\n命令：\"CD\"\n日期：zml84 于 2009-05-21 17:45"
: I/ s$ y/ L! c1 f/ u/ h  d;;;)
6 |& \$ E" x; w6 G8 U(princ)

- v  K8 Y& a0 N0 k$ b8 M/ z
9 Q2 J# x5 A2 t8 l% Z9 ^$ i4 P3 T. x’在AutoCAD中编程序，写到c盘根目录下的“123.xls”Excel表格中
2 H/ h# i- f( z! M7 o

’使用 VBA IDE 中的“工具” “引用”菜单选项，选择 Microsoft Excel 9.0 对象模型
9 B" v8 n( a5 Y' v& v6 q% }’水平不高，有点罗嗦，楼主可以精简下
’欢迎以后交流，QQ 42123043
6 V" ^: i& B; m# n9 q- rPublic Sub 取坐标()
& f) z* c# F6 j1 [’把AutoCAD中某一图层“多段线层”中的所有多段线的坐标列出来
/ h6 B3 T% F8 a( E: X* RDim PLSet As AcadSelectionSet
6 _, I8 A5 v% \0 E: `2 KDim pl As AcadLWPolyline
! w+ }$ n* D! u! i$ `- U
9 G; ^) a( c& s$ q
% l" H2 D3 s! z0 y- X) A1 _Dim ExcelApp As Excel.Application
Dim ExcelSheet As Object
Dim ExcelWorkbook As Object
6 x. p4 K" I, n0 ^) ]

Dim pts As Variant
: K$ k7 {+ @; P3 \0 m& ^  }
/ w5 J% _2 F+ Q/ tDim NN As Integer
/ \% T7 K7 R) p9 o/ z* |Dim j As Integer
% f4 ^7 w' b! H3 a
Dim pn As Integer

Dim px(0 To 10000) As Double
* B' n1 _' _- d; f% r5 y1 j* ZDim py(0 To 10000) As Double
Dim pz(0 To 10000) As Double
* J- Q  a3 }0 Y. m9 Q2 X

Dim filtertype(10) As Integer
1 T. R3 R( }7 }& e; v& BDim filterdata(1) As Variant
! w' k$ K( t: [+ U2 A! B0 Z# Y" o
; e8 E; {1 K3 U6 b4 B! O8 hfiltertype(0) = 0 ’ 选择线型
filterdata(0) = "LWPOLYLINE"
filtertype(1) = 8 ’ 图层标识，可以根据具体情况改动
filterdata(1) = "多段线层"
$ E$ t/ r+ d/ A1 ^


0 x+ D5 o3 K2 z0 cSet PLSet = ThisDrawing.SelectionSets.Add("pl")
# w3 U# }" Z* y2 G# QPLSet.SelectOnScreen filtertype, filterdata
' B; v! j/ U  G, Z& q+ _; W, P
NN = 0
j = 0
For Each pl In PLSet

pts = pl.Coordinates
; I* g' m3 o+ ]% Z/ Q! Mpn = (UBound(pts) + 1) / 2
1 P  V0 l+ o# h: D, t8 r
$ s/ \* W" b* b! v" IFor i = 0 To pn - 1
9 f3 M* u& _! q0 [5 Dpx(i + pn * j) = pts(2 * i)
7 A. f: n( e2 L; Lpy(i + pn * j) = pts(2 * i + 1)
Next i
/ {5 @, d6 ~5 G' K6 j3 jj = j + 1
( C1 G# `# R) V, D: m1 N# P4 z% N0 PNN = NN + pn
" h3 L* F  ~$ M/ X+ WNext pl
7 R* O6 `) I. s1 B3 H: U
PLSet.Delete
. I  M+ M- l# s
% b1 j+ U  y( J1 i7 I1 [/ e% C
; C) z8 x: s5 X$ }* a+ N7 x* ]# l% WSet ExcelApp = New Excel.Application
5 L. G8 R) Y. `5 G1 X7 X7 D  g
7 l% W# c* T8 p8 H7 ?1 TSet ExcelWorkbook = ExcelApp.Workbooks.Add
# D. W) m. R% V$ A
Set ExcelSheet = ExcelApp.ActiveSheet
3 y9 Y) C  L0 e) Y( z
ExcelWorkbook.SaveAs "c:\123.xls"

& u8 v) i6 c) @" K+ A" JExcelSheet.Cells(1, 1) = "x"
% g* i0 ]3 s( _2 j' \  D4 H. nExcelSheet.Cells(1, 2) = "y"
) E4 A) e. G, a8 C" b3 }
9 ]! |( z1 h# C6 v' g& m; ?2 yFor i = 0 To NN - 1
. b1 ~5 v5 g/ T; o4 {& kExcelSheet.Cells(i + 2, 1) = px(i)
9 V3 a$ @  T3 z3 PExcelSheet.Cells(i + 2, 2) = py(i)
Next i

0 E# r4 B: Q6 m& OEnd Sub

其实，从Excel里面操作，完全也可以实现
只需在excel的 VBA IDE 中的“工具” “引用”菜单选项，选择 AutoCAD 2004 Type Library 对象模型
; c) _( t$ z8 c- Z5 C4 X/ O然后类似的思路编程即可，大家可以试试！

获取标注尺寸函数

2 A; ^) d& o  G3 e! v

Function FixDimMeas(Dimension As AcadDimension) As Long
7 N9 N/ A, w' i- v" iDim BlockCount As Long
Dim bz As Long
0 {4 s  v9 g* [. _/ @# R+ G1 W
BlockCount = ThisDrawing.Blocks.Count
( i$ l# Z  T: L, N" N; e( t% t'遍历块中的对象，取得标注尺寸
Dim EntityInBlock As AcadEntity
For Each EntityInBlock In ThisDrawing.Blocks(BlockCount - 1)
2 d) c% s% I9 q) CIf EntityInBlock.ObjectName = "AcDbMText" Then
bz = Dimension.Measurement
FixDimMeas = bz '取得标注尺寸
7 d( Q! s/ z  m% N4 D+ O1 ^7 c. FExit For
8 N* |6 Z4 p1 v/ `& H, E9 FEnd If
Next
8 C- [2 h2 h7 p% p3 x) F5 c4 D" LEnd Function

sblisb

这段是在cad中执行,写入excel,偶想改成在excel中执行,写入表
+ R+ s- i; A# B$ d0 A4 u

选择CAD线条 EXCEL记录长度
选择“工具”\“引用”项，在弹出的“引用”对话框的“可使用的引用”列表框内，选择“Microsoft Excel 8.0 Object Library"项
1 J' }0 P# Q: G3 Z. I
'计算两点之间距离
& H. d. B/ z" R+ H& M6 l, O2 [Public Function GetDistance(ptSt As Variant, ptEn As Variant) As Double
1 C+ l% c) p. R* v/ [: J7 _    Dim x As Double
9 B& K$ t& t1 e$ `    Dim y As Double
  i+ Z: D: k; r8 l8 Q- G    Dim z As Double
9 }9 i, C& Y0 L' O    x = ptSt(0) - ptEn(0)
    y = ptSt(1) - ptEn(1)
0 |, p# A% a* K    z = ptSt(2) - ptEn(2)
    GetDistance = Sqr((Sqr((x ^ 2) + (y ^ 2)) ^ 2) + (z ^ 2))
0 c$ q2 |* W; x+ a5 mEnd Function
1 t+ t8 M& |3 T1 t% |8 q
5 H6 Z+ ^: z2 t. m8 N/ _Private Sub xz()
1 u3 [& r, h" i '创建选择集
, {2 c) g0 U3 u8 P% I2 P( o For JJ = 1 To 10
7 e3 k0 u: [7 Z$ y1 a0 J# \ If MsgBox("是否继续选择", vbYesNo) = vbNo Then
Exit For
Else
    On Error Resume Next
8 Z% [- y9 t4 M/ O/ d* ^    Set myyactiveDoc = ActiveDocument
$ c' S5 C8 @& @/ M  |' _% c$ K
    Dim SSet As AcadSelectionSet
      Set SSet = myyactiveDoc.SelectionSets.Add("Ehlxz")
/ i& w: R1 }0 C    If Not IsNull(myyactiveDoc.SelectionSets.Item("Ehlxz")) Then
        Set SSet = myyactiveDoc.SelectionSets.Item("Ehlxz")
' B9 t5 b* ~- A1 @* u0 l& x1 _8 |3 ^        SSet.Delete     '及时删除不用的选择集非常重要
    End If
   Set SSet = myyactiveDoc.SelectionSets.Add("Ehlxz")
    SSet.SelectOnScreen
    '创建点组
    Dim ptArr1() As Variant
    Dim ptArr2() As Variant
    Dim count As Integer
1 [: r1 `& s  l" E* {( u! v+ W0 q    count = SSet.count
    ReDim ptArr1(count - 1)
    ReDim ptArr2(count - 1)
7 X! a0 D) r- T% x    '错误判断
. l4 X! X1 a4 M. {  j. ~9 U, ^    If count = 0 Then
- f. m2 F# U' M, C; _7 g        MsgBox "未选择任何对象！", vbCritical
2 w/ k2 Y3 y6 [        Exit Sub
2 a- v: x# D( e) n    End If

    '获得最左侧和下侧的角点
7 ?+ b5 a. q* q+ P! V* q& A/ a5 i" F    Dim objEnt As AcadEntity
    Dim ptTemp As Variant
    Dim i As Integer
    i = 0
    For Each objEnt In SSet
) q: E7 y$ W% l- u. P3 _! Q        objEnt.GetBoundingBox ptArr1(i), ptTemp
        i = i + 1
    Next
    '获得最上侧和右侧的角点
    i = 0
    For Each objEnt In SSet
% z# S. `$ r9 U& Z% M. K2 v  w        objEnt.GetBoundingBox ptTemp, ptArr2(i)
        i = i + 1
1 n0 h! G) _2 v; a4 O    Next
    Dim ptLeftX, ptLeftY, ptRightX, ptRightY
    Dim ptRight, ptTop
# T2 A! X" J, W3 ]; y6 z- u' b   For WWW = 1 To count
) a# u! m4 H2 C  A      ptLeftX = ptArr1(WWW - 1)(0)
      ptLeftY = ptArr2(WWW - 1)(1)
      ptRightX = ptArr2(WWW - 1)(0)
0 \* y( u5 f7 P      ptRightY = ptArr1(WWW - 1)(1)
! G) S0 H& p9 D& C5 j* H: Z
3 }  @2 H; {$ u: J5 s    Dim pppt1(0 To 2) As Double
3 p% h3 \, o/ k; |  z    Dim pppt2(0 To 2) As Double
        pppt1(2) = 0
        pppt2(2) = 0
    Dim gzkuan As Double, gzgao As Double
     gzkuan = (ptRightX - ptLeftX - 25 * (Int(Val(HjigeCb.Text)) - 1)) / Int(Val(HjigeCb.Text))
2 C( ^( C. M3 R9 u     gzgao = (ptLeftY - ptRightY - 25 * (Int(Val(SjigeCb.Text)) - 1)) / Int(Val(SjigeCb.Text))
    For j = 1 To Int(Val(HjigeCb.Text))
, @9 _+ p& ~0 c! z8 u      For k = 1 To Int(Val(SjigeCb.Text))
4 Y" B) B& b+ b$ o$ N        pppt1(0) = ptLeftX + (gzkuan + 25) * (j - 1)
& ?; o( W% L; v, x9 a         pppt1(1) = ptLeftY - (gzgao + 25) * (k - 1)
- @$ w6 G; s5 Q+ ]1 p         pppt2(0) = pppt1(0) + gzkuan
" Z4 V: U7 J! a( p$ v. E' l8 Y- z         pppt2(1) = pppt1(1) - gzgao
7 Y6 v9 U: s! Q5 d7 l; r  v
      Next
( k% v/ L: f) s    Next
         pppt1(0) = ptLeftX
         pppt1(1) = ptLeftY
, k) @5 D  K4 z+ P+ o- Y         pppt2(0) = ptRightX
         pppt2(1) = ptRightY
  Next
$ v3 m; ~4 b/ g$ U. E% O; V# ~    SSet.Delete
    KK = GetDistance(pppt1, pppt2)
$ @; L9 y1 ~9 Q1 J'在程序中操作EXCEL表常用命令:
( H# D2 P+ L" K9 S0 O  Dim Excel As Excel.Application
* \( A# o# h7 e( @* r. M    Dim ExcelSheet   As Object
    Dim ExcelWorkbook   As Object
    '创建Excel应用程序实例
3 v6 ?" V; _- |6 f# Q7 M    On Error Resume Next
    Set Excel = GetObject(, "Excel.Application")
    If Err <> 0 Then
        Set Excel = CreateObject("Excel.Application")
; H  A8 }5 q3 w& s% Z           '创建一个新工作簿
  z0 m' ?1 C8 W! Y$ I7 d" E/ A         Set ExcelWorkbook = Excel.Workbooks.Add
# D  L) V$ Q7 v, M+ Q, K          '令Excel应用程序可见
0 d# x. y3 H; f: y. i) |& V           Excel.Visible = True
" u$ G, {8 y8 V( Q/ l8 [* L6 Q/ G          '将新创建的工作簿保存为Excel文件
             ExcelWorkbook.SaveAs "属性表.xls"
    End If
    '确保Sheet1工作表为当前工作表
    Set ExcelSheet = Excel.ActiveSheet
/ Y7 V$ c- T, n+ b% s1 K. B7 q% b    Excel.Visible = True
    endrow = ExcelSheet.Range("A65536").End(xlUp).Row + 1
! M1 `4 A0 ^1 G    ExcelSheet.Range("A" & endrow) = KK
7 O4 R. |% G1 f. p# H, b9 N    Set Excel = Nothing
+ S$ Y1 h* k' j5 D: c    End If
8 d2 i8 T+ L- L  ^! U/ {  Next
6 l- x% n3 a, a* G9 e3 o8 {) v, XEnd Sub
* K0 z& U, M# J4 K
7 T& V3 [* d9 w0 N! E- g

woaishuijia

1# sblisb
在 Excel VBAIDE 中引用 ACAD 类库,将下面的代码写入 Sheet1 对象代码窗口.
+ l% X' E3 j% I: k运行代码时必须保证待查询的 ACAD 文档已打开并处于激活状态

1. 
   
2. Sub A()
   5 Y$ x. B9 n: E- K/ r: M" D5 ~8 A
3.     Dim CAD As AutoCAD.AcadApplication, St As AcadState, SS As AcadSelectionSet, Ft(0) As Integer, Fd(0) As Variant, I As Integer
     t, o- m( N/ B! T
4.     On Error GoTo 10
   
5.     '获取ACAD进程
   
6.     '类名称最后的编号按版本
   
7.     'R14版本为14
   ( J( M# D3 `1 i, u1 H3 h
8.     '2000~2002版本为15
     J' x( m/ Z! p/ c7 N  l/ Y
9.     '2004~2006版本为16
   
10.     '2007~2009版本为17
    
11.     '2010~2012版本为18
    
12.     Set CAD = GetObject(, "AutoCAD.Application.18" )
    
13.     '获取当前ACAD进程的状态
    
14.     Set St = CAD.GetAcadState
    
15.     '当ACAD进程空闲时查询直线长度
    4 j" }9 D" P1 W
16.     If St.IsQuiescent Then
    
17.         '创建选择集
    4 m. f% _; L" Y# C' ~$ U9 v' F0 l
18.         Set SS = CAD.ActiveDocument.SelectionSets.Add("SS" )
    
19.         '定义选择集过滤器为只选择直线
    ) w) D% ]( p; N$ h8 p* C1 ~
20.         Fd(0) = "Line"
    
21.         '用户在窗口选择
    6 g7 Y1 o% _4 w( z8 s' x: c" G
22.         SS.SelectOnScreen Ft, Fd
    ( n5 |7 z# }7 a0 _! A9 ~& t
23.         '逐个提取选择集中直线的长度并写入本工作表A列
    
24.         For I = 0 To SS.Count - 1
    
25.             Sheet1.Cells(I + 1, 1) = SS(I).Length
    6 q, O$ }8 H3 g3 u, A3 A) C  A
26.         Next
    
27.         '删除用过选择集
    6 |$ _" L6 ^. v
28.         SS.Delete
    ' A6 V! ~! S# |0 f6 _
29.     Else
    # V0 M& X6 i2 F& \: ~
30.         MsgBox "ACAD正忙"
    ! y7 M7 I. q1 e, ]4 C/ R& r# d# ^8 E+ _
31.     End If
    # l/ A8 Q' V  V/ A/ ?' c4 V
32. 10: If Err Then MsgBox "ACAD没有运行或没有活动文档"
    
33. End Sub
    * f) O4 q# l! s2 J' Z* v

复制代码

sblisb

谢谢!
能不能帮助改进两点:
1 O5 c3 r; v, x* \1 r3 d$ K: r1 数据写入A列时不覆盖A列原有数据.
2 运行程序后自动转到Acad界面,原代码运行后,是在等待状态,还在exce界面,要自己转到Acad界面

279491611

厉害，学习学习

清风香客

果断留印，方便后查。

玉紫玄

学习学习