excel如何得到线的长度?

sblisb

我想在excel中操作,得到打开的cad文件中择的线的长度,然后写入excel表.
其中选择效果就象在cad中选菜单下的"工具_查询_列表显示",选择后按空格或回车,得到线的长度就分别写入excel表中A列了.
在网上搜索了两天,得到如下代码,偶vba不好,请哪位高手帮我整合下,谢谢!
* r8 X* ?: i8 w: Zexcel中操作cad请参考下面的步骤：
; l  B$ z9 E9 J9 \; b

在EXCEL VBA编辑器的“工具”菜单中点“引用”，在“引用”对话框中找到ACAD类库，勾选它，确定。见图
4、在EXCEL VBA编辑器Sheet1对象代码窗口写如下代码
2 O# r' Y% z3 L6 r0 a$ q% fSub A()

) W/ r7 w& `4 W3 bDim CAD As AcadApplication '声明一个AutoCAD应用程序对象
; n; g1 i" E. n8 z; ]* GDim DOC As AcadDocument '声明AutoCAD文档对象
Set CAD = New AcadApplication '运行一个新的AutoCAD进程
8 e+ r9 w! U( t8 I. ~# JCAD.Visible = True '使运行的AutoCAD程序可见。如果没有这行，程序将不可见，就是说看不见CAD窗口，只能在Windows任务管理器看到有CAD程序运行
1 Z" H& y4 a# X, N% B4 OSet DOC = CAD.Documents.Open(Sheet1.Cells(1, 1).Value) '按照“Sheet1”工作表第一行第一列单元格的内容打开文件
DOC.SendCommand Sheet1.Cells(1, 2).Value '按“Sheet1”工作表第一行第二列单元格的内容向CAD命令行发送命令
* W5 ?4 @, q2 J3 Csub

;;;=================================================================*
# D3 _& e, {5 ~, x# }) |;;;功能：测量线的长度 *
;;;日期：zml84 于 2009-05-21 17:45 *
6 e3 W# J2 m0 {0 R& N(defun C:cd ()
(princ "统计线段长度"
(if (setq SS (ssget '((0 . "LINE,ARC,CIRCLE,ELLIPSE,*POLYLINE,SPLINE"))
)
)
4 a& K- N7 |' C$ G$ J2 S, j( R(progn
;;
(setq LST_LEN '()
3 q4 v1 V: J. G1 D* e: W1 eI 0
( ?; ^3 x/ n, p- t)
;;逐个统计
5 M' q. D/ u/ z/ L, w* [(repeat (sslength SS)
(setq EN (ssname SS I)
LEN (vlax-curve-getdistatparam
/ `1 E0 n, m# z% GEN
(vlax-curve-getendparam EN)
)
LST_LEN (cons LEN LST_LEN)
1 x) d4 T  P; H/ C/ kI (1+ I)
)
8 j& h: K9 ~. z$ H' Q)
/ J# x  I* i6 k' t3 b" s* a1 l(setq LST_LEN (reverse LST_LEN))
9 [" o2 a% Q9 a! g9 \9 \;;显示输出
(princ "\n找到个数：")
(princ (sslength SS))
(princ "\n单个长度：")
- H8 |' ^& ^; V6 b- o9 h(princ LST_LEN)
/ S8 N+ M  Z8 w7 _! p) R2 {& l(princ "\n总计长度：")
2 x8 v. C# O, P7 _(princ (apply '+ LST_LEN))
)
7 l  e2 s+ P  q8 P* M9 A7 P! Z8 Z)
+ m9 o7 x9 b7 |. \0 N0 h( v' K(princ)
: S" c5 V- ^3 D)
;;;=================================================================*
;;;(alert
;;; "功能：统计线段长度\n命令：\"CD\"\n日期：zml84 于 2009-05-21 17:45"
5 N$ w' }6 k, g7 a- ~;;;)
! V; O5 |% q% d6 y/ O  r/ J(princ)

0 W. u. u1 G# X% h& G, r6 k’在AutoCAD中编程序，写到c盘根目录下的“123.xls”Excel表格中
% i- _# G" i6 g0 w

’使用 VBA IDE 中的“工具” “引用”菜单选项，选择 Microsoft Excel 9.0 对象模型
% N* e4 ^$ L4 d9 E* B’水平不高，有点罗嗦，楼主可以精简下
’欢迎以后交流，QQ 42123043
Public Sub 取坐标()
) {- s7 \7 @& r% G’把AutoCAD中某一图层“多段线层”中的所有多段线的坐标列出来
Dim PLSet As AcadSelectionSet
Dim pl As AcadLWPolyline

) B0 z5 q8 o1 }6 M7 G
( z+ w0 ?; Z( @7 l; ZDim ExcelApp As Excel.Application
Dim ExcelSheet As Object
/ s, f& L. _* T1 _% NDim ExcelWorkbook As Object
6 W6 F, I! p9 y3 A8 |& F9 k) K' M6 q

) i) b! ?, D4 ~4 aDim pts As Variant

8 @; d* @+ t5 O1 bDim NN As Integer
Dim j As Integer
* H7 g+ Z/ A! v& u; V* M5 r, _
9 g, `$ X, H" t$ eDim pn As Integer

! o2 c# Q8 Q! pDim px(0 To 10000) As Double
$ O9 g- G8 {) r( v) P7 K* |/ {Dim py(0 To 10000) As Double
Dim pz(0 To 10000) As Double

% A  h+ o( L! i4 |, W' g# K
Dim filtertype(10) As Integer
Dim filterdata(1) As Variant

5 S' z/ V0 h: {/ C5 ?9 A+ dfiltertype(0) = 0 ’ 选择线型
" S8 e/ f+ I. Gfilterdata(0) = "LWPOLYLINE"
filtertype(1) = 8 ’ 图层标识，可以根据具体情况改动
filterdata(1) = "多段线层"
* l5 N! Z% `' V% h

+ P& |- J. S& E8 t4 ^3 H
Set PLSet = ThisDrawing.SelectionSets.Add("pl")
PLSet.SelectOnScreen filtertype, filterdata

/ w+ l4 ^8 t. B+ S9 MNN = 0
0 R& Q- m6 {4 i& p3 o2 Vj = 0
- {; I, L! X1 f; J& U. pFor Each pl In PLSet

7 N& Z% }8 V( Qpts = pl.Coordinates
pn = (UBound(pts) + 1) / 2
% K$ O2 e# p1 w3 n6 ?
For i = 0 To pn - 1
: h7 j: h+ j! g3 V8 Z- b  Mpx(i + pn * j) = pts(2 * i)
py(i + pn * j) = pts(2 * i + 1)
" N2 i1 e! E$ jNext i
j = j + 1
NN = NN + pn
Next pl
: }: O) h* r! C( `% I
PLSet.Delete
; d) f6 b% J. m: z- w
: J: H" V+ ]6 ~6 C* H
Set ExcelApp = New Excel.Application

Set ExcelWorkbook = ExcelApp.Workbooks.Add
& `" p' `" b2 j
! [3 M* B" s0 c$ A2 \Set ExcelSheet = ExcelApp.ActiveSheet
- H4 r" E; O4 g+ a5 c; w
4 d! ^4 a6 c8 ~( b8 w! f: W. ^+ mExcelWorkbook.SaveAs "c:\123.xls"
1 U9 {4 d* \% k  X, S
1 {  `7 `$ V" Z% D* D( sExcelSheet.Cells(1, 1) = "x"
ExcelSheet.Cells(1, 2) = "y"
0 C& d4 `! u) Z) b
7 o# k& `* U8 GFor i = 0 To NN - 1
ExcelSheet.Cells(i + 2, 1) = px(i)
ExcelSheet.Cells(i + 2, 2) = py(i)
Next i
$ k" A  f5 W2 W. o4 ]
End Sub

其实，从Excel里面操作，完全也可以实现
- K: T0 a' c; B- O  ~3 k' q只需在excel的 VBA IDE 中的“工具” “引用”菜单选项，选择 AutoCAD 2004 Type Library 对象模型
然后类似的思路编程即可，大家可以试试！

获取标注尺寸函数
7 w) M2 E( `( L  x6 ^3 M- P
. W+ r) Q. h6 _; H) L) T9 {

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

BlockCount = ThisDrawing.Blocks.Count
'遍历块中的对象，取得标注尺寸
' L, Y- ~7 p9 W  JDim EntityInBlock As AcadEntity
8 `/ m0 e$ h* v4 UFor Each EntityInBlock In ThisDrawing.Blocks(BlockCount - 1)
If EntityInBlock.ObjectName = "AcDbMText" Then
bz = Dimension.Measurement
FixDimMeas = bz '取得标注尺寸
$ D  c8 l5 g) {- M5 Y7 wExit For
End If
Next
End Function

sblisb

这段是在cad中执行,写入excel,偶想改成在excel中执行,写入表
) J5 I, H. }$ W

选择CAD线条 EXCEL记录长度
/ x7 W, Z/ T8 B5 i选择“工具”\“引用”项，在弹出的“引用”对话框的“可使用的引用”列表框内，选择“Microsoft Excel 8.0 Object Library"项
% c1 {2 D/ Z8 a- M; [
'计算两点之间距离
" @1 _/ H0 Y, \Public Function GetDistance(ptSt As Variant, ptEn As Variant) As Double
4 f, M% i; r" O! x* B    Dim x As Double
8 H  M; Z, [( o7 U4 b7 p    Dim y As Double
& h. T8 c0 K. H5 }. S, F8 G    Dim z As Double
3 k. i* t# H3 t% I$ X, _+ V. g9 n; l    x = ptSt(0) - ptEn(0)
" ]! {' y. C2 J# y' }    y = ptSt(1) - ptEn(1)
6 ]% k" h% |# U    z = ptSt(2) - ptEn(2)
    GetDistance = Sqr((Sqr((x ^ 2) + (y ^ 2)) ^ 2) + (z ^ 2))
End Function

Private Sub xz()
5 e! }( j, Z) F4 u+ L4 @/ x; r '创建选择集
( g  S1 T: V. V4 Q$ H For JJ = 1 To 10
5 f* W+ h! a) x2 m0 ]- [9 Q/ h; I" b9 ` If MsgBox("是否继续选择", vbYesNo) = vbNo Then
, h/ z' `! s4 l% y Exit For
Else
( C0 r" F  }/ Y    On Error Resume Next
1 \  i$ ~# _+ }3 `    Set myyactiveDoc = ActiveDocument

* s$ |, i# h, f4 g0 |    Dim SSet As AcadSelectionSet
0 ?$ j3 n' A  s. i' C: s      Set SSet = myyactiveDoc.SelectionSets.Add("Ehlxz")
    If Not IsNull(myyactiveDoc.SelectionSets.Item("Ehlxz")) Then
        Set SSet = myyactiveDoc.SelectionSets.Item("Ehlxz")
        SSet.Delete     '及时删除不用的选择集非常重要
  A" A3 f# K  ^    End If
   Set SSet = myyactiveDoc.SelectionSets.Add("Ehlxz")
* p$ \$ Y. ~" U! b    SSet.SelectOnScreen
    '创建点组
6 }* w& r1 K3 q1 G8 ]# m" a    Dim ptArr1() As Variant
& W' u" Q3 J+ j; e9 |    Dim ptArr2() As Variant
    Dim count As Integer
    count = SSet.count
/ u2 f% L8 Q" k    ReDim ptArr1(count - 1)
' b0 m; ?- A6 ]6 Y8 x    ReDim ptArr2(count - 1)
% @1 X. f& L, J+ c6 t3 N9 r! M    '错误判断
1 U9 k! l/ i& i) w    If count = 0 Then
/ u1 B8 V. L% r+ E( h/ P% j        MsgBox "未选择任何对象！", vbCritical
        Exit Sub
    End If
$ M) }8 D; p' t' h) x3 X
( j: b5 M2 _5 A- d: x    '获得最左侧和下侧的角点
1 f& a+ h2 V/ _& m! E0 [    Dim objEnt As AcadEntity
3 r3 F! \. X. {& S    Dim ptTemp As Variant
$ D* Y2 D* ^7 y% m    Dim i As Integer
    i = 0
( ^  h/ d' A) D$ w( N2 l' |8 E1 A    For Each objEnt In SSet
* d3 j: E( f0 U; d        objEnt.GetBoundingBox ptArr1(i), ptTemp
! r0 T5 ^/ h) d9 [; W5 D        i = i + 1
9 C  {) \. m2 Z% P8 y    Next
- }( _* }" z# B2 W  b    '获得最上侧和右侧的角点
' u' L+ O) }5 ]8 K    i = 0
    For Each objEnt In SSet
        objEnt.GetBoundingBox ptTemp, ptArr2(i)
4 ]& Z+ t1 k& c+ i        i = i + 1
    Next
    Dim ptLeftX, ptLeftY, ptRightX, ptRightY
    Dim ptRight, ptTop
3 L+ y5 G$ O; \, Q: }   For WWW = 1 To count
/ ~  G/ r6 |0 K- c1 ?  m" E      ptLeftX = ptArr1(WWW - 1)(0)
      ptLeftY = ptArr2(WWW - 1)(1)
- C# R/ y) j6 o9 C# a( p- L% _9 h      ptRightX = ptArr2(WWW - 1)(0)
      ptRightY = ptArr1(WWW - 1)(1)
# a* h! X# ~4 X$ F
9 \7 d7 c2 L: C; e' t    Dim pppt1(0 To 2) As Double
    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))
  r2 A0 ?1 c6 y+ M( E2 o5 J# L     gzgao = (ptLeftY - ptRightY - 25 * (Int(Val(SjigeCb.Text)) - 1)) / Int(Val(SjigeCb.Text))
& t7 @& {2 d( J# s, c1 w  [/ e    For j = 1 To Int(Val(HjigeCb.Text))
      For k = 1 To Int(Val(SjigeCb.Text))
        pppt1(0) = ptLeftX + (gzkuan + 25) * (j - 1)
7 ]% |4 ]$ U, H2 b- @" U         pppt1(1) = ptLeftY - (gzgao + 25) * (k - 1)
( x9 H8 u) j) |         pppt2(0) = pppt1(0) + gzkuan
         pppt2(1) = pppt1(1) - gzgao

4 C3 G( L3 w- i2 c      Next
    Next
7 U* r7 ?$ ]9 F; Z         pppt1(0) = ptLeftX
         pppt1(1) = ptLeftY
/ ]" K/ g$ g3 h: |( A         pppt2(0) = ptRightX
# O; H  o# h+ X( O" q         pppt2(1) = ptRightY
8 ]; W1 ^% D3 {. S" P) W' Q2 Y- E  Next
! [( |8 d' L5 z$ |% Q: l1 {5 z2 L    SSet.Delete
$ h; }- i. u6 g5 I6 e    KK = GetDistance(pppt1, pppt2)
  d% S' k3 J9 C* g6 w'在程序中操作EXCEL表常用命令:
5 m9 S+ `' I: J" ^: f  Dim Excel As Excel.Application
( g1 c! t5 e* Y) b    Dim ExcelSheet   As Object
. M/ z' Y6 _1 u    Dim ExcelWorkbook   As Object
5 u. x  R6 d# R4 V  J    '创建Excel应用程序实例
3 P6 w; P: V4 ]: f; Z; O    On Error Resume Next
! A: Z& U! m# j$ m6 \7 _% |% @, \    Set Excel = GetObject(, "Excel.Application")
: |! C4 Q0 c3 u; T. p  |9 |5 u    If Err <> 0 Then
; k) n0 y' C+ N8 W% n' G9 l        Set Excel = CreateObject("Excel.Application")
0 e) A  q/ F: \% N           '创建一个新工作簿
         Set ExcelWorkbook = Excel.Workbooks.Add
          '令Excel应用程序可见
           Excel.Visible = True
          '将新创建的工作簿保存为Excel文件
             ExcelWorkbook.SaveAs "属性表.xls"
    End If
    '确保Sheet1工作表为当前工作表
# a0 @- `/ Z  D$ Y6 M    Set ExcelSheet = Excel.ActiveSheet
    Excel.Visible = True
6 ]' g: K3 \7 t) [! [/ l  W    endrow = ExcelSheet.Range("A65536").End(xlUp).Row + 1
    ExcelSheet.Range("A" & endrow) = KK
    Set Excel = Nothing
7 b4 e5 L1 B2 |    End If
  C" j9 F/ d2 ?6 D3 V  Next
End Sub
* W. \6 U. A% `. l( g1 N7 J( Y5 m- y
0 t2 L. s& t& {

woaishuijia

1# sblisb
1 K2 h+ D% p: P0 V在 Excel VBAIDE 中引用 ACAD 类库,将下面的代码写入 Sheet1 对象代码窗口.
! C9 y' c: H+ K$ ]# P运行代码时必须保证待查询的 ACAD 文档已打开并处于激活状态

1. 
   
2. Sub A()
   8 X4 _7 K% j% D) P' @9 s* @' [# B
3.     Dim CAD As AutoCAD.AcadApplication, St As AcadState, SS As AcadSelectionSet, Ft(0) As Integer, Fd(0) As Variant, I As Integer
   + f& |4 w7 e, _6 Q/ m
4.     On Error GoTo 10
   
5.     '获取ACAD进程
   * U  u2 f$ p  b1 d- P
6.     '类名称最后的编号按版本
   
7.     'R14版本为14
   0 A8 \& k- Q( X- A. g8 ]9 i4 C
8.     '2000~2002版本为15
   
9.     '2004~2006版本为16
   
10.     '2007~2009版本为17
    $ s+ B( P2 w3 F3 r/ s
11.     '2010~2012版本为18
    + ~5 s, m* g/ O9 C3 `
12.     Set CAD = GetObject(, "AutoCAD.Application.18" )
    9 c: {+ T/ T& V& m
13.     '获取当前ACAD进程的状态
    
14.     Set St = CAD.GetAcadState
    * ~2 i/ g/ ~8 y. @- X0 U3 f: \
15.     '当ACAD进程空闲时查询直线长度
    + Z& i$ w% p* k! Q7 G5 G
16.     If St.IsQuiescent Then
    / F% e7 Q. R( |/ J5 G" c8 v* N: O! M
17.         '创建选择集
    8 _# w+ Y3 L2 B+ S. s8 A% U. c
18.         Set SS = CAD.ActiveDocument.SelectionSets.Add("SS" )
    
19.         '定义选择集过滤器为只选择直线
    
20.         Fd(0) = "Line"
    , \- P% S3 B, Q+ X, Z! Y
21.         '用户在窗口选择
    
22.         SS.SelectOnScreen Ft, Fd
    
23.         '逐个提取选择集中直线的长度并写入本工作表A列
    
24.         For I = 0 To SS.Count - 1
    & a- t. l5 E! Q# }
25.             Sheet1.Cells(I + 1, 1) = SS(I).Length
    9 X2 J7 }" ]  m# u9 \
26.         Next
    ) s7 v+ a9 g& C! k& P
27.         '删除用过选择集
    # }" @4 n: t1 I! H
28.         SS.Delete
    ' L8 K3 O6 d& L1 t. n
29.     Else
    
30.         MsgBox "ACAD正忙"
    $ d0 L/ Z' M3 g5 p+ W
31.     End If
    " W% D4 I, _% c, W# E
32. 10: If Err Then MsgBox "ACAD没有运行或没有活动文档"
    
33. End Sub
    $ D3 i) A% S( ?' h- S

复制代码

sblisb

谢谢!
8 V: d1 R0 z( L+ f/ M4 m能不能帮助改进两点:
" u+ T! W; N' r3 a/ m1 数据写入A列时不覆盖A列原有数据.
3 b. j2 A/ l% d2 H" W" W& R- E1 i2 运行程序后自动转到Acad界面,原代码运行后,是在等待状态,还在exce界面,要自己转到Acad界面

279491611

厉害，学习学习

清风香客

果断留印，方便后查。

玉紫玄

学习学习