excel如何得到线的长度?

sblisb

我想在excel中操作,得到打开的cad文件中择的线的长度,然后写入excel表.
8 j6 ~6 C. u, q; I  J其中选择效果就象在cad中选菜单下的"工具_查询_列表显示",选择后按空格或回车,得到线的长度就分别写入excel表中A列了.
- k  ^5 `6 v4 ?在网上搜索了两天,得到如下代码,偶vba不好,请哪位高手帮我整合下,谢谢!
excel中操作cad请参考下面的步骤：
, b- S2 m9 A7 r+ ~9 ^3 C: U3 t: K

在EXCEL VBA编辑器的“工具”菜单中点“引用”，在“引用”对话框中找到ACAD类库，勾选它，确定。见图
0 Q$ b8 l, k" s4 S7 R4 Q4、在EXCEL VBA编辑器Sheet1对象代码窗口写如下代码
( ]# r: d; w$ {5 x- n7 Z; W) S8 ySub A()
* o6 ?4 Z4 K4 [( `( o
Dim CAD As AcadApplication '声明一个AutoCAD应用程序对象
, ]& M  `8 }- Q1 YDim DOC As AcadDocument '声明AutoCAD文档对象
( M- Q. G6 _/ ~. a# e% RSet CAD = New AcadApplication '运行一个新的AutoCAD进程
CAD.Visible = True '使运行的AutoCAD程序可见。如果没有这行，程序将不可见，就是说看不见CAD窗口，只能在Windows任务管理器看到有CAD程序运行
+ z9 y' o8 {6 z: C- M$ v. A) {( y$ bSet DOC = CAD.Documents.Open(Sheet1.Cells(1, 1).Value) '按照“Sheet1”工作表第一行第一列单元格的内容打开文件
5 M* g! h5 r8 q- j7 B) M9 f0 aDOC.SendCommand Sheet1.Cells(1, 2).Value '按“Sheet1”工作表第一行第二列单元格的内容向CAD命令行发送命令
) }2 d; b  ~1 X; {& \sub

;;;=================================================================*
+ s* f& ~2 g. c; _) ?/ l9 ~! o;;;功能：测量线的长度 *
;;;日期：zml84 于 2009-05-21 17:45 *
(defun C:cd ()
) g- D* `5 ]1 \; z4 Z/ P" @" ?(princ "统计线段长度"
5 n- T8 `) h! X0 p) A(if (setq SS (ssget '((0 . "LINE,ARC,CIRCLE,ELLIPSE,*POLYLINE,SPLINE"))
)
+ v9 S: J. W' {4 G)
- M" A: Y2 Q: j5 o4 T% x% x(progn
;;
9 I8 k9 A. b. P- S; N" |; z(setq LST_LEN '()
I 0
)
;;逐个统计
(repeat (sslength SS)
(setq EN (ssname SS I)
LEN (vlax-curve-getdistatparam
EN
(vlax-curve-getendparam EN)
)
+ W8 E3 P  A- m1 I- d8 BLST_LEN (cons LEN LST_LEN)
) @6 D8 h: ~1 [+ v* X# j" ^I (1+ I)
6 a, v9 `- R4 d( [0 V5 _)
, S- i$ J  _1 S  Q* [( C3 W) [)
(setq LST_LEN (reverse LST_LEN))
;;显示输出
(princ "\n找到个数：")
& X6 d% n4 p9 I4 W8 `(princ (sslength SS))
7 J2 l4 |) h/ C( `7 ]# \) ~(princ "\n单个长度：")
(princ LST_LEN)
(princ "\n总计长度：")
* w8 H/ a5 {, S1 n- Z0 q(princ (apply '+ LST_LEN))
4 t( M! A8 G; E3 E. T% N. G)
)
(princ)
)
/ C* s4 H9 J1 ], ~4 h;;;=================================================================*
;;;(alert
# u" e* L5 U9 E$ [& O1 u;;; "功能：统计线段长度\n命令：\"CD\"\n日期：zml84 于 2009-05-21 17:45"
;;;)
(princ)

: C: {2 U  n3 {  g' _’在AutoCAD中编程序，写到c盘根目录下的“123.xls”Excel表格中
' Q3 V5 z. E" g

’使用 VBA IDE 中的“工具” “引用”菜单选项，选择 Microsoft Excel 9.0 对象模型
’水平不高，有点罗嗦，楼主可以精简下
% e! J* G3 T  l5 X’欢迎以后交流，QQ 42123043
Public Sub 取坐标()
’把AutoCAD中某一图层“多段线层”中的所有多段线的坐标列出来
Dim PLSet As AcadSelectionSet
9 s  X/ i' d4 w* ]Dim pl As AcadLWPolyline


7 R$ o5 c: A- U, l, F2 bDim ExcelApp As Excel.Application
+ l" [4 k& j; B6 DDim ExcelSheet As Object
$ I( ]( q1 ]' g% `- D  K9 mDim ExcelWorkbook As Object
" v! I% x' t% I1 U& n- h* X
5 q7 @" x& ]5 r5 n+ ~' }# ?
% T- \- q& a6 B: ^1 j$ hDim pts As Variant

% C. U5 X; Y" e2 X, P6 xDim NN As Integer
( k. [4 R5 v. T7 f; |Dim j As Integer
! {/ @: z: z" \! \4 s. ^6 S
Dim pn As Integer

7 K9 r( v: p' o0 W4 wDim px(0 To 10000) As Double
Dim py(0 To 10000) As Double
Dim pz(0 To 10000) As Double

" _9 w3 f! a) a4 V; {
Dim filtertype(10) As Integer
! K% M; T' |; N3 S, q* xDim filterdata(1) As Variant

" g  C  @( k4 a  N! ifiltertype(0) = 0 ’ 选择线型
filterdata(0) = "LWPOLYLINE"
& g' b5 q' D0 \' d# \& k8 I4 h" }, ~7 ifiltertype(1) = 8 ’ 图层标识，可以根据具体情况改动
  k$ O, T  z8 }5 M' Rfilterdata(1) = "多段线层"


% N7 m) s; W+ D! b. o6 a
Set PLSet = ThisDrawing.SelectionSets.Add("pl")
PLSet.SelectOnScreen filtertype, filterdata
7 C5 R. K$ v) H+ J
; [" F& n2 \0 z2 H( G- `+ wNN = 0
1 V; E9 l6 Y0 o3 N) z' W5 kj = 0
5 t" r: C+ z# @9 G" L$ OFor Each pl In PLSet
: h1 _, E4 y" C
pts = pl.Coordinates
pn = (UBound(pts) + 1) / 2

3 P8 P% A. w3 A0 N6 wFor i = 0 To pn - 1
px(i + pn * j) = pts(2 * i)
& }( B! z6 O; J2 w' K" v/ Ppy(i + pn * j) = pts(2 * i + 1)
- R% Q: g' m2 ~& T, F0 z+ jNext i
1 C' S$ j, P' g# yj = j + 1
4 c1 q- m# ~% Q& r- v" P, QNN = NN + pn
Next pl

PLSet.Delete


- I% j4 t, G# U. ?9 F$ P: ySet ExcelApp = New Excel.Application

Set ExcelWorkbook = ExcelApp.Workbooks.Add
! {3 E3 G% ~0 R9 n5 r3 I
Set ExcelSheet = ExcelApp.ActiveSheet
, v/ n7 v- J1 ], D
ExcelWorkbook.SaveAs "c:\123.xls"
9 |+ x/ S7 {/ X0 P% J2 U
ExcelSheet.Cells(1, 1) = "x"
$ W4 x9 ?' V, |ExcelSheet.Cells(1, 2) = "y"
9 g% Z3 w' U0 ]! ?& g) c9 C4 ]; U
For i = 0 To NN - 1
ExcelSheet.Cells(i + 2, 1) = px(i)
1 m2 p2 ?1 w0 b1 n4 i1 hExcelSheet.Cells(i + 2, 2) = py(i)
6 ?2 f# ]* L6 P% w9 WNext i

End Sub

其实，从Excel里面操作，完全也可以实现
) \, v0 g! }2 G" G+ V& m只需在excel的 VBA IDE 中的“工具” “引用”菜单选项，选择 AutoCAD 2004 Type Library 对象模型
然后类似的思路编程即可，大家可以试试！

4 L; C2 ~+ r* V1 w获取标注尺寸函数

Function FixDimMeas(Dimension As AcadDimension) As Long
Dim BlockCount As Long
" h- w4 g8 T  g+ ?+ }  gDim bz As Long
$ D6 f* w1 R8 @5 w% [3 h
# d! C1 }" f9 W) j9 `& BBlockCount = ThisDrawing.Blocks.Count
3 a+ u! }4 E( T# y'遍历块中的对象，取得标注尺寸
Dim EntityInBlock As AcadEntity
For Each EntityInBlock In ThisDrawing.Blocks(BlockCount - 1)
If EntityInBlock.ObjectName = "AcDbMText" Then
bz = Dimension.Measurement
6 V' Z: S  Y! _5 HFixDimMeas = bz '取得标注尺寸
Exit For
0 i* B: N* G8 T* @$ F; i! hEnd If
Next
# |1 s) C: o7 n- B1 `' i& B9 {End Function

sblisb

这段是在cad中执行,写入excel,偶想改成在excel中执行,写入表
- Q- g) ~7 {" M7 y8 ~* Z, X2 _8 D

选择CAD线条 EXCEL记录长度
3 p" }1 N& }. |/ v0 |8 M* y% ?2 O选择“工具”\“引用”项，在弹出的“引用”对话框的“可使用的引用”列表框内，选择“Microsoft Excel 8.0 Object Library"项

# h. D6 G7 ]* C'计算两点之间距离
0 j- V  B- H& FPublic Function GetDistance(ptSt As Variant, ptEn As Variant) As Double
    Dim x As Double
$ C" K9 R0 h* Z    Dim y As Double
    Dim z As Double
    x = ptSt(0) - ptEn(0)
    y = ptSt(1) - ptEn(1)
1 }: {9 J/ R& ]) H. }* K) _# |8 N    z = ptSt(2) - ptEn(2)
    GetDistance = Sqr((Sqr((x ^ 2) + (y ^ 2)) ^ 2) + (z ^ 2))
End Function
2 |: g; {+ G) Z. z1 c
Private Sub xz()
6 q& F2 y8 }% l, C; o '创建选择集
3 F) J( q9 K& c1 D* y' { For JJ = 1 To 10
, b$ B5 c3 O5 C7 y! x8 ~ If MsgBox("是否继续选择", vbYesNo) = vbNo Then
Exit For
! `9 g- e% p& K9 U0 V5 DElse
    On Error Resume Next
    Set myyactiveDoc = ActiveDocument

( E0 Q. H3 d8 h6 {, b' P6 Q    Dim SSet As AcadSelectionSet
6 P: q& f2 l7 Z; \      Set SSet = myyactiveDoc.SelectionSets.Add("Ehlxz")
( V, c* Y; Q  p- J) u6 j    If Not IsNull(myyactiveDoc.SelectionSets.Item("Ehlxz")) Then
        Set SSet = myyactiveDoc.SelectionSets.Item("Ehlxz")
0 ~- _& k( |# ]4 o- D; _        SSet.Delete     '及时删除不用的选择集非常重要
    End If
' P- a; n1 l; u- E   Set SSet = myyactiveDoc.SelectionSets.Add("Ehlxz")
( p5 S$ g  }9 g/ X  m+ W8 P- V    SSet.SelectOnScreen
    '创建点组
    Dim ptArr1() As Variant
+ R, p% H+ `8 e$ `- s9 \    Dim ptArr2() As Variant
    Dim count As Integer
    count = SSet.count
4 j# c! y6 Q$ h" t( I    ReDim ptArr1(count - 1)
5 M# H9 S" r: n- N    ReDim ptArr2(count - 1)
    '错误判断
    If count = 0 Then
        MsgBox "未选择任何对象！", vbCritical
# ~' l; m1 n) d' y        Exit Sub
- k7 a; @( G& j0 y* e* @    End If
9 p/ Q$ |% ~$ |" U# p1 D2 B
    '获得最左侧和下侧的角点
    Dim objEnt As AcadEntity
/ H7 j- a! t# v# u    Dim ptTemp As Variant
    Dim i As Integer
    i = 0
    For Each objEnt In SSet
        objEnt.GetBoundingBox ptArr1(i), ptTemp
        i = i + 1
% X, m# w% ~4 c; G1 w    Next
    '获得最上侧和右侧的角点
    i = 0
    For Each objEnt In SSet
' w4 p  E, \  G+ e, S; S        objEnt.GetBoundingBox ptTemp, ptArr2(i)
        i = i + 1
5 z% V( O' z5 }. P    Next
    Dim ptLeftX, ptLeftY, ptRightX, ptRightY
/ R8 t$ Q' b! l9 I7 K    Dim ptRight, ptTop
2 Z! S$ n- w) |# Y5 Y& L   For WWW = 1 To count
      ptLeftX = ptArr1(WWW - 1)(0)
8 }5 y, y- M; F      ptLeftY = ptArr2(WWW - 1)(1)
/ p. G' q* E& E! s4 g$ h5 {6 J      ptRightX = ptArr2(WWW - 1)(0)
      ptRightY = ptArr1(WWW - 1)(1)

$ f" B4 P7 `  H, _) t/ B# f6 J9 S& S    Dim pppt1(0 To 2) As Double
; h, \% |5 L+ p8 F! ?1 h    Dim pppt2(0 To 2) As Double
- f5 x2 O! a- h  e2 x. L        pppt1(2) = 0
        pppt2(2) = 0
    Dim gzkuan As Double, gzgao As Double
$ @1 O- r0 Y# p; |3 H     gzkuan = (ptRightX - ptLeftX - 25 * (Int(Val(HjigeCb.Text)) - 1)) / Int(Val(HjigeCb.Text))
+ y7 L. I& r0 B     gzgao = (ptLeftY - ptRightY - 25 * (Int(Val(SjigeCb.Text)) - 1)) / Int(Val(SjigeCb.Text))
7 w7 h, M% A% W6 B8 |' @& |9 m8 \. o    For j = 1 To Int(Val(HjigeCb.Text))
( V( j( r6 I* ?1 E. {" \. c% g      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
         pppt2(1) = pppt1(1) - gzgao

      Next
: H8 L7 }* D; K' J- m2 c* t  c- K    Next
         pppt1(0) = ptLeftX
$ k3 ^0 t3 p8 ~5 O1 w4 O         pppt1(1) = ptLeftY
         pppt2(0) = ptRightX
" h. Q% w. ~' X* p* a7 d7 U+ b/ L         pppt2(1) = ptRightY
$ }* U) d; A& T+ x7 q! E$ m  Next
) d7 V" A! i+ k/ ~; }    SSet.Delete
    KK = GetDistance(pppt1, pppt2)
  ~- F3 w8 y6 Q: [2 N+ R0 m5 q( G'在程序中操作EXCEL表常用命令:
  Dim Excel As Excel.Application
" L, i. m+ X  K    Dim ExcelSheet   As Object
" ]/ \8 c' R7 x& [9 O- n    Dim ExcelWorkbook   As Object
    '创建Excel应用程序实例
    On Error Resume Next
. h' Q. V* E! A) [2 O    Set Excel = GetObject(, "Excel.Application")
! }6 b! P5 y! ]& H0 @! U: z; o    If Err <> 0 Then
        Set Excel = CreateObject("Excel.Application")
           '创建一个新工作簿
         Set ExcelWorkbook = Excel.Workbooks.Add
& D' W# Z: H+ M. q5 y          '令Excel应用程序可见
% y& O7 m2 o( ?  {1 \. v5 n           Excel.Visible = True
          '将新创建的工作簿保存为Excel文件
             ExcelWorkbook.SaveAs "属性表.xls"
. f" z( p9 A: I  t% i    End If
    '确保Sheet1工作表为当前工作表
; y  ?* C6 v1 H1 L9 \1 M# D    Set ExcelSheet = Excel.ActiveSheet
    Excel.Visible = True
    endrow = ExcelSheet.Range("A65536").End(xlUp).Row + 1
+ F' y% Z/ F& V6 h4 |- t; H3 n    ExcelSheet.Range("A" & endrow) = KK
    Set Excel = Nothing
) e, P! L" ^/ _  p. p3 i    End If
6 {/ J; O2 {. v& n+ ?  e+ v, A  Next
End Sub

: S/ T' W. O$ K! b. k

woaishuijia

1# sblisb
# @: o* E- C" a在 Excel VBAIDE 中引用 ACAD 类库,将下面的代码写入 Sheet1 对象代码窗口.
/ ]( @4 b: ~5 y. q$ V- u7 W8 C运行代码时必须保证待查询的 ACAD 文档已打开并处于激活状态

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
   * \% M; O0 ^1 F$ N8 q
5.     '获取ACAD进程
   
6.     '类名称最后的编号按版本
   0 Q+ m& O7 n; d8 r1 e% H& H
7.     'R14版本为14
   % z1 V, K, @) x7 K: _7 C8 R$ Z0 V
8.     '2000~2002版本为15
   5 d& X3 [5 m0 r7 P4 y' F
9.     '2004~2006版本为16
   
10.     '2007~2009版本为17
    + }  `* h8 s, w8 R& _7 W3 E3 I
11.     '2010~2012版本为18
    5 o0 R; m- B8 E1 G0 c4 Q0 Z5 |
12.     Set CAD = GetObject(, "AutoCAD.Application.18" )
    
13.     '获取当前ACAD进程的状态
    3 X, z% s4 ~7 N8 \) k5 r- \) I& _
14.     Set St = CAD.GetAcadState
    ! Z: H, z* F" `  n
15.     '当ACAD进程空闲时查询直线长度
    1 m9 W: m+ b& ^6 q3 {% w
16.     If St.IsQuiescent Then
    
17.         '创建选择集
    * C$ Y3 e5 S1 A: F4 x
18.         Set SS = CAD.ActiveDocument.SelectionSets.Add("SS" )
    & X/ W* X) {) K# _
19.         '定义选择集过滤器为只选择直线
    
20.         Fd(0) = "Line"
    " X/ i* s! `. b
21.         '用户在窗口选择
    
22.         SS.SelectOnScreen Ft, Fd
    
23.         '逐个提取选择集中直线的长度并写入本工作表A列
    2 ^4 p% ~8 L, E* {# w. I
24.         For I = 0 To SS.Count - 1
    9 S6 s# k7 f* a5 Z5 ]$ q; y
25.             Sheet1.Cells(I + 1, 1) = SS(I).Length
    
26.         Next
    " O9 ~8 A0 r+ i2 W
27.         '删除用过选择集
    
28.         SS.Delete
    
29.     Else
    
30.         MsgBox "ACAD正忙"
    
31.     End If
    8 e8 D; Z- R2 w: }4 Y8 k+ `
32. 10: If Err Then MsgBox "ACAD没有运行或没有活动文档"
    , W' X) q5 d# d: X
33. End Sub
    : I; I5 g. o8 K! N

复制代码

sblisb

谢谢!
% _" h6 @" Q4 a+ \: X& d9 }能不能帮助改进两点:
1 数据写入A列时不覆盖A列原有数据.
2 运行程序后自动转到Acad界面,原代码运行后,是在等待状态,还在exce界面,要自己转到Acad界面

279491611

厉害，学习学习

清风香客

果断留印，方便后查。

玉紫玄

学习学习