CAD二次开发对二维图某些数据的统计(请我爱谁家版主再指导)

koutx · 发表于 2009-2-19 11:24:05

马上注册，结识高手，享用更多资源，轻松玩转三维网社区。

您需要登录才可以下载或查看，没有帐号？注册

x

新手求一代码实例教程：
画好了一张简单的二维矩形分块图，如何按长宽尺寸分类进行统计，并导出到已有的（biao.xls）Excel表中。biao.xls表中的字段有“长”、“宽”、“块数”。VBA的代码该如何写呢？敬请高手赐教

[ 本帖最后由 koutx 于 2009-2-21 11:08 编辑 ]

koutx · 发表于 2009-2-19 20:32:32

如有这方面的高手能帮这个忙，也可单独联系我。koutx@sina.com

woaishuijia · 发表于 2009-2-20 10:45:24

运行下面的代码之前，必须引用Microsoft Excel类库。方法是：在VBAIDE界面的“工具”菜单下点“引用”。。。

( x4 o9 J- z/ L( L& h
Sub A()
4 f8 U* O5 ]2 M. G7 I4 Q6 b1 J7 r, Y
'声明一个选择集及过滤器' h1 m& c6 _" Z- ^+ S
Dim SS As AcadSelectionSet, FT(0) As Integer, FD(0) As Variant& Q/ n7 S {9 H3 u% x L8 J/ K9 M5 c
'声明一个直线临时变量9 z' d% I- e* ^
'声明两个直线动态数组，分别用于存放水平直线和垂直直线3 g" B( j0 O d# h
Dim L As AcadLine, L1() As AcadLine, L2() As AcadLine
) D3 F- u: q3 v
'声明一个双精度变量，用于存放计算精度。精度的用途见后面输入框中的文字! t' o* N. t) ]0 j2 i$ |: g
Dim 精度 As Double2 P) o; ?4 @) }5 `: F/ w' ^; e/ G
'声明循环变量
9 L2 P6 I) G. I8 s) \4 S
Dim I As Long, J As Long, K As Long
( t% a1 S+ T& p4 Q( s" b- k6 _1 ~% T. t
'声明四个变体变量，用于存放两相邻水平直线与两相邻垂直直线间的四个交点
1 C. M6 I- O# M0 j, p% \: `" h' Y
'通过检查交点是否存在，鉴别该四条直线是否能围成矩形" D' B' w$ P6 D9 I4 |
Dim P1 As Variant, P2 As Variant, P3 As Variant, P4 As Variant
& M m: H) \; i! G! Z3 e* t8 |& n
'声明一个动态数组，用于存放查询矩形规格数量的结果
: I! C! o& b4 ]# v9 [
Dim 矩形() As Double
* A8 U2 d* O4 S/ K, F, t8 x
'声明一个逻辑变量，用于条件判断' b* k2 _, i6 s/ C6 j7 V
Dim B As Boolean
p3 Q( r1 \/ w( U8 D9 y
2 P# K. r3 _9 @ p+ c7 l9 j
On Error Resume Next
Z9 k+ v8 O7 i4 }3 @" w
With ThisDrawing; F; Z9 @# [! x' T" s# b4 ~) F/ Z# |
'输入精度+ M" M* J2 J- o7 `/ Z
精度 = Val(InputBox("输入精度" & vbLf & "鉴别直线是否水平（垂直）时，如果直线与极轴的夹角（弧度）的绝对值小于该精度值，即认为该直线水平（垂直）" _
3 m! D3 w) R* h: c, o
& vbLf & "鉴别矩形大小是否一致时，如果被比较的矩形的长（宽）与原始矩形的（长）宽之差的绝对值小于该精度值，即认为两矩形一样大小", "AutoCAD", 0.00000001))6 i9 e; h. P: v7 p B
'定义选择的对象为直线对象，创建选择集并由用户在屏幕上选择. }, \3 A' h7 f* L+ K
FT(0) = 0
4 x* y4 o# d9 _# e; d4 a
FD(0) = "line"
' \2 u6 B/ p% h7 Z5 i
Set SS = .SelectionSets.Add("SS")
- l8 ]/ ^/ \; }, m3 j; O
SS.SelectOnScreen FT, FD
' i& H3 W7 Q0 o) X
'遍历选择集，鉴别其中的水平和垂直直线并分别存入动态数组
; P/ c- k0 Y7 Y& Q
For Each L In SS2 P9 n1 s: p( y
If L.Angle < 精度 Or L.Angle > .Utility.AngleToReal(180, acDegrees) * 2 - 精度 Or Abs(L.Angle - .Utility.AngleToReal(180, acDegrees)) < 精度 Then# k. ]& @0 x, c$ L5 q# a# ?0 E2 s
If UBound(L1) = -1 Then" w3 x, _9 P9 Z+ q% J0 Q3 a
ReDim L1(0) B5 E u3 Q* y9 \5 o
Else
% u. t8 b P8 A2 [% I
ReDim Preserve L1(UBound(L1) + 1)+ N. v! C j- |+ C& s
End If+ f$ u& n; R, @2 Y
Set L1(UBound(L1)) = L
8 W2 T% Z& O1 ^+ G% `' p$ [ [
ElseIf Abs(L.Angle - .Utility.AngleToReal(90, acDegrees)) < 精度 Or Abs(L.Angle - .Utility.AngleToReal(270, acDegrees)) < 精度 Then6 E3 |7 g$ N$ D. E- w! P$ t
If UBound(L2) = -1 Then2 _6 m( n: `% Q% h7 ?
ReDim L2(0)
% l4 R1 m7 p6 q" m
Else
4 d2 \9 X" Y$ L# a. S0 M' s* W* y
ReDim Preserve L2(UBound(L2) + 1)7 \% u- j% K& k
End If+ o% C3 d# i2 B+ h2 r3 b+ N
Set L2(UBound(L2)) = L# D& O4 S) k6 P" a5 c* h: C
End If
9 B# l, T; E+ y- i" H' ?+ Q9 g
Next2 w- ]% H! Q. [) z, s0 j) Q8 r
'删除选择集
2 k) @8 e8 R2 t1 {& r
SS.Delete/ [1 L) x* g( \
'当水平直线和垂直直线数量均不小于2时，执行下面的代码，查询矩形规格和数量并保存: Q: }3 z: g* W2 j
If UBound(L1) < 1 Or UBound(L2) < 1 Then
4 q* {) b; e/ W- W, b7 V
Else
3 N, a5 k+ n! o0 X c
'水平直线数组中的直线，按起点纵坐标由小到大重新排序" `! j4 @+ h# I& Q8 j1 K
For I = 0 To UBound(L1) - 16 I% o$ P3 e6 S8 n' ?+ b( e
For J = I + 1 To UBound(L1)
0 \/ L& f0 A+ h$ \, r/ m. I4 V
If L1(J).StartPoint(1) < L1(I).StartPoint(1) Then
9 S2 C2 O5 v& M: R7 _# n' ^
Set L = L1(I)4 ~5 Z5 k3 N% a( B+ T
Set L1(I) = L1(J); h# H( a3 q" X1 n. @7 ?2 j
Set L1(J) = L
9 e6 ^" ^- I) g" n0 Z/ k
End If' O5 S M9 s# i# d
Next$ N* q: O' z1 D" n) `; C
Next
7 B+ o5 K5 E& D! @$ L
'垂直直线数组中的直线，按起点横坐标由小到大重新排序
) w3 J( {; E4 @1 `
For I = 0 To UBound(L2) - 1
2 o+ ~6 Y$ ?( O$ p: D
For J = I + 1 To UBound(L2)# D9 n! d5 U X2 }
If L2(J).StartPoint(0) < L2(I).StartPoint(0) Then
% Y6 s* f( T; K) z: p0 t
Set L = L2(I)- W6 {1 f% a8 F4 ]
Set L2(I) = L2(J)
% j9 M' [, F7 M/ M8 Q+ M
Set L2(J) = L
0 i9 J. k3 u3 _( B- I* p' y
End If
' S v- f, b% b4 h2 w! j" D8 S, D: z
Next
, J: v0 t# Y6 ^; K0 g# B
Next
8 u, z" Y: k% ]% e& W) j: x
'检查相邻直线是否相交围成矩形并做进一步处理. Y2 G: a, D I; C
For I = 0 To UBound(L1) - 1, H7 J! @, O2 p- R
For J = 0 To UBound(L2) - 1
" `# d1 d; ~0 E3 G: l2 z
'获得相邻直线的交点1 l1 j+ _$ q9 V# m; z
P1 = L1(I).IntersectWith(L2(J), acExtendNone)) B" h( _. T3 A3 h7 e
P2 = L1(I).IntersectWith(L2(J + 1), acExtendNone)7 J: |" k6 P' o v* x
P3 = L1(I + 1).IntersectWith(L2(J + 1), acExtendNone)
7 T) S2 U- y5 r1 R+ f0 z
P4 = L1(I + 1).IntersectWith(L2(J), acExtendNone)- X6 z1 K! ~9 q! `. S/ ~1 q1 z
'当四个交点都存在时，执行下面的代码
/ [$ A# ]8 G9 o! Z" e( L- A" B9 I
If UBound(P1) = -1 Or UBound(P2) = -1 Or UBound(P3) = -1 Or UBound(P4) = -1 Then
$ K; A0 j: W3 J) \, S+ ^3 L
Else: B- C; m ^) Y2 h- M$ v
If UBound(矩形, 2) < 0 Then '第一个矩形直接存入数组/ |4 \9 K. M5 ~$ }) e) H
ReDim 矩形(2, 0)
3 D; g. m$ ~( a% K+ c4 ~
矩形(0, 0) = P2(0) - P1(0); Q( s9 M, d$ A q! z4 @) x
矩形(1, 0) = P3(1) - P2(1)
2 g. D M O7 H: }4 X
矩形(2, 0) = 1; @' r' C* ^ i' r
Else '其它矩形
) g7 v% Q, v; L4 w; t3 O/ ?
'检查前面存入数组的矩形中是否有相同规格
' J8 J/ Q) A/ _+ U- y
'如果存在，则在数组中的数量上加1，并改写逻辑变量（标记）$ m; L+ H: t8 q. }9 u- M9 D9 _
B = False6 ~5 n7 Z' _2 w
For K = 0 To UBound(矩形, 2)# B+ p( L! Y: Q: K
If Abs(矩形(0, K) - (P2(0) - P1(0))) < 精度 And Abs(矩形(1, K) - (P3(1) - P2(1))) < 精度 Then. k" o* N+ p4 g, R/ C
矩形(2, K) = 矩形(2, K) + 1
& J. r% ~8 @6 \" [; i) V5 c
B = True
( v" R7 P) i- S6 f7 l( ]8 j/ ~' Y
Exit For/ L& a% ^7 S; ^0 b8 n
End If( Y% ?( [& F; ^! I/ g! L# f
Next) Y3 i$ `+ R+ y2 J- \, ^/ x
'如果数组中没有相同规格的矩形，则重定义数组，并写入新的规格、数量为1
$ L V: w4 v) O) o
If Not (B) Then9 K. l$ {* v& D+ @% c0 L! w6 }9 [' V
ReDim Preserve 矩形(2, UBound(矩形, 2) + 1)
8 D' H9 b& C/ {, D" I) \0 l
矩形(0, UBound(矩形, 2)) = P2(0) - P1(0): G. J- I" j: U& [ b/ L
矩形(1, UBound(矩形, 2)) = P3(1) - P2(1)
I0 f9 m, {1 b3 s+ C
矩形(2, UBound(矩形, 2)) = 1; G! e+ c. C7 B" w3 \/ p8 O! f
End If
0 Q8 P( @+ \- R/ Q6 l
End If! h/ Z+ @' k" u; Y6 ^3 ?- O- K1 \
End If- K3 {3 E6 L4 L5 W
Next
; W* _! @1 t8 i. g
Next$ ^8 u( z/ ^" U& c7 n
'如果存在矩形，把数组中的规格、数量写入Excel文档
$ l/ h: m1 c; S( _# k4 J
If UBound(矩形, 2) < 0 Then1 t9 ^- d! f# f* O& N
Else+ H! x( K. D6 _; J; {: f
'声明并启动Excel程序; v4 X. h1 o. x& I" S( Q- C6 Y9 r, Y. \
'声明工作簿
: g: h5 @2 N- F4 P; T! @( J
Dim E As New Excel.Application, Book As Workbook6 }( w# v2 H1 Z. i9 T) G* \
'创建工作簿
' J7 K7 `* N/ Z. b- W: i
Set Book = E.Workbooks.Add) v( K2 B1 Q# w
'写入字段名称
0 n* u. W% l1 P: O
Book.ActiveSheet.Cells(1, 1) = "长"
, [1 i" B5 _/ @
Book.ActiveSheet.Cells(1, 2) = "宽"; m0 U4 W% n1 j( ]) _' T
Book.ActiveSheet.Cells(1, 3) = "块数"/ `, z. Z- K3 @
'写入矩形规格和数量
) ^1 ?6 K2 l! V( k
For I = 0 To UBound(矩形, 2)1 @! `/ U3 |, z9 g; T
For J = 0 To 2$ h* P7 S) k; w* O+ K
Book.ActiveSheet.Cells(I + 2, J + 1) = 矩形(J, I)$ l# m, M" T8 u* x# r
Next# N& ^. d' L3 t7 ^$ h3 H
Next" o5 f {) G# A; \: Y) j
'保存文档并退出Excel
8 f/ ]( ` D4 O/ U# F* ^2 o
Book.SaveAs "c:\biao.xls"/ }* ~5 X5 j8 W* e+ v, P
Book.Close
" q% U( p6 M) B- N) R$ {
E.Quit
* @. a0 h7 s: ~. F( Q
End If
" C2 q: ]- x8 L' C4 O' I' Z8 x. R
End If
* B* B: n9 I9 x: O/ w
End With4 c9 E" t& i8 q( g/ l: b$ U+ ?
End Sub
8 ^ `4 `! y" I! n1 Z c

复制代码

koutx · 发表于 2009-2-20 17:41:20

万分感谢我爱谁家版主。收下并试试认真研究学习。俺是新手，以后少不了讨教。

koutx · 发表于 2009-2-21 10:58:14

还得请我爱谁家版主指导：
在VBAIDE界面的“工具”菜单引用Microsoft Excel类库后，我插入一模块Model1，在之中将您的Sub A()过程代码整个贴入后，又回到CAD鼠标点选了几条水平线和几条垂直线，后通过工具菜单---宏----VBA管理器调出管理器窗口，点窗口上的宏按钮后按执行，总是不能成功导出。真不知错在哪儿。还清帮忙。
传上附件，能不能帮我看一看，改一改。多谢了。

例子.rar (19.63 KB, 下载次数: 11)

koutx · 发表于 2009-2-23 15:50:39

别沉下去呀。。

woaishuijia · 发表于 2009-2-23 21:06:05

试了你的附件，可以导出EXCEL文件。不过有下列几个问题还请你自己根据实际情况考虑：
1、我的代码中，保存的EXCEL文件路径是“c:\biao.xls”，在C盘根目录下，请你检查一下文件是否存在？
2、我的代码只是提供一个思路，并不严谨。比如，根据水平和垂直直线判断是否围成矩形的部分，是针对你在一楼的附图编写的，只是检查了相邻直线，而未检查不相邻的直线。如果针对的是任意图形，这就是一个漏洞。实用程序应该比这段代码复杂很多。再比如，保存的文件路径，如果这个程序用于发布的话，还是使用公共对话框，由用户指定文件名和路径好一些。再比如，打开新的EXCEL进程前，可以先检查一下是否已经有EXCEL进程在运行。等等
3、可以改写一下代码：在声明并启动EXCEL程序的代码下面加一行

E.Visible = True

复制代码

使EXCEL进程可见。删除保存文件、关闭工作簿、退出EXCEL程序的三行代码，可以在运行宏时直观地看到数据是否被写进了EXCEL表格。

koutx · 发表于 2009-2-24 16:11:32

现在的问题是If UBound(L1) = -1 Then这一句总报"下标越界"。不知是什么原因。请帮忙解释。多谢。再有我用的CAD2004，版本合适不合适？

[ 本帖最后由 koutx 于 2009-2-24 16:12 编辑 ]

woaishuijia · 发表于 2009-2-25 07:42:07

这个程序中使用了三个动态数组。在动态数组未被定义维数和下标之前，使用Ubound()函数检查最大下标是会出错的。因此，代码前面有一行

On Error Resume Next

复制代码

这是一个错误处理语句。当一个运行时错误发生时，转到紧接着发生错误的语句之后的语句，并在此继续运行。
如果不使用 On Error 语句，则任何运行时错误都是致命的；也就是说，结果会导致显示错误信息并中止运行。
实际上，在程序首次运行到

If UBound(L1) = -1 Then

复制代码

时，由于此时L1数组尚未被定义维数和下标，"下标越界"错误就会发生。由于程序在此之前已经执行了

On Error Resume Next

复制代码

，
此时就会继续执行下面的

ReDim L1(0)

复制代码

，然后跳过Else后面的代码段并继续向下运行。
与此类似的代码还有

If UBound(L2) = -1 Then

复制代码

If UBound(L1) < 1 Or UBound(L2) < 1 Then

复制代码

If UBound(矩形, 2) < 0 Then

复制代码

这也是我为什么在上面后两行代码的后面接着是Else代码段的原因。

这段代码并没有使用CAD2004不支持的对象、方法和属性，在CAD2004下运行应该没有问题。

koutx · 发表于 2009-2-25 21:49:50

谢谢对On Error Resume Next的作用的详细讲解，是为了保证动态数组首次定义维数和下标语句的执行。
还有以下语句
Set SS = .SelectionSets.Add("SS")
SS.SelectOnScreen FT, FD
在我测试时，如第一次未正常完成，在点选直线第二次执行时总出现“已存在选择集”的错误提示。不懂是什么机理？

woaishuijia · 发表于 2009-2-26 08:21:25

选择集是命名对象，

Set SS = .SelectionSets.Add("SS")

复制代码

括号中的"SS"就是这个新建选择集的名字。选择集是不能重名的，一个选择集在用过之后应该被删除，以免出现诸如在再次创建选择集时重名的错误，这就是

SS.Delete

复制代码

的用途。当程序非正常结束，而没有删除用过的选择集时，第二次运行程序会因为文档中已存在同名的选择集在

Set SS = .SelectionSets.Add("SS")

复制代码

这一行出错。
知道了原因，解决的办法就多了。比如关闭文档后重新打开，文档中就没有选择集了；再比如第二次运行程序前把代码中新建选择集的名字修改一下

Set SS = .SelectionSets.Add("SSA")

复制代码

；再比如在这一行的前面加上

On Error Resume Next

复制代码

koutx · 发表于 2009-2-26 12:21:54

谢谢版主精辟的讲解，胜读十天书啊！现在我先加载此工程后运行宏，再选择各直线的已能正确输出Excel。
另有一问题请教：如果在Access 的VBA代码中如何实现在调用AutoCAD的同时自动加载此工程。谢谢

[ 本帖最后由 koutx 于 2009-2-26 13:02 编辑 ]

woaishuijia · 发表于 2009-2-26 15:36:41

Dim CAD As New AcadApplication/ g# v* Q4 V3 d: h
CAD.Visible = True( ~& P' S+ ~% k) t3 u
CAD.LoadDVB Name

复制代码

其中，Name是.dvb工程的完整路径名称字符串

koutx · 发表于 2009-2-26 21:53:31

再次谢谢，我马上试一试学一学。

koutx · 发表于 2009-2-27 17:44:36

版主提供的代码已顺利通过，现在的问题是：如果想在打开一个已有的dwg图文件时，用VBA代码自动加载如版主在3#的工程代码，如何实现？因为我在用Shell语句打开已有dwg文件时就不用再使用以下两行语句了：
Dim CAD As New AcadApplication
CAD.Visible = True
如此下面语句就不能用了
CAD.LoadDVB Name
可如果只用LoadDVB Name又不管用。不知如何处理，请不吝赐教。

注：此问题通过版主在13#中的方法即可解决了。

[ 本帖最后由 koutx 于 2009-2-28 12:08 编辑 ]

koutx · 发表于 2009-2-28 12:22:45

在1#的图中，由于池子分类不是一种，在导出Excel时，如何分别将对应的类别也导出呢？见附图示。
能通过填充不同的底纹来分类吗？如何分类处理？因水平太低，不能按版主的框架融会旁通，恳请版主再帮一下，百倍感谢。

[ 本帖最后由 koutx 于 2009-2-28 12:24 编辑 ]

woaishuijia · 发表于 2009-2-28 14:41:14

LoadDVB 是 AcadApplication 对象的方法，要在VB或其它VBA中使用这个方法，就必须创建一个对CAD进程的引用，也就是代码中的 CAD 变量。
打开一个已有的dwg图文件，可以使用 AcadApplication 的子对象 Documents 的 Open 方法。
改写一下13楼的代码

5 E) D- N/ j# M) H
Dim CAD As New AcadApplication4 \/ U$ q# e& L5 I# p% g7 q
CAD.Visible = True
, d. y. o7 @6 R9 ?2 W
CAD.Documents.Open .dwg文件路径
. n- A2 ~+ S; ?! {0 @0 @1 ]) f4 p) f
CAD.LoadDVB .dvb工程路径" d/ |- X4 _) R1 u2 f7 |

复制代码

如果一定要使用 Shell() 函数，则代码可以写成下面的形式

1 g9 }2 |8 v, V9 Y& f" k2 J
Shell acad.exe文件路径、参数和DWG文件路径( U! n% p6 u/ ^1 p4 i+ W- |5 w3 X) {
Dim CAD As AcadApplication
; |) k" o3 Z% w2 Y' X" U/ [
On Error Resume Next' R, E I% t7 _* v1 y2 \# L5 o3 U9 P: d
Do
! f4 e {+ @1 l3 q+ n
Err.Clear Y1 m) }( L. l
Set CAD = GetObject(, "AutoCAD.Application")0 P# G4 f' F7 }, |: e8 y
DoEvents& @4 H2 P4 P8 L& N+ P0 E: [
Loop While Err& F- q" R2 N; [8 Y+ d6 F2 T( u& i3 r
CAD.LoadDVB .dvb工程路径
/ X3 i7 T5 @7 K, |

复制代码

由于 Shell() 函数并不能直接返回对打开的CAD程序的引用，还要用到 GetObject() 函数；而 Shell() 函数是以异步方式来执行其它程序的，也就是说，用 Shell() 启动的程序可能还没有完成执行过程，就已经执行到 Shell() 函数之后的语句，所以还要用循环语句反复检查确认CAD程序已经运行（如果CAD程序没有运行，GetObject() 函数会出错），才能继续执行下面 LoadDVB 这一行；如果在运行这段代码之前已经有CAD程序在运行，用 GetObject() 函数会返回运行对象表中的第一个CAD进程而不是 Shell() 函数启动的新的CAD进程，CAD变量会找错对象。。。综上所述，第二段代码与第一段代码相比有百害而无一利。

koutx · 发表于 2009-2-28 16:14:38

原帖由 woaishuijia 于 2009-2-28 14:41 发表 http://www.3dportal.cn/discuz/images/common/back.gif
3 f5 C& N2 |# X" uDim CAD As New AcadApplication
1 p9 `; Q) S2 Q1 B% y% m CAD.Visible = True& ?. a+ Y' W" ]& V
CAD.Documents.Open .dwg文件路径
3 ]0 S* N0 r: g; Y. u CAD.LoadDVB .dvb工程路径

非常非常感谢，不然我还只能采用版主13楼的代码调用AutoCAD后再打开dwg文件呢。只是有一点不明白：在第三句之后，用什么语句实现在加载dvb工程后，自动运行工程中的宏A呢（即不用手工在CAD中输入CADRun命令调出运行宏窗体再选择D:\CAD二次开发\Project.dvb!模块1.A后按运行）？我不知试了多少次都不能成功。希望在百忙中连同16楼中的难题给指导一下。

[ 本帖最后由 koutx 于 2009-2-28 16:25 编辑 ]

woaishuijia · 发表于 2009-3-1 20:29:31

运行宏的问题，再加上一行

" f9 U5 X) P, w$ ^$ j
CAD.RunMacro "D:\CAD二次开发\Project.dvb!模块1.A"7 ?3 r) K; x9 C1 o8 E

复制代码

代码中的字符串是从你帖子中复制过来的，也就是“宏”对话框中的“宏名称”字符串。

16楼的问题，实际上是一个如何制定规则的问题。从你的附图看到池子已不能像一楼的图那样单纯按尺寸分类，还要分析判断是A类池还是B类池，这首先需要在图上特定的位置加上适当的标记，然后再在代码中检查图形中的相应位置的标记结合矩形尺寸以区分池子的类型。我感觉，最方便的办法是在矩形内部加上单行文字，就像你的附图一样；在三楼代码的基础上做以下修改（红色部分是新增加或改动的）

Sub A()
'声明一个选择集及过滤器
Dim SS As AcadSelectionSet, FT(0) As Integer, FD(0) As Variant
'声明一个直线临时变量
'声明两个直线动态数组，分别用于存放水平直线和垂直直线
Dim L As AcadLine, L1() As AcadLine, L2() As AcadLine
'声明一个双精度变量，用于存放计算精度。精度的用途见后面输入框中的文字
Dim 精度 As Double
'声明循环变量
Dim I As Long, J As Long, K As Long
'声明四个变体变量，用于存放两相邻水平直线与两相邻垂直直线间的四个交点
'通过检查交点是否存在，鉴别该四条直线是否能围成矩形
Dim P1 As Variant, P2 As Variant, P3 As Variant, P4 As Variant
'声明两个动态数组，用于存放查询矩形规格数量的结果
Dim 矩形() As Double'放置长、宽、数量
Dim 分类() As String'放置分类(单行文字)字符串
'声明一个逻辑变量，用于条件判断
Dim B As Boolean

On Error Resume Next
With ThisDrawing
      '输入精度
      精度 = Val(InputBox("输入精度" & vbLf & "鉴别直线是否水平（垂直）时，如果直线与极轴的夹角（弧度）的绝对值小于该精度值，即认为该直线水平（垂直）" _
         & vbLf & "鉴别矩形大小是否一致时，如果被比较的矩形的长（宽）与原始矩形的（长）宽之差的绝对值小于该精度值，即认为两矩形一样大小", "AutoCAD", 0.00000001))
      '定义选择的对象为直线对象，创建选择集并由用户在屏幕上选择
      FT(0) = 0
      FD(0) = "line"
      Set SS = .SelectionSets.Add("SS" )
      SS.SelectOnScreen FT, FD
      '遍历选择集，鉴别其中的水平和垂直直线并分别存入动态数组
      For Each L In SS
         If L.Angle < 精度 Or L.Angle > .Utility.AngleToReal(180, acDegrees) * 2 - 精度 Or Abs(L.Angle - .Utility.AngleToReal(180, acDegrees)) < 精度 Then
            If UBound(L1) = -1 Then
                  ReDim L1(0)
            Else
                  ReDim Preserve L1(UBound(L1) + 1)
            End If
            Set L1(UBound(L1)) = L
         ElseIf Abs(L.Angle - .Utility.AngleToReal(90, acDegrees)) < 精度 Or Abs(L.Angle - .Utility.AngleToReal(270, acDegrees)) < 精度 Then
            If UBound(L2) = -1 Then
                  ReDim L2(0)
            Else
                  ReDim Preserve L2(UBound(L2) + 1)
            End If
            Set L2(UBound(L2)) = L
         End If
      Next
      '删除选择集
      SS.Delete
      '当水平直线和垂直直线数量均不小于2时，执行下面的代码，查询矩形规格和数量并保存
      If UBound(L1) < 1 Or UBound(L2) < 1 Then
      Else
         '水平直线数组中的直线，按起点纵坐标由小到大重新排序
         For I = 0 To UBound(L1) - 1
            For J = I + 1 To UBound(L1)
                  If L1(J).StartPoint(1) < L1(I).StartPoint(1) Then
                     Set L = L1(I)
                     Set L1(I) = L1(J)
                     Set L1(J) = L
                  End If
            Next
         Next
         '垂直直线数组中的直线，按起点横坐标由小到大重新排序
         For I = 0 To UBound(L2) - 1
            For J = I + 1 To UBound(L2)
                  If L2(J).StartPoint(0) < L2(I).StartPoint(0) Then
                     Set L = L2(I)
                     Set L2(I) = L2(J)
                     Set L2(J) = L
                  End If
            Next
         Next
         '为下一步选择单行文字定义选择集过滤器
         FT(0) = 0
         FD(0) = "text"
         '检查相邻直线是否相交围成矩形并做进一步处理
         For I = 0 To UBound(L1) - 1
            For J = 0 To UBound(L2) - 1
                  '获得相邻直线的交点
                  P1 = L1(I).IntersectWith(L2(J), acExtendNone)
                  P2 = L1(I).IntersectWith(L2(J + 1), acExtendNone)
                  P3 = L1(I + 1).IntersectWith(L2(J + 1), acExtendNone)
                  P4 = L1(I + 1).IntersectWith(L2(J), acExtendNone)
                  '当四个交点都存在时，执行下面的代码
                  If UBound(P1) = -1 Or UBound(P2) = -1 Or UBound(P3) = -1 Or UBound(P4) = -1 Then
                  Else
                     '新建选择集
                     Set SS = .SelectionSets.Add("SS" )
                     '在矩形范围内框选单行文字
                     SS.Select acSelectionSetWindow, P1, P3, FT, FD
                     If UBound(矩形, 2) < 0 Then '第一个矩形直接存入数组
                        ReDim 矩形(2, 0), 分类(0)
                        矩形(0, 0) = P2(0) - P1(0)
                        矩形(1, 0) = P3(1) - P2(1)
                        矩形(2, 0) = 1
                        分类(0) = SS(0).TextString
                     Else '其它矩形
                        '检查前面存入数组的矩形中是否有相同规格
                        '如果存在，则在数组中的数量上加1，并改写逻辑变量（标记）
                        B = False
                        For K = 0 To UBound(矩形, 2)
                              If Abs(矩形(0, K) - (P2(0) - P1(0))) < 精度 And Abs(矩形(1, K) - (P3(1) - P2(1))) < 精度 And 分类(K) = SS(0).TextString Then
                                 矩形(2, K) = 矩形(2, K) + 1
                                 B = True
                                 Exit For
                              End If
                        Next
                        '如果数组中没有相同规格的矩形，则重定义数组，并写入新的规格、数量为1
                        If Not (B) Then
                              ReDim Preserve 矩形(2, UBound(矩形, 2) + 1), 分类(UBound(分类) + 1)
                              矩形(0, UBound(矩形, 2)) = P2(0) - P1(0)
                              矩形(1, UBound(矩形, 2)) = P3(1) - P2(1)
                              矩形(2, UBound(矩形, 2)) = 1
                              分类(UBound(分类)) = SS(0).TextString
                        End If
                     End If
                     '删除选择集
                     SS.Delete
                  End If
            Next
         Next
         '如果存在矩形，把数组中的规格、数量写入Excel文档
         If UBound(矩形, 2) < 0 Then
         Else
            '声明并启动Excel程序
            '声明工作簿
            Dim E As New Excel.Application, Book As Workbook
            '创建工作簿
            Set Book = E.Workbooks.Add
            '写入字段名称
            Book.ActiveSheet.Cells(1, 1) = "分类"
            Book.ActiveSheet.Cells(1, 2) = "长"
            Book.ActiveSheet.Cells(1, 3) = "宽"
            Book.ActiveSheet.Cells(1, 4) = "块数"
            '写入矩形规格和数量
            For I = 0 To UBound(矩形, 2)
                  Book.ActiveSheet.Cells(I + 2, 1) = 分类(I)
                  For J = 0 To 2
                     Book.ActiveSheet.Cells(I + 2, J + 2) = 矩形(J, I)
                  Next
            Next
            '保存文档并退出Excel
            Book.SaveAs "c:\biao.xls"
            Book.Close
            E.Quit
         End If
      End If
End With
End Sub

koutx · 发表于 2009-3-1 23:35:07

谢谢版主的诲人不倦，实在佩服。我又得好好学习，摸索试验几天了。遗憾的是论坛等级限制不能给版主如此精品贴子加分。

)19*(

[ 本帖最后由 koutx 于 2009-3-2 08:55 编辑 ]

koutx · 发表于 2009-3-2 08:46:37

Dim CAD As New AcadApplication
CAD.Visible = True
CAD.Documents.Open "D:\CAD二次开发\例子.dwg"
CAD.LoadDVB "D:\CAD二次开发\Project.dvb"
CAD.RunMacro "D:\CAD二次开发\Project.dvb!模块1.A"

运行以上代码结果如下，不知错误原因，也无论如何解决不了，请版主费心再讲一下。谢谢

结果是可打开例子.dwg，但出现错误，错误类型及部位说明如下：
1、有第4句但无第5句时出现图1红箭头指向所示的错误；但也将Project.dvb工程装载上了
2、加上第5句时，1、中的错误照旧。并出现如图2所示错误，该句黄色显示；并且指向第2句时显示CAD.Visible=<远程服务器不存在或不可用>的提示

[ 本帖最后由 koutx 于 2009-3-2 08:50 编辑 ]

woaishuijia · 发表于 2009-3-2 12:21:14

第一个“错误”不是错误，是正常的。
第二个确实是错误，问题可能出在被运行的“宏”有错误，使得这一行没法完成了。
说来也巧，我刚才下载了你在5楼的DWG文件，用3楼的代码保存了DVB工程文件，在VB6.0中运行下列代码

7 ?3 g6 x, }) `+ {* |. v' |
Dim CAD As New AcadApplication
2 z" i1 @3 l0 ?9 D% S: v3 o
CAD.Visible = True. u) u& y& n& i$ { l
CAD.Documents.Open "C:\Documents and Settings\Owner\桌面\例子.dwg"
+ J% B5 l% f7 Q( r3 {! c* K# A, b+ [
CAD.LoadDVB "C:\Documents and Settings\Owner\桌面\Project1.dvb"6 N0 G* R% A2 c1 k& a
CAD.RunMacro "C:\Documents and Settings\Owner\桌面\Project1.dvb!模块1.A"
$ |; A5 A, W" `* L Z) @

复制代码

结果出现和你所说一样的错误，原因是我在保存Project1.dvb文件时忘记引用EXCEL对象。

:lol:

koutx · 发表于 2009-3-2 18:27:07

我是在AccessVBA中作的，也引用了Excel对象，不知错出在哪儿？

woaishuijia · 发表于 2009-3-3 06:35:58

能否把你的AccessVBA、AutoCADVBA、DWG文件都传上来？

koutx · 发表于 2009-3-3 12:18:30

出去刚回来上网看到了版主的贴子，现将我练习时的文件都打包传上来，请帮助指导。。（新的带分类的SUB A（）尚未来得及试学。）

例子.rar (34.77 KB, 下载次数: 6)

		自动登录	找回密码
密码			注册

通知

[已解决] CAD二次开发对二维图某些数据的统计(请我爱谁家版主再指导)

马上注册，结识高手，享用更多资源，轻松玩转三维网社区。

回复 5# koutx 的帖子

回复 8# koutx 的帖子

请求帮助

回复 15# koutx 的帖子

评分

评分

回复 18# koutx 的帖子

评分

回复 21# koutx 的帖子

回复 23# koutx 的帖子

浏览过的版块