excel如何得到线的长度?

sblisb

我想在excel中操作,得到打开的cad文件中择的线的长度,然后写入excel表.
其中选择效果就象在cad中选菜单下的"工具_查询_列表显示",选择后按空格或回车,得到线的长度就分别写入excel表中A列了.
4 u  i7 t2 e  O在网上搜索了两天,得到如下代码,偶vba不好,请哪位高手帮我整合下,谢谢!
excel中操作cad请参考下面的步骤：
* g5 }! C4 ^- h5 u" ^0 `9 q- u9 `

在EXCEL VBA编辑器的“工具”菜单中点“引用”，在“引用”对话框中找到ACAD类库，勾选它，确定。见图
4、在EXCEL VBA编辑器Sheet1对象代码窗口写如下代码
Sub A()
4 R  g/ j$ t+ w  E; i8 @
" u5 ^' N# \! |% K. k* BDim CAD As AcadApplication '声明一个AutoCAD应用程序对象
5 d0 @  Z, M# j6 l3 D6 s, Q2 U% j& KDim DOC As AcadDocument '声明AutoCAD文档对象
Set CAD = New AcadApplication '运行一个新的AutoCAD进程
" P( R3 Y' }1 \; b' ]" kCAD.Visible = True '使运行的AutoCAD程序可见。如果没有这行，程序将不可见，就是说看不见CAD窗口，只能在Windows任务管理器看到有CAD程序运行
Set DOC = CAD.Documents.Open(Sheet1.Cells(1, 1).Value) '按照“Sheet1”工作表第一行第一列单元格的内容打开文件
/ ^  {6 r5 A$ \7 j3 S3 [DOC.SendCommand Sheet1.Cells(1, 2).Value '按“Sheet1”工作表第一行第二列单元格的内容向CAD命令行发送命令
* ?8 ]. \, _/ n, d( Ssub

;;;=================================================================*
;;;功能：测量线的长度 *
( `: Y% @, k) o5 z9 O9 r% r9 R;;;日期：zml84 于 2009-05-21 17:45 *
(defun C:cd ()
(princ "统计线段长度"
(if (setq SS (ssget '((0 . "LINE,ARC,CIRCLE,ELLIPSE,*POLYLINE,SPLINE"))
) X2 `/ q2 ~0 U6 R- n" O)
)
(progn
8 u! n! @6 [+ D;;
) M' o# \7 h/ T6 U8 r. x(setq LST_LEN '()
I 0
  x( i2 l. |: L# e! G' n# y)
' R% q8 N+ I5 Q& {9 o: a;;逐个统计
(repeat (sslength SS)
(setq EN (ssname SS I)
LEN (vlax-curve-getdistatparam
$ a3 [( o! P8 z; W% t  P3 p1 n6 T3 U0 sEN
8 ]! s* i. K& @9 P7 S* j2 M0 j2 n(vlax-curve-getendparam EN)
)
8 O  u0 ~7 q- s; v7 W1 a' n% B: F/ iLST_LEN (cons LEN LST_LEN)
6 b2 d5 j0 L" S" @- wI (1+ I)
5 D  L' c! a$ t3 N)
)
(setq LST_LEN (reverse LST_LEN))
0 Z# M" `. H: b;;显示输出
6 A5 [1 z! R% x* Y4 G$ Q* ~& e5 A(princ "\n找到个数：")
: F0 a6 c1 g. S8 u(princ (sslength SS))
8 O; W# ^. d9 U! N! E( J: _(princ "\n单个长度：")
(princ LST_LEN)
(princ "\n总计长度：")
(princ (apply '+ LST_LEN))
" p5 [6 Y7 j9 {( V)
( I- Y) o, c) `3 j* e)
(princ)
' {6 L6 g6 _# t9 ^3 S( S)
& C! m) x% W9 B% K; N* O. A;;;=================================================================*
8 y. ~/ d5 X5 O; `% X2 M;;;(alert
;;; "功能：统计线段长度\n命令：\"CD\"\n日期：zml84 于 2009-05-21 17:45"
: Q* G/ d" e5 M" w8 m;;;)
(princ)

2 ^4 e/ {) z" r9 W  ^0 a3 ^
# a% g2 _. [3 T! c) U$ H’在AutoCAD中编程序，写到c盘根目录下的“123.xls”Excel表格中
7 N# l9 z9 H0 k/ w! r4 r1 z

’使用 VBA IDE 中的“工具” “引用”菜单选项，选择 Microsoft Excel 9.0 对象模型
’水平不高，有点罗嗦，楼主可以精简下
7 m" J4 Y% V$ q’欢迎以后交流，QQ 42123043
; M' t; v8 y8 ?Public Sub 取坐标()
) e$ i& C0 q: p’把AutoCAD中某一图层“多段线层”中的所有多段线的坐标列出来
Dim PLSet As AcadSelectionSet
, b+ M  O! K' BDim pl As AcadLWPolyline


Dim ExcelApp As Excel.Application
7 M3 K' e  s8 U* s! EDim ExcelSheet As Object
/ W4 r5 X* G5 O* e2 H% DDim ExcelWorkbook As Object


: I* K# U6 n2 f  Z7 UDim pts As Variant
- R( Q$ ^1 \3 p7 N0 q, x
3 d3 @4 Z* l' _- {: ~4 ~9 L9 tDim NN As Integer
9 d( H( `+ n/ \, PDim j As Integer

Dim pn As Integer

/ J6 f$ G$ _$ `: o  ^- i6 A7 XDim px(0 To 10000) As Double
* S  u/ C# q# M. T* D5 f( y) H4 zDim py(0 To 10000) As Double
2 [3 M  J( |& aDim pz(0 To 10000) As Double


0 K! `3 ]! N2 L! }2 T2 ^1 Q/ N- ^Dim filtertype(10) As Integer
Dim filterdata(1) As Variant

filtertype(0) = 0 ’ 选择线型
! |8 ?, U" ~& @filterdata(0) = "LWPOLYLINE"
filtertype(1) = 8 ’ 图层标识，可以根据具体情况改动
) S! P5 v/ l+ k; w% V1 ]$ Ffilterdata(1) = "多段线层"

  }0 ?# w6 z3 y, p( g6 y

# J/ n. _. k$ P/ {2 mSet PLSet = ThisDrawing.SelectionSets.Add("pl")
7 F( F; T/ n! ]PLSet.SelectOnScreen filtertype, filterdata
, V7 ^8 v" j! Z8 J* ?8 Q: `: \- C
NN = 0
. @% P5 S) S3 B/ xj = 0
For Each pl In PLSet

( ?7 A9 y/ ~4 q) ^/ Q3 Lpts = pl.Coordinates
pn = (UBound(pts) + 1) / 2

9 |$ [! c1 n$ q0 a5 i& z( OFor i = 0 To pn - 1
3 n6 j$ S3 g' y% c, p# |px(i + pn * j) = pts(2 * i)
1 \6 H# i6 w0 ~8 ]/ r+ qpy(i + pn * j) = pts(2 * i + 1)
9 J. N( a7 }' rNext i
j = j + 1
NN = NN + pn
Next pl
6 Y% r6 @! \* _7 {
PLSet.Delete
, j! Z1 l4 X! ^  O
2 Q$ r0 T) E. f
' e0 a5 v! l' P' E' e- tSet ExcelApp = New Excel.Application

- c% b9 i9 I4 {  K- |$ BSet ExcelWorkbook = ExcelApp.Workbooks.Add
  ?" n/ s* a4 u+ F; n4 D% J# h
Set ExcelSheet = ExcelApp.ActiveSheet
6 r* ~/ ]" M; A1 `) Y( P
ExcelWorkbook.SaveAs "c:\123.xls"

9 X6 K& g7 d4 \7 |  K1 j3 `! T! TExcelSheet.Cells(1, 1) = "x"
4 E' B  g" z% h' }( O' w$ c) HExcelSheet.Cells(1, 2) = "y"

5 L5 U7 `% Y; gFor i = 0 To NN - 1
+ {( g0 W; o2 o+ Q; g# ZExcelSheet.Cells(i + 2, 1) = px(i)
ExcelSheet.Cells(i + 2, 2) = py(i)
# h: W7 j) q; C, x$ Z8 w5 E$ B4 XNext i
/ o: f5 C4 `( w- I
! N2 R8 C, |  S( E$ [# UEnd Sub

其实，从Excel里面操作，完全也可以实现
' h! n; k/ C6 y; V- D& @只需在excel的 VBA IDE 中的“工具” “引用”菜单选项，选择 AutoCAD 2004 Type Library 对象模型
9 [7 d! @( Q# Q; t8 X' [: @然后类似的思路编程即可，大家可以试试！
8 V: L" b& }& l7 b* J
' r* O8 E9 p' N获取标注尺寸函数

" [& J6 z6 @3 F3 j2 h, m

Function FixDimMeas(Dimension As AcadDimension) As Long
Dim BlockCount As Long
Dim bz As Long
9 g1 E! k, V. C+ ~8 L) ^
BlockCount = ThisDrawing.Blocks.Count
'遍历块中的对象，取得标注尺寸
( ^! R4 j' I+ k6 EDim EntityInBlock As AcadEntity
For Each EntityInBlock In ThisDrawing.Blocks(BlockCount - 1)
If EntityInBlock.ObjectName = "AcDbMText" Then
bz = Dimension.Measurement
FixDimMeas = bz '取得标注尺寸
& K) G0 v: ~2 ?Exit For
9 e; ?* U7 e* BEnd If
, L( I- `/ d( }9 Z7 \4 g! pNext
4 \/ f6 M! F( d+ R% U* A6 R/ c; JEnd Function

sblisb

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

选择CAD线条 EXCEL记录长度
选择“工具”\“引用”项，在弹出的“引用”对话框的“可使用的引用”列表框内，选择“Microsoft Excel 8.0 Object Library"项

3 U( z7 E+ n( c, `'计算两点之间距离
Public Function GetDistance(ptSt As Variant, ptEn As Variant) As Double
    Dim x As Double
    Dim y As Double
    Dim z As Double
; E! ?3 S; d* e' u    x = ptSt(0) - ptEn(0)
  j( i5 M0 @- K$ y. F  ~    y = ptSt(1) - ptEn(1)
2 m) Q& b  r" ?. D2 }    z = ptSt(2) - ptEn(2)
    GetDistance = Sqr((Sqr((x ^ 2) + (y ^ 2)) ^ 2) + (z ^ 2))
End Function

Private Sub xz()
& A$ g& u, F8 | '创建选择集
# W, U& ?1 d2 s0 D9 E. \6 i6 U For JJ = 1 To 10
If MsgBox("是否继续选择", vbYesNo) = vbNo Then
8 v/ b  P7 R9 @( m( r; G$ C Exit For
% q2 K* f7 J" F$ S7 e/ t) @Else
& p$ T0 U- b$ P, b# M) m1 i    On Error Resume Next
/ ~! U  `+ R5 ~    Set myyactiveDoc = ActiveDocument

1 k  `6 N/ x8 a7 A+ U    Dim SSet As AcadSelectionSet
3 g0 O& S' y- c9 p1 I% ?      Set SSet = myyactiveDoc.SelectionSets.Add("Ehlxz")
+ j" f  b& w' ?) |    If Not IsNull(myyactiveDoc.SelectionSets.Item("Ehlxz")) Then
. e7 U, s9 s' x% j! k- O7 v        Set SSet = myyactiveDoc.SelectionSets.Item("Ehlxz")
0 K  U$ V, l  j" g        SSet.Delete     '及时删除不用的选择集非常重要
    End If
   Set SSet = myyactiveDoc.SelectionSets.Add("Ehlxz")
7 _# l& A- `! k  V& ^( d    SSet.SelectOnScreen
    '创建点组
    Dim ptArr1() As Variant
    Dim ptArr2() As Variant
    Dim count As Integer
# Z/ a* @3 ?7 t6 [" [. V8 j. a    count = SSet.count
    ReDim ptArr1(count - 1)
8 d( O: s) U$ I- ]6 r1 \    ReDim ptArr2(count - 1)
3 R. d; @: ?7 g7 ?4 j& H    '错误判断
    If count = 0 Then
, R) O4 Q. I( Y' Q5 n% |) H. b        MsgBox "未选择任何对象！", vbCritical
9 V5 u- N$ X3 J* i4 ?8 g        Exit Sub
    End If
" L; B* f  j. x' r: y$ m
    '获得最左侧和下侧的角点
* w7 P- R1 v/ B9 ?+ \! \+ S2 c: C    Dim objEnt As AcadEntity
    Dim ptTemp As Variant
    Dim i As Integer
    i = 0
  \! }! _0 W6 m& z* B! F" `; T    For Each objEnt In SSet
        objEnt.GetBoundingBox ptArr1(i), ptTemp
        i = i + 1
    Next
5 e; [# Y1 p  T- D. [8 P( X' B    '获得最上侧和右侧的角点
    i = 0
    For Each objEnt In SSet
        objEnt.GetBoundingBox ptTemp, ptArr2(i)
0 ~3 y. ~: J. K* e1 X        i = i + 1
    Next
7 W" s) x' y; Q( p1 u" Q    Dim ptLeftX, ptLeftY, ptRightX, ptRightY
. i7 |, v+ N- |4 d    Dim ptRight, ptTop
# q# [+ j' V# G1 s  @( d2 [   For WWW = 1 To count
1 O- h) K8 w4 `) t3 e      ptLeftX = ptArr1(WWW - 1)(0)
# U4 ~* R; C: ^1 V: |" l$ t' o; \      ptLeftY = ptArr2(WWW - 1)(1)
7 c: i( ?' g3 ^2 @, q. s0 g      ptRightX = ptArr2(WWW - 1)(0)
      ptRightY = ptArr1(WWW - 1)(1)
4 G" W5 M2 F1 }9 w' {! n
0 D% C* n9 s; N, H& Y; E' a9 g) U    Dim pppt1(0 To 2) As Double
  C# f  m6 H. @# \    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))
     gzgao = (ptLeftY - ptRightY - 25 * (Int(Val(SjigeCb.Text)) - 1)) / Int(Val(SjigeCb.Text))
1 ?% I" T8 C, I! |    For j = 1 To Int(Val(HjigeCb.Text))
      For k = 1 To Int(Val(SjigeCb.Text))
8 N1 o: A& `2 j* N: H$ p& C        pppt1(0) = ptLeftX + (gzkuan + 25) * (j - 1)
' S- e+ ~  J* k& A8 F" c         pppt1(1) = ptLeftY - (gzgao + 25) * (k - 1)
+ N4 w: t+ J/ k) ?) `         pppt2(0) = pppt1(0) + gzkuan
) F0 A  l4 `) {  x3 S; N( a         pppt2(1) = pppt1(1) - gzgao
& N/ u( f: o; r  I/ o
% h% |4 e* ^' f- A* A% K' ]& M: \7 N6 I/ ]      Next
    Next
         pppt1(0) = ptLeftX
         pppt1(1) = ptLeftY
         pppt2(0) = ptRightX
1 k# Y+ n, j; i% j/ W         pppt2(1) = ptRightY
  Next
9 Z) l6 h7 `) _5 Y( l* }    SSet.Delete
3 d4 F, ?! `8 _, d, ^1 o    KK = GetDistance(pppt1, pppt2)
'在程序中操作EXCEL表常用命令:
  Dim Excel As Excel.Application
    Dim ExcelSheet   As Object
    Dim ExcelWorkbook   As Object
1 g$ Q' D+ a8 |; _# T    '创建Excel应用程序实例
    On Error Resume Next
    Set Excel = GetObject(, "Excel.Application")
    If Err <> 0 Then
        Set Excel = CreateObject("Excel.Application")
7 I+ f% p7 r9 \6 @: r. L& v" H           '创建一个新工作簿
         Set ExcelWorkbook = Excel.Workbooks.Add
6 A9 b0 Y6 W5 O2 J" m          '令Excel应用程序可见
, K8 l$ q( C! f+ J           Excel.Visible = True
          '将新创建的工作簿保存为Excel文件
             ExcelWorkbook.SaveAs "属性表.xls"
$ j. f% M1 O- q( {5 u    End If
    '确保Sheet1工作表为当前工作表
$ P: F; v' n, V) k8 [3 s! Y# o/ P    Set ExcelSheet = Excel.ActiveSheet
    Excel.Visible = True
  x6 z0 @/ J2 E! L2 s    endrow = ExcelSheet.Range("A65536").End(xlUp).Row + 1
    ExcelSheet.Range("A" & endrow) = KK
; s7 u( m4 C: K' v' i& U* ]" B* r    Set Excel = Nothing
    End If
  Next
* T) R" T( }& p) WEnd Sub

3 S# A2 B& q8 V& G& B& C9 A

woaishuijia

1# sblisb
6 A  X- M; G4 K- w9 r  q2 f4 L0 R在 Excel VBAIDE 中引用 ACAD 类库,将下面的代码写入 Sheet1 对象代码窗口.
运行代码时必须保证待查询的 ACAD 文档已打开并处于激活状态
" R% X# @* ?* s, [) S4 _

1. 
   4 l$ x4 e  z1 R; Q' ~  c1 K
2. Sub A()
   # X+ n9 x$ D( A; r; d! J
3.     Dim CAD As AutoCAD.AcadApplication, St As AcadState, SS As AcadSelectionSet, Ft(0) As Integer, Fd(0) As Variant, I As Integer
   , o6 t' b' {" o) d, G, A+ w' k
4.     On Error GoTo 10
   ; G5 }4 }; w; T9 p9 {9 @1 D
5.     '获取ACAD进程
   
6.     '类名称最后的编号按版本
   0 L3 Y8 K7 z. ~/ l8 I: ^, F1 B- Q
7.     'R14版本为14
   $ c: m+ x8 ^" {; Q; v1 k) r
8.     '2000~2002版本为15
   
9.     '2004~2006版本为16
   8 f6 f1 ~9 x; v/ l! q. Z9 j  ~
10.     '2007~2009版本为17
    8 j3 \7 c* K( ^$ S
11.     '2010~2012版本为18
    
12.     Set CAD = GetObject(, "AutoCAD.Application.18" )
    
13.     '获取当前ACAD进程的状态
    
14.     Set St = CAD.GetAcadState
    - Y' I/ n9 \4 b" q2 Q2 H! }
15.     '当ACAD进程空闲时查询直线长度
    " ^# }0 Y% C0 K5 ~
16.     If St.IsQuiescent Then
    6 v0 Q' c! P1 O) I4 n
17.         '创建选择集
    % Y* F& {4 h9 p5 o- U% P
18.         Set SS = CAD.ActiveDocument.SelectionSets.Add("SS" )
    
19.         '定义选择集过滤器为只选择直线
    3 F) R- r. k8 F- ~: w
20.         Fd(0) = "Line"
    
21.         '用户在窗口选择
    6 Z1 \; u; x0 K6 U& |
22.         SS.SelectOnScreen Ft, Fd
    
23.         '逐个提取选择集中直线的长度并写入本工作表A列
    ; m9 n. e: D1 [! W, _/ ^
24.         For I = 0 To SS.Count - 1
    
25.             Sheet1.Cells(I + 1, 1) = SS(I).Length
    
26.         Next
    ' r7 ?# ~  y3 [! O3 ?
27.         '删除用过选择集
    " D( Q- \4 l: u. I' S( m: B) p
28.         SS.Delete
    
29.     Else
    7 r1 x0 W* c' r1 l! F  H5 `
30.         MsgBox "ACAD正忙"
    
31.     End If
    
32. 10: If Err Then MsgBox "ACAD没有运行或没有活动文档"
    - C6 f+ b8 i# H4 `/ o% x
33. End Sub
    ! Q! ?' `8 A5 Z! m

复制代码

sblisb

谢谢!
能不能帮助改进两点:
0 z$ S8 H0 A% y" e1 数据写入A列时不覆盖A列原有数据.
2 运行程序后自动转到Acad界面,原代码运行后,是在等待状态,还在exce界面,要自己转到Acad界面

279491611

厉害，学习学习

清风香客

果断留印，方便后查。

玉紫玄

学习学习