excel如何得到线的长度?

sblisb

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

在EXCEL VBA编辑器的“工具”菜单中点“引用”，在“引用”对话框中找到ACAD类库，勾选它，确定。见图
, I" \; T# ^- V" d  R4、在EXCEL VBA编辑器Sheet1对象代码窗口写如下代码
Sub A()
( k" i  d% d( z* S& D$ @
5 r: d. ?$ P/ M, b7 g; `, YDim CAD As AcadApplication '声明一个AutoCAD应用程序对象
: {9 B3 u, k# S. E* o8 JDim DOC As AcadDocument '声明AutoCAD文档对象
Set CAD = New AcadApplication '运行一个新的AutoCAD进程
5 k5 V5 o& q; u. i$ ?$ PCAD.Visible = True '使运行的AutoCAD程序可见。如果没有这行，程序将不可见，就是说看不见CAD窗口，只能在Windows任务管理器看到有CAD程序运行
2 n; X3 K) @7 G/ iSet DOC = CAD.Documents.Open(Sheet1.Cells(1, 1).Value) '按照“Sheet1”工作表第一行第一列单元格的内容打开文件
DOC.SendCommand Sheet1.Cells(1, 2).Value '按“Sheet1”工作表第一行第二列单元格的内容向CAD命令行发送命令
2 \. A' h0 B; H; Fsub

;;;=================================================================*
- L& C6 {" b& Z' x' m, Z;;;功能：测量线的长度 *
;;;日期：zml84 于 2009-05-21 17:45 *
(defun C:cd ()
: o. ]7 G& q. H) B$ _(princ "统计线段长度"
6 x6 g5 G& v; A/ B6 h(if (setq SS (ssget '((0 . "LINE,ARC,CIRCLE,ELLIPSE,*POLYLINE,SPLINE"))
3 }; l; a' M/ `' h" q)
)
(progn
- f0 r) O4 k5 H- s6 M/ k;;
(setq LST_LEN '()
I 0
)
5 ]1 `  N- l! M  r! p* e4 h6 F8 p;;逐个统计
( J( c& d' P& p# h' o(repeat (sslength SS)
; z2 v4 K. N' v7 U5 F" B+ ^: b3 s- ~(setq EN (ssname SS I)
LEN (vlax-curve-getdistatparam
, t9 i! N0 u7 _  e. ^% Y! w) ~EN
(vlax-curve-getendparam EN)
5 c% [3 r! U7 b# r8 J- }! @/ Q+ x)
LST_LEN (cons LEN LST_LEN)
! j6 Z) @- N8 E1 sI (1+ I)
- z4 q, z& G, e4 X)
" H2 i$ {7 l9 O( c: O. r)
5 F$ N0 i2 W  T  I( s/ _(setq LST_LEN (reverse LST_LEN))
6 d- s; U* ~+ b;;显示输出
% e! Q6 e1 t6 A1 r(princ "\n找到个数：")
(princ (sslength SS))
1 e( h* i3 {  y. Y5 X- t9 @(princ "\n单个长度：")
) t$ T9 [1 M! E(princ LST_LEN)
8 l2 j9 f! [& i, H3 e$ p8 a' w(princ "\n总计长度：")
9 \, s* _: g. e: R. _' N(princ (apply '+ LST_LEN))
- E! d8 H: J# D; z)
. b+ W2 _+ H3 }; j, e)
(princ)
)
$ Z, ?2 E$ }# {;;;=================================================================*
;;;(alert
;;; "功能：统计线段长度\n命令：\"CD\"\n日期：zml84 于 2009-05-21 17:45"
;;;)
(princ)

7 \$ O# a) v: w5 ?7 U
' S' E' ~6 v" }4 F) M2 Y: s’在AutoCAD中编程序，写到c盘根目录下的“123.xls”Excel表格中

’使用 VBA IDE 中的“工具” “引用”菜单选项，选择 Microsoft Excel 9.0 对象模型
! ]) g' ~. n) h! a& N% {( c’水平不高，有点罗嗦，楼主可以精简下
’欢迎以后交流，QQ 42123043
5 G9 v" X# a, b) i' M1 lPublic Sub 取坐标()
’把AutoCAD中某一图层“多段线层”中的所有多段线的坐标列出来
9 ~6 A! A8 E+ U, Z1 V- L+ mDim PLSet As AcadSelectionSet
Dim pl As AcadLWPolyline

1 }! A: O8 P2 ~0 a; ^: h
Dim ExcelApp As Excel.Application
Dim ExcelSheet As Object
' s* S: c, H' g8 F' X, \1 @0 HDim ExcelWorkbook As Object


Dim pts As Variant
: x+ X# W5 y) ^+ {# R+ h/ K
Dim NN As Integer
Dim j As Integer
: T0 R# r' d) I/ T/ O; [) D
8 y. V) Z5 Q- L' wDim pn As Integer

8 I# d3 X7 [2 e% ?2 S" qDim px(0 To 10000) As Double
Dim py(0 To 10000) As Double
Dim pz(0 To 10000) As Double
6 t, \; G" `9 O1 a

/ s- g" [2 j0 \- P1 ?Dim filtertype(10) As Integer
5 i7 q+ ?( U0 J1 O$ ^% _4 nDim filterdata(1) As Variant
& G& \# d9 d: O6 D* }
filtertype(0) = 0 ’ 选择线型
filterdata(0) = "LWPOLYLINE"
7 ~& v3 u* h  j: C, E. Y. Dfiltertype(1) = 8 ’ 图层标识，可以根据具体情况改动
/ p- d# l5 E" k1 I9 Jfilterdata(1) = "多段线层"

! h0 m2 f3 q* ~& K2 D
5 h1 z3 P8 K, k2 D. ?4 Z- q* d
Set PLSet = ThisDrawing.SelectionSets.Add("pl")
PLSet.SelectOnScreen filtertype, filterdata
; Y- m$ s% [, f+ L/ q4 \$ a" W! G
NN = 0
j = 0
( n& `0 Z2 G: m! A' H, S$ wFor Each pl In PLSet
) W! F6 O0 w1 y- \! }1 d5 d7 u+ p
pts = pl.Coordinates
% m6 _! U# P! W$ V% {1 c! Zpn = (UBound(pts) + 1) / 2
5 a4 u. c) O9 j6 g
For i = 0 To pn - 1
) H1 W& w% {8 }* N% P' rpx(i + pn * j) = pts(2 * i)
py(i + pn * j) = pts(2 * i + 1)
Next i
j = j + 1
NN = NN + pn
Next pl

PLSet.Delete
/ v' O9 w; z& _% X$ v

7 `  E7 |  T# @; f# p2 L4 RSet ExcelApp = New Excel.Application

Set ExcelWorkbook = ExcelApp.Workbooks.Add

Set ExcelSheet = ExcelApp.ActiveSheet

ExcelWorkbook.SaveAs "c:\123.xls"

ExcelSheet.Cells(1, 1) = "x"
% s' S4 t, B8 M8 hExcelSheet.Cells(1, 2) = "y"

For i = 0 To NN - 1
( G% n# ^$ T* @ExcelSheet.Cells(i + 2, 1) = px(i)
ExcelSheet.Cells(i + 2, 2) = py(i)
Next i
# v8 T: x; m# t; E; O% w8 D
6 o9 F+ V2 Q* W+ Z, QEnd Sub

其实，从Excel里面操作，完全也可以实现
只需在excel的 VBA IDE 中的“工具” “引用”菜单选项，选择 AutoCAD 2004 Type Library 对象模型
0 |" T1 F1 ~( f' H7 V2 ]然后类似的思路编程即可，大家可以试试！
; D6 P4 b, p& S2 [. J/ d- o  M8 _
获取标注尺寸函数

% c2 l% o2 |+ r, Z9 K

Function FixDimMeas(Dimension As AcadDimension) As Long
6 i  @( G  S& A! p* ?: r  J) rDim BlockCount As Long
, C) t/ }7 \' Z+ SDim bz As Long
, k5 b/ D! M0 [8 ^5 J) B
0 V9 P2 X* o3 H& e" N( G, {BlockCount = ThisDrawing.Blocks.Count
7 {& w# r7 q) r. l'遍历块中的对象，取得标注尺寸
5 c3 y1 _# E" I+ ZDim EntityInBlock As AcadEntity
3 A+ z: H2 n! U& `For Each EntityInBlock In ThisDrawing.Blocks(BlockCount - 1)
1 _+ R' n* A0 t* t  ]5 {' s$ IIf EntityInBlock.ObjectName = "AcDbMText" Then
bz = Dimension.Measurement
FixDimMeas = bz '取得标注尺寸
$ ]- G: o6 U+ G6 Q2 {Exit For
' }/ [) ?/ ^4 T$ j( tEnd If
5 M  Q; f) b) ?7 M& |& DNext
End Function

sblisb

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

选择CAD线条 EXCEL记录长度
$ b' V5 T" I4 Y  I" X选择“工具”\“引用”项，在弹出的“引用”对话框的“可使用的引用”列表框内，选择“Microsoft Excel 8.0 Object Library"项
! R% v4 b( m2 r0 S0 t# w
'计算两点之间距离
Public Function GetDistance(ptSt As Variant, ptEn As Variant) As Double
, H. E" y2 r0 }2 X6 H0 }    Dim x As Double
  M( K( z' S3 N    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))
: U6 z1 p+ h  IEnd Function

Private Sub xz()
6 x4 d. @8 B& U7 q9 A '创建选择集
For JJ = 1 To 10
If MsgBox("是否继续选择", vbYesNo) = vbNo Then
Exit For
Else
    On Error Resume Next
    Set myyactiveDoc = ActiveDocument
9 N' j" B" C& a5 j8 s- n) f( F' c
    Dim SSet As AcadSelectionSet
      Set SSet = myyactiveDoc.SelectionSets.Add("Ehlxz")
    If Not IsNull(myyactiveDoc.SelectionSets.Item("Ehlxz")) Then
' x1 c+ r  A$ A        Set SSet = myyactiveDoc.SelectionSets.Item("Ehlxz")
        SSet.Delete     '及时删除不用的选择集非常重要
    End If
( `, k* i& g! L* B6 D' P   Set SSet = myyactiveDoc.SelectionSets.Add("Ehlxz")
( L3 j4 p. U% c4 w8 b    SSet.SelectOnScreen
    '创建点组
    Dim ptArr1() As Variant
! R, d0 h3 N* R3 x2 t' D' @& s    Dim ptArr2() As Variant
    Dim count As Integer
' Q. F, P9 v) r' g7 x    count = SSet.count
0 x( Q2 L6 @3 X7 L" ~( ?/ H    ReDim ptArr1(count - 1)
    ReDim ptArr2(count - 1)
/ n6 D" T8 y  T+ T    '错误判断
    If count = 0 Then
. ~3 P+ `# n( p, g  g! L: A# R        MsgBox "未选择任何对象！", vbCritical
        Exit Sub
  [4 Y0 B# `/ C# O( u8 x    End If

; Y, }6 w' k5 @& }. F    '获得最左侧和下侧的角点
. Y% g' @' _- _) X; R/ K) [5 l    Dim objEnt As AcadEntity
    Dim ptTemp As Variant
& v) p/ K' a! L  \; E    Dim i As Integer
# |! x' E: O; E9 |    i = 0
    For Each objEnt In SSet
' I, e& M# u! t4 u* T8 H' q        objEnt.GetBoundingBox ptArr1(i), ptTemp
6 N; h( v" j* T( J        i = i + 1
    Next
. F& u: ^' t& g4 F/ \    '获得最上侧和右侧的角点
. X' t2 m9 c* H4 G    i = 0
+ b5 [9 y0 b6 w) ]0 q  k4 b    For Each objEnt In SSet
        objEnt.GetBoundingBox ptTemp, ptArr2(i)
        i = i + 1
% V) Z1 X. Q: S4 |( W1 |    Next
    Dim ptLeftX, ptLeftY, ptRightX, ptRightY
8 b% k1 n1 U1 @% k8 V" O    Dim ptRight, ptTop
7 X8 l" {5 |8 B+ g6 l5 {5 R   For WWW = 1 To count
      ptLeftX = ptArr1(WWW - 1)(0)
. \7 h2 A! p6 Z6 A      ptLeftY = ptArr2(WWW - 1)(1)
  ?1 r! t2 w; N" N4 z      ptRightX = ptArr2(WWW - 1)(0)
      ptRightY = ptArr1(WWW - 1)(1)

; q' A* w# Y6 A2 [) H    Dim pppt1(0 To 2) As Double
    Dim pppt2(0 To 2) As Double
        pppt1(2) = 0
$ \8 }$ Z8 h* D6 S! j        pppt2(2) = 0
    Dim gzkuan As Double, gzgao As Double
; _$ [) y+ T0 `. t) `& K+ r     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))
( r  q6 l# i- Z8 y    For j = 1 To Int(Val(HjigeCb.Text))
      For k = 1 To Int(Val(SjigeCb.Text))
; {  n1 G2 y7 y$ `$ l  O* L# v        pppt1(0) = ptLeftX + (gzkuan + 25) * (j - 1)
         pppt1(1) = ptLeftY - (gzgao + 25) * (k - 1)
. n8 z; j( X% _, h& O, @+ o! s         pppt2(0) = pppt1(0) + gzkuan
         pppt2(1) = pppt1(1) - gzgao
' a% A, W2 K& \, ]7 R
      Next
    Next
( |1 l2 V+ P* ~         pppt1(0) = ptLeftX
         pppt1(1) = ptLeftY
         pppt2(0) = ptRightX
         pppt2(1) = ptRightY
  Next
    SSet.Delete
  j; X  B% ?" u    KK = GetDistance(pppt1, pppt2)
; ^0 l* V5 }2 k) T8 Q7 c% M3 M( f# ^'在程序中操作EXCEL表常用命令:
- q. @) m/ D4 j4 Q2 w  Dim Excel As Excel.Application
4 H- o+ N: ^, e5 k    Dim ExcelSheet   As Object
    Dim ExcelWorkbook   As Object
    '创建Excel应用程序实例
) `1 m6 p4 D4 [8 [3 s3 v3 j! X+ {    On Error Resume Next
& ?9 X) n* C& x; P+ q( Q    Set Excel = GetObject(, "Excel.Application")
    If Err <> 0 Then
- T5 S7 Z6 I& k6 G3 i  B        Set Excel = CreateObject("Excel.Application")
) p4 A6 F' a: Y/ l: Z9 }           '创建一个新工作簿
3 q" k0 Q3 K; c7 Y& m% K$ D         Set ExcelWorkbook = Excel.Workbooks.Add
          '令Excel应用程序可见
           Excel.Visible = True
; a# c% p* D( W          '将新创建的工作簿保存为Excel文件
- W0 U' \1 I& a$ O             ExcelWorkbook.SaveAs "属性表.xls"
    End If
    '确保Sheet1工作表为当前工作表
    Set ExcelSheet = Excel.ActiveSheet
    Excel.Visible = True
    endrow = ExcelSheet.Range("A65536").End(xlUp).Row + 1
    ExcelSheet.Range("A" & endrow) = KK
    Set Excel = Nothing
    End If
  Next
# e) I. T' r# u2 ~" L/ J( fEnd Sub

woaishuijia

1# sblisb
9 F: X5 g, d) v1 S& Y' q& q在 Excel VBAIDE 中引用 ACAD 类库,将下面的代码写入 Sheet1 对象代码窗口.
运行代码时必须保证待查询的 ACAD 文档已打开并处于激活状态

1. 
   
2. Sub A()
   " w/ x; o6 I; P( E5 x
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
   1 X( P% u* `" V) K7 o; Z; A
5.     '获取ACAD进程
   
6.     '类名称最后的编号按版本
   
7.     'R14版本为14
   1 t1 X' X; J* u' l) y* K. B
8.     '2000~2002版本为15
   3 r( P2 }5 j" ]6 H9 m  p
9.     '2004~2006版本为16
   
10.     '2007~2009版本为17
    
11.     '2010~2012版本为18
    
12.     Set CAD = GetObject(, "AutoCAD.Application.18" )
    
13.     '获取当前ACAD进程的状态
    / R/ o2 V2 L5 T' ?1 `- f* B
14.     Set St = CAD.GetAcadState
    
15.     '当ACAD进程空闲时查询直线长度
    
16.     If St.IsQuiescent Then
    
17.         '创建选择集
    
18.         Set SS = CAD.ActiveDocument.SelectionSets.Add("SS" )
    
19.         '定义选择集过滤器为只选择直线
    7 q7 Z. H5 n3 Y. U. Z: ]5 A- ^1 c% e
20.         Fd(0) = "Line"
    # E* q# l/ U( i5 |! i; M
21.         '用户在窗口选择
    
22.         SS.SelectOnScreen Ft, Fd
    
23.         '逐个提取选择集中直线的长度并写入本工作表A列
    1 L" `* V8 @! V" S6 s
24.         For I = 0 To SS.Count - 1
    
25.             Sheet1.Cells(I + 1, 1) = SS(I).Length
    
26.         Next
    % j( B5 x! M) X8 F) i* I) ?
27.         '删除用过选择集
    
28.         SS.Delete
    $ E! D( X7 H5 I$ r7 P+ z
29.     Else
    : h& K9 P4 t& A9 j; T0 o8 K
30.         MsgBox "ACAD正忙"
    ! m: L" e$ @4 x3 [( y% [
31.     End If
    
32. 10: If Err Then MsgBox "ACAD没有运行或没有活动文档"
    . w. k9 a" x2 N/ I; i3 H1 e
33. End Sub
    " z  H3 c. l" v# F6 R

复制代码

sblisb

谢谢!
1 c* h4 r" G% r; `3 b$ j3 @! d能不能帮助改进两点:
1 数据写入A列时不覆盖A列原有数据.
2 运行程序后自动转到Acad界面,原代码运行后,是在等待状态,还在exce界面,要自己转到Acad界面

279491611

厉害，学习学习

清风香客

果断留印，方便后查。

玉紫玄

学习学习