excel如何得到线的长度?

sblisb

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

在EXCEL VBA编辑器的“工具”菜单中点“引用”，在“引用”对话框中找到ACAD类库，勾选它，确定。见图
' @" t* }4 i! u+ q4、在EXCEL VBA编辑器Sheet1对象代码窗口写如下代码
. f* e# ~" \7 nSub A()

& ]( G, a) s, M8 t4 p8 [Dim CAD As AcadApplication '声明一个AutoCAD应用程序对象
5 y0 t- C# k( R; mDim DOC As AcadDocument '声明AutoCAD文档对象
Set CAD = New AcadApplication '运行一个新的AutoCAD进程
" w, e  L% ~. t8 C7 u' @CAD.Visible = True '使运行的AutoCAD程序可见。如果没有这行，程序将不可见，就是说看不见CAD窗口，只能在Windows任务管理器看到有CAD程序运行
  C& N9 Y" Y5 o! z- ]: O! ]Set DOC = CAD.Documents.Open(Sheet1.Cells(1, 1).Value) '按照“Sheet1”工作表第一行第一列单元格的内容打开文件
DOC.SendCommand Sheet1.Cells(1, 2).Value '按“Sheet1”工作表第一行第二列单元格的内容向CAD命令行发送命令
" |2 I+ M/ @) m) t. D4 b, Wsub

;;;=================================================================*
1 b2 ?  n/ e" H% u0 ]' E) c;;;功能：测量线的长度 *
" p8 j2 B% f! m, n  Z$ x9 Q;;;日期：zml84 于 2009-05-21 17:45 *
+ ^5 n% f, e  ^(defun C:cd ()
9 ~, c6 U, z! `4 a+ O(princ "统计线段长度"
! ], N4 Q# @; d& L% p$ c(if (setq SS (ssget '((0 . "LINE,ARC,CIRCLE,ELLIPSE,*POLYLINE,SPLINE"))
0 Y4 j5 @8 h- A/ P% @2 q- |5 L)
" X( @6 R! C: L& y" @: o6 P" S7 {)
(progn
;;
) q9 h6 N* Y. z/ n) M9 {! u# @(setq LST_LEN '()
I 0
. \+ x- i# b% h0 ~1 [$ e: B, y)
;;逐个统计
(repeat (sslength SS)
(setq EN (ssname SS I)
% G% [* G5 ^* w& E; L3 ?; W: @9 Q! KLEN (vlax-curve-getdistatparam
EN
(vlax-curve-getendparam EN)
6 v. E9 b) L* {" Y! S+ y# I. V( B)
LST_LEN (cons LEN LST_LEN)
* {+ Q* a) H( f( i0 JI (1+ I)
)
0 F: s& L4 Y7 L)
4 P" h4 q! ?: f) v6 d(setq LST_LEN (reverse LST_LEN))
* F2 ~, `! N* h- f  D/ R& \;;显示输出
5 i# z/ j! }% `& E(princ "\n找到个数：")
- @, t* _0 {+ {: s# T( K  I(princ (sslength SS))
. j/ t' F. u" I  f(princ "\n单个长度：")
(princ LST_LEN)
(princ "\n总计长度：")
(princ (apply '+ LST_LEN))
* B. @8 \' s- X7 K2 l)
+ l/ S9 p0 Q) V/ p" U)
$ n$ X5 S" `* u- J' T, a(princ)
3 J2 S% d6 }' g( t)
;;;=================================================================*
9 F' g# H6 F, \, w;;;(alert
) A( ?% F; T  ]/ g# h) t;;; "功能：统计线段长度\n命令：\"CD\"\n日期：zml84 于 2009-05-21 17:45"
;;;)
(princ)

6 g1 O; `7 N$ g9 e3 p) |’在AutoCAD中编程序，写到c盘根目录下的“123.xls”Excel表格中
# p+ ]! [, f: r, n" k* _; @! S

’使用 VBA IDE 中的“工具” “引用”菜单选项，选择 Microsoft Excel 9.0 对象模型
; k# r  H( m# \6 X! g5 }’水平不高，有点罗嗦，楼主可以精简下
’欢迎以后交流，QQ 42123043
Public Sub 取坐标()
’把AutoCAD中某一图层“多段线层”中的所有多段线的坐标列出来
Dim PLSet As AcadSelectionSet
+ G/ w2 r5 Q( YDim pl As AcadLWPolyline
) Y) ~+ g$ _/ I  o" s4 V2 `  p

. y4 i) z/ l* YDim ExcelApp As Excel.Application
, Q) A6 }' Q  J' ^$ XDim ExcelSheet As Object
( B( C9 ^6 h3 P) I. {Dim ExcelWorkbook As Object
8 q/ a1 C: O7 S8 R0 h$ w; x( `
8 i0 y  S' }% Q
Dim pts As Variant

Dim NN As Integer
3 x2 u+ S9 ~' s8 L4 HDim j As Integer
* Z% P$ E* i& v
Dim pn As Integer

Dim px(0 To 10000) As Double
Dim py(0 To 10000) As Double
) ~/ a7 q2 \0 D) }5 yDim pz(0 To 10000) As Double
& F' y4 K, F( |' ~( B* f6 w/ R

Dim filtertype(10) As Integer
Dim filterdata(1) As Variant

3 V6 @, d, S; C8 @) B* pfiltertype(0) = 0 ’ 选择线型
filterdata(0) = "LWPOLYLINE"
7 J' D# N- n  G/ j: S: Q! \9 N% Zfiltertype(1) = 8 ’ 图层标识，可以根据具体情况改动
filterdata(1) = "多段线层"
! q: v+ X) l0 X, L" T3 H- R" O


) N0 B! j. r/ A! LSet PLSet = ThisDrawing.SelectionSets.Add("pl")
PLSet.SelectOnScreen filtertype, filterdata
0 [+ \/ p+ k4 y* G: B( t( [% U
3 p5 g" B( [/ p( X$ H. bNN = 0
j = 0
For Each pl In PLSet
, R! m7 V5 m/ z3 R
pts = pl.Coordinates
7 o. T/ n) o7 \3 ^pn = (UBound(pts) + 1) / 2
2 S$ \7 E) p1 q9 {
For i = 0 To pn - 1
px(i + pn * j) = pts(2 * i)
py(i + pn * j) = pts(2 * i + 1)
% s, Y2 S( [  w( {( w* J- sNext i
1 F* E4 f- ~( j7 Q4 S. Vj = j + 1
NN = NN + pn
Next pl

' E' Q8 g* s# }/ m. e% ?+ j+ L% yPLSet.Delete
8 m; R+ p# N( c5 }1 |

9 \0 ^7 `+ D) b# lSet ExcelApp = New Excel.Application
+ t# }! m$ q* J/ T* ]
2 F" N# s$ I  i, m: w+ E) hSet ExcelWorkbook = ExcelApp.Workbooks.Add
5 T: m5 A2 C* i! b6 Q9 I+ @& Y( c- ]
+ F  D8 p/ V' KSet ExcelSheet = ExcelApp.ActiveSheet
9 a& Z# d4 C$ Y; D8 K
ExcelWorkbook.SaveAs "c:\123.xls"
5 X7 m8 V: m: V; k; W- |. r8 H% E
/ ^  _* J) b% i# F+ Q# PExcelSheet.Cells(1, 1) = "x"
2 ^# \' ?2 i- f  A$ M" H: Y7 X2 ^) W, PExcelSheet.Cells(1, 2) = "y"
0 X7 A. r: m- o1 o+ s9 k
For i = 0 To NN - 1
+ ~+ I$ G7 ?8 X- M0 i! a  XExcelSheet.Cells(i + 2, 1) = px(i)
ExcelSheet.Cells(i + 2, 2) = py(i)
; ?! M* v1 h$ @6 c' j) ANext i
2 c2 {* u  m% \5 K4 M
End Sub

其实，从Excel里面操作，完全也可以实现
: C+ ?% V$ h/ V7 x9 G只需在excel的 VBA IDE 中的“工具” “引用”菜单选项，选择 AutoCAD 2004 Type Library 对象模型
然后类似的思路编程即可，大家可以试试！

获取标注尺寸函数
  r2 A, t! U4 k$ d) Y8 c2 L
$ `3 A8 k: s+ L5 p- Z8 K

Function FixDimMeas(Dimension As AcadDimension) As Long
Dim BlockCount As Long
5 E& u0 R; _* k# ~/ pDim bz As Long

BlockCount = ThisDrawing.Blocks.Count
7 R# C$ i  W; }* s'遍历块中的对象，取得标注尺寸
Dim EntityInBlock As AcadEntity
For Each EntityInBlock In ThisDrawing.Blocks(BlockCount - 1)
If EntityInBlock.ObjectName = "AcDbMText" Then
- v+ {3 k* w/ \/ Vbz = Dimension.Measurement
& M" e6 @- {7 T1 DFixDimMeas = bz '取得标注尺寸
9 m* C. Q' p& g* G% ^" ]Exit For
End If
, o- E" t2 ?' XNext
End Function

sblisb

这段是在cad中执行,写入excel,偶想改成在excel中执行,写入表
" V8 o2 t0 ?4 ]2 [7 D

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

/ A  `& r+ \' J& k! g1 E'计算两点之间距离
3 \: U( F2 b/ L& Y7 Q0 E2 cPublic Function GetDistance(ptSt As Variant, ptEn As Variant) As Double
    Dim x As Double
1 Y, V6 W7 A% n. p( U/ w' @    Dim y As Double
    Dim z As Double
- T. h8 `) t8 A* K) b4 V! S    x = ptSt(0) - ptEn(0)
    y = ptSt(1) - ptEn(1)
    z = ptSt(2) - ptEn(2)
5 X+ E% s! r5 _9 D! k    GetDistance = Sqr((Sqr((x ^ 2) + (y ^ 2)) ^ 2) + (z ^ 2))
End Function

Private Sub xz()
0 c& N& Q, y* P' n# D3 S '创建选择集
For JJ = 1 To 10
If MsgBox("是否继续选择", vbYesNo) = vbNo Then
Exit For
Else
, q: v1 s9 z( |3 r2 A) \0 `    On Error Resume Next
    Set myyactiveDoc = ActiveDocument
& V* Q2 Y+ J$ x% w  g
    Dim SSet As AcadSelectionSet
      Set SSet = myyactiveDoc.SelectionSets.Add("Ehlxz")
    If Not IsNull(myyactiveDoc.SelectionSets.Item("Ehlxz")) Then
& y$ B# N, B7 d5 ]( E        Set SSet = myyactiveDoc.SelectionSets.Item("Ehlxz")
        SSet.Delete     '及时删除不用的选择集非常重要
3 M: D; i5 Q  T" n    End If
# y7 z/ z! r5 ^+ f$ l   Set SSet = myyactiveDoc.SelectionSets.Add("Ehlxz")
    SSet.SelectOnScreen
    '创建点组
7 h! K2 c, f6 C    Dim ptArr1() As Variant
    Dim ptArr2() As Variant
+ Y" W# t: T  E: T, W    Dim count As Integer
% }" h0 J, P4 z) {0 G    count = SSet.count
    ReDim ptArr1(count - 1)
1 x- D) R, ~; T$ K. c/ E    ReDim ptArr2(count - 1)
% h1 z. w/ X3 v" U6 ^/ r! I    '错误判断
    If count = 0 Then
; ~* C9 T( P* S        MsgBox "未选择任何对象！", vbCritical
        Exit Sub
/ J2 D7 b0 C. \6 s3 d    End If
! F% n/ Z/ F+ h
    '获得最左侧和下侧的角点
+ c; `" C6 b7 X; x( t    Dim objEnt As AcadEntity
    Dim ptTemp As Variant
4 Y2 `0 v. t5 E. L4 x  N9 [    Dim i As Integer
    i = 0
+ l. r: r4 G  B8 K; u1 a6 c+ |    For Each objEnt In SSet
        objEnt.GetBoundingBox ptArr1(i), ptTemp
( x; j/ y+ i4 P1 g! M        i = i + 1
9 D: Y, T; i+ e- o! s; u* h    Next
% I' a3 e9 W; i9 p6 |1 H    '获得最上侧和右侧的角点
/ \  W. T! s9 C    i = 0
    For Each objEnt In SSet
" g8 M1 y  O4 O9 ]0 E        objEnt.GetBoundingBox ptTemp, ptArr2(i)
        i = i + 1
1 \0 V5 t/ n3 R) z    Next
+ O9 X% o+ g$ U8 c9 r$ c, `0 ]6 K    Dim ptLeftX, ptLeftY, ptRightX, ptRightY
    Dim ptRight, ptTop
   For WWW = 1 To count
      ptLeftX = ptArr1(WWW - 1)(0)
      ptLeftY = ptArr2(WWW - 1)(1)
      ptRightX = ptArr2(WWW - 1)(0)
      ptRightY = ptArr1(WWW - 1)(1)

1 X5 Y' _: b5 o' |9 v    Dim pppt1(0 To 2) As Double
  c6 p9 {* X* F; I    Dim pppt2(0 To 2) As Double
9 Z0 n- D. K1 r; o. I2 n2 N6 e        pppt1(2) = 0
        pppt2(2) = 0
- K1 U5 M; E" e& G2 H    Dim gzkuan As Double, gzgao As Double
     gzkuan = (ptRightX - ptLeftX - 25 * (Int(Val(HjigeCb.Text)) - 1)) / Int(Val(HjigeCb.Text))
& u5 t3 c% B2 ]/ ?( m     gzgao = (ptLeftY - ptRightY - 25 * (Int(Val(SjigeCb.Text)) - 1)) / Int(Val(SjigeCb.Text))
/ u! a' F) A- F) @2 \    For j = 1 To Int(Val(HjigeCb.Text))
) R' I+ D0 b: l  n6 S0 z1 e      For k = 1 To Int(Val(SjigeCb.Text))
$ g* A: p% u+ B0 |" h/ g* p3 M        pppt1(0) = ptLeftX + (gzkuan + 25) * (j - 1)
         pppt1(1) = ptLeftY - (gzgao + 25) * (k - 1)
         pppt2(0) = pppt1(0) + gzkuan
' h. y( J, `. M, ]% M/ g         pppt2(1) = pppt1(1) - gzgao

      Next
% I4 z% e" G* w& K    Next
+ F! K- \* p0 j         pppt1(0) = ptLeftX
/ @  q9 k' s' {. V# Q, U( ~7 d         pppt1(1) = ptLeftY
4 q1 I; P( `0 l* P- G% E% z         pppt2(0) = ptRightX
$ Y3 p1 u" o! ]         pppt2(1) = ptRightY
1 J7 m5 Z4 z" A* J  v0 X  Next
1 y6 }3 s: Y% m3 Q7 z    SSet.Delete
$ R$ b# d2 @6 Y9 ?    KK = GetDistance(pppt1, pppt2)
7 e* H' f8 e% l- p  ]2 L0 I'在程序中操作EXCEL表常用命令:
8 J5 m4 O; n: ^" N5 K  Dim Excel As Excel.Application
+ {; e0 g& G- U1 ?    Dim ExcelSheet   As Object
& R1 u4 _' o1 G3 ?/ N5 Q% q    Dim ExcelWorkbook   As Object
7 @$ g+ e3 Z) W/ d9 ~% n4 L    '创建Excel应用程序实例
! v9 W8 Z4 i7 Q; V* s& L    On Error Resume Next
" o; q: k  v( q) ?& y, p! f    Set Excel = GetObject(, "Excel.Application")
, M5 U8 G5 L: W3 J( O2 k* p2 u    If Err <> 0 Then
        Set Excel = CreateObject("Excel.Application")
           '创建一个新工作簿
: l8 [1 k3 q6 Y4 O" T& R         Set ExcelWorkbook = Excel.Workbooks.Add
& A6 z& q) d8 ]          '令Excel应用程序可见
           Excel.Visible = True
          '将新创建的工作簿保存为Excel文件
) d  v: \% A; F1 _. }             ExcelWorkbook.SaveAs "属性表.xls"
: d" S) D7 H5 ]* l6 L: B* u( `    End If
; Z- q- P. k* ^& p. Y- C    '确保Sheet1工作表为当前工作表
    Set ExcelSheet = Excel.ActiveSheet
0 K9 u! F( \7 ]' q- m    Excel.Visible = True
- b! a) h; A  A% I* N4 \    endrow = ExcelSheet.Range("A65536").End(xlUp).Row + 1
0 J1 p5 m( o9 D, p/ q0 Z: V2 o; z+ \    ExcelSheet.Range("A" & endrow) = KK
2 L# t) [; M4 g/ v$ Y6 c1 F) |    Set Excel = Nothing
    End If
  Next
End Sub
0 D& A7 {9 `2 f; e' y

woaishuijia

1# sblisb
# L& G4 B& A( S2 s在 Excel VBAIDE 中引用 ACAD 类库,将下面的代码写入 Sheet1 对象代码窗口.
运行代码时必须保证待查询的 ACAD 文档已打开并处于激活状态
2 M& W0 z' J' v+ i  V. L4 w

1. 
   6 B: G* a* s8 m- L
2. Sub A()
   6 d, j: h' X! P. O/ r" A
3.     Dim CAD As AutoCAD.AcadApplication, St As AcadState, SS As AcadSelectionSet, Ft(0) As Integer, Fd(0) As Variant, I As Integer
   - A; F0 a1 |6 E: e- Z7 @
4.     On Error GoTo 10
   
5.     '获取ACAD进程
   5 L1 x0 r) y( P! {1 O/ X, ]
6.     '类名称最后的编号按版本
   
7.     'R14版本为14
   
8.     '2000~2002版本为15
   
9.     '2004~2006版本为16
   7 J4 i; y( b3 @2 `( p' [9 M# g
10.     '2007~2009版本为17
    + p' c+ _0 y, k1 {% a2 I( g1 S
11.     '2010~2012版本为18
    ! }) V- f, v: a& G) `
12.     Set CAD = GetObject(, "AutoCAD.Application.18" )
    $ o7 Q* R! z( r* j2 R0 t
13.     '获取当前ACAD进程的状态
    + P# e" j5 g0 F) {2 N! l
14.     Set St = CAD.GetAcadState
    
15.     '当ACAD进程空闲时查询直线长度
    
16.     If St.IsQuiescent Then
    
17.         '创建选择集
    
18.         Set SS = CAD.ActiveDocument.SelectionSets.Add("SS" )
    
19.         '定义选择集过滤器为只选择直线
    : {6 L! y; _9 F2 d/ |" f
20.         Fd(0) = "Line"
    ; u6 M% @2 Q. l( _1 C7 L
21.         '用户在窗口选择
    
22.         SS.SelectOnScreen Ft, Fd
    5 T; V0 F* z* z
23.         '逐个提取选择集中直线的长度并写入本工作表A列
    
24.         For I = 0 To SS.Count - 1
    
25.             Sheet1.Cells(I + 1, 1) = SS(I).Length
    
26.         Next
    1 K- }* C. p+ i2 |
27.         '删除用过选择集
    . N, {4 l, j9 N0 ]3 N
28.         SS.Delete
    
29.     Else
    
30.         MsgBox "ACAD正忙"
    
31.     End If
    ; ~$ v8 N8 C4 @' U7 Q% Z
32. 10: If Err Then MsgBox "ACAD没有运行或没有活动文档"
    3 u5 ~# R6 p+ I  J
33. End Sub
    

复制代码

sblisb

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

279491611

厉害，学习学习

清风香客

果断留印，方便后查。

玉紫玄

学习学习