excel如何得到线的长度?

sblisb

我想在excel中操作,得到打开的cad文件中择的线的长度,然后写入excel表.
4 M: s, z- a8 X& F& J) _其中选择效果就象在cad中选菜单下的"工具_查询_列表显示",选择后按空格或回车,得到线的长度就分别写入excel表中A列了.
8 \+ B) [2 I& _( D/ H( n; i在网上搜索了两天,得到如下代码,偶vba不好,请哪位高手帮我整合下,谢谢!
# \; i( G! q  J* O) wexcel中操作cad请参考下面的步骤：
& ]$ ^6 e% M% }0 O" R- v4 i

在EXCEL VBA编辑器的“工具”菜单中点“引用”，在“引用”对话框中找到ACAD类库，勾选它，确定。见图
1 Z- k% S! s9 Y4、在EXCEL VBA编辑器Sheet1对象代码窗口写如下代码
Sub A()

; D5 r' Y3 Y1 j) u5 ~4 ^7 u. BDim CAD As AcadApplication '声明一个AutoCAD应用程序对象
3 y/ w: ~" F* i) j8 LDim DOC As AcadDocument '声明AutoCAD文档对象
) e* o5 R1 m2 r# ?" n+ rSet CAD = New AcadApplication '运行一个新的AutoCAD进程
CAD.Visible = True '使运行的AutoCAD程序可见。如果没有这行，程序将不可见，就是说看不见CAD窗口，只能在Windows任务管理器看到有CAD程序运行
7 h, c2 g4 |* i$ y6 r1 ASet DOC = CAD.Documents.Open(Sheet1.Cells(1, 1).Value) '按照“Sheet1”工作表第一行第一列单元格的内容打开文件
DOC.SendCommand Sheet1.Cells(1, 2).Value '按“Sheet1”工作表第一行第二列单元格的内容向CAD命令行发送命令
sub

;;;=================================================================*
; q3 x( ~" V6 ?) Z* };;;功能：测量线的长度 *
0 y  [& S4 j! |; p;;;日期：zml84 于 2009-05-21 17:45 *
(defun C:cd ()
(princ "统计线段长度"
(if (setq SS (ssget '((0 . "LINE,ARC,CIRCLE,ELLIPSE,*POLYLINE,SPLINE"))
: {% z* d. e! M1 J)
)
(progn
1 C5 c7 ^' Z# D9 A;;
( k" I% m( D$ B# B" |/ u# K8 L# {(setq LST_LEN '()
I 0
* a/ K; j6 O7 G. h  h# m9 P)
4 Z2 ~' t; O# ^; w;;逐个统计
(repeat (sslength SS)
(setq EN (ssname SS I)
LEN (vlax-curve-getdistatparam
EN
(vlax-curve-getendparam EN)
- k% D9 I+ }7 F& V3 C! X+ |5 j8 s0 Y)
LST_LEN (cons LEN LST_LEN)
I (1+ I)
1 E0 N) `# _, `- p( x. q6 k3 L)
)
(setq LST_LEN (reverse LST_LEN))
8 h; m! H  z' @; l" `, {8 N;;显示输出
. A) P4 c4 W* z9 b  @( Y(princ "\n找到个数：")
(princ (sslength SS))
1 H: q" R" q# H/ x* g4 e(princ "\n单个长度：")
(princ LST_LEN)
( F6 S: V3 U) G1 j& G' B(princ "\n总计长度：")
(princ (apply '+ LST_LEN))
$ Z/ r* l3 |! Y, A$ x)
. h( m* I- t9 q! i* h$ y% z)
(princ)
)
;;;=================================================================*
" r1 q2 ?" n1 I' \$ J;;;(alert
4 A  a8 p* e. `! j* S! Z4 j% K;;; "功能：统计线段长度\n命令：\"CD\"\n日期：zml84 于 2009-05-21 17:45"
;;;)
(princ)

’在AutoCAD中编程序，写到c盘根目录下的“123.xls”Excel表格中
4 C, F# I0 H5 i6 L3 f

’使用 VBA IDE 中的“工具” “引用”菜单选项，选择 Microsoft Excel 9.0 对象模型
- |; Y# `& o: I1 q2 [4 v* S1 H’水平不高，有点罗嗦，楼主可以精简下
. L' J: ~% ]: T1 R6 c’欢迎以后交流，QQ 42123043
# O5 n8 ]  R8 b3 {0 p( `0 uPublic Sub 取坐标()
’把AutoCAD中某一图层“多段线层”中的所有多段线的坐标列出来
- O5 h5 i) g# c/ ~) x. cDim PLSet As AcadSelectionSet
Dim pl As AcadLWPolyline
- i# @) Z$ o) p' c# |% p* L
1 N% O/ Z- q  K: X0 ]
Dim ExcelApp As Excel.Application
Dim ExcelSheet As Object
Dim ExcelWorkbook As Object


Dim pts As Variant
4 e. ~: g; W! a5 Y8 Y) M2 b' z
Dim NN As Integer
: {7 t8 S' Q  ADim j As Integer
+ R' x% z' [; R6 K5 q: p9 U
+ l- d7 e0 B  y# [Dim pn As Integer

Dim px(0 To 10000) As Double
Dim py(0 To 10000) As Double
Dim pz(0 To 10000) As Double
  S9 z6 ]# H: M+ |

Dim filtertype(10) As Integer
3 T; y' y% O+ ]& [Dim filterdata(1) As Variant
7 F3 T% _/ @( G& k
" V: O$ W; l! I5 J9 lfiltertype(0) = 0 ’ 选择线型
4 i  o( U0 E; b* n" Z8 ]) _filterdata(0) = "LWPOLYLINE"
" V' Z0 `' d- r+ Gfiltertype(1) = 8 ’ 图层标识，可以根据具体情况改动
filterdata(1) = "多段线层"
9 S& ]; X9 Z/ ~0 S! ]( a" Z


" V& h' Z2 J/ iSet PLSet = ThisDrawing.SelectionSets.Add("pl")
PLSet.SelectOnScreen filtertype, filterdata

$ D+ s* O1 U8 ~3 a5 a- D) J& CNN = 0
" A, l% s' N- dj = 0
For Each pl In PLSet

pts = pl.Coordinates
& l$ W. E) u/ @7 ^  I' r! B5 i% Ypn = (UBound(pts) + 1) / 2
8 e, [% B6 A) N: Q# A
For i = 0 To pn - 1
. F4 i; K% o4 [% {' l7 dpx(i + pn * j) = pts(2 * i)
9 Y! H$ d& o+ }% @% f' m8 R. K; wpy(i + pn * j) = pts(2 * i + 1)
/ D8 Y/ T; Z+ T$ H$ u7 t& mNext i
j = j + 1
. r& ?8 M  g, m: K2 lNN = NN + pn
Next pl

+ t, o3 s# B3 Y, P1 @4 mPLSet.Delete
1 Q. {' P6 O1 b% a. y
  ?, _9 t5 P% o7 M
# T+ f  B+ {" i& t1 YSet ExcelApp = New Excel.Application
5 `- n1 ~) ?- m" n
Set ExcelWorkbook = ExcelApp.Workbooks.Add

Set ExcelSheet = ExcelApp.ActiveSheet
; c$ m( Z- [, ^
ExcelWorkbook.SaveAs "c:\123.xls"
- B; c2 g' H7 S: d% X7 _0 L
% H; M$ W- Y' n% S! x( VExcelSheet.Cells(1, 1) = "x"
ExcelSheet.Cells(1, 2) = "y"

For i = 0 To NN - 1
$ M) M/ M8 l7 w6 j1 oExcelSheet.Cells(i + 2, 1) = px(i)
5 l) q7 C, o6 @3 e4 _ExcelSheet.Cells(i + 2, 2) = py(i)
Next i

$ R+ ^; n; t" dEnd Sub

其实，从Excel里面操作，完全也可以实现
" x! D; ?& E0 ?, T3 v! I9 z% {' Q只需在excel的 VBA IDE 中的“工具” “引用”菜单选项，选择 AutoCAD 2004 Type Library 对象模型
% F' {5 n# \9 P4 `0 \" s% K然后类似的思路编程即可，大家可以试试！

5 \5 ^- X: D  t6 t- W/ s获取标注尺寸函数
) C' r6 g* N" `: K' @, @( i3 S
5 S9 r% `; ?% E

Function FixDimMeas(Dimension As AcadDimension) As Long
Dim BlockCount As Long
Dim bz As Long
8 v! B# ]" D  ]6 u# d
1 F" N$ H: |1 f+ E) h7 r% g5 R: z! }BlockCount = ThisDrawing.Blocks.Count
'遍历块中的对象，取得标注尺寸
Dim EntityInBlock As AcadEntity
" M  h/ f! X; i1 ?4 c; M. T% ^For Each EntityInBlock In ThisDrawing.Blocks(BlockCount - 1)
If EntityInBlock.ObjectName = "AcDbMText" Then
bz = Dimension.Measurement
' B" j6 _$ m" n7 p( ?$ FFixDimMeas = bz '取得标注尺寸
; o- B# ^8 I5 bExit For
End If
5 s' s" P" ?+ J* E9 t7 XNext
End Function

sblisb

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

选择CAD线条 EXCEL记录长度
选择“工具”\“引用”项，在弹出的“引用”对话框的“可使用的引用”列表框内，选择“Microsoft Excel 8.0 Object Library"项
' @8 k7 r8 }+ g4 X9 F) S( W
; P$ ?  g1 y. G0 K: k'计算两点之间距离
# F2 q% d) R- YPublic Function GetDistance(ptSt As Variant, ptEn As Variant) As Double
    Dim x As Double
% O; v* M2 Q8 K5 q9 u+ ~. V0 j    Dim y As Double
    Dim z As Double
    x = ptSt(0) - ptEn(0)
2 S9 D) w: x, Z9 m. }, X3 j    y = ptSt(1) - ptEn(1)
0 K% S4 d/ w: D# T    z = ptSt(2) - ptEn(2)
    GetDistance = Sqr((Sqr((x ^ 2) + (y ^ 2)) ^ 2) + (z ^ 2))
. j' t6 P# \: @& ^End Function
* A0 v3 i" d* W: L" @5 w
' O; a9 f) Z& O4 E  SPrivate Sub xz()
'创建选择集
7 I( `1 a' O( Y For JJ = 1 To 10
If MsgBox("是否继续选择", vbYesNo) = vbNo Then
Exit For
0 c* i  [* t0 Q9 kElse
  C' M2 E! K' D5 w    On Error Resume Next
    Set myyactiveDoc = ActiveDocument
* g5 l! {0 H5 ~, S* D1 z
    Dim SSet As AcadSelectionSet
      Set SSet = myyactiveDoc.SelectionSets.Add("Ehlxz")
    If Not IsNull(myyactiveDoc.SelectionSets.Item("Ehlxz")) Then
        Set SSet = myyactiveDoc.SelectionSets.Item("Ehlxz")
5 o( m3 @( w' m  d$ Y        SSet.Delete     '及时删除不用的选择集非常重要
, n; X1 x% v$ @+ _- N- A/ Z+ Z3 V    End If
  x0 q1 S/ i5 {% j* z   Set SSet = myyactiveDoc.SelectionSets.Add("Ehlxz")
    SSet.SelectOnScreen
$ O/ m/ h( W* }9 e" T) K6 A    '创建点组
6 }( J. |* N2 l) v  s    Dim ptArr1() As Variant
    Dim ptArr2() As Variant
( \3 ~7 h( C5 n2 T    Dim count As Integer
    count = SSet.count
    ReDim ptArr1(count - 1)
4 {* L* |* s. c; B    ReDim ptArr2(count - 1)
5 x0 p1 y" n/ t/ C3 E    '错误判断
$ H& X: ^, s, S" Q1 u$ W& e. {    If count = 0 Then
        MsgBox "未选择任何对象！", vbCritical
        Exit Sub
$ t3 L" S3 n0 x0 J) r# O    End If
- i* o+ K5 g, ~( K
    '获得最左侧和下侧的角点
% s% G9 K2 D' e# z2 S* j8 q/ p    Dim objEnt As AcadEntity
    Dim ptTemp As Variant
    Dim i As Integer
    i = 0
7 K; T0 i: y5 Z$ _5 N    For Each objEnt In SSet
- G4 r; q7 K! T9 b' ]/ ?        objEnt.GetBoundingBox ptArr1(i), ptTemp
+ q9 H: J! v& l; W6 `7 l3 b        i = i + 1
    Next
    '获得最上侧和右侧的角点
    i = 0
  ^& \8 x& R3 Q1 A# n$ P    For Each objEnt In SSet
9 Z0 N' t- u+ p- i6 z        objEnt.GetBoundingBox ptTemp, ptArr2(i)
        i = i + 1
% \& o! n6 K( l; {: O    Next
) ?; t& l) Q2 r* {4 ]- I    Dim ptLeftX, ptLeftY, ptRightX, ptRightY
    Dim ptRight, ptTop
   For WWW = 1 To count
      ptLeftX = ptArr1(WWW - 1)(0)
      ptLeftY = ptArr2(WWW - 1)(1)
      ptRightX = ptArr2(WWW - 1)(0)
: A1 y. l% O0 |9 O      ptRightY = ptArr1(WWW - 1)(1)

( |  g) X3 P/ P# Z1 b    Dim pppt1(0 To 2) As Double
    Dim pppt2(0 To 2) As Double
; _9 h1 Z% R* T* b        pppt1(2) = 0
8 x: C2 \/ {' B6 K* l        pppt2(2) = 0
5 v9 _) @/ T! A, ?/ A# S) _0 c    Dim gzkuan As Double, gzgao As Double
5 g- d1 D+ _/ U  w     gzkuan = (ptRightX - ptLeftX - 25 * (Int(Val(HjigeCb.Text)) - 1)) / Int(Val(HjigeCb.Text))
& R7 G( v8 o" N# h2 _3 y! S  L     gzgao = (ptLeftY - ptRightY - 25 * (Int(Val(SjigeCb.Text)) - 1)) / Int(Val(SjigeCb.Text))
& u( Y+ K1 C/ e* k. C$ U2 o    For j = 1 To Int(Val(HjigeCb.Text))
      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
3 d$ A6 Y$ [7 j. v1 ^0 Q+ [6 l
      Next
9 i4 ?7 u3 t( ~! a6 q$ G. q    Next
* f9 H$ `8 j3 H: K  I  ^+ R+ R         pppt1(0) = ptLeftX
         pppt1(1) = ptLeftY
, C$ o7 b7 v! w6 Z& I2 v( n         pppt2(0) = ptRightX
         pppt2(1) = ptRightY
  Next
    SSet.Delete
    KK = GetDistance(pppt1, pppt2)
) u: ?$ B' p; A- v'在程序中操作EXCEL表常用命令:
1 M+ t5 @2 Q/ q8 Q6 K  Dim Excel As Excel.Application
    Dim ExcelSheet   As Object
5 ^1 A8 ^1 ]: r. I" e, Q    Dim ExcelWorkbook   As Object
    '创建Excel应用程序实例
    On Error Resume Next
7 f5 S( q8 Y4 y% M7 j! Q    Set Excel = GetObject(, "Excel.Application")
, t# s3 Z& X! Q    If Err <> 0 Then
        Set Excel = CreateObject("Excel.Application")
: A1 e# [& H$ i2 i! y, F2 V           '创建一个新工作簿
         Set ExcelWorkbook = Excel.Workbooks.Add
          '令Excel应用程序可见
  r- A, B' M2 W' z           Excel.Visible = True
          '将新创建的工作簿保存为Excel文件
             ExcelWorkbook.SaveAs "属性表.xls"
    End If
8 K3 _9 j0 r9 {4 a& U0 ^9 @    '确保Sheet1工作表为当前工作表
    Set ExcelSheet = Excel.ActiveSheet
    Excel.Visible = True
    endrow = ExcelSheet.Range("A65536").End(xlUp).Row + 1
& b* T% _+ N6 m0 K7 b    ExcelSheet.Range("A" & endrow) = KK
# m! P4 C0 T# P    Set Excel = Nothing
    End If
# @8 V; w( q) @- g+ B  Next
End Sub

+ E( x) E' ^/ i9 ~

woaishuijia

1# sblisb
: Z3 ^* C2 M" g( C8 D% M% ^在 Excel VBAIDE 中引用 ACAD 类库,将下面的代码写入 Sheet1 对象代码窗口.
运行代码时必须保证待查询的 ACAD 文档已打开并处于激活状态
2 f0 e2 V* P* S- ~4 {, y. i

1. 
   . d1 ~# r( ^1 q  O
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
   - \8 y) a2 {4 e+ Y1 i8 T& a
5.     '获取ACAD进程
   - p4 q; k  T2 O
6.     '类名称最后的编号按版本
   / N9 _' q2 H7 F9 y$ O
7.     'R14版本为14
   2 O$ X+ m5 g; p) D% p) Z
8.     '2000~2002版本为15
   
9.     '2004~2006版本为16
   8 N0 J1 e9 g+ t+ E; k% y+ B
10.     '2007~2009版本为17
    
11.     '2010~2012版本为18
    
12.     Set CAD = GetObject(, "AutoCAD.Application.18" )
    ( P  S/ y( J* K3 @0 \7 v, T) c
13.     '获取当前ACAD进程的状态
    ; W; K, O8 i( J5 r+ s1 r$ Z9 c" |
14.     Set St = CAD.GetAcadState
    2 z& F, P3 u. O8 W; P1 Y' J2 ]1 }3 H/ _
15.     '当ACAD进程空闲时查询直线长度
    
16.     If St.IsQuiescent Then
    
17.         '创建选择集
    
18.         Set SS = CAD.ActiveDocument.SelectionSets.Add("SS" )
    
19.         '定义选择集过滤器为只选择直线
    
20.         Fd(0) = "Line"
    
21.         '用户在窗口选择
    ' s; \! d. \( y1 n! m
22.         SS.SelectOnScreen Ft, Fd
    7 H9 I+ @: `8 R' E4 Q" f
23.         '逐个提取选择集中直线的长度并写入本工作表A列
    $ M3 V0 V/ k" j8 T$ `6 a8 n
24.         For I = 0 To SS.Count - 1
    
25.             Sheet1.Cells(I + 1, 1) = SS(I).Length
    
26.         Next
    
27.         '删除用过选择集
    
28.         SS.Delete
    
29.     Else
    
30.         MsgBox "ACAD正忙"
    * ^' i) q3 W, z- h
31.     End If
    ; t; @/ ~  E1 `0 l5 n
32. 10: If Err Then MsgBox "ACAD没有运行或没有活动文档"
    5 l% n+ g9 ^5 W
33. End Sub
    : }8 i1 _/ c. L# c) `& ~

复制代码

sblisb

谢谢!
能不能帮助改进两点:
# E! e4 r4 i- y* j- S* @1 数据写入A列时不覆盖A列原有数据.
2 运行程序后自动转到Acad界面,原代码运行后,是在等待状态,还在exce界面,要自己转到Acad界面

279491611

厉害，学习学习

清风香客

果断留印，方便后查。

玉紫玄

学习学习