excel如何得到线的长度?

sblisb

我想在excel中操作,得到打开的cad文件中择的线的长度,然后写入excel表.
! d+ B. B7 |% X; [: j其中选择效果就象在cad中选菜单下的"工具_查询_列表显示",选择后按空格或回车,得到线的长度就分别写入excel表中A列了.
7 m+ q3 E  D7 f3 O在网上搜索了两天,得到如下代码,偶vba不好,请哪位高手帮我整合下,谢谢!
* R' h1 `. `+ X0 f9 j3 k- O/ Zexcel中操作cad请参考下面的步骤：

在EXCEL VBA编辑器的“工具”菜单中点“引用”，在“引用”对话框中找到ACAD类库，勾选它，确定。见图
! U4 m9 u4 |/ v$ [4、在EXCEL VBA编辑器Sheet1对象代码窗口写如下代码
  {+ I9 k9 d' {& xSub A()
' n5 l5 f+ {7 {0 h; [& Z$ E$ i2 A+ m
Dim CAD As AcadApplication '声明一个AutoCAD应用程序对象
; b' H, t4 f0 ^Dim DOC As AcadDocument '声明AutoCAD文档对象
0 I6 e& Q, O  i1 Q  RSet CAD = New AcadApplication '运行一个新的AutoCAD进程
CAD.Visible = True '使运行的AutoCAD程序可见。如果没有这行，程序将不可见，就是说看不见CAD窗口，只能在Windows任务管理器看到有CAD程序运行
Set DOC = CAD.Documents.Open(Sheet1.Cells(1, 1).Value) '按照“Sheet1”工作表第一行第一列单元格的内容打开文件
5 g; |9 J7 G1 z3 i- p" ADOC.SendCommand Sheet1.Cells(1, 2).Value '按“Sheet1”工作表第一行第二列单元格的内容向CAD命令行发送命令
sub

;;;=================================================================*
% ^+ L% H* i4 |' A0 j) ];;;功能：测量线的长度 *
;;;日期：zml84 于 2009-05-21 17:45 *
/ a9 |* s3 G- W- Z) j(defun C:cd ()
(princ "统计线段长度"
3 K% l, I# g7 J9 G. a9 o1 u  n6 t(if (setq SS (ssget '((0 . "LINE,ARC,CIRCLE,ELLIPSE,*POLYLINE,SPLINE"))
# n$ H2 D0 r" W1 \)
)
(progn
5 O; m# _# I4 o# T8 `3 l! ?( a5 Y;;
; u5 U2 \3 t/ G* ~, N0 A8 n0 G, V9 a(setq LST_LEN '()
I 0
! j6 E( O( V1 R! T( k1 z8 U& z( `/ G)
, w; Z, A" d& k* w  q;;逐个统计
) e' @" _/ Z: w/ c4 I(repeat (sslength SS)
) ?0 ]( e! `5 D% u+ J, s( d/ Z. y# M(setq EN (ssname SS I)
LEN (vlax-curve-getdistatparam
# l. _) V" b3 H/ j' @7 [6 N; W: KEN
(vlax-curve-getendparam EN)
3 N# W$ `9 T+ q7 @$ b& y)
LST_LEN (cons LEN LST_LEN)
& c' \! a/ _1 O; S: ?: Z. FI (1+ I)
)
3 b, R2 b$ O9 P( t: N7 m, U)
(setq LST_LEN (reverse LST_LEN))
0 O( X9 a1 Z) f% \$ Q;;显示输出
(princ "\n找到个数：")
/ C6 G! \0 p2 d& A7 L& D(princ (sslength SS))
- C( j6 y5 f1 I( o) }2 u, z(princ "\n单个长度：")
) _: Q7 ^( y9 u9 q* r5 m; S1 B(princ LST_LEN)
3 c- X* H  M2 ~(princ "\n总计长度：")
( Q) U! S/ ~1 F+ a! e' [(princ (apply '+ LST_LEN))
+ R4 i$ X' b% B6 |  [)
! B. r( u: w- x& \  Q0 ^)
(princ)
2 w( L1 O# D  v)
;;;=================================================================*
- J$ X2 j9 ?( o8 {- f( ~- h) c;;;(alert
& Q- l6 K7 q3 ?$ R/ u;;; "功能：统计线段长度\n命令：\"CD\"\n日期：zml84 于 2009-05-21 17:45"
  B( L6 a3 P$ z" N1 `% C% O;;;)
(princ)

$ `9 a. c+ d, f’在AutoCAD中编程序，写到c盘根目录下的“123.xls”Excel表格中

’使用 VBA IDE 中的“工具” “引用”菜单选项，选择 Microsoft Excel 9.0 对象模型
’水平不高，有点罗嗦，楼主可以精简下
’欢迎以后交流，QQ 42123043
: J& |& X+ H+ g8 s5 mPublic Sub 取坐标()
: J! T5 h  x: U6 I’把AutoCAD中某一图层“多段线层”中的所有多段线的坐标列出来
9 \+ P% k8 s: C# bDim PLSet As AcadSelectionSet
! f( @1 ^6 t" ~1 ZDim pl As AcadLWPolyline
$ X% f% l7 z& _  t  H2 V

Dim ExcelApp As Excel.Application
- x, [8 \' I  B9 A+ z! aDim ExcelSheet As Object
( K! s& o) @8 s: Z: v1 nDim ExcelWorkbook As Object
; d% U% C2 Z2 A" e% I- _
: b) u, h9 \& n: `# W+ n* s
Dim pts As Variant
, h+ d7 X, b8 {; O) B
7 O% H' `* o) {* ?% N) bDim NN As Integer
2 T$ l( U) a  R; M# kDim j As Integer

/ N( I- n  H- jDim pn As Integer

Dim px(0 To 10000) As Double
Dim py(0 To 10000) As Double
8 f' G2 [7 B, h+ E8 N+ HDim pz(0 To 10000) As Double

, L/ C) ?9 r" @, `5 `* f; s
' z+ s: U# X1 k) q9 W6 ~Dim filtertype(10) As Integer
* _" L, Y  S- @* d7 r8 M" JDim filterdata(1) As Variant

filtertype(0) = 0 ’ 选择线型
filterdata(0) = "LWPOLYLINE"
0 ?/ j0 m+ k5 wfiltertype(1) = 8 ’ 图层标识，可以根据具体情况改动
0 `& L/ {9 S" }7 i, P, ufilterdata(1) = "多段线层"
- }- D1 d: [) J/ R/ |2 E

4 {% E% {) Q( o* D8 q5 Y
) Q; U* `# r9 r9 F+ x3 ~( B) }Set PLSet = ThisDrawing.SelectionSets.Add("pl")
PLSet.SelectOnScreen filtertype, filterdata

; i0 S" d# Y, U+ X+ n0 \NN = 0
$ w+ g+ {. |2 G4 J6 B7 I# c; ~) [" aj = 0
+ {  U9 f3 O8 pFor Each pl In PLSet
/ X0 e3 o! D, L1 N) s; {
pts = pl.Coordinates
pn = (UBound(pts) + 1) / 2

( }/ E) @/ v0 j, H2 qFor i = 0 To pn - 1
px(i + pn * j) = pts(2 * i)
$ U7 X3 ]) m# Y5 ~1 S8 }! lpy(i + pn * j) = pts(2 * i + 1)
Next i
j = j + 1
NN = NN + pn
Next pl
. Q8 W2 }- m# b! p0 P* j# s
PLSet.Delete


Set ExcelApp = New Excel.Application
7 m: ~: t2 \/ ?6 x( o
Set ExcelWorkbook = ExcelApp.Workbooks.Add

Set ExcelSheet = ExcelApp.ActiveSheet

. E+ l- n  M  r1 ]; UExcelWorkbook.SaveAs "c:\123.xls"
# c# Z/ J4 d9 g* Q- ^4 G! p
2 v, E) I+ p) U9 a: xExcelSheet.Cells(1, 1) = "x"
ExcelSheet.Cells(1, 2) = "y"

  z" h( d; g2 @+ L/ b; Q( AFor i = 0 To NN - 1
1 C# D' @. |, \1 y  sExcelSheet.Cells(i + 2, 1) = px(i)
) T& K% M/ X+ [# k5 kExcelSheet.Cells(i + 2, 2) = py(i)
" ~! L6 o8 I3 c) j- t: GNext i

End Sub

其实，从Excel里面操作，完全也可以实现
0 @& H& b! N3 r6 Y只需在excel的 VBA IDE 中的“工具” “引用”菜单选项，选择 AutoCAD 2004 Type Library 对象模型
8 p3 B/ o, _$ c, I; V' l2 h然后类似的思路编程即可，大家可以试试！
( Q4 m1 [0 V6 v2 y" _
8 `  ~+ c6 {/ [( m+ ^0 H获取标注尺寸函数
  E$ u* p2 `# o8 H2 R# d8 k

Function FixDimMeas(Dimension As AcadDimension) As Long
Dim BlockCount As Long
, @1 p2 k9 s6 z  k2 A8 Z% WDim bz As Long
8 g% w3 v6 h4 u5 S9 t4 L* ]
+ f& t) K" k7 G/ ZBlockCount = ThisDrawing.Blocks.Count
5 O; ^* x3 W+ }; t0 S' q( X4 t4 J'遍历块中的对象，取得标注尺寸
' E* I) f5 U+ z! Q& _Dim EntityInBlock As AcadEntity
For Each EntityInBlock In ThisDrawing.Blocks(BlockCount - 1)
If EntityInBlock.ObjectName = "AcDbMText" Then
bz = Dimension.Measurement
FixDimMeas = bz '取得标注尺寸
Exit For
End If
, }# E& ?  E, H" n, h8 QNext
End Function

sblisb

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

选择CAD线条 EXCEL记录长度
+ w2 ^8 r  s/ h1 {( ~选择“工具”\“引用”项，在弹出的“引用”对话框的“可使用的引用”列表框内，选择“Microsoft Excel 8.0 Object Library"项

+ }0 _+ U7 s" G% V/ R: L3 R'计算两点之间距离
. @! F% F- q1 d; N9 MPublic Function GetDistance(ptSt As Variant, ptEn As Variant) As Double
    Dim x As Double
6 G) n1 z' W" D8 @' O( U    Dim y As Double
3 m7 T1 A% p1 ?9 Q* s    Dim z As Double
& p# P* ]! Z- x2 u3 R( b    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))
, [9 s* U" F4 dEnd Function
' {( [1 h- g. E& N& n+ |; E* W
. m, [7 B3 D1 {  ZPrivate Sub xz()
+ Y9 w- x. l  `2 d: I/ h- l '创建选择集
! K* Q7 M) l( O# T3 M& {$ x1 q For JJ = 1 To 10
6 I9 c& D" I3 t/ E If MsgBox("是否继续选择", vbYesNo) = vbNo Then
Exit For
: @1 R' j% \9 ^! G6 eElse
5 p3 |0 A; @, [    On Error Resume Next
    Set myyactiveDoc = ActiveDocument

% H; ^, h! M3 O* e7 i2 b/ |+ {    Dim SSet As AcadSelectionSet
. U# i' @: {* [$ @4 g      Set SSet = myyactiveDoc.SelectionSets.Add("Ehlxz")
    If Not IsNull(myyactiveDoc.SelectionSets.Item("Ehlxz")) Then
        Set SSet = myyactiveDoc.SelectionSets.Item("Ehlxz")
        SSet.Delete     '及时删除不用的选择集非常重要
    End If
, M0 Y) Q3 c# C( j1 [   Set SSet = myyactiveDoc.SelectionSets.Add("Ehlxz")
8 R9 m+ `$ V$ k# p- W    SSet.SelectOnScreen
    '创建点组
0 q; l) }5 D2 }2 S; H5 t$ ]4 f    Dim ptArr1() As Variant
; L& g  T- W9 Z3 R    Dim ptArr2() As Variant
    Dim count As Integer
    count = SSet.count
1 q& Y7 f7 S3 k' M    ReDim ptArr1(count - 1)
, \0 K+ q9 z& m: a5 A, j8 H1 W    ReDim ptArr2(count - 1)
    '错误判断
' w4 Q' ^; K& w- {" x2 W6 n    If count = 0 Then
1 y6 q: ~) w6 Q- M* a        MsgBox "未选择任何对象！", vbCritical
: w# E7 F8 Z6 ?+ C% M9 D        Exit Sub
6 O/ F2 r3 C5 x" B% d    End If

    '获得最左侧和下侧的角点
, d3 t) R! x+ B0 w$ A! }    Dim objEnt As AcadEntity
$ t5 B: p- b. |; A, K    Dim ptTemp As Variant
& `6 N7 S' M3 r4 m1 G9 f    Dim i As Integer
& J$ d. U8 c: M! O. H    i = 0
    For Each objEnt In SSet
        objEnt.GetBoundingBox ptArr1(i), ptTemp
        i = i + 1
    Next
    '获得最上侧和右侧的角点
    i = 0
7 W0 d7 p6 y4 \+ g% `    For Each objEnt In SSet
        objEnt.GetBoundingBox ptTemp, ptArr2(i)
$ q. Q1 }( m  _8 z" x5 C        i = i + 1
4 B, [; Q8 }/ g2 ]2 L    Next
( B/ p* V: ]* a. B6 I4 q# r) X    Dim ptLeftX, ptLeftY, ptRightX, ptRightY
6 T- `' c5 @8 Q' F9 l; X6 t+ o    Dim ptRight, ptTop
   For WWW = 1 To count
2 M# A7 D, W7 w2 Y% ~) V      ptLeftX = ptArr1(WWW - 1)(0)
      ptLeftY = ptArr2(WWW - 1)(1)
      ptRightX = ptArr2(WWW - 1)(0)
      ptRightY = ptArr1(WWW - 1)(1)
- w3 F" `  `# ^7 q1 d* ~
+ l) L; H- m( B1 t0 e: o  `' a    Dim pppt1(0 To 2) As Double
    Dim pppt2(0 To 2) As Double
/ g& O: ~3 f/ |        pppt1(2) = 0
. R( k% R. e. `# f        pppt2(2) = 0
4 M/ G1 C5 @! G0 Q/ \    Dim gzkuan As Double, gzgao As Double
     gzkuan = (ptRightX - ptLeftX - 25 * (Int(Val(HjigeCb.Text)) - 1)) / Int(Val(HjigeCb.Text))
     gzgao = (ptLeftY - ptRightY - 25 * (Int(Val(SjigeCb.Text)) - 1)) / Int(Val(SjigeCb.Text))
6 _3 z  \. S7 \0 d    For j = 1 To Int(Val(HjigeCb.Text))
: b% ~9 r/ v0 l/ ]2 ]5 ?      For k = 1 To Int(Val(SjigeCb.Text))
$ o6 X# g5 D' Y9 s        pppt1(0) = ptLeftX + (gzkuan + 25) * (j - 1)
. O+ U5 R- @: e& c         pppt1(1) = ptLeftY - (gzgao + 25) * (k - 1)
         pppt2(0) = pppt1(0) + gzkuan
         pppt2(1) = pppt1(1) - gzgao

      Next
8 v. o% Q; F/ K7 D    Next
         pppt1(0) = ptLeftX
         pppt1(1) = ptLeftY
         pppt2(0) = ptRightX
% }" S2 A% D0 k% o3 v& J7 a         pppt2(1) = ptRightY
  Next
4 F# D% v) J# f! {) }2 k8 @: K/ a    SSet.Delete
+ O& A6 O/ M  E/ W2 E3 L    KK = GetDistance(pppt1, pppt2)
'在程序中操作EXCEL表常用命令:
  Dim Excel As Excel.Application
- }$ C( t6 A% A' L7 I8 E8 \/ Y9 E2 g    Dim ExcelSheet   As Object
    Dim ExcelWorkbook   As Object
4 U  n  X* H0 P1 Q8 B# X5 O% b& b    '创建Excel应用程序实例
9 Z  D" E+ h4 H2 T  R. M9 f9 C* {    On Error Resume Next
    Set Excel = GetObject(, "Excel.Application")
    If Err <> 0 Then
4 K- |! z( G" ]4 S; n% C) E4 H! ?        Set Excel = CreateObject("Excel.Application")
           '创建一个新工作簿
         Set ExcelWorkbook = Excel.Workbooks.Add
- D+ N: Q8 k  v. ~) i: \; M- _, t          '令Excel应用程序可见
8 P& g" `. J) w8 ~$ X           Excel.Visible = True
          '将新创建的工作簿保存为Excel文件
4 {2 n- a2 X/ F: `5 v% K6 A             ExcelWorkbook.SaveAs "属性表.xls"
    End If
% r* t9 v. F3 f& w( I) ?    '确保Sheet1工作表为当前工作表
2 [8 [  A; O& q& {9 Z4 \9 b    Set ExcelSheet = Excel.ActiveSheet
8 }/ Z+ i' Z! u) R' Z    Excel.Visible = True
! S) B+ M% h  [' m. Z    endrow = ExcelSheet.Range("A65536").End(xlUp).Row + 1
1 ?/ s4 B8 R" T    ExcelSheet.Range("A" & endrow) = KK
" c( i, ~& ?/ v+ ]    Set Excel = Nothing
; p% @2 Z( v" N1 ^% L    End If
  Next
End Sub

, A6 a9 v  D5 G' ]! \, e7 w+ p

woaishuijia

1# sblisb
在 Excel VBAIDE 中引用 ACAD 类库,将下面的代码写入 Sheet1 对象代码窗口.
# v0 U5 s& h% J1 A, t8 D3 ?运行代码时必须保证待查询的 ACAD 文档已打开并处于激活状态
' J( B* N) l' ?- O& W6 d" E- A

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
     o0 l1 t2 _8 P; N6 J" M/ d
5.     '获取ACAD进程
   3 x% W' R: o, _) e  Z; ]1 k! u
6.     '类名称最后的编号按版本
   
7.     'R14版本为14
   9 F6 j$ a- R8 y/ X  Z: L% G2 k
8.     '2000~2002版本为15
   
9.     '2004~2006版本为16
   
10.     '2007~2009版本为17
    
11.     '2010~2012版本为18
    * f& }# _4 v# A  |) L! ]4 M  h- \3 x
12.     Set CAD = GetObject(, "AutoCAD.Application.18" )
    
13.     '获取当前ACAD进程的状态
    
14.     Set St = CAD.GetAcadState
    
15.     '当ACAD进程空闲时查询直线长度
    1 g+ z9 P: I1 k/ p$ g; U1 c4 C
16.     If St.IsQuiescent Then
    
17.         '创建选择集
    
18.         Set SS = CAD.ActiveDocument.SelectionSets.Add("SS" )
    8 ?* o/ l& e( f- k
19.         '定义选择集过滤器为只选择直线
    0 B) X" e% E% s1 [: v
20.         Fd(0) = "Line"
    
21.         '用户在窗口选择
    
22.         SS.SelectOnScreen Ft, Fd
    
23.         '逐个提取选择集中直线的长度并写入本工作表A列
    - e4 U+ J% A% h" ^1 B
24.         For I = 0 To SS.Count - 1
    % q: Q" y/ w5 a) Y
25.             Sheet1.Cells(I + 1, 1) = SS(I).Length
    
26.         Next
    
27.         '删除用过选择集
    
28.         SS.Delete
    
29.     Else
    
30.         MsgBox "ACAD正忙"
    ( c! m# s/ _* M6 Z6 j; [# c. Z1 L7 r
31.     End If
    & s4 I+ P2 V1 V0 B5 m# s
32. 10: If Err Then MsgBox "ACAD没有运行或没有活动文档"
    
33. End Sub
    

复制代码

sblisb

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

279491611

厉害，学习学习

清风香客

果断留印，方便后查。

玉紫玄

学习学习