excel如何得到线的长度?

sblisb

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

在EXCEL VBA编辑器的“工具”菜单中点“引用”，在“引用”对话框中找到ACAD类库，勾选它，确定。见图
4、在EXCEL VBA编辑器Sheet1对象代码窗口写如下代码
Sub A()
- u# R3 R- X# o5 I0 K* `
Dim CAD As AcadApplication '声明一个AutoCAD应用程序对象
3 W5 }+ W6 `4 e) XDim DOC As AcadDocument '声明AutoCAD文档对象
1 T0 {7 N4 b% J8 U! S/ A2 DSet CAD = New AcadApplication '运行一个新的AutoCAD进程
CAD.Visible = True '使运行的AutoCAD程序可见。如果没有这行，程序将不可见，就是说看不见CAD窗口，只能在Windows任务管理器看到有CAD程序运行
Set DOC = CAD.Documents.Open(Sheet1.Cells(1, 1).Value) '按照“Sheet1”工作表第一行第一列单元格的内容打开文件
DOC.SendCommand Sheet1.Cells(1, 2).Value '按“Sheet1”工作表第一行第二列单元格的内容向CAD命令行发送命令
sub

;;;=================================================================*
;;;功能：测量线的长度 *
1 R& K' H6 ^2 E& Z. n# y;;;日期：zml84 于 2009-05-21 17:45 *
(defun C:cd ()
(princ "统计线段长度"
4 e% z4 r: F  ]5 \(if (setq SS (ssget '((0 . "LINE,ARC,CIRCLE,ELLIPSE,*POLYLINE,SPLINE"))
)
" K. y& ?$ H! o% y)
(progn
/ K+ o4 M& q5 B;;
& Q+ M6 M7 ~6 `(setq LST_LEN '()
I 0
)
;;逐个统计
8 ]4 @( N: L  G) O- h4 k(repeat (sslength SS)
(setq EN (ssname SS I)
& D+ E9 J3 t9 i( s+ [3 oLEN (vlax-curve-getdistatparam
EN
4 N2 |$ j1 n. P& Q, z  H! t  T- F- I(vlax-curve-getendparam EN)
)
LST_LEN (cons LEN LST_LEN)
+ p, s% j) r- B8 H. j# cI (1+ I)
- z! k4 c2 x7 l)
)
(setq LST_LEN (reverse LST_LEN))
;;显示输出
7 i2 ^$ |+ e5 g  c* ^9 }) _(princ "\n找到个数：")
8 x( O% @/ [# L3 p(princ (sslength SS))
3 I1 h. ~& |) a3 N(princ "\n单个长度：")
/ X2 p# ?6 p1 U. P(princ LST_LEN)
(princ "\n总计长度：")
(princ (apply '+ LST_LEN))
6 V$ j" T! y. F* w+ `9 v)
1 ]% G" D5 j. u# Z0 b- {1 s)
8 Y' ^: i- |8 t/ C1 c(princ)
)
7 W- a! r* O( i( e0 n) a;;;=================================================================*
;;;(alert
;;; "功能：统计线段长度\n命令：\"CD\"\n日期：zml84 于 2009-05-21 17:45"
* X4 A2 R" d3 H  a6 g;;;)
(princ)

’在AutoCAD中编程序，写到c盘根目录下的“123.xls”Excel表格中
) k0 m+ ~$ y- E0 s5 T' x

’使用 VBA IDE 中的“工具” “引用”菜单选项，选择 Microsoft Excel 9.0 对象模型
' D% R+ H1 u9 u9 v* s$ _’水平不高，有点罗嗦，楼主可以精简下
’欢迎以后交流，QQ 42123043
' v1 Q; u$ j3 m+ fPublic Sub 取坐标()
’把AutoCAD中某一图层“多段线层”中的所有多段线的坐标列出来
" m! M2 _6 B4 _1 y: E( c: wDim PLSet As AcadSelectionSet
Dim pl As AcadLWPolyline

$ [& g/ q% ]1 Q# h
Dim ExcelApp As Excel.Application
& E# H+ n! ]0 `5 m2 R+ @Dim ExcelSheet As Object
6 j5 m& r$ ~4 _( x8 P5 l* O& \Dim ExcelWorkbook As Object

, ~; z' u8 K& D' j( L
Dim pts As Variant

Dim NN As Integer
Dim j As Integer
7 c0 f) \% H% f/ H
Dim pn As Integer
2 y) {* w: [# m' h# y/ O
3 V0 e7 I! i8 z4 MDim px(0 To 10000) As Double
: f, d% G* c- p0 _* a$ t" r! I" m$ HDim py(0 To 10000) As Double
4 H/ c+ j+ W/ ~/ L& ~Dim pz(0 To 10000) As Double

8 x. z1 E5 a- I  O+ W& K
! `* e% S3 Y) M( O% WDim filtertype(10) As Integer
Dim filterdata(1) As Variant

* M  k4 I. j7 |2 hfiltertype(0) = 0 ’ 选择线型
filterdata(0) = "LWPOLYLINE"
filtertype(1) = 8 ’ 图层标识，可以根据具体情况改动
filterdata(1) = "多段线层"
7 W$ i6 O* `7 O1 w5 ?


. B; a" F4 |. i9 h4 DSet PLSet = ThisDrawing.SelectionSets.Add("pl")
PLSet.SelectOnScreen filtertype, filterdata

: X/ I5 g% U- D5 V3 PNN = 0
. M/ B" I* D9 H1 d7 c+ C4 a8 C( xj = 0
For Each pl In PLSet

pts = pl.Coordinates
pn = (UBound(pts) + 1) / 2

For i = 0 To pn - 1
px(i + pn * j) = pts(2 * i)
py(i + pn * j) = pts(2 * i + 1)
Next i
7 m$ j' l2 W8 Yj = j + 1
NN = NN + pn
/ N4 s2 L: K# M& i, xNext pl

0 c% A" \( ~7 Z+ w& pPLSet.Delete


Set ExcelApp = New Excel.Application
. Y9 X  L7 \6 D: F; z9 u9 O
Set ExcelWorkbook = ExcelApp.Workbooks.Add

& A% X& Y3 X6 Q: ^/ e: @/ lSet ExcelSheet = ExcelApp.ActiveSheet
5 v. g) E4 M% f. w* }% }' Z) ~: d
ExcelWorkbook.SaveAs "c:\123.xls"

7 _' _7 O! x2 \- C  bExcelSheet.Cells(1, 1) = "x"
ExcelSheet.Cells(1, 2) = "y"

* @: U2 ~3 C- f" zFor i = 0 To NN - 1
* R5 V9 k! q$ m4 NExcelSheet.Cells(i + 2, 1) = px(i)
3 h8 F* j0 U' ?/ m- s' `ExcelSheet.Cells(i + 2, 2) = py(i)
4 [1 }, S6 h9 x1 g1 a9 ?Next i
: J9 B3 p' H8 o4 x, k( ?# l# y1 {
1 d* T* T' D. n8 _; _# U4 _2 @$ QEnd Sub

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

获取标注尺寸函数
7 }$ R: K1 R) I/ t  c

Function FixDimMeas(Dimension As AcadDimension) As Long
Dim BlockCount As Long
Dim bz As Long

BlockCount = ThisDrawing.Blocks.Count
'遍历块中的对象，取得标注尺寸
Dim EntityInBlock As AcadEntity
6 h0 q" u. t) a8 w6 [For Each EntityInBlock In ThisDrawing.Blocks(BlockCount - 1)
If EntityInBlock.ObjectName = "AcDbMText" Then
2 U9 a1 F! p  M' u! M5 M" r8 v3 pbz = Dimension.Measurement
: {$ y6 {5 x7 I: a. q* EFixDimMeas = bz '取得标注尺寸
Exit For
% W2 `7 f5 S+ G# C$ xEnd If
8 T, q9 M, ?) lNext
, C8 o8 t! @, ?: k+ gEnd Function

sblisb

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

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

6 t4 n$ o9 M$ {# z; ~  J'计算两点之间距离
Public Function GetDistance(ptSt As Variant, ptEn As Variant) As Double
    Dim x As Double
" F$ C+ ^( h  H. W( n( y* P; j0 O    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))
2 V7 g2 ?0 m$ t- x( V2 YEnd Function

) X  N* P/ t$ O8 pPrivate Sub xz()
'创建选择集
8 \+ k7 I. ]3 X1 L4 i1 o For JJ = 1 To 10
# r* ?1 t: _2 _5 Z2 T0 p2 D If MsgBox("是否继续选择", vbYesNo) = vbNo Then
0 Q( p8 _6 r; z& k% r" _& z Exit For
# m0 p) G3 \5 l! ?# iElse
    On Error Resume Next
* f: k5 v2 t0 C: b    Set myyactiveDoc = ActiveDocument

. J$ |. z7 v6 `" A  D5 ?- Y    Dim SSet As AcadSelectionSet
      Set SSet = myyactiveDoc.SelectionSets.Add("Ehlxz")
- Q: v* A4 M+ k    If Not IsNull(myyactiveDoc.SelectionSets.Item("Ehlxz")) Then
6 X" o. v% }& C5 y        Set SSet = myyactiveDoc.SelectionSets.Item("Ehlxz")
; w% w7 g% H) b, `' _        SSet.Delete     '及时删除不用的选择集非常重要
9 N) `0 x* i5 Y5 z% u    End If
   Set SSet = myyactiveDoc.SelectionSets.Add("Ehlxz")
1 }. b  ^" ?( L! s# A. k    SSet.SelectOnScreen
& i$ Q' a; B" ?% @- a, q( g    '创建点组
, w8 b% h+ m4 x+ J, r/ I( D# z    Dim ptArr1() As Variant
3 n% ^$ K) ~6 v6 T1 M& g* v    Dim ptArr2() As Variant
- R1 r+ I. E3 _( c, M$ i    Dim count As Integer
% F% ^0 e/ A5 L: N  m6 Y; h    count = SSet.count
    ReDim ptArr1(count - 1)
0 t0 Z1 R+ c; i. M2 R    ReDim ptArr2(count - 1)
: l8 q9 g3 C. z$ b( |    '错误判断
2 r# ?! c7 v. F; D    If count = 0 Then
        MsgBox "未选择任何对象！", vbCritical
        Exit Sub
    End If

" Z; m# O% Q0 w& K5 |: U& ~6 s    '获得最左侧和下侧的角点
7 [2 u" g7 u  t2 o. b; }% @' [: @: i    Dim objEnt As AcadEntity
+ E+ j* Z6 |5 N/ a    Dim ptTemp As Variant
    Dim i As Integer
6 b& j) O3 J  }    i = 0
# H) v8 {5 N7 |    For Each objEnt In SSet
' h/ d6 x( a. {  x        objEnt.GetBoundingBox ptArr1(i), ptTemp
7 Y; Q" q" H% Q2 e0 T' b* h) L, V        i = i + 1
    Next
) n' u1 p; ?/ K7 O. T* c    '获得最上侧和右侧的角点
    i = 0
    For Each objEnt In SSet
        objEnt.GetBoundingBox ptTemp, ptArr2(i)
        i = i + 1
    Next
: `2 i- G0 p, ~# R5 Q) e# y    Dim ptLeftX, ptLeftY, ptRightX, ptRightY
    Dim ptRight, ptTop
   For WWW = 1 To count
      ptLeftX = ptArr1(WWW - 1)(0)
8 v, O/ B+ M1 @  E      ptLeftY = ptArr2(WWW - 1)(1)
- V6 q4 S7 B5 j      ptRightX = ptArr2(WWW - 1)(0)
      ptRightY = ptArr1(WWW - 1)(1)
6 V5 {# m; y* [, Q1 O" Z
    Dim pppt1(0 To 2) As Double
& T+ w, ^3 \) E    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))
/ e- Q) {: Z+ Q! J" }+ {     gzgao = (ptLeftY - ptRightY - 25 * (Int(Val(SjigeCb.Text)) - 1)) / Int(Val(SjigeCb.Text))
; `4 i" n" w1 ]( Y0 ^' S/ r/ v+ ]) r    For j = 1 To Int(Val(HjigeCb.Text))
      For k = 1 To Int(Val(SjigeCb.Text))
        pppt1(0) = ptLeftX + (gzkuan + 25) * (j - 1)
$ r2 ~( ^' ]+ j         pppt1(1) = ptLeftY - (gzgao + 25) * (k - 1)
' g+ W: k3 R# H8 P% n         pppt2(0) = pppt1(0) + gzkuan
6 k% {. N+ t3 ?5 x' i         pppt2(1) = pppt1(1) - gzgao
1 ~5 h% S( v4 `* |9 J
, _) t  d+ j; Y" r; a7 N      Next
    Next
         pppt1(0) = ptLeftX
6 }) I$ l) i1 H. N2 }         pppt1(1) = ptLeftY
8 B! W6 V+ A/ m3 Y$ A0 J         pppt2(0) = ptRightX
         pppt2(1) = ptRightY
/ O* L$ w& I/ J/ l: {  Next
0 ~& [1 F/ ?( a# \0 |    SSet.Delete
    KK = GetDistance(pppt1, pppt2)
1 S! Q$ }9 p; Y, u) Z'在程序中操作EXCEL表常用命令:
  Dim Excel As Excel.Application
    Dim ExcelSheet   As Object
9 J1 T$ M% J4 d; Q    Dim ExcelWorkbook   As Object
    '创建Excel应用程序实例
    On Error Resume Next
. i$ @  l* v2 ?: B+ O( h( \    Set Excel = GetObject(, "Excel.Application")
! ?! J# F0 T% f, i    If Err <> 0 Then
: M5 `- ?, e' p4 D$ E: h        Set Excel = CreateObject("Excel.Application")
           '创建一个新工作簿
         Set ExcelWorkbook = Excel.Workbooks.Add
          '令Excel应用程序可见
4 r, A# ]' x  y3 E2 d           Excel.Visible = True
          '将新创建的工作簿保存为Excel文件
             ExcelWorkbook.SaveAs "属性表.xls"
. T; X! a9 M2 v1 E( T0 [4 V    End If
    '确保Sheet1工作表为当前工作表
    Set ExcelSheet = Excel.ActiveSheet
0 D$ L7 w3 v$ N3 _) H; J    Excel.Visible = True
* }4 X% o! V) q, W$ g    endrow = ExcelSheet.Range("A65536").End(xlUp).Row + 1
" C5 e  a6 Z8 U! F( q    ExcelSheet.Range("A" & endrow) = KK
. m0 d1 V- j* J- u5 N7 o    Set Excel = Nothing
    End If
9 e0 ]. L# V/ ^8 u5 T$ s  Next
) P  f6 ~  H' V% M  O; aEnd Sub

6 [! I( `; |1 ^5 z0 k

woaishuijia

1# sblisb
6 v3 H% d# _% a3 M7 k在 Excel VBAIDE 中引用 ACAD 类库,将下面的代码写入 Sheet1 对象代码窗口.
运行代码时必须保证待查询的 ACAD 文档已打开并处于激活状态
3 Q2 _/ v$ U) N1 R1 ]* }7 `2 `

1. 
   0 \; q* E3 f; e7 N$ H& @2 @8 F  z: _
2. Sub A()
   ! k5 s% N6 w# |8 k! S6 v
3.     Dim CAD As AutoCAD.AcadApplication, St As AcadState, SS As AcadSelectionSet, Ft(0) As Integer, Fd(0) As Variant, I As Integer
   ( T: Z7 h! t) z3 B4 Y1 ?. y% c
4.     On Error GoTo 10
   
5.     '获取ACAD进程
   0 \% C1 L6 m/ w4 y
6.     '类名称最后的编号按版本
   
7.     'R14版本为14
   * x1 x' a8 F2 z! T4 e( e4 S5 y
8.     '2000~2002版本为15
   ! \5 m. N' B4 v8 H3 W0 ?' Z- L& O
9.     '2004~2006版本为16
   - l" ]6 X3 l3 f  g% |; |2 Y
10.     '2007~2009版本为17
    
11.     '2010~2012版本为18
    
12.     Set CAD = GetObject(, "AutoCAD.Application.18" )
    + j( B5 ]' i9 o7 K: P8 Q! Y& f9 m
13.     '获取当前ACAD进程的状态
    
14.     Set St = CAD.GetAcadState
    
15.     '当ACAD进程空闲时查询直线长度
    
16.     If St.IsQuiescent Then
    
17.         '创建选择集
    
18.         Set SS = CAD.ActiveDocument.SelectionSets.Add("SS" )
    2 v7 r% r; T" U5 ~% b
19.         '定义选择集过滤器为只选择直线
    6 i! J, b4 a- Z3 _
20.         Fd(0) = "Line"
    $ ?( S! P& ?) ~4 {3 H0 S
21.         '用户在窗口选择
    0 i1 m# ^" w, I! p
22.         SS.SelectOnScreen Ft, Fd
    8 m! a) M9 A0 G' A+ R
23.         '逐个提取选择集中直线的长度并写入本工作表A列
    " b7 M- N: Q) ~# u+ g- w9 W
24.         For I = 0 To SS.Count - 1
    
25.             Sheet1.Cells(I + 1, 1) = SS(I).Length
    
26.         Next
    # V, @- m' ?8 `- w3 o+ y
27.         '删除用过选择集
    + P5 _6 c. }2 q, v" i
28.         SS.Delete
    
29.     Else
    
30.         MsgBox "ACAD正忙"
    
31.     End If
    
32. 10: If Err Then MsgBox "ACAD没有运行或没有活动文档"
    * q+ [9 \" J* d# b; V
33. End Sub
    1 }  [" S& [" ~$ j5 g) \3 [

复制代码

sblisb

谢谢!
. h' ]8 ?3 c4 J' @: C$ Z/ x; m能不能帮助改进两点:
+ S) T' Z1 v7 A  ]1 数据写入A列时不覆盖A列原有数据.
2 运行程序后自动转到Acad界面,原代码运行后,是在等待状态,还在exce界面,要自己转到Acad界面

279491611

厉害，学习学习

清风香客

果断留印，方便后查。

玉紫玄

学习学习