excel如何得到线的长度?

sblisb

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

在EXCEL VBA编辑器的“工具”菜单中点“引用”，在“引用”对话框中找到ACAD类库，勾选它，确定。见图
3 z/ i7 i. [& J& v6 z. A5 h4、在EXCEL VBA编辑器Sheet1对象代码窗口写如下代码
Sub A()
9 w& ?; S# z) j* y" |
- E( f! m( q' n9 ^- L; T$ v: NDim CAD As AcadApplication '声明一个AutoCAD应用程序对象
8 [; l/ `' v2 g; LDim DOC As AcadDocument '声明AutoCAD文档对象
Set 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命令行发送命令
. {2 Z$ x. N: D" A4 N9 gsub

;;;=================================================================*
2 `/ F5 Y. R! n;;;功能：测量线的长度 *
! ]  Y, D  Z3 T3 N;;;日期：zml84 于 2009-05-21 17:45 *
(defun C:cd ()
(princ "统计线段长度"
  u, N+ a/ T2 l( ?" a# m1 |8 l(if (setq SS (ssget '((0 . "LINE,ARC,CIRCLE,ELLIPSE,*POLYLINE,SPLINE"))
3 L9 e  N6 d1 Y  z, O)
)
(progn
;;
(setq LST_LEN '()
I 0
)
) I, b" R) m  Q7 t; o;;逐个统计
8 C* |7 ~+ s* |& U, [" Y(repeat (sslength SS)
(setq EN (ssname SS I)
" O8 D9 f" j& u; qLEN (vlax-curve-getdistatparam
% e) d+ _1 i! X& }0 X# @EN
( ?( w% h  X; e; A" y; o1 {(vlax-curve-getendparam EN)
)
% ~" F' ~( y, MLST_LEN (cons LEN LST_LEN)
I (1+ I)
6 B; y5 {  E! t4 a)
)
' _5 ~) w! T( F(setq LST_LEN (reverse LST_LEN))
6 L& P6 ?$ U( u5 l; G- d; J2 b, t;;显示输出
8 g; Y2 V4 ]/ Q" I% S) N(princ "\n找到个数：")
(princ (sslength SS))
(princ "\n单个长度：")
(princ LST_LEN)
: ^1 u/ |) `; `0 P! _+ [(princ "\n总计长度：")
(princ (apply '+ LST_LEN))
4 L2 L+ f3 Z" g1 P)
* Q% o' [  v! L. ~; d)
2 |2 B" M! H% K# L: F7 Y) q(princ)
)
;;;=================================================================*
8 n- T, Y# M; E4 F;;;(alert
4 z: ]- J6 N1 F9 [+ e; G$ G; b. F;;; "功能：统计线段长度\n命令：\"CD\"\n日期：zml84 于 2009-05-21 17:45"
;;;)
; _1 p; p/ ?" x( d(princ)

0 ^1 v7 i/ ~" `* _' u. k6 @
’在AutoCAD中编程序，写到c盘根目录下的“123.xls”Excel表格中

’使用 VBA IDE 中的“工具” “引用”菜单选项，选择 Microsoft Excel 9.0 对象模型
’水平不高，有点罗嗦，楼主可以精简下
’欢迎以后交流，QQ 42123043
0 T. [7 m+ ]& xPublic Sub 取坐标()
- @5 {1 ^% U% F5 F’把AutoCAD中某一图层“多段线层”中的所有多段线的坐标列出来
Dim PLSet As AcadSelectionSet
Dim pl As AcadLWPolyline

( V4 g! H, x" E( p: n' z3 I
Dim ExcelApp As Excel.Application
Dim ExcelSheet As Object
( x: W* I# x  r5 q+ i5 {: JDim ExcelWorkbook As Object
8 D9 m8 T7 D4 E' X. {) N1 H$ a5 {
2 H0 r* w& v5 V: z* d3 N5 x- v+ p# I6 G
1 }6 b* M* x. t9 Y! m2 U+ NDim pts As Variant

Dim NN As Integer
* k* S5 ?. N/ u# i) c6 [. R& ]Dim j As Integer

% h! v& P( W+ b" l& {2 }Dim pn As Integer

0 m& ~" Z1 h! ODim px(0 To 10000) As Double
, p  Q8 n- ?6 ?6 `Dim py(0 To 10000) As Double
Dim pz(0 To 10000) As Double


8 q% ]0 H- ~! zDim filtertype(10) As Integer
* T5 [1 }, ?  G: u9 o2 N: l( @Dim filterdata(1) As Variant
0 S. Z5 j. x* A5 S
filtertype(0) = 0 ’ 选择线型
  H2 y/ o1 }, o( n( ?# xfilterdata(0) = "LWPOLYLINE"
8 T+ L$ l2 Q( l' p* |3 ?, lfiltertype(1) = 8 ’ 图层标识，可以根据具体情况改动
2 M, A* _3 p2 h( T2 tfilterdata(1) = "多段线层"


' Z6 R- T/ P6 {' M" s+ {
* v  o- y8 k. FSet PLSet = ThisDrawing.SelectionSets.Add("pl")
2 P; P0 a/ x8 D( j; U4 GPLSet.SelectOnScreen filtertype, filterdata
& a( d9 Q- S% F" g
2 ]7 O; R8 ~7 T2 U1 iNN = 0
j = 0
For Each pl In PLSet
8 G' t3 Y, z9 N
' z( G! v9 q$ P4 Y% g( B( gpts = pl.Coordinates
pn = (UBound(pts) + 1) / 2

For i = 0 To pn - 1
5 w$ p4 {* N8 G; H! x- ?2 vpx(i + pn * j) = pts(2 * i)
* Q. X: L; z- @7 H0 O: @6 {py(i + pn * j) = pts(2 * i + 1)
3 S) V# a- Z9 dNext i
: O- X) t& l7 U4 y; ^+ ]7 d1 wj = j + 1
NN = NN + pn
Next pl

PLSet.Delete
+ t% n( L2 g9 U2 t$ n

( N: u( S0 A0 [2 USet ExcelApp = New Excel.Application

Set ExcelWorkbook = ExcelApp.Workbooks.Add

Set ExcelSheet = ExcelApp.ActiveSheet
/ q! P: t% M. f; p- K. P
. e/ g) p( R+ s3 TExcelWorkbook.SaveAs "c:\123.xls"

0 Q8 N: L2 {7 k" T0 u: K/ _ExcelSheet.Cells(1, 1) = "x"
; g/ W, ^/ I# |6 O1 F. hExcelSheet.Cells(1, 2) = "y"

For i = 0 To NN - 1
ExcelSheet.Cells(i + 2, 1) = px(i)
ExcelSheet.Cells(i + 2, 2) = py(i)
) _. p/ y! ]1 x9 S$ DNext i
/ T7 n- s. t% [0 ], `) H
+ r! F- ~! }0 F0 }& L& z# cEnd Sub

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

获取标注尺寸函数

0 u# L6 z& M: T0 M. s

Function FixDimMeas(Dimension As AcadDimension) As Long
Dim BlockCount As Long
, U- d( [  ]' P4 H7 r; EDim bz As Long
& F9 Y+ ?; `% v* A' x) j! j
, a1 i$ B! P# B5 D+ eBlockCount = ThisDrawing.Blocks.Count
7 m0 B2 D/ U4 J$ M'遍历块中的对象，取得标注尺寸
Dim EntityInBlock As AcadEntity
' D$ f" {& ^5 x9 |5 |) yFor Each EntityInBlock In ThisDrawing.Blocks(BlockCount - 1)
If EntityInBlock.ObjectName = "AcDbMText" Then
! C7 f& I: T, lbz = Dimension.Measurement
- n3 J5 z  w" |* P( gFixDimMeas = bz '取得标注尺寸
Exit For
7 e: B+ \( X# ^End If
% S& Q* |  e, W1 N- @8 qNext
End Function

sblisb

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

选择CAD线条 EXCEL记录长度
% U6 D( h6 Z2 y# p5 R) ~选择“工具”\“引用”项，在弹出的“引用”对话框的“可使用的引用”列表框内，选择“Microsoft Excel 8.0 Object Library"项
! @5 K  D& A  x: i5 D1 T
'计算两点之间距离
7 ~9 E% K) A1 r( TPublic Function GetDistance(ptSt As Variant, ptEn As Variant) As Double
: V& p2 J9 s3 ?4 m8 [8 }7 d    Dim x As Double
    Dim y As Double
    Dim z As Double
. L. R  _4 N( n2 C1 R1 i* L% _  l    x = ptSt(0) - ptEn(0)
* K4 R  d. Y' b2 v! t; c- t+ K    y = ptSt(1) - ptEn(1)
: I9 x7 T7 E" q) B( a) \' S    z = ptSt(2) - ptEn(2)
& _, R3 g9 p4 a/ V    GetDistance = Sqr((Sqr((x ^ 2) + (y ^ 2)) ^ 2) + (z ^ 2))
End Function

; ^6 O# U* o" ~. V! T$ k* LPrivate Sub xz()
'创建选择集
For JJ = 1 To 10
If MsgBox("是否继续选择", vbYesNo) = vbNo Then
Exit For
Else
2 y+ t, @% w4 t/ H: B    On Error Resume Next
    Set myyactiveDoc = ActiveDocument
: _; I1 r  |' ]7 d! b  h% M
    Dim SSet As AcadSelectionSet
$ ]" Z1 ^* X1 \$ _, W0 H, \      Set SSet = myyactiveDoc.SelectionSets.Add("Ehlxz")
    If Not IsNull(myyactiveDoc.SelectionSets.Item("Ehlxz")) Then
        Set SSet = myyactiveDoc.SelectionSets.Item("Ehlxz")
        SSet.Delete     '及时删除不用的选择集非常重要
6 V$ C1 _- X7 D8 q$ x    End If
) k( q1 D& U0 `4 k4 h% \. F   Set SSet = myyactiveDoc.SelectionSets.Add("Ehlxz")
    SSet.SelectOnScreen
9 c& P  G. g+ k- A    '创建点组
9 t0 `7 [+ ?" H7 v    Dim ptArr1() As Variant
! ~9 a6 ?  n# l    Dim ptArr2() As Variant
    Dim count As Integer
    count = SSet.count
    ReDim ptArr1(count - 1)
    ReDim ptArr2(count - 1)
* N- ~' v' v' f, |! c2 W' x    '错误判断
! v; \# ^- d8 i% X    If count = 0 Then
        MsgBox "未选择任何对象！", vbCritical
, p) O; z& r0 i: O' p. O# Q6 _& V        Exit Sub
    End If

    '获得最左侧和下侧的角点
    Dim objEnt As AcadEntity
4 g3 p8 B9 n$ M. l( ^) _    Dim ptTemp As Variant
  ?! t; _* H$ S; ^4 h    Dim i As Integer
    i = 0
  s6 s0 Y1 o  ?% G  ^    For Each objEnt In SSet
0 B! p) ]9 B! C6 c        objEnt.GetBoundingBox ptArr1(i), ptTemp
6 A  Q4 e4 k* g3 F% A) R        i = i + 1
- p7 z' K+ g$ w! D* E9 r& G    Next
    '获得最上侧和右侧的角点
    i = 0
    For Each objEnt In SSet
) e  o* r% ~) r: w1 N. Z        objEnt.GetBoundingBox ptTemp, ptArr2(i)
        i = i + 1
    Next
( h4 W5 {4 v, h* _& h    Dim ptLeftX, ptLeftY, ptRightX, ptRightY
. O: x# F8 v+ r4 I( O; Z' q    Dim ptRight, ptTop
- q7 S( G8 N1 G; ^1 Z; j8 i1 H   For WWW = 1 To count
3 p3 Z0 @  Z- c, T( v      ptLeftX = ptArr1(WWW - 1)(0)
      ptLeftY = ptArr2(WWW - 1)(1)
      ptRightX = ptArr2(WWW - 1)(0)
7 O  W6 {7 @# f1 v/ c+ L" K7 c9 B      ptRightY = ptArr1(WWW - 1)(1)
% B% b: g' f* G
    Dim pppt1(0 To 2) As Double
/ K" m3 P  T3 a9 K/ @4 @    Dim pppt2(0 To 2) As Double
2 q8 F( N3 h. e3 N) u& L/ a3 C" p        pppt1(2) = 0
2 I# y+ j/ |, r: Y9 B1 H+ G        pppt2(2) = 0
    Dim gzkuan As Double, gzgao As Double
     gzkuan = (ptRightX - ptLeftX - 25 * (Int(Val(HjigeCb.Text)) - 1)) / Int(Val(HjigeCb.Text))
, j. p' p& T' [  {& D     gzgao = (ptLeftY - ptRightY - 25 * (Int(Val(SjigeCb.Text)) - 1)) / Int(Val(SjigeCb.Text))
    For j = 1 To Int(Val(HjigeCb.Text))
) D: T6 d: x7 O9 G' p( h) J0 J      For k = 1 To Int(Val(SjigeCb.Text))
        pppt1(0) = ptLeftX + (gzkuan + 25) * (j - 1)
         pppt1(1) = ptLeftY - (gzgao + 25) * (k - 1)
         pppt2(0) = pppt1(0) + gzkuan
1 A1 Y9 k6 o$ U* s         pppt2(1) = pppt1(1) - gzgao

      Next
0 U* x$ b$ \# k( M% W+ }    Next
+ ^) w4 x2 M+ |2 ]" e4 }         pppt1(0) = ptLeftX
         pppt1(1) = ptLeftY
7 n8 i# ~. {8 O) R1 X         pppt2(0) = ptRightX
         pppt2(1) = ptRightY
, L( o1 J8 Z1 z$ p9 Y  Next
    SSet.Delete
    KK = GetDistance(pppt1, pppt2)
. b6 A8 s( a* `, D+ o* O& Y' H5 m'在程序中操作EXCEL表常用命令:
& z5 j, l5 k3 C) a+ V& R  Dim Excel As Excel.Application
    Dim ExcelSheet   As Object
( s) G1 N. ]5 z6 I    Dim ExcelWorkbook   As Object
. Z' s, g9 @; u3 {4 F) p  V    '创建Excel应用程序实例
    On Error Resume Next
, X# |* N6 \3 d6 L    Set Excel = GetObject(, "Excel.Application")
$ `$ T/ o# l* |/ n$ J    If Err <> 0 Then
2 w2 \. B- r, x. @3 l        Set Excel = CreateObject("Excel.Application")
           '创建一个新工作簿
' N. B- ?6 R: S& g! w4 h         Set ExcelWorkbook = Excel.Workbooks.Add
          '令Excel应用程序可见
           Excel.Visible = True
- |( ~+ {* h9 S# M; X          '将新创建的工作簿保存为Excel文件
$ }; D. }8 f, G7 z; _# \  v             ExcelWorkbook.SaveAs "属性表.xls"
0 ^; R* Z2 Z8 g    End If
    '确保Sheet1工作表为当前工作表
    Set ExcelSheet = Excel.ActiveSheet
0 \! `( I; [4 C3 z& ^    Excel.Visible = True
* \! F, |$ {4 `: p" h5 r& e$ T3 I    endrow = ExcelSheet.Range("A65536").End(xlUp).Row + 1
    ExcelSheet.Range("A" & endrow) = KK
    Set Excel = Nothing
6 x1 m. A' a7 o3 W; C+ ^6 ^9 x    End If
  Next
$ _% J" E. A! ?! U! K- eEnd Sub

0 F7 F! w4 s3 {0 a& \4 U/ ]

woaishuijia

1# sblisb
在 Excel VBAIDE 中引用 ACAD 类库,将下面的代码写入 Sheet1 对象代码窗口.
运行代码时必须保证待查询的 ACAD 文档已打开并处于激活状态
9 ]$ A2 |! t& n9 {5 Y# z# B6 l* f

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进程
   # |( x: U( V& e% F+ P1 f- N; D
6.     '类名称最后的编号按版本
   
7.     'R14版本为14
   
8.     '2000~2002版本为15
   
9.     '2004~2006版本为16
   
10.     '2007~2009版本为17
    
11.     '2010~2012版本为18
    
12.     Set CAD = GetObject(, "AutoCAD.Application.18" )
    ( L9 ?! D, D" z9 P; k; q4 X
13.     '获取当前ACAD进程的状态
    
14.     Set St = CAD.GetAcadState
    2 q5 Z- y5 D8 W7 X# R* ~
15.     '当ACAD进程空闲时查询直线长度
    
16.     If St.IsQuiescent Then
    
17.         '创建选择集
    1 u6 G' p" ]6 ~2 o% O! c; L
18.         Set SS = CAD.ActiveDocument.SelectionSets.Add("SS" )
    
19.         '定义选择集过滤器为只选择直线
    
20.         Fd(0) = "Line"
    . ^# @. y1 r; J' C' e: K
21.         '用户在窗口选择
    
22.         SS.SelectOnScreen Ft, Fd
    * b; |- Q3 N8 v. b3 d9 z" t
23.         '逐个提取选择集中直线的长度并写入本工作表A列
    
24.         For I = 0 To SS.Count - 1
    7 D! a& X& Y4 Y& T1 h9 |
25.             Sheet1.Cells(I + 1, 1) = SS(I).Length
    4 a# B3 f$ Q* h* f: C2 ^* V" s9 H
26.         Next
    9 e4 P/ X- L( c' h. |
27.         '删除用过选择集
    
28.         SS.Delete
    
29.     Else
    
30.         MsgBox "ACAD正忙"
    / ]" j, C( b3 Y; K
31.     End If
    
32. 10: If Err Then MsgBox "ACAD没有运行或没有活动文档"
    
33. End Sub
    

复制代码

sblisb

谢谢!
能不能帮助改进两点:
% o+ Y5 P& i( C6 S, u9 w! p; `2 D1 数据写入A列时不覆盖A列原有数据.
2 运行程序后自动转到Acad界面,原代码运行后,是在等待状态,还在exce界面,要自己转到Acad界面

279491611

厉害，学习学习

清风香客

果断留印，方便后查。

玉紫玄

学习学习