分享学习AutoCAD编程之VBA笔记 (期初完结！)

kuangben8 · 发表于 2019-3-24 12:08:39

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

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

x

本帖最后由 kuangben8 于 2019-7-1 13:15 编辑

分享AutoCAD编程之VBA笔记

   本人是从Excel编程转到AutoCAD编程学习的，目的是想实现Excel与AutoCAD之间数据交互，实现自动绘图的功能！期望于解决平常工作中的繁琐绘图与反复修改的麻烦。

   作为AutoCAD编程完全小白的我，很庆幸自己在学习的过程中遇到了咱们论坛的版主woaishuijia老师的手把手式教学辅导！每次遇到不理解的问题都会去请教woaishuijia老师，而老师也总是会耐心的答疑、细心的解惑、不厌其烦的亲自写示例讲解，并且不断的扩展我的知识面！如果没有woaishuijia老师的热心帮助，那么我的学习之路将会漫长很多，甚至会严重打击我的学习热情和信心！

   所以在此我想对woaishuijia老师说一声：感谢！感谢您的热心帮助，感谢您细心、耐心的答疑解惑，感谢您循序渐进的扩展我的知识面！没有您，我就不可能在短时间内完成我的初期目标。

   取之于论坛，用之于论坛，在此也分享一下本人这段时间来的学习笔记，期望于给那些想学习CAD的VBA编程还没有门路的友人们一点绵薄之力。

   说明：以下分享的内容都是本人的学习笔记，在学习过程中是遇到一个问题解决一个问题，遇到一个知识点总结一个知识点。所以内容排版不一定最合理，错误也在所难免！若各位看官发现错误之处，还望指正！
以下是本次分享内容的目录：

一、AutoCAD编程与Excel编程的不同

1、编程环境不同带来的麻烦点击

2、学习中的参考资料

3、AutoCAD中程序的保存与修改点击

A、单次加载VBA宏的方法

B、自动加载工程代码方法

4、让AutoCAD界面显示单步运行的结果点击

二、初识AutoCAD编程对象与方法

1、直线命令(LINE) 点击

2、二维多段线命令(LightWeightPolyline) 点击

3、圆命令(Circle) 点击

A、根据圆心和半径画圆方法：AddCircle(圆心坐标,半径)

B、根据三点坐标画圆

C、根据两点直径画圆

4、圆弧命令(Arc) 点击

A、指定四个基本参数画弧

B、根据三点画弧

C、起点、端点、半径画弧点击

5、对象操作方法之偏移、镜像

A、Object.Offset方法点击

B、Object.Mirror方法点击

6、设置对象属性之颜色、线宽、线型、比例、图层

A、添加线型点击

B、设置对象属性之颜色点击

C、设置线宽和比例点击

D、添加图层点击

7、添加文字(AddMText) 点击

8、对象操作方法之复制、旋转、移动点击

A、Object.Copy方法

B、Object.Rotate方法

C、Object.Move方法

9、常用对象的常用方法、属性、事件

A、常用对象的方法列表点击

B、常用对象的事件列表

C、常用对象的属性列表

D、常用方法示例点击

E、常用属性示例点击

F、常用事件示例

10、辅助绘图方法

A、辅助三点画圆点击

B、辅助三点画弧点击

C、辅助两点半径画弧点击

11、对象操作方法之图案填充(AddHatch)

A、创建图案填充点击 创建图案填充的补充

B、图案填充的常用方法点击

C、图案填充的常用属性点击

12、很有用的Utility对象

A、Utility对象点击

B、. AngleFromXAxis方法点击

C、.AngleToReal方法

D、.AngleToString方法

E、.CreateTypedArray方法点击

F、.GetAngle方法

G、.GetCorner方法点击

H、.GetDistance方法

I、.GetEntity方法点击

J、.GetInput方法

K、.GetInteger方法点击

L、.GetKeyWord方法

M、.GetOrientation方法点击

N、.GetPoint方法

O、.GetReal方法点击

P、. GetRemoteFile方法

Q、.GetString方法

R、.GetSubEntity方法点击

S、.InitalizeUserInput方法

T、.IsRemoteFile方法

U、.IsURL方法点击

V、.LaunchBrowserDialog方法

W、.PolarPoint方法

X、.Prompt方法

Y、.PutRemoteFile方法

Z、.RealToString方法点击

AA、.SendModelessOperationEnded方法

AB、.SendModelessOperationStart方法

AC、.TranslateCoordinates方法

13、使用Utility对象手动辅助绘图示例点击

A、手动三点画弧

B、手动三点画圆

C、手动两点半径画弧

14、手动取点画图时添加提示线点击

A、手动画一条直线

B、手动画圆

15、样条曲线对象(SpLine) 点击

A、添加样条曲线方法(AddSpline)

B、样条曲线对象(SpLine)的常用方法及属性

C、画函数曲线点击

16、椭圆对象(Ellipse)

A、添加椭圆方法(AddEllipse) 点击

B、椭圆对象(Ellipse)的常用方法及属性点击

C、创建椭圆弧对象点击

三、实现Excel与AutoCAD之间数据交互

1、通过Excel编程调用指定AutoCAD文档自动画图点击

2、通过AutoCAD编程调用Excel数据自动绘图点击

& Z6 K% _- `/ }) D, ~
6 p1 D8 N1 x+ U- q8 x: e

kuangben8 · 发表于 2019-3-24 12:08:40

本帖最后由 woaishuijia 于 2019-3-30 04:48 编辑

1、编程环境不同带来的麻烦

自AutoCAD2010版本开始,VBA模块就已经不随软件自行安装,因此想在AutoCAD中编写VBA代码,首先需要下载(2016版本之后的网上很容易搜到)对应版本AutoCAD的VBA模块安装。

但是安装的VBA模块自带的帮助文件全是英文版本的！更可恨的是AutoCAD的VBA里没有像OFFICE那样的录制宏功能(What！！！)。

在对AutoCAD的VBA对象、属性、方法一无所知的情况下，我该怎么学习VBA呢？难道逼我退出吗？那我的理想怎么办(虽然不知道理想是什么)！！

方法总比困难多。。。。。。。。。。。。

2、学习中的参考资料

处于这个时代的最大好处是：当你决心去做成一件事的时候，你会发现早已有人做成了这件事，而且还免费的分享了一堆技术资料、示例、经验。。。。。。

什么？你问我在哪？

知道你的钥匙丢了去哪里找吗？百度啊！！

在此也分享一些本人学习的参考资料链接：(三维网的技术分享)。当然后续学习主要依靠自己摸索和请教老师！（论有个好老师的重要性！）

AutoCAD VBA二次开发初级教程

autocad二次开发(VBA)就这么简单

『AutoCAD二次开发问题解答和经验分享』

网络上免费分享的帖子、资料不计其数，初始时总像发现宝一样的疯狂下载到自己的电脑硬盘里，但是最后发现存储了很多！但是拥有的很少！因为人家的心不在你这里！

简述一下本人的学习观点：可以做疯狂的学习者，但不要做疯狂的下载者！勤动手、多总结！

另外在ExcelHome论坛里有一篇帖子非常好：相信、实践、理解！

写给初学者的随笔(完): 相信, 实践, 理解

kuangben8 · 发表于 2019-3-24 12:08:41

本帖最后由 woaishuijia 于 2019-3-30 04:57 编辑

3、AutoCAD中程序的保存与修改

通过观摩大神的技术分享并亲自动手试验一下，相信你对AutoCAD里VBA的的对象、方法、属性有了一点概念上的理解。

但是当你在AutoCAD的VBA里写完代码后满心欢喜的保存、关闭，以为下次打开后点击一下就自动运行了！哈哈哈，多刁！在打开的那一瞬间你是泪奔的！我写的代码哪里去了？？

这里要说的是AutoCAD的VBA代码保存方式和Excel很不同！不是有专门的对应格式文件，也不是直接存储在这个文档里！而是单独保存在一个叫“Project.dvb”的文件里(Project是文件名可以修改)，那是AutoCAD自己的工程代码类文件，需要额外加载。

以下内容原文链接地址：地址贴的第29楼层。

已知中心及其上三点，求作椭圆

A、单次加载VBA宏的方法

1、直接加载：

AutoCAD图形界面菜单：“工具”> “宏” > “加载工程”

或功能区：“管理” > “应用程序” > “加载工程”

或命令行：VBALOAD

在弹出的对话框中找到你的VBA工程库名.dvb文件，打开、加载。返回到VBE窗口就能看见代码了。

2、通过VBA管理器加载：

首先打开VBA管理器，方法是：

CAD图形界面菜单：“工具”> “宏” > “VBA管理器”

或功能区：“管理” > “应用程序” > “VBA管理器”

或命令行：VBAMAN

然后在弹出的“VBA管理器”上点击“加载”按钮。

同样在弹出的对话框中找到你的VBA工程库名.dvb文件，打开、加载。返回到VBE窗口就能看见代码了。

不过上述方法的缺点是每次重新打开AutoCAD时都需要这么操作一次，才能加载上你的工程代码。

3、卸载VBA宏的方法：

首先打开VBA管理器（方法同上），然后在列表框中选择要卸载的宏，点击“卸载”按钮

B、自动加载工程代码方法

想要AutoCAD文档打开可以自动加载工程代码大约有如下几种方法：

以下原文的地址链接：cad 自动加载vba程序

1、vba自己加载法：将你的vba工程文件改名为acad.dvb，放在cad的安装目录下，vba初始化后自动加载。

2、startup加载法：将你的vba文件放到cad的安装目下。cad安装目录下和suport目录下搜索acad.lsp文件，如果不存在，用windows记事本在安装目录下新建一个acad.lsp文件（如果已经存在，用记事本打开它），在该文件中添加如下内容：

(defunS::STARTUP()

(command"_VBALOAD" "myproj.dvb")

)

保存后退出，以后启动cad会自动加载，其中myproj.dvb是你的vba工程文件名。

以上是autodesk推荐的两种方法，其实还有第三种方法。

3、lisp加载法。用记事本打开support目录下的acad20xx.lsp，其中20xx与acad的版本对应（如acad2000对应acad2000.lsp,acad2012对应acad2012.lsp等等），在文件的最后添加如下语句：

(vl-vbaload"myproj.dvb")

同样，vba工程文件名。保存后退出，以后可自动加载了。

kuangben8 · 发表于 2019-3-24 12:08:42

本帖最后由 kuangben8 于 2019-3-25 20:45 编辑

4、让AutoCAD界面显示单步运行的结果

正常运行AutoCAD工程中的代码时,在CAD界面上看不见运行过程的,直到代码运行完后界面自动刷新，才会出现代码执行的结果。如果希望像Excel里那样单步执行可以看见过程，必须在程序中使用Update来刷新数据,但是刷新数据会耗费电脑内存资源，所以不是单步执行或者必须想看过程，不建议使用Update，因为必须每一步下面都要写上Update才能实现步步可见的效果。

Sub 刷新界面()' J0 q( n8 k' `( ~ w( U& ~9 r
Dim pt01(2) As Double, pt02(2) As Double,n% '定义两个点变量，再定义一个循环变量- p1 M7 m9 p, Q5 ?, i
Dim l As AcadLine, cir As AcadCircle '定义直线和圆变量，AcadLine是CAD中对象“直线”的类名，只有定义为指定的类名，CAD才知道你定义的这个变量是什么！
! X: W) P) q, }% c: }' ~. c
For n = 1 To 10 '给循环变量n指定循环次数，从1 到10，默认每次增加1，即1,2,3,4,5,6,7,8,9,10
5 r) F' V* _% ?; U( Q* ?9 |
pt01(0) = 10 * (n - 1) '通过2楼链接里的帖子，相信你已经知道接下来的6句是干什么了吧？
0 ^- r4 d0 ^8 U& q3 Q7 ~! k" [
pt01(1) = 10 * (n - 1)
! w' j$ |4 v7 c4 [
pt02(0) = pt01(0) + 50
: B- x; c. ?. k( A7 f4 [- e
pt02(1) = pt01(1) + 0
1 [- @) h4 ~2 D I+ @" S \1 Q
Set l =ThisDrawing.ModelSpace.AddLine(pt01, pt02)! |. e, O& v6 [, ^, M' D6 C/ C
Set cir =ThisDrawing.ModelSpace.AddCircle(pt01, 50)+ B* o8 y0 j2 S* Y. ]; z2 v( A
update '方法一、直接刷新' [: S* Z t; L
l.update '方法二、对象刷新 '可以指定任一对象刷新，效果都是屏幕刷新. o9 d4 x& s8 v+ N% R0 n ?
ThisDrawing.Application.update '方法三、使用当前画布对象刷新( J" e6 i2 n0 w) P+ @' `% K
Next" d6 H1 F5 X4 D$ A
End Sub

复制代码

1.4、刷新界面Update.zip (5.58 KB, 下载次数: 17)

kuangben8 · 发表于 2019-3-24 17:17:35

本帖最后由 kuangben8 于 2019-3-25 20:49 编辑

二、初识AutoCAD编程对象与方法

在你熟悉VBA编程的基本知识后,学习AutoCAD编程则要方便的多。虽然对象及其属性、方法不知道,也没办法录制宏!好在我们需要用到的对象也不用太多,先从直线、圆、圆弧、多段线等常用命令开始慢慢的积累。

1、直线命令(LINE)

在AutoCAD中画直线需要指定点的位置，CAD的模型空间相当于一个无限大的三维空间，因此绘制直线时指定的点的位置可以由三维坐标(x,y,z)来对应确定，如果只是在XY平面上画图，则Z坐标在赋值时可以省略(默认为0)，但是定义点的坐标数组时必须是3个元素。

画直线的方法：AddLine(起点坐标，终点坐标)。

Sub 画直线()
% Q8 x0 y' W r
Dim L01 As AcadLine '定义直线对象变量
% ~6 }5 c/ q( r' A! l6 b- |0 C
' Dim L02 As AcadLine. N/ D4 x7 p/ v
' Dim L03 As AcadLine
5 A# i, @ D' H% P
Dim P01(0 To 2) As Double '定义点数组变量，类型为双精度型(范围大，含小数)，数组元素下标为0、1、2
' T+ Y; C3 c+ t7 }9 [( c2 G
Dim P02(2) As Double '同上，单独一个数字表示数组元素下标的上限(最大值)，默认从0开始，所以是0、1、2' R1 z1 C+ T* L: L2 `- B
Dim P03(1 To 3) As Double '同上，数组下标的下限可以自由设定，一般从1开始，所以设为1、2、3
) w" g, r2 Q; ]$ ^
Dim P04(2 To 4) As Double '同上，数组元素下标也可以设置为2、3、42 O; ~# r. L- ? _3 Y% y- f
P01(0) = -500: P01(1) =0 '对点的坐标数组元素分别赋值，可省略 : P01(2) = 0,多行语句合在一行写时用:连接
6 c6 @) o7 J' u7 c3 r- R9 D! w6 B6 |
P02(0) = 500: P02(1) = 0：P02(2) = 0 '按照先后顺序，对应该点的X、Y、Z坐标值
. m4 r* T4 g: h' }, l" Z4 L
P03(1) = -600: P03(2) = 1000:P03(3) = 0- F* b6 }7 z b1 T& F7 P
P04(2) = 600: P04(3) =1000 'z坐标值省略，默认是0
& y2 h0 k& U7 [8 u! F7 @: r
With ThisDrawing.ModelSpace '在当前画布的模型空间里，with...end with语句简化代码的作用
; G. e" Q& V1 t& h3 R
Set L01 = .AddLine(P01, P02) '给对象赋值要用set，画直线的参数(起点坐标,终点坐标)要加括号/ b5 U% l3 E% G
Call .AddLine(P01, P03) '未定义对象时可以用call调用对应的过程或方法，参数也要加括号$ x# w% o2 C( R. x: L# P! I
.AddLine P02, P04 '也可以直接画，但此时画直线的参数不能加括号3 T% b9 B) ?9 }
End With+ X+ L) p- A/ ~: N6 y \
End Sub

复制代码

2.1、画直线.zip (4.65 KB, 下载次数: 17)

kuangben8 · 发表于 2019-3-25 20:55:42

本帖最后由 kuangben8 于 2019-3-25 20:58 编辑

2、二维多段线命令(LightWeightPolyline)

AutoCAD中多段线的作用是可以将多条线段、圆弧等对象连成一个整体，当然还有很多后续操作的方便之处(例如整体偏移等)。

二维多段线在定义点的坐标时默认Z坐标为0(省略)，多段线的连续点的坐标组成一个数组。数组中每两个元素值作为一个点的X、Y坐标值，所以二维多段线的点坐标数组的元素个数一定是偶数！画二维多段线方法：AddLightWeightPolyline(点坐标的数组集合)。

Sub 画多段线()& ^0 j( k: d# w
Dim pl As AcadLWPolyline '定义二维多段线对象变量$ g* X0 z- D& q4 _+ H
Dim pt1(1 To 8) As Double
& |. E* q+ g a; j7 `
Dim pt2(1 To 3) As Double, pt3(1 To 3) As Double '直线端点需要3个坐标，赋值时可以省略z坐标0
2 V# h5 H' H4 C: }0 C) n, \1 P
Dim pt4(1 To 3) As Double, pt5(1 To 3) As Double '直线端点需要3个坐标，赋值时可以省略z坐标0! {* k- z" c i0 O' l, X% N: G
Dim pt6(1 To 8) As Double, pt7(1 To 8) As Double
5 b3 i# f a6 O/ {
Dim n%, pts(1 To 10) As Double '画矩形
/ \1 C t5 L1 r/ P6 O
pt1(1) = -1600: pt1(2) = 3000 '每两个点作为一条二维多段线的一个端点坐标，默认z坐标为0省略。
9 t! ]- j( }4 }1 H; j4 Y
pt1(3) = -1400: pt1(4) = 0
}0 {0 H& P& @# t6 d* ^$ N
pt1(5) = 1400: pt1(6) = 0/ G7 z' E: G" {8 g
pt1(7) = 1600: pt1(8) = 3000
6 B& H1 D' L6 a( R3 X! ]
Set pl = ThisDrawing.ModelSpace.AddLightWeightPolyline(pt1) '第一种赋值语句5 p8 ?0 g, ?* c$ p% E# J- N2 r
pt2(1) = -1400.666667: pt2(2) = 10 |1 P% F4 m) O, A
pt3(1) = 1400.666667: pt3(2) = 105 m/ p, F/ M& z! j
ThisDrawing.ModelSpace.AddLine pt2, pt3
" |8 u3 q6 O& Q7 q5 ~4 D- R4 f( E
pt4(1) = -1410.666667: pt4(2) = 160
) F: h+ h& u" S! n, s
pt5(1) = 1410.666667: pt5(2) = 160* I5 ?$ U. [5 P9 }# \8 J; U
ThisDrawing.ModelSpace.AddLine pt4, pt5
' S! n# X! X# Q5 j! l+ _. @
pt6(1) = -1589.977802: pt6(2) = 3000 '每两个点作为一条二维多段线的一个端点坐标，默认z坐标为0省略。" z* N/ L- p; S# x
pt6(3) = -1400.644469: pt6(4) = 160
! Y8 Z. v0 e3 s# D( n$ S& C! `; j
pt6(5) = -1310.444691: pt6(6) = 160, i: n0 U- R( O& s0 i8 C
pt6(7) = -1499.778024: pt6(8) = 30004 R+ T9 I! c# F% t; d
Call ThisDrawing.ModelSpace.AddLightWeightPolyline(pt6) '第二种赋值语句6 M" {9 \2 d4 y5 V' ~
pt7(1) = 1589.977802: pt7(2) = 3000 '每两个点作为一条二维多段线的一个端点坐标，默认z坐标为0省略。
; M3 z* h5 V! C4 T9 o$ J
pt7(3) = 1400.644469: pt7(4) = 160
; m* z: [3 y/ _. y
pt7(5) = 1310.444691: pt7(6) = 160
/ P9 [- }! `, c
pt7(7) = 1499.778024: pt7(8) = 3000% A% j' f9 W5 T- {- }3 @
ThisDrawing.ModelSpace.AddLightWeightPolyline pt7 '第三种赋值语句% u( v6 `; {" r9 g# N* @8 w
For n = 1 To 28 '循环画矩形
& r5 ~' b) E- d
If n <= 12 Then '不同的n值对应的矩形不同，添加一个判断
* ]. k$ X! C7 Y( w8 T0 P1 b
pts(1) = -(n - 1) * 100 * 0.133333333333333 / 2 + pt6(5): pts(2) = (n - 1) * 100 + pt6(6)# v0 ]+ ~* Q/ J
pts(3) = pts(1) + 180: pts(4) = pts(2)3 g+ d$ k" M# `7 [3 k) r' H, C8 ?- C
pts(5) = pts(3): pts(6) = pts(4) + 100
4 c; k$ x' X6 K+ R9 |- R
pts(7) = pts(5) - 180: pts(8) = pts(6)7 m r$ Q' M+ p7 U6 A
pts(9) = pts(1): pts(10) = pts(2)9 B. G* e: L+ W9 P0 f& i; a" w
ElseIf n <= 20 Then+ j( r; D1 S$ P
pts(1) = -(n - 1) * 100 * 0.133333333333333 / 2 + pt6(5): pts(2) = (n - 1) * 100 + pt6(6), q! p4 y# ~& f9 s' I
pts(3) = pts(1) + 220: pts(4) = pts(2)
7 ]$ B! j, A. I7 K0 Y- U* v q9 H
pts(5) = pts(3): pts(6) = pts(4) + 100
3 u6 [6 k0 P0 Z$ f2 h8 n
pts(7) = pts(5) - 220: pts(8) = pts(6)) m6 v7 E* _! j
pts(9) = pts(1): pts(10) = pts(2)
9 I7 n# r# }; c1 c S
Else/ c/ d7 `( @$ z( q* l6 n- {
pts(1) = -(n - 1) * 100 * 0.133333333333333 / 2 + pt6(5): pts(2) = (n - 1) * 100 + pt6(6)5 | Y7 \3 P3 H4 S( M8 i7 F
pts(3) = pts(1) + 200: pts(4) = pts(2)
: c+ u/ ?) I( ^4 t' f# C6 |; D* a; c
pts(5) = pts(3): pts(6) = pts(4) + 100' h6 [/ ]5 F b! [/ q5 [8 }, O
pts(7) = pts(5) - 200: pts(8) = pts(6): L# A2 \4 h( g7 X" m! \
pts(9) = pts(1): pts(10) = pts(2)
" @0 w- Z% `2 a
End If! x( Y1 Y" j; z2 ]& }! d
ThisDrawing.ModelSpace.AddLightWeightPolyline pts '绘制二维多段线. F0 J( d9 ^$ V$ ~9 {. V! @
Next# e C& b7 V7 x+ J3 D1 m K
End Sub

复制代码

2.2、画多段线.zip (8.09 KB, 下载次数: 22)

kuangben8 · 发表于 2019-3-25 21:06:23

3、圆命令(Circle)

在AutoCAD中绘制圆时，需要指定圆的圆心坐标和半径，似乎只有这一种方法，想要通过其他方法画圆(如经过3点画圆)，需要根据3点求出圆心坐标和半径大小！

A、根据圆心和半径画圆方法：AddCircle(圆心坐标,半径)

Sub 同心圆() '画100个同心圆% D7 _& ?1 B$ }2 u! N9 Z
Dim cir As AcadCircle: c+ ^2 h* b/ o% n
Dim pot(2) As Double' p6 o; R. A; h3 w
Dim r As Double% c3 m2 O, H3 G. g- o3 u
Dim i6 G6 h$ V- t* [ G* j+ g% C( E1 s
pot(0) = 1006 l9 b$ x0 H7 E* a5 `
pot(1) = 100
! g- N/ U" ]8 S7 F9 L
pot(2) = 100 'Z坐标相当于将图形位置从XY平面平移到Z坐标所在位置。! G& R9 K7 B- G) A2 B
With ThisDrawing.ModelSpace9 P4 ?1 `8 O1 m' |
For i = 1 To 1000 Step 10
4 s5 \: l" `" j+ d4 ^0 _' E
r = i * 10
5 T9 B; |6 a- D! d m
Call .AddCircle(pot, r) '第一种赋值语句" _/ }6 P. p3 \- a2 [9 K7 u
Rem 上述语句中的call起到调用画圆的方法作用
5 v' v4 T3 G( n2 p. s, [
Rem 使用 Call 关键字来调用一个需要参数的过程，argumentlist 就必须要加上括号。 _
3 b6 X4 ]! B% J9 x8 k1 g3 E; Y
如果省略了 Call 关键字，那么也必须要省略 argumentlis 外面的括号0 x, f' k8 F7 @8 ?0 V$ y
' .AddCircle pot, r '不用call时则参数argumentlis 外面的括号不能要！第二种赋值语句
1 ~6 l/ V' w! k4 q- t( S5 [
' Set cir = .AddCircle(pot, r) '第三种赋值语句" A+ q, Q- Z' M2 ?0 N- {& K4 v
Next# o* L. M2 B4 y; i
Call MsgBox("100个同心圆已经绘制完毕！", vbOKOnly + vbInformation)
0 H+ G! K G* L4 C$ G
MsgBox "100个同心圆已经绘制完毕！", vbOKOnly + vbInformation
/ d6 o7 z4 {( e
End With
& B- N9 p4 Z9 b
End Sub

复制代码

B、根据三点坐标画圆

首先根据三点坐标计算出圆心坐标和半径大小,然后画圆，关于计算方法，根据几何图形知识换算即可。

Sub 三点画圆()
3 l2 O" ^* j- J' f1 M$ G; N" W7 L
Dim cir As AcadCircle
4 ], X. c0 Q7 X3 a7 u
Dim pt1(2) As Double, pt2(2) As Double, pt3(2) As Double
& [4 j& [$ F$ o
Dim A1#, B1#, C1#, A2#, B2#, C2# '定义中间变量为double类型，用于简化计算) K) L' d' z3 W% ~
Dim pt0(2) As Double, r# '定义圆心坐标(X,Y)和半径r
. t* E2 w! ]' J% F
pt1(0) = 120: pt1(1) = 105 '第一点坐标(X1,Y1)4 V9 g$ o. y) h
pt2(0) = 59: pt2(1) = 67 '第二点坐标(X2,Y2)
" r, q) l8 E+ K$ G! \
pt3(0) = 89: pt3(1) = 91 '第三点坐标(X3,Y3)
+ M. \$ H% H( ]& A' \; I0 ]6 @
A1 = 2 * (pt2(0) - pt1(0)) 'A1=2*(X2-X1)
$ t1 E2 Q2 W& ]0 z) R
B1 = 2 * (pt2(1) - pt1(1)) 'B1=2*(Y2-Y1)
! W8 F, l g+ `
C1 = pt2(0) ^ 2 - pt1(0) ^ 2 + pt2(1) ^ 2 - pt1(1) ^ 2 'C1=X2^2-X1^2+Y2^2-Y1^2* W5 i% [% {: q+ S
A2 = 2 * (pt3(0) - pt1(0)) 'A2=2*(X3-X1)
6 ?* \. t2 i( z9 A [8 e
B2 = 2 * (pt3(1) - pt1(1)) 'B2=2*(Y3-Y1)# L2 T4 a3 g' R' G
C2 = pt3(0) ^ 2 - pt1(0) ^ 2 + pt3(1) ^ 2 - pt1(1) ^ 2 'C2=X3^2-X1^2+Y3^2-Y1^2
8 g0 Z' {! Z6 x( ]9 U. z
pt0(0) = (B1 * C2 - B2 * C1) / (A2 * B1 - A1 * B2) 'X=(B1*C2-B2*C1)/(A2*B1-A1*B2)$ J9 g0 }7 Y6 m& J% k& F
pt0(1) = (A2 * C1 - A1 * C2) / (A2 * B1 - A1 * B2) 'Y=(A2*C1-A1*C2)/(A2*B1-A1*B2)
! W0 I6 ]$ v ^
r = ((pt0(0) - pt1(0)) ^ 2 + (pt0(1) - pt1(1)) ^ 2) ^ 0.5 'r=((X-X1)^2+(Y-Y1)^2)^0.5
0 I* h: c. D* d7 }0 K' ]
With ThisDrawing.ModelSpace. `: A7 p4 S5 O8 B2 f' H3 y
Set cir = .AddCircle(pt0, r)4 ~& ^$ a/ L& [2 {+ k& @5 s
Call .AddLine(pt1, pt2) '画这两条直线目的为了确认三点在圆上。! o" c$ q1 b( t# i K
.AddLine pt2, pt3
P9 f" `) @3 S
End With' M J0 }/ v) I6 F9 s: i( f$ g
ZoomAll '全部显示在窗口中7 W/ o6 F" T1 e, y9 c' e4 C
End Sub

复制代码

C、根据两点直径画圆

求出相应的圆心坐标和半径即可画圆

Sub 两点直径画圆()
$ v" U( |" t1 g8 e1 w4 g0 P' d' c$ s; E
Dim pt(3) As Double
, d8 M6 d% L6 i0 T
Dim pt0(2) As Double, R## \( ]4 X: s N9 }# [) }. O
pt(0) = 29: pt(1) = 35: pt(2) = 156: pt(3) = 286
8 j1 A D s" k3 K: F
pt0(0) = (pt(0) + pt(2)) / 2
# ^; n5 d/ b3 e/ l) j
pt0(1) = (pt(1) + pt(3)) / 23 B$ t, p+ I( r1 |, Q$ V
R = ((pt0(0) - pt(0)) ^ 2 + (pt0(1) - pt(1)) ^ 2) ^ 0.5" ^9 V$ n, `8 S
ThisDrawing.ModelSpace.AddCircle pt0, R
' M! W' s8 @! ^' M
End Sub

复制代码

2.3-画圆命令.zip (7.51 KB, 下载次数: 17)

kuangben8 · 发表于 2019-3-25 21:19:17

本帖最后由 kuangben8 于 2019-3-25 21:25 编辑

4、圆弧命令(Arc)

AutoCAD的VBA中添加圆弧的方法也很单一:需要指定圆心,半径,起始角,终止角四个参数.

A、指定四个基本参数画弧

方法: RetVal = Object.AddArc(Center, Radius, StartAngle, EndAngle)

Object：可以是模型空间、布局空间、块等对象,

Center：圆弧中心点坐标,3个元素组成的数组(double类型),其中Z坐标默认0可省略,

Radius：圆弧的半径,double类型，

StartAngle、EndAngle：double类型，用于输入定义圆弧的起始角和终止角(以弧度表示)大小。

起始角度和终止角度的确认：以圆心所在水平轴为X轴，圆心位置为坐标原点，以X轴正半轴为角度的起始边，逆时针旋转对应度数就是指定的起始角或终止角。所以AutoCAD中圆弧均是逆时针绘制。

弧的优劣：当起始角小于终止角时，角度差大于180°就是优弧，小于180°就是劣弧！当起始角大于终止角(可以为负角)时，圆弧依然是从起始角位置逆时针绘制到终止角位置！

RetVal：结果是新绘制的圆弧对象。

Sub 圆弧()
, x% F, H" R) U; Z- a3 J" I) K* ^2 w
Dim arc As AcadArc '定义圆弧对象' B& T: ? `+ @& J" C& @. L4 R# A
Dim pot(1 To 3) As Double '定义圆弧中心坐标点数组
7 g- e9 N1 g$ }1 G3 Y9 J4 D
Dim R As Double '定义半径( g8 Y4 M y9 j. `/ b; s
Dim stq As Double, edq As Double '定义起始角度,终止角度
2 \' N9 T) X9 U* q" E1 H7 N
Dim str As Double, edr As Double '定义起始弧度,终止弧度( _6 K" O( e5 @" ^0 x8 l
Const pi = 3.14159265358979 '定义π常量，只能保留15位有效数字+ n9 ?4 A, h% i/ l% c% W& K
Dim n%0 I, u4 O# s0 O0 Q
pot(1) = 0: pot(2) = 0: pot(3) = 0
* V- L% o8 D z) q
For n = 1 To 10( d$ J; @5 U+ w$ c0 B+ y
R = 39.5629 + (n - 1) * 106 g: B M/ }% }, `8 _
stq = 0 + (n - 1) * 10- ^' O/ K6 J S: `- }
edq = 60 + (n - 1) * 10+ f$ N: R8 {. c/ h% M
Rem 如下度数转换为弧度值
_2 X8 ^4 }! B: ?
str = stq * pi / 180
7 |' V& D, ?' ]" H: y# c* J
edr = edq * pi / 1800 o% Q" X$ K& `; ~' [
Rem 接下来画圆弧4 g4 I" C3 \; G
Set arc = ThisDrawing.ModelSpace.AddArc(pot, R, str, edr) '画的是逆时针圆弧
Update; ?2 y' `( i( l5 g
Set arc = ThisDrawing.ModelSpace.AddArc(pot, R, edr, str) '画的还是逆时针圆弧+ k5 W* m; V* j, _+ `
Update
R7 u3 U, o% [! M/ K0 b5 u; n
Next
9 K0 H0 l7 |9 g& D$ U8 M: p: J
For n = 1 To 10) \$ K7 {) u! A& g3 {4 Y
pot(1) = 200: pot(2) = 200
6 g: ~3 S3 p/ y( r& s/ U% S
R = 100 + (n - 1) * 10
! l1 Q8 S5 O+ [$ `5 z# t8 o6 ?
str = (0 + (n - 1) * 10) * pi / 180( o' [5 u0 M: Q5 J1 ^2 ^7 |
edr = (-60 - (n - 1) * 10) * pi / 180. q4 k3 M7 z+ s5 a
ThisDrawing.ModelSpace.AddArc pot, R, str, edr '画的还是逆时针圆弧
+ Y* F0 }. J: _# q, o! [( h
Update* x0 S& z0 b$ t4 k6 T
Next4 H! U# ~( z$ m/ N( j
End Sub

复制代码

B、根据三点画弧

首先需要根据三点坐标换算出圆心坐标,半径大小,起始角度,终止角度.然后使用A方法画圆弧即可.

Sub 三点画弧()" Y& n1 r7 o3 z2 n* X# B3 P T
Dim ARC As AcadArc* P+ t! D- S0 k8 R$ ^
Dim pt1(2) As Double, pt2(2) As Double, pt3(2) As Double
9 _8 C+ c- X( x0 e8 a- N
Dim A1#, B1#, C1#, A2#, B2#, C2# '定义中间变量为double类型，用于简化计算
, y5 E0 E% Y0 a0 s$ i: K
Dim pt0(2) As Double, r# '定义圆心坐标(X,Y)和半径r
% B: B8 O/ a0 |$ O* g
Dim fst As Double, enr As Double '定义起始角和终止角
- `! P+ o7 ^( k, n1 O# G3 A) ^" I1 W) A
Const pi As Double = 3.14159265358979 '定义π常量
- l8 f- l/ G5 M. |2 d! a
pt1(0) = 120: pt1(1) = 105 '第一点坐标(X1,Y1)，作为圆弧的起始角点" w* i, }- G( H- E
pt2(0) = 59: pt2(1) = 67 '第二点坐标(X2,Y2)，作为圆弧的终止角点! y- L+ p5 {1 m; |' p& [) m
pt3(0) = 89: pt3(1) = 91 '第三点坐标(X3,Y3)" ]3 B' v/ b, F2 x8 }, [- M
A1 = 2 * (pt2(0) - pt1(0)) 'A1=2*(X2-X1): T, U- J( u/ Q* ]) B8 P. o+ z" ~7 J
B1 = 2 * (pt2(1) - pt1(1)) 'B1=2*(Y2-Y1)5 g, h, q: }8 u. e1 E+ i' p+ r! w
C1 = pt2(0) ^ 2 - pt1(0) ^ 2 + pt2(1) ^ 2 - pt1(1) ^ 2 'C1=X2^2-X1^2+Y2^2-Y1^2( }0 P( }% Y, q# ^
A2 = 2 * (pt3(0) - pt1(0)) 'A2=2*(X3-X1)
* _! P8 j5 P$ T, h
B2 = 2 * (pt3(1) - pt1(1)) 'B2=2*(Y3-Y1)
" N6 ?3 t! k* z
C2 = pt3(0) ^ 2 - pt1(0) ^ 2 + pt3(1) ^ 2 - pt1(1) ^ 2 'C2=X3^2-X1^2+Y3^2-Y1^2
2 A& l; K. i8 E! d) R
pt0(0) = (B1 * C2 - B2 * C1) / (A2 * B1 - A1 * B2) 'X=(B1*C2-B2*C1)/(A2*B1-A1*B2)0 m: N7 D( I9 Q
pt0(1) = (A2 * C1 - A1 * C2) / (A2 * B1 - A1 * B2) 'Y=(A2*C1-A1*C2)/(A2*B1-A1*B2)
" z1 y: m+ f2 ^. B1 O+ O/ w
r = ((pt0(0) - pt1(0)) ^ 2 + (pt0(1) - pt1(1)) ^ 2) ^ 0.5 'r=((X-X1)^2+(Y-Y1)^2)^0.5
, n, }: S; O) r0 D" `3 u+ h3 u
fst = pi + Atn((pt1(1) - pt0(1)) / (pt1(0) - pt0(0))) 'VBA中只有反正切函数，没有反正弦和反余弦函数) d$ R! H3 g3 \5 t; ~! n
enr = pi + Atn((pt2(1) - pt0(1)) / (pt2(0) - pt0(0))) 'Atn((Y3-Y0)/(X3-X0))结果就是终止角的弧度值
7 ~4 h, T* _8 r" R6 B4 Z
Rem 因为圆心在指定的三点的右下方，所以起始角和终止角均为负值，实际画圆弧的起始角和终止角均要加180°4 K7 s; ^2 y# f
With ThisDrawing.ModelSpace4 i0 q0 J1 V& J, l7 h! a
.AddArc pt0, r, fst, enr '添加圆弧
9 v2 v% v3 {* h5 A1 g
.AddLine pt1, pt2 '画直线为了查看点在哪里
+ o4 r5 H! Z# w; k S4 ^
.AddLine pt2, pt3
9 Q# U1 f7 U! O8 F5 X
End With& _( F; R8 G! b8 I' `0 R3 e* y
End Sub

复制代码

关于起始角和终止角的判定:首先VBA中只有反正切函数,没有反正弦、反余弦函数,所以只能借助反正切函数求角度,自然就会出现90°/270°不能根据反正切求出的破绽。

所以需要事先判断起始角和终止角是否为90°/270°,方法是圆心横坐标和起点或终点的横坐标是否相同,圆心纵坐标与起点或终点纵坐标谁大?前者相同时,圆心纵坐标小则为90°,圆心纵坐标大则为270°;不同就不是90°/270°。

另外就是根据反正切求出的角度有时需要加π,根据几何图形可知:起点坐标相对于圆心坐标在第一象限或者第四象限时直接使用反正切的结果;相对在第二象限或第三象限时使用π+反正切。

直接判断横坐标:起点或终点横坐标大于圆心横坐标,则在第一或第四象限;起点或终点横坐标小于圆心横坐标,则在第二或第三象限。

所以修改后的代码如下:

Sub 三点画弧()
: e1 L( Y) ]/ x
Dim ARC As AcadArc
7 l8 T. h2 n9 H) d' B
Dim pt1(2) As Double, pt2(2) As Double, pt3(2) As Double
* R0 S; ^ j* C: Q. @ }: I$ H
Dim A1#, B1#, C1#, A2#, B2#, C2# '定义中间变量为double类型，用于简化计算
( c8 t3 r, j8 |7 A# \
Dim pt0(2) As Double, R# '定义圆心坐标(X,Y)和半径r: d% A$ a: o/ f8 ~2 f" F
Dim fst As Double, enr As Double '定义起始角和终止角6 k) f% Y) X1 s3 n) C/ [( b
Const pi As Double = 3.14159265358979 '定义π常量
9 o& R- v$ J# o* ?+ [$ j8 ~6 B
pt1(0) = 120: pt1(1) = 105 '第一点坐标(X1,Y1)，作为圆弧的起始角点/ s7 B" d! L: d* |. F& G
pt2(0) = 59: pt2(1) = 67 '第二点坐标(X2,Y2)，作为圆弧的终止角点
6 Q4 C' R( T9 o. g3 a
pt3(0) = 89: pt3(1) = 91 '第三点坐标(X3,Y3)$ M* s' `1 y4 k2 @
A1 = 2 * (pt2(0) - pt1(0)) 'A1=2*(X2-X1): A# @0 R$ W* d- b0 o7 v
B1 = 2 * (pt2(1) - pt1(1)) 'B1=2*(Y2-Y1)2 ^: E e: J9 @. T, l
C1 = pt2(0) ^ 2 - pt1(0) ^ 2 + pt2(1) ^ 2 - pt1(1) ^ 2 'C1=X2^2-X1^2+Y2^2-Y1^2! O4 B6 Q/ s# l. M0 y$ s0 V
A2 = 2 * (pt3(0) - pt1(0)) 'A2=2*(X3-X1)
! ^; r9 Z1 c# f" z2 e* p" y
B2 = 2 * (pt3(1) - pt1(1)) 'B2=2*(Y3-Y1)( V* v$ L1 A7 L0 n. M& M
C2 = pt3(0) ^ 2 - pt1(0) ^ 2 + pt3(1) ^ 2 - pt1(1) ^ 2 'C2=X3^2-X1^2+Y3^2-Y1^2
2 H, w/ d2 o( [) \# i3 A
pt0(0) = (B1 * C2 - B2 * C1) / (A2 * B1 - A1 * B2) 'X=(B1*C2-B2*C1)/(A2*B1-A1*B2)6 S6 O- r5 H2 W7 c1 [
pt0(1) = (A2 * C1 - A1 * C2) / (A2 * B1 - A1 * B2) 'Y=(A2*C1-A1*C2)/(A2*B1-A1*B2)1 ~" b4 A- ~* V- I" I3 h
R = ((pt0(0) - pt1(0)) ^ 2 + (pt0(1) - pt1(1)) ^ 2) ^ 0.5 'r=((X-X1)^2+(Y-Y1)^2)^0.50 s! y. w, x- P# E1 @; N% {- M& D
If pt1(0) > pt0(0) Then
- |' a8 C4 L4 Y3 p
fst = Atn((pt1(1) - pt0(1)) / (pt1(0) - pt0(0)))) l" X& R6 i/ W8 {" G
ElseIf pt1(0) < pt0(0) Then! X# e$ i8 Y5 F4 J
fst = pi + Atn((pt1(1) - pt0(1)) / (pt1(0) - pt0(0))) 'VBA中只有反正切函数，没有反正弦和反余弦函数( Y0 Z+ ]0 {* Z/ W7 P5 e
Else
0 k/ t3 O+ e. K9 I9 n% `
If pt1(1) > pt0(1) Then0 J: S" p0 ?; z9 M* E3 A
fst = pi / 2 }" Q" B7 Q1 w# A; k
Else2 D, i* W6 N. y& z
fst = 3 * pi / 2) `: }, E% w4 j: ?
End If
! i+ f: L8 a# j1 f* P* L2 N
End If- w+ e* {3 E- G* d# k
If pt2(0) > pt0(0) Then! }: A h& e+ H0 c3 a
enr = Atn((pt2(1) - pt0(1)) / (pt2(0) - pt0(0)))
) a) [/ z! G& M
ElseIf pt2(0) < pt0(0) Then. F8 _2 C/ I8 \2 H1 e
enr = pi + Atn((pt2(1) - pt0(1)) / (pt2(0) - pt0(0))) 'Atn((Y3-Y0)/(X3-X0))结果就是终止角的弧度值
) V* W" N1 n* }: O: K2 P
Else
+ N4 `! e/ g, p6 Y
If pt2(1) > pt0(1) Then
e: _* M. Z2 r/ h9 R+ ]( k
enr = pi / 2
s* Z0 s& d% u* T, \: W' l6 i
Else8 S5 v- f5 R! c$ u# E
enr = 3 * pi / 2
, c! W, \7 R) D/ R2 n
End If- A! T# a, h# ?4 w9 P+ K8 x; f
End If$ N4 P! v* C, e R- ?7 y$ C! d; _
With ThisDrawing.ModelSpace& x/ a: G4 R! z
.AddArc pt0, R, fst, enr '添加圆弧
' ]1 i( p0 l7 z
.AddLine pt1, pt2 '画直线为了查看点在哪里
0 d( K" h: s$ M" h, ], g$ |
.AddLine pt2, pt3
. H* _! W2 T3 o* A+ k; P( [9 s& C0 H
End With
\+ [% l4 S, R& L% p
End Sub

复制代码

kuangben8 · 发表于 2019-3-25 21:23:31

C、起点、端点、半径画弧

根据起点和端点及半径计算出圆心坐标,进而计算出起始角和终止角

已知：点A(X1,Y1)、点B(X2,Y2)、半径R，求圆心坐标O(X0,Y0)

理论计算如下: 当AB>2R时无解；AB=2R时有1解，圆心在AB中点处；AB<2R时有2解。

\& |3 Q" l* Z0 G* L+ \

7 f; X2 ^8 O D+ u

Sub 起端半径画弧()/ d k3 o9 {) V4 B) \& r
Rem 根据理论计算方法画弧,假设AB和OM斜率均存在的情况下。
: Z, r7 A/ X% e/ w
Dim pt1(2) As Double, pt2(2) As Double, R As Double '定义已知条件：起点A、端点B、半径R- v5 I% ]1 B! `5 I2 C/ v- g* X M
Dim pt3(2) As Double, pt01(2) As Double, pt02(2) As Double '定义辅助点(AB中点M)、圆心点O(有2个圆心)5 [" U: c- |/ k9 N7 p
Dim KAB As Double, KOM As Double '定义直线AB斜率KAB、直线OM斜率KOM" f/ x* t( m8 @! B/ @
Dim BM As Double '定义BM长度
5 N) z# f5 v9 G3 X/ T5 c& h
Dim QSJ As Double, ZZJ As Double '定义起始角，终止角
1 x2 Z( p" i6 M4 t8 i) j" N" h
Const pi As Double = 3.14159265358979 '定义常量π
$ j* T% C% q) L5 w
pt1(0) = 32.59: pt1(1) = 36.98 '已知点A坐标
" g: C( \8 K* _) v& g- d4 I
pt2(0) = 69.87: pt2(1) = 70.59 '已知点B坐标
" s! ?& m# r- P* J2 e+ I
ThisDrawing.ModelSpace.AddLine pt1, pt2 '画线段AB
8 P" [8 b$ ]! s/ e" f7 \- @
Update
; W: y5 R1 x7 h
R = 100 '已知条件R, e8 f9 ~ a) D1 X7 R9 M
pt3(0) = (pt1(0) + pt2(0)) / 2: pt3(1) = (pt1(1) + pt2(1)) / 2 '求出中点M坐标5 {! [8 s9 Y [2 I
BM = Sqr((pt2(1) - pt3(1)) ^ 2 + (pt2(0) - pt3(0)) ^ 2) '计算BM长度
+ e: [5 u- K+ A- V/ w1 L$ ?
KAB = (pt2(1) - pt1(1)) / (pt2(0) - pt1(0))! C6 ?' \1 [8 j8 E/ p* y
KOM = -1 / KAB
& V. O' K$ x2 ]* l* ^3 M# Z5 J) y
pt01(0) = pt3(0) + Sqr((R ^ 2 - BM ^ 2) / (KOM ^ 2 + 1)) '第一组圆心坐标X0
& d/ g/ s8 [3 m4 ^/ c" @. v: K6 M1 P: [
pt01(1) = pt3(1) + KOM * Sqr((R ^ 2 - BM ^ 2) / (KOM ^ 2 + 1)) '第一组圆心坐标Y06 Y! O# s; t) J6 u
pt02(0) = pt3(0) - Sqr((R ^ 2 - BM ^ 2) / (KOM ^ 2 + 1)) '第二组圆心坐标X0; C C. y& j F$ v1 d- ^- [ o
pt02(1) = pt3(1) - KOM * Sqr((R ^ 2 - BM ^ 2) / (KOM ^ 2 + 1)) '第二组圆心坐标Y0
+ A7 D) I; m X- ~% [: A
Rem 计算起始角和终止角时需根据点坐标关系判断谁是起点和终点，以及想画的是优弧还是劣弧" m; O+ _% X8 b. f( j& |' v4 U# p
If pt2(0) > pt01(0) Then
' | X" R" ? n8 ]# e- _# S7 x
QSJ = Atn((pt2(1) - pt01(1)) / (pt2(0) - pt01(0)))/ h2 R" U+ [/ l4 W9 B
ElseIf pt2(0) < pt01(0) Then
8 v( h5 _- O- t' |# C8 {$ `* W; r- U
QSJ = pi + Atn((pt2(1) - pt01(1)) / (pt2(0) - pt01(0)))5 d* P% X, ^0 u& H& M& D
Else, G5 P' T# E! r1 f4 [ t
If pt2(1) > pt01(1) Then0 z, _" t- I% s2 s; Q6 L
QSJ = pi / 2
1 o0 ~1 E: P9 r! V: D
Else
5 y8 z, B3 {! s F
QSJ = 3 * pi / 2 Y6 S# Z6 H& S; {
End If7 V& U( h/ p! u! f! t. D: h9 ^
End If# f2 ? V7 N% z' j* ]
If pt1(0) > pt01(0) Then
( d* W9 L" D) ~3 w. G
ZZJ = Atn((pt1(1) - pt01(1)) / (pt1(0) - pt01(0)))) ^6 S' [' @% o7 H( x! z
ElseIf pt1(0) < pt01(0) Then6 G& L' x1 z+ K" b; |' V8 F) O4 \* b; u
ZZJ = pi + Atn((pt1(1) - pt01(1)) / (pt1(0) - pt01(0)))4 Z; F0 V! y" Z6 ]6 N% `
Else
7 q- W x; x! d; {$ e( I+ s
If pt1(1) > pt01(1) Then# A: F2 P. l9 |( N x
ZZJ = pi / 2
& \5 Z2 a( U2 I0 E/ S i: D' Q. R8 r
Else# a1 X# ?, H% y
ZZJ = 3 * pi / 21 m& {% y* G1 R; @% U+ _* g ?
End If6 S# W: t) ^" |* E
End If* U) _/ s9 s* \# O$ v$ [9 Z. y
ThisDrawing.ModelSpace.AddArc pt01, R, QSJ, ZZJ6 N; S; q0 ~( p9 B
Update
1 @8 d/ o" O3 I5 h: L: Z
If pt1(0) > pt02(0) Then# ], ?0 ~! A# v2 d: k( ?5 W
QSJ = Atn((pt1(1) - pt02(1)) / (pt1(0) - pt02(0)))9 ^! A3 M& i: B2 N- c7 T) l4 L7 `
ElseIf pt1(0) < pt02(0) Then1 G5 A: G! l$ |, I* d# [1 v1 O$ W
QSJ = pi + Atn((pt1(1) - pt02(1)) / (pt1(0) - pt02(0)))6 Q4 f5 T7 E9 y) w* N0 w9 v6 O
Else
5 t! ~2 @3 Z, K: k+ a7 [
If pt1(1) > pt02(1) Then) A, D3 |. R& e3 X' V. _4 I
QSJ = pi / 20 c# E5 q1 B' V# a
Else/ e I/ d8 }6 X T. W1 Q# g( z
QSJ = 3 * pi / 2* O" M$ g9 K. L
End If
+ r+ T! O& V; u, T- T- {' Z, @
End If
6 s" w6 F& \% A2 \' M' m2 o
If pt2(0) > pt02(0) Then7 R. k. Z- V$ g$ b
ZZJ = Atn((pt2(1) - pt02(1)) / (pt2(0) - pt02(0)))
+ P8 l( Z& p4 e. y) h
ElseIf pt2(0) < pt02(0) Then
/ m! l' s) K" m; U0 u$ n4 \
ZZJ = pi + Atn((pt2(1) - pt02(1)) / (pt2(0) - pt02(0)))
' N4 b% N( z7 Y5 m# ~& Y) ^
Else4 F( H/ H9 Y0 m; U& G9 y2 P& Y
If pt2(1) > pt02(1) Then
9 x e: q0 f, V) j+ G( _* z
ZZJ = pi / 2
6 v% |7 ~3 p0 v( [
Else& e+ a* ^) a" A5 C3 }
ZZJ = 3 * pi / 24 G: `$ W7 S) ^; L5 m; d
End If/ X* ]+ L+ ?8 I; ?3 J5 V$ ?
End If9 o$ j8 z2 O, P, L
QSJ = Atn((pt1(1) - pt02(1)) / (pt1(0) - pt02(0)))
Y. `9 O7 f2 _
ZZJ = Atn((pt2(1) - pt02(1)) / (pt2(0) - pt02(0)))- w4 b. H, x; X: P5 s
ThisDrawing.ModelSpace.AddArc pt02, R, QSJ, ZZJ '画劣弧$ x. y- K: t: P2 B9 Z
Update, p6 s! ]/ g) x( @
ThisDrawing.ModelSpace.AddArc pt02, R, ZZJ, QSJ '画优弧
' {6 B( J$ k( {7 C* E) N
Update V& U, V F1 X' k/ q8 u" U
End Sub

复制代码

2.4、圆弧命令.zip (11.43 KB, 下载次数: 21)

kuangben8 · 发表于 2019-3-25 21:32:37

5、对象操作方法之偏移、镜像$ N$ l0 R& o" \ l3 o

A、Object.Offset方法

在AutoCAD中，对象偏移的结果仍是对象，但是与Excel不同的是，在AutoCAD中对于很多对象，该操作的结果形成单一的新曲线（它的类型可能与原始曲线不同）。例如，椭圆偏移后的对象将会是样条曲线，这是因为结果不能与椭圆的方程式匹配。有时偏移结果可能形成多个曲线。

所以AutoCAD中偏移的结果是一个对象组成的数组。

基本语法：RetVal = object.Offset(Distance)

Object：可以是圆、圆弧、直线、多段线、样条曲线、构造线等对象。

Distance：是偏移的距离(double双精度型)，可以是正值或负值，但是不能为0。如果偏移为负值，这意味着将得到更“小”的曲线 (例如，一个圆以负值偏移后的得到的圆的半径将会比原对象半径小). 如果“小”没有意义，则AutoCAD将向小的X，Y，Z WCS坐标方向偏移。如果偏移距离无效，则返回错误。

[明经通道特别提示对于的LightweightPolyline 和 Polyline 对象，曲线有顺时针方向和逆时针方向，对于顺时针方向，距离值为正值时为向内偏移，距离值为负值时为向外偏移。对于逆时针时刚好相反。对于自相交的多段线的偏移方向需要自己慢慢实践了。

RetVal：返回偏移的结果，注意是一个对象数组，所以在赋值时不用set，并且对赋予的新变量后续操作时，需用索引号选取第几个对象，一般用(0)来选取第一个。

Sub 偏移()
6 |* E# V n# s' v! ~% S
Dim l As AcadLWPolyline( f/ e# |+ a+ N1 I' Y$ X L
Dim pot(5) As Double) H7 V) y# J6 r
Dim LL, l02 '直接定义为变体型类型，/ |3 L- p& s( F: h; w+ U
pot(0) = 50: pot(1) = 100
/ Y- D! |6 t% m
pot(2) = 300: pot(3) = 500
+ R. J+ G& I/ M9 }5 S, v$ [ Y- ]
pot(4) = 600: pot(5) = 190
$ ]# d- d, n9 O8 j$ `
Set l = ThisDrawing.ModelSpace.AddLightWeightPolyline(pot) '顺时针多段线& G' e/ k& z8 J' w7 D+ j3 a* T
LL = l.Offset(35.26) '正值向内偏移0 s$ L% i3 H& `4 F4 T) G9 f& O+ ^
LL(0).Lineweight = acLnWt050 '设置线宽为0.50mm,用索引号(0)选取第一个对象元素/ ]0 U# ~6 }' K. a/ [
l02 = l.Offset(-36.28) '负值向外偏移
H7 \& [( D3 z% }' w
'.....................................................................# O* A* l9 g! @
/ B R0 t+ T6 o' ]0 C3 V
Dim l1 As AcadLWPolyline
P1 {9 W6 U' L9 H8 H
Dim pot2(5) As Double" |( C$ N" y8 m$ A9 X& l- e9 D
Dim lll, lll02 '定义变体型
2 ^- Q" C4 z7 z6 V8 f
pot2(0) = 10: pot2(1) = 10
& t$ r0 L3 u( R' A' A' Q. p
pot2(2) = 100: pot2(3) = -300
_! m: z. [7 Y @& d
pot2(4) = 300: pot2(5) = 500
" h; W4 [5 ~9 f4 {# j
Set l1 = ThisDrawing.ModelSpace.AddLightWeightPolyline(pot2) '逆时针多段线
8 O+ r, {3 X- h* O
lll = l1.Offset(100) '正值向外偏移+ |) Y. `& l/ Y- {, f
lll(0).Lineweight = acLnWt050 '设置线宽为0.50mm
# M; H6 x& }+ c# g, j' X/ A, T) e
lll02 = l1.Offset(-100) '负值向内偏移，且结果变成一条线了！
4 M6 p; R+ c- t* O2 A( N0 l
l1.Offset 300 '直接偏移
+ @2 B ?" G6 f! p3 n4 H
End Sub

复制代码

通过以上程序感受一下对象偏移的结果及引用偏移的结果对象的方法。

kuangben8 · 发表于 2019-3-25 21:38:36

B、Object.Mirror方法

镜像方法相对简单，结果就是一个新的对象。

语法：RetVal =Object.Mirror(Point1, Point2)

Object可以是任何图形对象；

Point1, Point2是镜像对称轴上两点的坐标，均为double类型。

RetVal：是镜像后的对应对象

注意：可以使用 MIRRTEXT系统变量来管理文本对象的反向属性。MIRRTEXT 的缺省设置为开(1)，它使文本对象与其它对象一样镜像。当其设置为关(0)时，文本不被镜像———AddMText方法讲解。

如果是想同时镜像多个对象，可以先将多个对象建立成块，然后镜像块即可。

Sub 镜像()
$ w2 ]+ q- `8 t1 V b: C+ y7 g
Dim pl As AcadLWPolyline
; {# [0 H, U- ?9 p$ w r n
Dim pts(9) As Double
4 v: q0 D# F8 \3 E( Q
Dim pl2 As AcadLWPolyline
7 {0 q5 z! X: K
Dim pt01(2) As Double, pt02(2) As Double, pt03(2) As Double. t, m% b7 [3 Y! U
Dim rec As Object+ Q5 g& s5 R% ]+ p7 g2 q8 D
pts(0) = 0: pts(1) = 0
8 K- t7 \! b# G( u% S t1 C9 W
pts(2) = 100: pts(3) = 0
8 u2 | A5 @# O$ q
pts(4) = 100: pts(5) = 100
+ O2 n- s) A( [4 h+ V, }" s. m
pts(6) = 0: pts(7) = 100
- ~! R7 s" s( N/ n
pts(8) = 0: pts(9) = 0
) c* N4 F! B6 M9 |5 d
Set pl = ThisDrawing.ModelSpace.AddLightWeightPolyline(pts) '绘制多段线矩形
4 n4 `: Q/ v+ W ~% s4 |) v0 _3 L
pt01(0) = 0: pt01(1) = 150/ {$ J! X# Y/ Y' d5 {, M: v$ q
pt02(0) = 150: pt02(1) = 150
3 p1 T7 e! z8 g# y( e4 v% ?/ I
pt03(0) = 150: pt03(1) = 0, @$ W6 |. a9 Z: [5 \/ T
With ThisDrawing.ModelSpace
4 j/ H6 y. z" l
.AddLine pt01, pt02+ W8 i- C4 A& K& i; ~" e& s! ?
.AddLine pt02, pt03
, E: A' s+ T8 ?2 S2 B! A# a& l1 m1 o8 K
End With M# i3 Z) y" h% {- K
Set rec = pl.Mirror(pt01, pt02) '给矩形镜像并赋给新对象
3 e, g9 F$ b% u$ A: j j' E
pl.Mirror pt02, pt03 '直接镜像
- a" M% c6 Y* r( \
End Sub

复制代码

2.5、偏移、镜像.zip (4.58 KB, 下载次数: 13)

kuangben8 · 发表于 2019-3-25 21:48:57

本帖最后由 kuangben8 于 2019-3-25 22:04 编辑

6、设置对象属性之颜色、线宽、线型、比例、图层5 l: M Z( w" y+ K

A、添加线型

Sub 添加线型()4 d4 b! h, ?% A/ ~+ x+ P/ x) G- U7 j
' 该示例尝试从acad.lin文件中加载 "CENTER" 线型。如果该线型已经存在，则提示错误。" u. \+ ~. a" k3 n5 t* N
Dim L As AcadLine, P1(2) As Double, P2(2) As Double
6 f' K; V7 s" ?8 z% k8 I) W
' 从acad.lin文件中加载 "CENTER"线型
9 f2 Z) O/ H$ X6 Z% g# [
On Error Resume Next ' 下面添加线型语句在已经添加了线型时会出错！所以添加此句0 |8 l( E; v) a, l; f
ThisDrawing.Linetypes.Load "CENTER", "acad.lin" ‘加载线型$ t: J- w8 v' L" Z ^+ S5 ]( }& v c
On Error GoTo 0 '恢复错误提示
0 M& h2 P L2 m1 q# Y: |2 k
MsgBox Err.Number '弹出错误对应的数字代码,此处没啥用，就是看看错误对应的代码。
2 m# Q7 s3 j- k
Err.Clear '清除错误
z4 |2 r- E5 |, `
P1(0) = 0: P1(1) = 0- m8 h8 Y1 i# ~* T+ {
P2(0) = 100: P2(1) = 1002 B; a x% q1 H. M% Q5 L8 ^
Set L = ThisDrawing.ModelSpace.AddLine(P1, P2)
, F+ P# y+ w1 Q1 ~6 J5 r! b; }
L.Linetype = "CENTER" ‘设置对象的线型属性 [: m7 U9 e" R4 E0 C. M3 I6 L
End Sub

复制代码

B、设置对象属性之颜色

在AutoCAD中设置对象颜色有两种方法:Color属性(早起版本，后续会被淘汰)、AcadAcCmColor对象(AutoCAD真彩色对象)。

Sub 颜色属性()" w9 f# ?$ P* n% r3 s% o
Dim L As AcadLine, P1(2) As Double, P2(2) As Double
: S) t9 ^. z: [ Y7 A
' Dim CL As AcadAcCmColor. ]$ z7 T2 V. r6 z
On Error Resume Next
1 B- |0 s7 r2 B4 H
ThisDrawing.Linetypes.Load "DASHDOT", "acad.lin". ?- @+ _. I7 `
'先加载线型，如果已存在，会报错，所以添加上面容错语句4 ]- P& K/ J; I7 w
Rem dashdot是线型的名字,加载中心线就是CENTER，Acad.lin类似CAD存储线型的文件夹
1 T* a3 }) | _
On Error GoTo 08 I* i. y1 d" l
Err.Clear '清除错误！: E/ u, ^) w, H1 l
' Set CL = New AcadAcCmColor1 S X8 p. A. W+ N2 h' M/ q
' CL.ColorIndex = acRed
# _# r: t* _0 `& P z
P2(0) = 100: P2(1) = 100. ^1 r5 k3 l7 e/ ]- K
Set L = ThisDrawing.ModelSpace.AddLine(P1, P2)4 v& j2 L5 j7 k l. ]6 t
L.Linetype = "DASHDOT"+ M! m. R! q3 c+ i: ?% `0 p' E3 [" I
' L.TrueColor = CL
& c8 D y8 V! M$ \, b+ C- L
L.color = acCyan '藏青色1 y0 }) u2 n U1 b4 J5 S
' L.color = RGB(213, 222, 198) '使用RGB函数赋值颜色无效！# d% ~1 a' H" ]. t# H# X+ O
End Sub

复制代码

Sub 颜色对象()
. F/ H+ B- T4 `% V- `' v1 r4 ^8 U
Dim L As AcadLine, P1(2) As Double, P2(2) As Double
% q+ K8 e8 t6 c o5 b n
Dim CL As Object 'AcadAcCmColor 定义为对象或者制定的颜色对象均可。
! A9 R: y: z( ~4 C- z
Dim n8 s/ }3 ?, ^5 o8 D t& l: y* T, y
On Error Resume Next
4 C- `; o1 v0 _3 Q" [: V
'如果线型已加载，使用下面这行加载线型的语句就会引发错误。所以这行用错误处理语句跳过可能的错误，这样在重复使用这段程序时就不会带来不必要麻烦——不用先检查线型是否已加载
6 b- n' l: ]4 f: p
ThisDrawing.Linetypes.Load "DASHDOT", "acad.lin"
. |2 Q% {! j7 \$ w
On Error GoTo 0 '这行是恢复正常报错，以免后面调试时出了错不报0 D$ x2 Y3 z& O2 Z
Err.Clear '和上面这行一样用处，清除错误, R8 P1 T$ X9 q* a
' Set CL = New AcadAcCmColor
1 I: c5 P: l1 _$ A: |
Rem 上面语句相当于新建一个颜色对象，也可以使用AcadApplication.GetInterfaceObject("AutoCAD.AcCmColor.版本号")来创建颜色对象
- B- {* j3 n; e5 T. X
n = Application.Version '查看当前CAD版本号) `/ O# s! Q6 S' M e/ x
Set CL = GetInterfaceObject("AutoCAD.AcCmColor.19") '19就是上一句获得的结果
0 H3 h' R; W) j% u
CL.ColorIndex = acRed '可以使用颜色索引号索取颜色" o6 n, ?$ X' e
' CL.color = RGB(200, 215, 225) '同样不能使用RGB函数赋值颜色6 o7 [; f; q+ \$ m
Call CL.SetRGB(200, 215, 225) '也可以使用SetRGB方法指定对应颜色,不用call时，参数的括号不要写。
$ ` U5 y, @5 j+ d
P2(0) = 100: P2(1) = 100
9 H. j& k G3 g ^
Set L = ThisDrawing.ModelSpace.AddLine(P1, P2)
~1 l# E$ B4 t8 [" ^+ Q; t5 G
L.Linetype = "DASHDOT"
# w) ]- E j3 q5 J7 C# r0 Y7 X! t
L.TrueColor = CL4 l: _2 f7 Z- s' R2 o+ x
End Sub

复制代码

注意：AcadApplication对象的GetInterfaceObject 方法，是创建一个CAD程序的子对象，它在VBA中是没有加载的，用的时候新建就可以了。通过以上两例子来体会一下两种赋值颜色的语句的不同！

kuangben8 · 发表于 2019-3-25 21:51:49

C、设置线宽和比例

Sub 设置线宽和比例()
$ y( y: y1 _) |, G3 Z9 a
Dim L As AcadLine, P1(2) As Double, P2(2) As Double% q G+ p$ ]# ~, B2 c- G
Dim CL As AcadAcCmColor
& N z- w# W7 o. u5 V
On Error Resume Next
. w/ G' l8 N2 E2 z( U
ThisDrawing.Linetypes.Load "DASHDOT", "acad.lin"
& q* r0 N! j7 U+ P4 O
On Error GoTo 0 '这行是恢复正常报错，以免后面调试时出了错不报- O+ X% `' C9 b
Err.Clear '和上面这行一样用处，清除错误) Z3 k' f# W# }7 [* P) O6 |
Set CL = New AcadAcCmColor/ f$ b5 |$ v: F
CL.ColorIndex = acRed \5 f; K: J/ k# i: \; F* n
P2(0) = 100: P2(1) = 100; W" |) G$ i0 Z! \
Set L = ThisDrawing.ModelSpace.AddLine(P1, P2)1 d( _6 K, P2 J: s
L.Linetype = "DASHDOT"
7 w/ \* T; U) \
L.TrueColor = CL
5 x$ G4 y6 s" t8 y4 `7 W' o+ ]
L.Lineweight = acLnWt050 '050代表0.50mm 粗% g' ?- g8 r- d6 z; c$ M
L.LinetypeScale = 2.25 '指定线型的比例因子，该值必须正实数，默认1.0
3 J4 O( a9 _. P
End Sub

复制代码

对象的一些基本属性相对简单，不在赘述！

D、添加图层

Sub 添加图层()
, i: e1 J' d3 B7 k1 \, r
Dim layerObj As AcadLayer '定义图层对象变量/ V1 g, R5 b4 H/ [+ a
Set layerObj = ThisDrawing.Layers.Add("ABC") '创建新图层8 i% ]) Y8 o7 q) P1 U
Dim color As AcadAcCmColor '定义颜色对象变量( c8 E6 E: ?* t! M; p0 L
Set color = AcadApplication.GetInterfaceObject("AutoCAD.AcCmColor.19") '创建颜色对象) K0 A* [% v# p5 @! r' o
Call color.SetRGB(80, 100, 244) '设置颜色值(通过RGB值指定)4 @; y6 c. v a4 f! I% q6 W" G' g
layerObj.TrueColor = color '设置图层颜色
) N" @0 n- @, C0 f
On Error Resume Next) ^, u, l5 X2 e# W" x" a
ThisDrawing.Linetypes.Load "DIVIDE2", "acad.lin"& _& k7 x6 x: ^
On Error GoTo 0 '这行是恢复正常报错，以免后面调试时出了错不报" Z6 ?$ d9 x/ {5 b; w0 ?: }5 X
Err.Clear '和上面这行一样用处，清除错误
. s- b3 a& r- k# K' d6 b. ~
layerObj.Linetype = "DIVIDE2" '设置图层的线型" `+ k) G H$ M" i
layerObj.Lineweight = acLnWt040 '设置图层的线宽
% t8 z" q1 A/ n- f
' layerObj.LinetypeScale = 2.5 '不支持设置线型比例方法- o0 @" T6 j( J4 w0 Y: D) u5 m
Dim circleObj As AcadCircle '定义圆变量/ M& Y0 e8 X. D4 S0 g- @1 y, j) R
Dim center(0 To 2) As Double
: H- P$ \6 P. d7 w0 ]% h
Dim radius As Double& |$ L6 L5 M- U9 X, c, d
center(0) = 3: center(1) = 3: center(2) = 02 e v' ?2 q; k- F' y" ?3 W. f
radius = 1.5
+ P0 @$ d: F! d
Set circleObj = ThisDrawing.ModelSpace.AddCircle(center, radius) '画圆9 n6 v/ s0 o/ I" ^6 y
Update: d" ~. W# h) m4 v/ D2 w
MsgBox "已经在图层上创建了圆，对应图层是： " & circleObj.Layer, , "Layer 示例"- w' X/ F) l' q/ M: h
Update
; O* A4 K' w" N
circleObj.Layer = "ABC" '将圆所在图层设置为指定的图层1 F2 u6 H! y, i7 w
Update: I4 Z3 D: `2 A+ X, j; x9 o. i
ThisDrawing.Regen (True) '重生成整个图形并重计算所有对象的屏幕坐标和显示精度。2 R4 k0 y' g! v% I: C
MsgBox "现在圆已经在" & circleObj.Layer & "图层上了！", , "Layer 示例"
( r6 c7 O( o7 Q4 b: B; ~: R; s! F
End Sub

复制代码

2.6、线型、颜色、线宽、比例、图层.zip (10.02 KB, 下载次数: 21)

kuangben8 · 发表于 2019-3-27 20:45:31

7、添加文字(AddMText)

该方法是在由插入点和边框宽度所定义的矩形中创建多行文字。

语法：RetVal= object.AddMText(InsertionPoint, Width, Text)

Object：针对ModelSpace 集合,PaperSpace 集合, Block等对象。

InsertionPoint：Variant[变体] (三元素双精度数组); 仅用于输入多行文字边框的插入点。

Width：Double[双精度]; 仅用于输入多行文字边框的宽度(一行容纳字符数量的宽度)。

Text：String[字符串]; 仅用于输入MText 对象的实际文本字符串。

RetVal：结果就是一个多行文本对象。示例如下：

Sub Example_AddMtext()
8 |, |2 H8 r1 t. i
' 该示例在模型空间中创建多行文字对象。" S+ v) ^# m7 S8 b: c: Q
Dim MTextObj As AcadMText
* \' q) W l+ r3 M: W; ]7 C; t
Dim corner(0 To 2) As Double( p! P1 ?6 y" }" i# n: b" |
Dim width As Double
- O8 h5 ~8 h+ L$ f0 _* D+ |0 H
Dim text As String6 B, u1 m' z; q- s. k; [/ x
corner(0) = 0#: corner(1) = 10#: corner(2) = 0#* ~4 j D* c2 {
width = 20 '一行容纳文字数量的宽度7 y& r% M0 E7 S: a- j+ Q
text = "This is the text String for the mtext Object"% G& [5 s+ z" i: u, q+ E7 e( l( j
' 创建多行文字对象
9 N+ d$ B( a3 Y& v; S
Set MTextObj = ThisDrawing.ModelSpace.AddMText(corner, width, text)8 g; H% j5 x$ q2 w0 \, E/ |
ZoomAll# x) l f0 u! s3 ]( X3 p% w7 I& h% q
'.................................................................................................................
: P9 O7 x# r8 u! G
Dim pt1(2) As Double, pt2(2) As Double: c3 Z4 b- P- o; H) a% z, j
Dim str As String
/ t: W0 ]* m& G8 B G
str = "mirrtext 1 " '按照界面操作顺序输入
) m& D$ f! @ J* f9 w: r- S2 b3 m- C
ThisDrawing.SendCommand str '向命令行发送命令并自动执行* X+ {0 v6 Q0 r
pt1(0) = 30: pt1(1) = -10
6 N1 p0 z! U0 ]! B( u4 s: M3 |6 Y
pt2(0) = 30: pt2(1) = 305 G5 @. L7 r; M/ H
MTextObj.Mirror pt1, pt26 x7 y. e; r2 l) g+ \' W8 t3 }6 K
ThisDrawing.SendCommand "mirrtext 0 " '恢复文字不镜像,因为一般都不镜像1 N( _' { p( r/ F# _+ g
End Sub

复制代码

修改系统变量，除了类似界面操作外，在代码中改可以用 Document 对象的 SetVariable 方法。获取系统变量值用 GetVariable(有兴趣自己摸索一下：)。

想要创建单行文本,可以使用AddText方法。

RetVal = object.AddText(实际显示文字的字符串,文字插入点三维坐标, 文字的高度)

需注意文字的高度必须是正数!以mm为单位。

Sub AddText方法()9 {. q7 e m4 H2 d
Dim textObj As AcadText
4 E. u( u3 ]) g
Dim textString As String
) m& ~6 \% C' Y/ [: j. y2 q5 M
Dim insertionPoint(0 To 2) As Double* e% R8 _2 M- F7 ]
Dim height As Double8 p- e9 k% M; ?3 h% x
' 定义文字对象
9 c5 a8 e7 m3 f2 ?6 G
textString = "我的AutoCAD文字"2 j& S# w/ w0 F6 @* i- g
insertionPoint(0) = 2: insertionPoint(1) = 2: insertionPoint(2) = 0
4 x! M8 `" E8 i! h* K- z4 E
height = 2.5 ‘2.5mm高7 |1 j1 @. w" m' G( ]
' 在模型空间中创建文字对象, k0 ~& h0 U- [& W; J( m
Set textObj = ThisDrawing.ModelSpace.AddText(textString, insertionPoint, height)
2 ]9 c6 L1 U: X. x# D# l4 d
Update! G b5 d% }- g' x
'............................................................$ w! b- a, `9 o' |# t3 A$ `
Dim pt1(2) As Double, pt2(2) As Double, c1 z- g l1 T% L
Dim str As String
" r7 I* W9 [$ b5 u- a
str = "mirrtext 1 " '按照界面操作顺序输入
7 p+ O* `' i! g) I
ThisDrawing.SendCommand str '向命令行发送命令并自动执行, W. D; E9 H$ N5 W; ~
pt1(0) = 30: pt1(1) = -10' V# G/ w& S7 w5 q- _$ Q! I( Y
pt2(0) = 30: pt2(1) = 30
+ X' m+ ]1 ]+ Q( r. H/ X& b: o
textObj.Mirror pt1, pt2
) C# g, c Y* ~- q- t( o
ThisDrawing.SendCommand "mirrtext 0 " '恢复文字不镜像,一般都不镜像。
- }" K$ c: \8 T5 m5 _% J" t: ~
End Sub

复制代码

2.7、添加文字.zip (6.16 KB, 下载次数: 14)

kuangben8 · 发表于 2019-3-27 20:53:52

8、对象操作方法之复制、旋转、移动
3 Q9 E3 w3 g J: q
A、Object.Copy方法

在同一位置复制指定对象！

Sub 复制()4 H6 c0 w8 I$ E
Dim cir As AcadCircle, cirs As AcadCircle
! b9 o2 h; W* {8 S, |7 E
Dim pt(2) As Double, r As Double9 i5 C5 z6 b' Q0 c
pt(0) = 5: pt(1) = 10: r = 15! N, H# D3 s8 b( v* K
Set cir = ThisDrawing.ModelSpace.AddCircle(pt, r)" a) [& M5 i7 s3 i# l. q& p
Set cirs = cir.Copy '复制绘制的圆，但是复制的圆还在原地 a( z' z! I; K `, R
cirs.color = acBlue '设置复制的圆的颜色( q2 e: G5 z4 m$ F
End Sub

复制代码

B、Object.Rotate方法

语法：Object.Rotate BasePoint, RotationAngle

Object：使用该方法的所有图形对象

BasePoint：指定旋转中心点坐标(Double类型，3元素数组)

RotationAngle：Double类型，以弧度表示的用于旋转对象的角度。正值逆时针旋转、负值顺时针旋转。注意该方法仅是旋转对象，不能复制旋转！想要旋转时复制对象，可以先复制对象，然后在旋转。

需注意:旋转、移动等方法操作的就是原对象,不会产生新的对象,所以旋转、移动等操作的结果不能赋给新的对象变量! 如Set l01 =l1.Rotate(旋转中心,旋转角)会提示错误!!!

Sub 旋转对象()1 G2 C: ]- N0 C+ L5 u* | i# M
Dim plineObj As AcadLWPolyline2 K4 y! A2 F; n5 K8 n% ^* D
Dim points(0 To 11) As Double
4 m5 u& I0 e% d. M# s
points(0) = 1: points(1) = 2
9 L" r% S) V1 K; y# p$ d @
points(2) = 1: points(3) = 3) H' I+ C$ C# J% ?; w4 m' W
points(4) = 2: points(5) = 3
0 V% a) ?/ y+ V9 c9 o$ B" M" ]
points(6) = 3: points(7) = 3! r# l" d8 h/ P7 p9 _
points(8) = 4: points(9) = 4
7 D* O0 R" x! |4 \
points(10) = 4: points(11) = 2) P q+ L* I( [8 A
Set plineObj = ThisDrawing.ModelSpace.AddLightWeightPolyline(points)8 c3 I6 O) q( I) M8 r$ Q7 j1 K- i
plineObj.Closed = True 'true表示多段线或样条曲线为闭合的，False(默认)表示多段线或样条曲线为开放的.
( C Y7 O0 X8 r x# ^
zoomAll '全部显示
+ v" P# B. ^* \/ _# U
Dim basePoint(0 To 2) As Double '定义旋转中心; v) [' s j, d k# P# i' V
Dim rotationAngle As Double '定义旋转角( T. \0 o' Y! U$ f9 }5 J( m
basePoint(0) = 4: basePoint(1) = 4.25: basePoint(2) = 0
' Y m1 |* U$ X
rotationAngle = 0.7853981 ' 45°，转化为弧度,正值逆时针旋转% v. q( F2 f# F& D! m5 Z5 p9 m( `
plineObj.Rotate basePoint, rotationAngle& T M; t% e9 V) p/ E
Update
) a7 c7 F8 A8 x" x( x
rotationAngle = -0.7853981 ' -45°，转化为弧度负值顺时针旋转! }8 B, x+ F8 _5 m/ w; P/ A4 Y! U
plineObj.Rotate basePoint, rotationAngle
0 m/ I6 I% s# U
Update
5 t8 L8 `8 Z. Z! I
ZoomAll
, F0 Z' m8 o1 ?' _& b# V4 t
End Sub

复制代码

以上代码仅旋转对象,想要实现旋转复制，需要先复制对象，然后旋转。

Sub 旋转复制()
! V3 I8 ~9 w* ^; L( R
Dim plineObj As AcadLWPolyline
5 l8 O4 j/ d6 \7 |1 X5 ~6 i5 T3 m
Dim copypl As AcadLWPolyline
6 `5 |$ P R! H3 Z% j
Dim points(0 To 11) As Double; |) x6 Z' f' D( u
points(0) = 1: points(1) = 2* v) a8 o, m8 D( ~" l
points(2) = 1: points(3) = 3
$ r* g, j, u4 X: f4 e
points(4) = 2: points(5) = 3. F+ @+ p6 U: V0 z+ }; M% c2 x6 `% {) y
points(6) = 3: points(7) = 3" d) W+ s) V W& M/ W
points(8) = 4: points(9) = 4* O$ r5 V E$ \) ?/ @% Y
points(10) = 4: points(11) = 26 J, O( p% G8 l) O
Set plineObj = ThisDrawing.ModelSpace.AddLightWeightPolyline(points)7 o) ?# z9 R$ S2 F9 Z1 C- n3 r
plineObj.Closed = True 'true表示多段线或样条曲线为闭合的，False(默认)表示多段线或样条曲线为开放的.: g1 {4 L* a3 E2 F2 q0 n
ZoomAll '全部显示
9 x' B$ [/ A/ i* \
Dim basePoint(0 To 2) As Double '定义旋转中心* N) I4 b8 b; [; c6 x; b9 y/ j# L
Dim rotationAngle As Double '定义旋转角
+ x4 `; ~2 j1 j/ P4 u/ X; R% X
basePoint(0) = 4: basePoint(1) = 4.25: basePoint(2) = 0
4 Y5 `6 ^2 R# w* M
rotationAngle = 0.7853981 ' 45°，转化为弧度,正值逆时针旋转
. N4 |& f/ T; s
Set copypl = plineObj.Copy '复制多段线/ g* f9 X# W: c8 \: \/ b0 r
copypl.Rotate basePoint, rotationAngle '逆时针旋转复制的多段线2 c! C3 I; v7 t/ j
copypl.color = acBlue8 \6 v! Y: R) d+ Z6 \" X! q1 ]
Update
( E0 D7 m/ @( s, x+ H) b
rotationAngle = -0.7853981 ' -45°，转化为弧度负值顺时针旋转8 Q* P1 u) E. T5 `: e8 n) |5 k; e
Set copypl = plineObj.Copy '再次复制原多段线: A- J1 t. R% h7 B5 l
copypl.Rotate basePoint, rotationAngle '顺时针旋转复制的对象
- D0 K1 b: s3 S5 a" j
copypl.color = acGreen) y* X) j4 H! W) o( F
Update
7 e/ J' A4 T# [( P1 M5 k
ZoomAll
* i' U2 j: P8 M! W, C* E* [ S
End Sub

复制代码

以上代码是先复制对象，然后旋转复制的对象，实现了旋转复制。

C、Object.Move方法

语法：Object.Move Point1, Point2 将对象按照点1到点2的向量方向移动向量的模长距离。

Sub 移动()3 w% i! J I; {1 ]0 p+ f
Dim circleObj As AcadCircle; H1 U3 q) _0 `7 Q' g
Dim cirs As AcadCircle, |* s: \: ]5 {/ `( S& c: V, I- ?
Dim center(0 To 2) As Double" u3 a( ~2 U" `0 @' ?; v
Dim radius As Double: p1 e |2 A/ v' u% i& J
center(0) = 2#: center(1) = 2#: center(2) = 0## z0 j. Z' x8 B3 j7 o' i8 ?7 M1 \
radius = 0.59 ^7 y5 Q4 G5 _! T) K
Set circleObj = ThisDrawing.ModelSpace.AddCircle(center, radius)
' a9 \/ ^$ t9 F/ Q/ }+ E" ^% _- N
Update
7 F! w3 o9 P5 U2 G& C& @4 r
Dim point1(0 To 2) As Double
0 R3 L; L3 s$ g* n* H
Dim point2(0 To 2) As Double
( J1 T* ]" i( S+ \
point1(0) = 0: point1(1) = 1: point1(2) = 0: Z; t0 v9 h8 D% j
point2(0) = 2: point2(1) = 6: point2(2) = 0
$ Y6 g% c1 n2 ?/ i7 b. J
Set cirs = circleObj.Copy
2 @, X/ M% z6 V3 u) |
cirs.Move point1, point2 '移动复制的对象5 J. o/ v! T2 C9 w2 q: E3 l1 \; S
cirs.color = acCyan
% \+ ~: f4 S7 I8 O4 p* D1 O' \# C
ZoomAll
: S$ Q! | V j/ S9 c5 b
End Sub

复制代码

2.8复制、旋转、移动.zip (7.33 KB, 下载次数: 11)

kuangben8 · 发表于 2019-3-27 21:09:10

本帖最后由 kuangben8 于 2019-3-27 21:40 编辑

9、常用对象的常用方法、属性、事件

至此，绘制一般的图形，应该没啥问题了！但其实AutoCAD除了给予图形对象的创建方法外，还给予了对象自身很多的操作方法及属性值，通过获取或者修改对象的属性值，可以更加简便的获取我们想要的图形数据。所以本节我们总结一下常用图形对象的常用方法及常见属性值。在AutoCAD中大部分对象的操作方法及属性都相同，所以一通百通！下面以多段线为例，概括一下常用的对象方法及属性、事件。
A、常用对象的方法列表

方法	对应作用
AddVertex	向优化多段线中添加顶点。
ArrayPolar	以给定的对象数量、填充角度和中心点创建对象的环形阵列。
ArrayRectangular	创建对象的二维或三维矩形阵列。
Copy	在同一位置复制给定对象。
Delete	删除指定对象或一组保存了的图层设置。
Explode	将复合对象分解为子图元。
GetBoundingBox	返回图元对象边框的最大和最小点。
GetBulge	获取多段线上给定索引位置的凸度值。
GetExtensionDictionary	获取与对象关联的扩展词典。
GetWidth	返回多段线的起始和终止宽度。
GetXData	获取与对象关联的扩展数据(XData) 。
Highlight	设置给定对象或给定选择集中所有对象的亮显状态。
IntersectWith	获取对象与图形中其它对象的相交点。
Mirror	围绕轴创建平面对象的镜像图像副本。
Mirror3D	绕由三点定义的平面镜像选定的对象。
Move	将图元对象从源向目标移动。
Offset	创建由现有对象偏移指定距离的新对象
Rotate	绕一点旋转图元对象。
Rotate3D	绕三维直线旋转图元对象。
ScaleEntity	按指定的基点和比例因子来缩放图元对象。
SetBulge	设置多段线在给定索引位置的凸度。
SetWidth	设置多段线上给定段索引的起始和终止宽度。
SetXData	设置与对象关联的扩展数据 (外部数据) 。
TransformBy	给定4×4转换矩阵移动、缩放或旋转对象。
Update	更新图形屏幕的对象。

B、常用对象的事件列表

事件	对应作用
Modified	图形中的对象和集合被修改时触发。

C、常用对象的属性列表

属性	对应作用
Application	获取 Application 对象。只读属性
Area	指定构成弧、圆、椭圆、填充图案、优化多段线、多段线、面域或平面闭合样条曲线的封闭区域的面积。对于圆可修改，其他图形是只读属性
Closed	决定三维多段线、优化多段线、多段线或样条曲线是否闭合。
ConstantWidth	指定多段线的固定宽度。
Coordinate	指定对象中单个顶点的坐标。
Coordinates	指定对象中每个顶点的坐标。
Document	获取对象所属的文档(图形)。只读属性
Elevation	指定图案填充或多段线的当前标高
Handle	获取对象的句柄。只读属性
HasExtensionDictionary	确定对象是否有扩展词典与其关联。只读属性
Hyperlinks	获取图元的 Hyperlinks 集合。只读属性
Layer	指定图元的图层。
Length	获取对象的长度。只读属性
Linetype	指定图元的线型。
LinetypeGeneration	指定二维多段线或优化多段线的线型生成方式。
LinetypeScale	指定图元的线型比例因子。
Lineweight	指定个别图元的线宽或图形的默认线宽。
Normal	指定图元的三维法向单位矢量。
ObjectID	获取对象的对象ID。只读属性
OwnerID	获取所有者(上层)对象的对象ID。只读属性
PlotStyleName	指定一个对象、一组对象或图层的打印样式名称。
Thickness	指定二维 AutoCAD 对象按其平面向上或向下拉伸的距离。
TrueColor	指定对象的真彩色。
Visible	指定对象或应用程序的可见性.
Angle	指定直线的角度。————————Line属性。只读属性
Delta	指定直线的增量。————————Line属性。只读属性
EndPoint	指定弧、直线或椭圆的终点。————————Line属性。对于Arc和Ellipse对象该属性为只读。Line可读写
StartPoint	指定弧、直线或椭圆的起点。————————Line属性。对于Arc和Ellipse对象该属性为只读。Line可读写
Center	指定圆弧、圆、椭圆、视图或视口的中心。————————Circle属性
Radius	指定圆弧或圆的半径。————————Circle属性
Circumference	指定圆的周长。————————Circle属性
Diameter	指定圆的直径。————————Circle属性
ArcLenth	指定圆弧的弧长。————————Arc属性。只读属性
EndAngle	指定弧或椭圆的终止角度。————————Arc属性
StartAngle	指定圆弧或椭圆的起点角度。————————Arc属性
TotalAngle	获取圆弧的总角度。————————Arc属性。只读属性

表中标明只读属性的表示只能获取对象的对应属性值，不可以修改对象的对应属性值。其他非只读属性可以修改对应属性值，相当于对图形进行编辑。了解一下大部分对象共同具有的属性及方法后，后续学习到新的对象，对比学习一下新的属性值和操作方法即可(如属性表后续增加内容)。

kuangben8 · 发表于 2019-3-27 21:21:40

本帖最后由 kuangben8 于 2019-3-27 21:41 编辑

D、常用方法示例

注意:

1、关于偏移的注意:OFFSET的结果是一个对象数组，赋值时不用set，获取结果中的对象时需用索引号(一般用0获取第一个)。

2、关于删除的注意:当用户删除集合中的对象时，集合中所有剩余项目会依据目前的计数重新指定新的索引。因此当处理整个集合时，应避免执行删除对象的循环。

3、关于旋转的注意: Rotate只是旋转某个对象,旋转的结果不能赋给某个对象变量。

所以Set l01= l1.Rotate(midl1pt, 3.1415926 / 2) 会提示错误!

l1.Rotate midl1pt, 3.1415926 / 2 没问题!

类似的还有Move方法,凡是对原对象操作不会产生新的对象的方法,结果都不能重新赋给新的变量!

Sub 对象常用方法()
4 t4 D* d8 C5 p: W+ w0 y7 Y
Dim L As AcadLine. r) G2 G) ?7 m
Dim p1(2) As Double, p2(2) As Double
6 t8 s# r4 Z) N" R
Dim cir As AcadCircle5 z! [( U5 T0 Y' \9 {& i3 [
Dim p0(2) As Double, R As Double/ a- q9 d/ ?" A8 {# B
Dim pl As AcadLWPolyline8 T; N" F3 T3 M3 k+ b
Dim ps(7) As Double5 ]4 n' P% N3 r
p1(0) = 10: p1(1) = 10" s7 b D7 I# |0 q/ E7 G! s! d/ ]
p2(0) = 100: p2(1) = 100
4 l( |) K+ `& \
Set L = ThisDrawing.ModelSpace.AddLine(p1, p2)
2 w* j2 S7 T) v3 U* u& y
L.Update
4 v- X+ |$ ?& j2 D1 @! H
p0(0) = 20: p0(1) = 30: R = 50! n& {8 P7 _2 V1 ]8 T
Set cir = ThisDrawing.ModelSpace.AddCircle(p0, R), f% q7 H3 b6 g$ Q2 S- C
cir.Update3 m& N: y) r# O$ ~
ps(0) = -40: ps(1) = 40
3 O/ e- Y& K7 ?# O6 l
ps(2) = 8: ps(3) = 10
5 C9 ]8 m- j3 H* w) e
ps(4) = 40: ps(5) = 209 l) }0 D6 s5 ?; O; I
ps(6) = 60: ps(7) = 98, c6 O) p0 ?5 j( Y: Z: d
Set pl = ThisDrawing.ModelSpace.AddLightWeightPolyline(ps)$ r4 ?. a9 ^! t8 v, U! V/ g
pl.Update
2 y) u% W8 {) l, H x* S
Rem 接下来演示复制、移动、旋转、镜像、偏移、删除
0 a: u* P1 g; Y
Dim p3(2) As Double, p4(2) As Double, ang As Double/ D# v* u7 u( v8 I+ i5 D! X
Dim copycir As AcadCircle, copy As AcadLine, copypl As AcadLWPolyline, mirpl As AcadLWPolyline, offsetpl As Variant V' p6 g, q& U! K
Dim obj As Object2 L1 v; l7 y6 w4 f! y3 t
p3(0) = 100: p3(1) = -20. z& ^) K {" y1 Z- V8 ]# v; @# ]
p4(0) = 160: p4(1) = 90
o# F) }5 t$ A5 B* j) p
ang = 60 * 3.14 / 180 '指定旋转角度(弧度值)
9 [% P8 `" l0 B. ]& k7 o
Set copycir = cir.copy '先在原位置复制圆4 x2 B# {7 E! d6 X0 M; T
copycir.Move p3, p4 '移动复制的圆
: s7 w' a" x/ V8 y6 {4 y" F% E( h
Update
! u+ b) S% N, u. F
Set copypl = pl.copy '先在原位置复制多段线" i2 F; n! E& H; f: b1 _; j
copypl.Rotate p3, ang '在旋转复制的多段线
0 v6 |/ X# f9 s0 n4 U1 b$ H7 D% u
Update
+ V$ p E9 d* w9 C& u: S" \! ^
Set mirpl = copypl.Mirror(p3, p4) '镜像复制的多段线并赋给mirpl
/ [5 ]# {' ]) K) ?& v/ v
Update
' D; P! E. X, m& S
mirpl.Offset (50) '顺时针多段线，正值向内偏移,负值向外偏移。' ^0 C1 d4 a0 H
Update
% Y* j/ U- T5 F' i: `. K) L1 u: u$ F# B
offsetpl = mirpl.Offset(-50) '偏移的结果是对象数组，所以offsetpl定义为变体型,赋值时不需要set(对象赋值时必须使用)
4 r/ G1 [5 `6 ?! c3 u' @; I
Update
3 l& h! A- E( i& H4 q. b p s3 B
offsetpl(0).color = acGreen '设置偏移后的对象颜色属性值为绿色,虽然只有一个对象，但属于从数组中获取，所以以索引号0获取第一个。
( B6 J$ v w/ u, S) j" w
Update. F: @& N6 ?& ]3 d4 a1 n( }
Rem 接下来删除所有对象' P' b/ K2 }; i; t% s
offsetpl(0).Delete '可以删除指定名称的对象
' i1 _ J! v+ I1 \
Update9 R& ^9 Z: m/ ^/ y
For Each obj In ThisDrawing.ModelSpace '在当前画布模型空间中
( P7 U8 l& o3 {6 n1 u- D
obj.Delete '删除对象,似乎是按照绘图顺序依次删除对象的！
- @$ c f$ ]2 D
Update3 K7 \) U. w, o) K* l8 e
Next8 I6 }4 X! D. x7 ~2 G
End Sub

复制代码

kuangben8 · 发表于 2019-3-27 21:58:11

获取交点语法: RetVal = object.IntersectWith(IntersectObject, ExtendOption) 获取交点坐标

Object:使用该方法的对象或对象集合。

IntersectObject：Object[对象], 为输入项; 对象可以是所有图形对象中的任一个。

ExtendOption：AcExtendOption常数; 为输入项，该选项指定两个对象中是否没有、单个或两个对象延伸来得到交点。有如下4个参数：

acExtendNone 两个对象均不延伸 acExtendThisEntity 延伸基本对象。

acExtendOtherEntity 延伸作为参数传递的对象。 acExtendBoth 延伸两个对象。

RetVal：获取的结果是交点的坐标组成的数组。注意不是点的数组，而是坐标数组，所以有多个交点时，后续需要分别取值赋给点变量才能形成多个点对象。

如果两个对象不相交，则没有返回数据。用户可以要求一个或两个对象延伸相交来产生相交点。

Sub 获取交点()
+ M1 {0 `* \' J. K
Dim L01 As AcadLine, L02 As AcadLine, L03 As AcadLine
( c; x& @ L- W O7 V0 N
Dim p1(2) As Double, p2(2) As Double
! x1 E% c- c5 s
Dim p3(2) As Double, p4(2) As Double/ i& c5 P5 V8 N! D3 @3 a- |6 x
Dim p5(2) As Double, p6(2) As Double. Y+ b! @$ h* ~+ ~! H* X
Dim cir As AcadCircle D. Y" g8 z' ?6 u: M& E4 i0 c# w3 }
Dim p0(2) As Double, R As Double
- T( W6 x w* P' Q4 B0 Y! @
Dim pl As AcadLWPolyline4 [- ^& L7 x+ v6 A5 _( P$ B
Dim ps(7) As Double0 T* t0 w4 S( d
p1(0) = 10: p1(1) = 10
Y; h) `0 ~3 J
p2(0) = 100: p2(1) = 100! u- c* t' q- e: d- C) Z
p3(0) = 80: p3(1) = 30% t0 d: \5 X, N8 x J5 q
p4(0) = 130: p4(1) = 30
1 Z6 x( c4 @0 G1 i, y; `
p5(0) = 150: p5(1) = 40
6 O, x/ C& o$ f8 H, \9 {0 E
p6(0) = 160: p6(1) = 70( ?4 h) t+ t5 b4 w" ^7 F
Set L01 = ThisDrawing.ModelSpace.AddLine(p1, p2)
5 g- W' V4 f1 w
L01.Update! u' ?9 n( J2 T, n
Set L02 = ThisDrawing.ModelSpace.AddLine(p3, p4)
. L% k+ c- G8 k7 N
L02.Update: o) ?$ f4 Z" N4 \$ j2 l7 k/ t
Set L03 = ThisDrawing.ModelSpace.AddLine(p5, p6)9 L9 W6 A' v. k8 W6 c- ^
L03.Update
. h4 a3 ]; l9 `, p9 l
p0(0) = 20: p0(1) = 30: R = 50
6 Q9 a. ^* d# V% e8 v
Set cir = ThisDrawing.ModelSpace.AddCircle(p0, R)
2 t( m/ ~7 v) m
cir.Update( u" v& r/ ?, K5 Q# _# p+ d( Z
ps(0) = -40: ps(1) = 40# c2 c2 b" W' c1 Y
ps(2) = 8: ps(3) = 10
! w, r3 i" y Y. V) l8 y/ T5 b
ps(4) = 40: ps(5) = 20' W) w) y- P2 t W! j; X
ps(6) = 60: ps(7) = 98
% f" ?) {+ [/ q: v5 M; ]8 F
Set pl = ThisDrawing.ModelSpace.AddLightWeightPolyline(ps)# ^8 {9 l+ e1 r1 q
pl.Update6 W1 c+ \3 x/ p% g& C$ g
Rem 接下来获取交点坐标. J% _' s# m. y( j X% S# [& K2 I; i) T
Dim ppt01 As Variant, ppt02, ppt03, ppt04 '默认是变体型, O4 T. ^$ I2 g
ppt01 = L01.IntersectWith(cir, acExtendBoth) '两个都延伸，获得延伸后的交点坐标
3 [. v8 s5 Y. F+ T( w8 x) |. g$ E
ppt02 = L01.IntersectWith(cir, acExtendNone) '两个都不延伸,获得唯一1个交点坐标0 b+ E' w% U4 w( }
ppt03 = L01.IntersectWith(cir, acExtendOtherEntity) '延伸作为参数传递的对象,延伸圆，所以结果还是1个交点坐标
( Z" Q# @, Y+ X6 K# B2 T. }. F+ K
ppt04 = L01.IntersectWith(cir, acExtendThisEntity) '延伸基本对象，延伸基本对象L01,所以结果是2个交点坐标
4 n# R& }& D8 Y/ k* B" I- m
Rem 以上是L01与圆的交点情况: Z; E' _1 S% ~" m* f& b% @5 [7 ~4 t
ppt01 = L01.IntersectWith(L02, acExtendBoth) '两个都延伸，可以获得一个交点坐标
: k9 Q& X( A# P' n: u5 ?' P; l/ Q
ppt02 = L01.IntersectWith(L02, acExtendNone) '两个都不延伸，不相交，所以无交点坐标
. H8 z1 |! C ~4 O/ F% G7 E
ppt03 = L01.IntersectWith(L02, acExtendOtherEntity) '延伸作为参数传递的对象，延伸L02，所以获得一个交点坐标
) S" p' S/ A# L: z8 A- c$ w
ppt04 = L01.IntersectWith(L02, acExtendThisEntity) '延伸基本对象，延伸L01,仍然无交点坐标
% T" R* u K! U/ d# c
Rem 以上是L01与L02直线的交点情况% b$ M* d- ~; `6 Q8 B0 x
ppt01 = L02.IntersectWith(L03, acExtendBoth) '两个都延伸
( L4 G& Q ^- i1 f+ s
ppt02 = L02.IntersectWith(L03, acExtendNone) '两个都不延伸
) x8 ?; _- J0 q0 n
ppt03 = L02.IntersectWith(L03, acExtendOtherEntity) '延伸作为参数传递的对象
( L4 {+ i& @+ Z* P5 E) ?
ppt04 = L02.IntersectWith(L03, acExtendThisEntity) '延伸基本对象
9 B/ U: t( Q: ~; w3 `
Rem 以上是L02与L03交点情况
5 Z; e# l2 w- g, t/ V' T
ppt01 = L03.IntersectWith(cir, acExtendBoth) '两个都延伸+ C$ E; @( [3 l: t+ A: Z' ~
ppt02 = L03.IntersectWith(cir, acExtendNone) '两个都不延伸
0 j# ]# V) t( x# y" ^+ ]& {% D
ppt03 = L03.IntersectWith(cir, acExtendOtherEntity) '延伸作为参数传递的对象* y C# q$ n. x0 x
ppt04 = L03.IntersectWith(cir, acExtendThisEntity) '延伸基本对象
( a4 d- ?; D' ?- q: h" W' E! H
Rem 以上是L03与圆交点情况
* u5 j. a) f( Q
ppt01 = L02.IntersectWith(pl, acExtendBoth) '两个都延伸
7 {5 h& a0 P3 t4 t# w8 B6 k
ppt02 = L02.IntersectWith(pl, acExtendNone) '两个都不延伸2 k* C1 y, e6 p6 l
ppt03 = L02.IntersectWith(pl, acExtendOtherEntity) '延伸作为参数传递的对象
2 K* ]* h# G5 |( }
ppt04 = L02.IntersectWith(pl, acExtendThisEntity) '延伸基本对象
: e& H3 j0 q3 T6 B! @- T
Rem 以上是L02与多段线交点情况4 J/ D9 y2 E9 n R
ppt01 = L01.IntersectWith(pl, acExtendBoth) '两个都延伸
3 T. G& Z. O( g9 M7 @$ q4 u
ppt02 = L01.IntersectWith(pl, acExtendNone) '两个都不延伸7 E; I7 r8 Q" g: X
ppt03 = L01.IntersectWith(pl, acExtendOtherEntity) '延伸作为参数传递的对象
7 [. L" E8 h6 T1 q$ F' ^
ppt04 = L01.IntersectWith(pl, acExtendThisEntity) '延伸基本对象
; i+ h% L; ^$ J' @6 G4 ~
Rem 以上是L01与多段线交点情况
. F" k0 u2 J h' D' Y0 e& A
Rem 通过以上几种示例结合本体窗口中ppt01、ppt02、ppt03、ppt04的结果理解四个参数的区别1 w4 f% C1 F4 |
End Sub

复制代码

程序包见下楼！

kuangben8 · 发表于 2019-3-27 22:03:09

E、常用属性示例

注意:1、直线角度Angle是按照直线起点为坐标原点，起点所在水平线为基准线逆时针旋转至直线处的角度。所以画直线时起点和终点互换位置后对应的直线角度不同!

Sub 常用对象属性()6 u, n' @# d# w/ B& h/ }
Dim L01 As AcadLine! S6 a( F# i& L& [: [# I/ W. ]1 [
Dim p1(2) As Double, p2(2) As Double: ?3 B8 u$ I& i7 q7 H& f
Dim cir As AcadCircle& n* u0 ^/ u5 p# A( o* V2 S k
Dim p01(2) As Double, R1 As Double
8 U1 k x4 J8 q3 t* T! r6 h
Dim pl As AcadLWPolyline
# W. k ?2 G. o; i
Dim ps(7) As Double, L4 M$ w) u1 V* s! [
Dim arc As AcadArc9 T z* ^- V& D3 h
Dim p02(2) As Double, R2 As Double, fstangle As Double, endangle As Double
2 r8 }/ H% ~7 _8 E
p1(0) = 10: p1(1) = 103 ` Z& ?% v4 G/ S2 j: N5 Q1 E
p2(0) = 100: p2(1) = 100
m% ~& U2 ]. T0 T2 R
Set L01 = ThisDrawing.ModelSpace.AddLine(p1, p2)
. M' u9 ^( T# u$ i# v. H
L01.Update8 \2 k5 @. ?0 v6 a$ ?
p01(0) = 20: p01(1) = 30: R1 = 50
; M9 r: ], n0 D' u5 k
Set cir = ThisDrawing.ModelSpace.AddCircle(p01, R1)
& P; t+ O7 L. N. k, s
cir.Update8 v3 Z% D! B( k7 c
ps(0) = -40: ps(1) = 404 m2 q$ G" r9 P }% g
ps(2) = 8: ps(3) = 108 c- L7 A% i' X6 R; f
ps(4) = 40: ps(5) = 20" U L; V" Q9 h) R8 y- m
ps(6) = 60: ps(7) = 98) h. @8 o6 ~) d
Set pl = ThisDrawing.ModelSpace.AddLightWeightPolyline(ps)
( Z9 r) l4 s) l) X8 { x/ Q
pl.Update7 d# k; K5 b* p& Q7 O
p02(0) = 50: p02(1) = 60: R2 = 80: fstangle = 60 * 3.14 / 180: endangle = -60 * 3.14 / 180
' I) A8 @0 x! k- s2 }
Set arc = ThisDrawing.ModelSpace.AddArc(p02, R2, fstangle, endangle)
. C, l9 J( f% X3 ]' e
arc.Update
6 w6 ^. V I1 i# f! L
Rem 接下来设置/获取对象属性
% b) H7 r( l- _3 ]+ {
Rem 多段线属性
: _ U) t- d3 m" y$ S! O& t7 _6 R
Dim X As Variant
( t( K0 Z+ b! L+ ^9 ?1 h
X = pl.Area '返回闭合图形的面积，结果是double,值为4040，即使非闭合，系统自动按照起点和终点连接闭合图形计算, b4 p7 q8 u' c" Z4 R2 m
X = pl.Closed '结果为false表示非闭合曲线，为true则表示闭合曲线7 @7 T; n! T1 N/ h! R
pl.Closed = True '设置多段线为闭合曲线,系统会自动将多段线起点和终点连接闭合。
8 e; u4 J5 R: x9 i, t
Update
( B$ U! }0 c0 H% o$ v
X = pl.ConstantWidth '固定宽度为0(默认值)
6 K) w. l4 ^5 K- q
pl.ConstantWidth = 0.35 '设置多段线固定宽度为0.35mm，设定后线宽属性设置无效！' {5 v9 h* n5 O t
Update
) ?3 |/ r0 f# V! K* B7 Z# v% |
Rem 该属性设置多段线所有段的起始和终止宽度为统一值。该属性只有在所有段设置为统一宽度时才返回固定宽度。
. |, v4 j5 d+ k& h
Rem 可以使用 SetWidth 和 GetWidth 方法来指定各个段的宽度。
' H) Z/ L( ]" p4 c- c9 A
X = pl.Layer '返回对象所在的图层名字0，string类型，亦可指定图层，参考“添加图层”。. p$ H8 F" d, m# \) Q
X = pl.Length '获取对象的长度,属于只读属性，不可重新赋值！9 Z; i) s) G! r. d! j! |9 s( G
X = pl.Linetype '获取对象的线型"ByLayer"，此处是随层，亦可指定线型
- ?# O$ l# u* W# K
X = pl.LinetypeScale '获取多段线线型比例，亦可指定线型比例 ]5 K5 k/ Y8 _- ~
X = pl.Lineweight '获取多段线的默认线宽"-1"# G+ s3 S! d% E5 }+ A& c
pl.Lineweight = acLnWt100 '指定多段线的线宽为1.00mm，设定固定宽度后此属性值修改无效！
' x0 o0 G& q9 b; N4 P8 w5 A# X
Update
. O4 l/ s& ^' _
' pl.TrueColor=xxx '该属性值是设置属性，不能获取！ K0 K, A3 [2 @
Rem 接下来了解直线属性
, d h; a4 ?8 f# |# b9 k
X = L01.Angle '获取直线的角弧度(只读属性)，该角度是由 X 轴开始并沿逆时针方向测量值。
) `+ T% [6 y- c4 n
X = L01.Delta '获取直线的增量(只读属性)，终点坐标相对于起点坐标增加的量！
' i+ r( Q+ [' R; Q6 D
X = L01.EndPoint '获取直线的终点坐标, I9 o8 R) c! {" w( q) K! `. I) h
X = L01.StartPoint '获取直线的起点坐标
2 ~! H5 F9 M! d
Rem 接下来是圆的属性
( Q s) U. Z: ~7 W5 w
X = cir.Center '获取圆的圆心坐标. g5 K: @% J4 P, \
X = cir.Radius '获取圆的半径, I9 j, a2 f* e
X = cir.Circumference '获取圆的周长
5 A4 S6 D& v/ ?) S
X = cir.Diameter '获取圆的直径
, }* d; {$ h& `0 }! W2 R# ]! R
Rem 接下来是圆弧的属性
0 Q' I8 j/ T& p( t7 _' c. f
X = arc.ArcLength '获取圆弧弧长(只读属性)0 p9 ~2 f1 l! P2 p! J+ }
X = arc.endangle '获取圆弧的终止角弧度6 N& g9 @, {4 l1 A+ e( r
X = arc.StartAngle '获取圆弧的起始角弧度8 Q. N; g0 o7 ?$ Z4 ^
X = arc.TotalAngle '获取圆弧的总角弧度(只读属性)- w4 b* i; Z; F5 _$ B
End Sub

复制代码

2.9、常用对象的常用方法、属性、事件.zip (10.16 KB, 下载次数: 11)

kuangben8 · 发表于 2019-3-29 19:07:30

10、辅助绘图方法

在通过VBA绘图中发现很多手工绘图命令在VBA中并没有直接可用的命令,而需要转换.例如通过3点画圆方法,前面提到的是通过理论计算出圆心和半径,然后按照圆心、半径画圆即可。

也可以通过辅助绘图方式完成,然后将辅助线删除即可。

A、辅助三点画圆

辅助思路:3个点连接2条线段,绕各自中点旋转90°,交点就是圆心,交点与任意一点连线就是半径:画圆。

Sub 辅助三点画圆()
0 N1 Y2 Y/ S5 s
Rem 通过3点画两条线，然后分别以中点为基点旋转90°，取得相交点坐标就是圆心，圆心和任意点连线长度就是半径。* K+ P6 J: j/ D9 A
Dim pt1(2) As Double, pt2(2) As Double, pt3(2) As Double' c5 n$ b& s' t
pt1(0) = 100: pt1(1) = 608 h0 P3 @$ ]6 D2 t! ^
pt2(0) = 70: pt2(1) = 95
: o0 g3 `1 k# Z, d- \' z
pt3(0) = 150: pt3(1) = 76$ _7 d$ Z0 \! Y7 f" ]6 G
Dim l1 As AcadLine, l2 As AcadLine '画两条辅助直线并求中点坐标
" Y8 n' [/ {8 f# q/ M
Dim midl1pt(2) As Double, midl2pt(2) As Double '定义中点坐标变量
3 u7 t; \% t% `" f ~& D( U
With ThisDrawing.ModelSpace
2 {2 L9 @9 M+ |; Z" F- {; y4 s
Set l1 = .AddLine(pt1, pt2)
; C/ z! }: h, F# ~* O1 U6 p" `5 X
Update8 W: K* D2 w$ Z' G
midl1pt(0) = (l1.StartPoint(0) + l1.EndPoint(0)) / 2 \1 m' r0 f) ]7 e7 m' z
midl1pt(1) = (l1.StartPoint(1) + l1.EndPoint(1)) / 2
* A3 ^; z- N, r' K
Set l2 = .AddLine(pt2, pt3)
- Z2 c0 D6 \; ~ a2 |7 o- b
Update
2 D- J2 @* `) m& F( M$ H* n
midl2pt(0) = (l2.StartPoint(0) + l2.EndPoint(0)) / 2- V# r# |) ]$ i8 L0 R" L/ t" i: {
midl2pt(1) = (l2.StartPoint(1) + l2.EndPoint(1)) / 2
$ N! p7 _+ i4 S* |4 D, f' A
End With
1 K& E3 n8 g# N/ Z! H
Rem 复制并旋转90°
1 y1 Q; p$ j' _# ?' Q8 }
l1.Copy
e' R2 _+ B, _% s
l2.Copy @" y# j) V+ o; I
l1.Rotate midl1pt, 3.1415926 / 2 '旋转的结果还是l10 }5 M& I `' W6 h( ]
Update
* A/ t9 b9 V3 W7 p
l2.Rotate midl2pt, 3.1415926 / 2 '旋转的结果还是l2
% l/ ~& _& z# d0 A3 U
Update* R- D) W' j$ D5 J+ u
Dim p0, R As Double '定义圆心和半径
5 W8 u0 Q: h4 I& X9 g
p0 = l1.IntersectWith(l2, acExtendBoth) '获取交点坐标，两个都延伸，防止不相交
/ S4 R* u& G4 P' I, _
R = Sqr((p0(0) - pt1(0)) ^ 2 + (p0(1) - pt1(1)) ^ 2)
$ B2 P9 }. J# U: b
Dim cir As AcadCircle6 T) h& p% f% l
Set cir = ThisDrawing.ModelSpace.AddCircle(p0, R)8 S. {5 R6 l" N3 v7 _
Update( E/ M. g+ D, W: a: u# u: c
Dim obj As Object, x '定义对象变量7 T: s. B( ? F: O
For Each obj In ThisDrawing.ModelSpace
, ^# c& t0 P) s3 H0 B' A
' x = obj.Type '没有这个属性，那怎么知道这个obj是什么类型呢？( N6 h* X& U6 R Q7 C6 {/ p8 f3 V
If TypeOf obj Is AcadLine Then '如果对象的图元类型是直线则删除# [, z: s- N9 ^* ]* g
obj.Delete
7 q g' r( h- A% n
Update
# V5 D9 q; k: r. ]
End If
2 q; n" {; D# N o: O
Next
: n5 A0 F* [- ^
End Sub

复制代码

新增的知识点:TypeOf

TypeOf是语句，只应用于 If ... Then ... 语句中，

MSDN解释:TypeOf <ObjectName> Is <ObjectType>形式的表达式。其中的ObjectName是任何对象的引用，而ObjectType则是任何有效的对象类型。如果ObjectName是ObjectType所指定的一种对象类型，则表达式为True，否则为False。

例如，将窗体中的所有文本框清空，用如下语句:

Dim c As Control

For Each c In Me.Controls

If TypeOf c Is TextBox Then c.Text =""

kuangben8 · 发表于 2019-3-29 19:13:58

B、辅助三点画弧

辅助思路:3个点连接2条线段,绕各自中点旋转90°,交点就是圆心,交点与任意一点连线长度就是半径,圆心与起点连线角度就是起始角,圆心与终点连线角度就是终止角。

Sub 辅助三点画弧(), h0 p8 Y" l; J1 K5 w8 {/ l5 m
Dim P1(2) As Double, P2(2) As Double, P3(2) As Double, l1 As AcadLine, l2 As AcadLine( q1 y% h/ f a6 N \/ W2 W* n
P1(0) = 100: P1(1) = 60
) m/ j5 @5 i# L+ V1 E" O u
P2(0) = 70: P2(1) = 95: a( U) C( n6 W+ \+ \/ i0 \" }
P3(0) = 150: P3(1) = 76! r3 W, v( {/ [ \) n
Set l1 = ThisDrawing.ModelSpace.AddLine(P1, P2)# d4 E8 h, }3 A) u
Update
4 Y! V" n7 m; W" @, `4 w! H
Set l2 = ThisDrawing.ModelSpace.AddLine(P1, P3)6 A9 X/ V3 c! O% E( g; m" n
Update
) L! g C: P. J1 D4 T" A
Dim p01(2) As Double, p02(2) As Double' T9 f/ q _) U5 n' Z
p01(0) = (P1(0) + P2(0)) / 2: p01(1) = (P1(1) + P2(1)) / 2* `0 {" H3 o2 E% I! x7 v: {- E
p02(0) = (P1(0) + P3(0)) / 2: p02(1) = (P1(1) + P3(1)) / 2
, B+ C1 i& F& k0 a* k6 P1 w" o
l1.Rotate p01, 3.1415926 / 2
. m0 [5 T/ `; z0 |$ {
Update
( x8 W$ F8 O# w/ U
l2.Rotate p02, 3.1415926 / 2$ ]$ t1 ]$ u1 G* a) D
Update. f6 t7 _; b! }) l3 ~
Dim p0 As Variant, R As Double, l01 As AcadLine, l02 As AcadLine, arc As AcadArc( O5 x" n N0 A- n7 p+ f
Dim firstangle As Double, endangle As Double
8 S s$ ^8 ~5 M, o0 M1 c
p0 = l1.IntersectWith(l2, acExtendBoth), o7 m" @3 X5 L) P/ Q. M
Set l01 = ThisDrawing.ModelSpace.AddLine(p0, P2) '圆心与起点连线，就是半径
9 |8 \/ m/ v) l" Y% O
Update/ R: O- ?) I6 e# o
Set l02 = ThisDrawing.ModelSpace.AddLine(p0, P3) '圆心与终点连线，也是半径
, g: b( k! \* ~2 R
Update
% @, ? l. G4 M# a0 T8 M
R = l01.Length 'l01的长度就是半径6 _# B& I; i9 h0 O* j
firstangle = l01.Angle 'l01的角度就是起始角9 z v: o' Y) j# y; b( x$ ~1 J, _
endangle = l02.Angle 'l02的角度就是终止角 {/ ~1 m8 y8 f. T/ J% q8 W/ H7 t
Set arc = ThisDrawing.ModelSpace.AddArc(p0, R, firstangle, endangle) '画弧
. @+ V; S5 a: O8 k
Update" \2 B, W% h* ^/ S" x) @
l1.Delete '删除直线l1
9 Y. _7 x1 {0 n0 O& |
Update7 w4 U7 d/ Y1 u$ L' t1 A/ P
l2.Delete '删除直线l2) N$ _" ?9 {, y/ \/ C: A$ m
Update; k9 m& w+ ~9 w' a u5 b
Set l01 = ThisDrawing.ModelSpace.AddLine(P2, p0) '圆心与起点连线，就是半径
8 ]) {9 z5 M: s& o
Update
8 V' `0 d9 f. B! i5 x
Set l02 = ThisDrawing.ModelSpace.AddLine(P3, p0) '圆心与终点连线，也是半径6 w/ G* ]1 h3 I" g: w* P8 y
Update
7 {: s/ k: l. p3 ?+ V3 I
R = l01.Length 'l01的长度就是半径; t9 `) H0 [$ l7 S4 m# ?
firstangle = l01.Angle 'l01的角度就是起始角
4 `( N- X" `* \
endangle = l02.Angle 'l02的角度就是终止角
/ D8 t" O5 f1 n ^4 ]- o r; L
Set arc = ThisDrawing.ModelSpace.AddArc(p0, R, firstangle, endangle) '画弧3 C5 D8 k! K# O
Update8 ~! i! I3 [6 D% S6 A5 M! z: L; z
Rem 通过以上两例发现，直线角度是按照直线起点为坐标原点，起点所在水平线为基准线逆时针旋转至直线处的角度。8 _/ U/ S% m. [% e
End Sub

复制代码

Sub 验证直线角度()# [5 j7 z* @( I- I4 U6 i2 h' ]
Dim P1(2) As Double, P2(2) As Double, l1 As AcadLine, l2 As AcadLine0 }2 J( y% T8 v$ C
P1(0) = 100: P1(1) = 60) A; y( Y- r" }+ [+ U
P2(0) = 70: P2(1) = 95
7 I/ e( J' f( Z3 t! c. E( U* K: ~
Set l1 = ThisDrawing.ModelSpace.AddLine(P1, P2)
/ ], `9 Z: E' a; f) f7 N
Set l2 = ThisDrawing.ModelSpace.AddLine(P2, P1)
. G7 L; l. u: ?0 [* ?
Dim m, n" z |4 e# }% N3 J ^5 t
m = l1.Angle * 180 / 3.14159269 s" P9 `( i: t( y. e0 ], B* T
n = l2.Angle * 180 / 3.1415926 ~' J0 C7 R. ]7 y! m% H( t2 D. O1 t2 j
Rem 直线的角度是以起点为坐标原点，起点所在水平线为X正半轴逆时针旋转至直线处的旋转角度。; R' h; X- _. ]
End Sub4 q. P* F$ Y1 h# }' B) a, n

复制代码

kuangben8 · 发表于 2019-3-29 19:19:00

本帖最后由 kuangben8 于 2019-3-29 19:20 编辑

C、辅助两点半径画弧
辅助思路：分别以A、B点为圆心，R为半径画圆，两圆交点就是圆心。圆心与起点连线角度就是起始角,圆心与终点连线角度就是终止角-----然后画弧。

Sub 辅助两点半径画弧()
; I4 i% G3 L- T1 b7 S
Rem 能画弧条件:两点距离小于2R,等于2R是半圆，大于2R不能形成图形. ~" o$ \9 e1 n( T: p
Rem 分别以A、B点为圆心，R为半径画圆，两圆交点就是圆心。圆心与起点连线角度就是起始角,圆心与终点连线角度就是终止角-----然后画弧。
8 J) g$ P: U0 {9 Y& P
Dim p1(2) As Double, p2(2) As Double, R As Double, l As AcadLine' R$ B( h3 Z0 q( i
p1(0) = 30: p1(1) = 30
5 Q1 \ r M3 n p! ~ t
p2(0) = p1(0) + 50 * 2 ^ 0.5: p2(1) = p1(1) + 50 * 2 ^ 0.5 '为了让线段长为100
7 g5 e( E" x U
R = InputBox("请输入圆的半径:")2 a! I" e \6 V+ `7 z1 v
Set l = ThisDrawing.ModelSpace.AddLine(p1, p2)
0 i) X9 I. c9 {" T+ v8 U
Update- e3 \: p! |$ S$ E8 Y. F7 L! h
If l.Length > 2 * R Then6 I# f- C+ Y: V$ @! P2 K
MsgBox "两点距离大于直径，不能形成圆或圆弧", vbInformation, "AutoCAD提示！". Y* \+ a. y% [1 }* v
ElseIf l.Length = 2 * R Then
7 a6 L& ~" D, M% ]
Dim p0(2) As Double4 x$ Y. g, ^) U2 G. E' r7 _
p0(0) = (p1(0) + p2(0)) / 2: p0(1) = (p1(1) + p2(1)) / 28 }$ v! h0 [0 E1 G, {
ThisDrawing.ModelSpace.AddArc p0, R, l.Angle, 3.1415926 + l.Angle '起始角是直线的角度，终止角是直线角度+180°. F% r/ n5 o# E5 X6 J+ j" v
Update# f! e9 Y2 b3 h# F
ThisDrawing.ModelSpace.AddArc p0, R, 3.1415926 + l.Angle, l.Angle
% I% P7 e D9 j! g3 V
Update
6 J* J. E: x" z; V4 N/ ]; c1 m3 r7 z
Else r1 a! f5 z+ o: X1 ~# S6 z
Dim cir1 As AcadCircle, cir2 As AcadCircle, ps As Variant, ps1(2) As Double, ps2(2) As Double, l01 As AcadLine, l02 As AcadLine! _/ D2 Y' R7 U \# F- t* F
With ThisDrawing.ModelSpace: p R( Y( u1 p6 [) I/ J
Set cir1 = .AddCircle(p1, R)
! C9 w& G$ g/ x, k/ z6 I
Update5 I }9 F$ \5 G5 D* g
Set cir2 = .AddCircle(p2, R)
0 u( o8 s k1 o. D$ t
Update0 v! B9 Q# _% X2 m2 y4 j; p) `* ~. q
End With5 A* q$ K/ z3 X) Q% i# j( g
ps = cir1.IntersectWith(cir2, acExtendNone) '取两个圆的交点坐标，都不延伸
" I# Z. Y/ L. @
ps1(0) = ps(0): ps1(1) = ps(1) '第一个圆心坐标7 }0 K; a' K' L5 r
ps2(0) = ps(3): ps2(1) = ps(4) '第二个圆心坐标
. [3 [9 O* g7 N+ \' P" n( w6 y2 x
With ThisDrawing.ModelSpace' L6 g( M# o9 q! d
Set l01 = .AddLine(ps1, p1) '注意必须是圆心作为直线的起点
! r2 I! p- H/ J% R6 a
Update
3 M! l" D1 N) \) ?$ D1 ?
Set l02 = .AddLine(ps1, p2) '注意必须是圆心作为直线的起点
3 i; v& j0 }. k6 |) ?3 H
Update% K% \7 [7 {( g% A- h I
.AddArc ps1, R, l01.Angle, l02.Angle '圆心作为直线的起点，角度才是画弧需要的角度
3 a$ Z$ ]6 y* s- J- q2 m
Update4 @* T1 }; `# J+ t- w8 Y
+ `9 {: M/ v# {+ R C
Set l01 = .AddLine(ps2, p1)
3 |' e4 _8 n* _4 D( v; R# W
Update8 M9 K- H; j3 x1 N# d6 m
Set l02 = .AddLine(ps2, p2)
* L- ]0 @2 y8 | ^( |7 B
Update- o1 ~' q1 f3 o* N# f! X( r
.AddArc ps2, R, l01.Angle, l02.Angle
+ q! r3 J. x' g( f! }6 Y( t
Update" o5 Q' U" a. I, b/ G& g. E
.AddArc ps2, R, l02.Angle, l01.Angle4 r/ s8 o8 b' `! D/ c! R9 d
Update4 y5 ~- X+ x+ n- S K+ H- P
End With
, G, a) J) B, s2 h' q& w
End If* ^5 c2 A/ ?( w* `6 B/ M( O
Dim obj As Object" A9 ]) O0 h% N6 N# m
For Each obj In ThisDrawing.ModelSpace3 _7 H* p: l/ p5 L# k6 b' l0 ^7 n* [
If Not TypeOf obj Is AcadArc Then '如果对象的图元不是圆弧则删除，按照绘图顺序删除。 S8 v" ~4 q g! P
obj.Delete
+ p, s9 ~! H* _; F# H" c3 z1 u1 t
Update
& J/ J# d7 O4 O6 n
End If* r3 a1 s7 o/ R9 S% l
Next
) G) x/ K1 U/ }$ h' u% j" R
End Sub. k: d8 L5 B6 N! K4 ]" e9 K- b

复制代码

2.10、辅助绘图方法.zip (12.4 KB, 下载次数: 11)

kuangben8 · 发表于 2019-3-29 19:26:23

本帖最后由 kuangben8 于 2019-4-13 20:54 编辑

11、对象操作方法之图案填充(Hatch)

A、创建图案填充

语法:RetVal = Object.AddHatch(PatternType, PatternName, Associativity [,HatchObjectType])

Object:使用该方法的对象

PatternType(图案类型): AcPatternType 或AcGradientPatternType 常数; 仅用于输入,如果 HatchObjectType 常数值为 acHatchObject，则使用 AcPatternType 常数; 如果 HatchObjectType 常数值为 AcGradientObject则使用 AcGradientPatternType 常数.

PatternName(图案名称): String[字符串]; 仅用于输入,如果HatchObjectType 常数值为 acHatchObject, 则 PatternName 包含填充图案名称。如果 HatchObjectType 常数值为 acGradientObject，则 PatternName 包含在 GradientName 中列出的其中一个渐变图案名称。

Associativity(是否关联): Boolean[布尔值]; 仅用于输入,TRUE: 图案填充为关联的。FALSE:图案填充为不关联的。

HatchObjectType(填充对象类型): HatchObjectType; 可选项; 仅用于输入,默认值为AcHatchObjectType 常数值的 AcHatchObject。

如果AcHatchObjectType 常数值为 AcGradientObject，则 PatternType 为 AcGradientPatternType 类型，并且 PatternName 包含渐变图案名称。

RetVal: Hatch 对象,新创建的 Hatch 对象。

说明

PatternType 常数值如下:

acHatchPatternTypePredefined : 选择那些定义在 acad.pat 文件中的图案名称。

acHatchPatternTypeUserDefined : 使用当前线线型定义的线图案。

acHatchPatternTypeCustomDefined : 从 acad.pat 文件名的其它 PAT 中选择图案名称。

创建了 Hatch 对象后，必须使用AppendOuterLoop 方法添加外边界。外边界必须封闭而且必须在任何内边界创建前创建。内边界使用 AppendInnerLoop 方法创建的，一次只能创建一个。

警告! 当创建了 Hatch 对象后，你必须立即追加外边界到 Hatch 对象以便它成为有效的 AutoCAD 对象。如果试图进行调用 AppendOuterLoop 方法以外的其它操作，AutoCAD 将进入无法预测的状态。

Sub 填充图案()
) {) y5 Y2 L& U6 Z w$ n
' 该示例在模型空间中创建关联的渐变填充图案。
7 S; _ {5 \+ w. s
* U" N, y6 _0 r/ N6 Q& T1 d
Dim hatchObj As AcadHatch '定义图案填充变量
4 J9 N' \3 O& S5 Z& q- J9 u) o3 V8 U
Dim patternName As String '定义填充图案名称
% W O4 F8 I _6 \
Dim PatternType As Long '定义填充图案类型
4 P1 e5 T# ^) Q- p5 T2 [+ S
Dim bAssociativity As Boolean '定义关联结果为布尔值
8 G& {* ?, z+ N/ \& Y, N
8 n4 ?8 E. ^9 ]+ c" A: @# D) K
' 定义填充图案
^/ M9 D7 S2 K% ]
patternName = "CYLINDER"# D! a+ [) s3 Z1 H
PatternType = acPreDefinedGradient '0: a; A1 W( T$ r' b3 I& V" E
bAssociativity = True
! g r" q7 M' i6 @
! y& }- l m+ V5 p8 G/ U7 R( A! F8 ]
' 在模型空间中创建关联的 Hatch 对象
" ^4 t2 y. {: e" s( g$ N
Set hatchObj = ThisDrawing.ModelSpace.AddHatch(PatternType, patternName, bAssociativity, acGradientObject)
6 { q. h# J+ y0 y `
Dim col1 As AcadAcCmColor, col2 As AcadAcCmColor '定义颜色对象
. B9 q2 G0 Y2 I& k& f0 K) {1 i' o
MsgBox Application.Version '查看一下版本号，下一句的19即是版本号
3 b- U. q5 \! r; \; R$ ]+ _7 p. C
Set col1 = AcadApplication.GetInterfaceObject("AutoCAD.AcCmColor.19")
7 C7 g( j4 n, v) H& U8 h
Set col2 = AcadApplication.GetInterfaceObject("AutoCAD.AcCmColor.19")
* I/ d& Y$ O- [5 {
Call col1.SetRGB(255, 0, 0)
$ P; D) S, B: ~
Call col2.SetRGB(0, 255, 0)/ P! Z) F2 d/ c; {6 e* G
hatchObj.GradientColor1 = col1 '定义两种渐变色
; c- o1 {: Y# ~" K9 g
hatchObj.GradientColor2 = col2
# _8 M! k( E ^9 \
. `4 x8 X$ Z5 K, q. r
' 为填充图案创建外边界(圆)
5 ?$ z3 @ M* v+ H' n
Dim outerLoop(0 To 0) As AcadEntity% I: h4 C% S% s$ b5 b* e
Dim center(0 To 2) As Double
' o9 m7 i. J6 t1 w: M+ T8 f) @
Dim radius As Double
8 ]2 J# M7 |2 b" h+ j0 ~
center(0) = 3: center(1) = 3: center(2) = 0 l+ ^! e9 i( _6 i. v
radius = 14 C* X! J5 H4 E% ?: H- e5 r
Set outerLoop(0) = ThisDrawing.ModelSpace.AddCircle(center, radius)
( R3 ?8 p7 q- w+ L1 G _
% G# Y& H* _ D
' 附着外边界到填充图案对象，并显示该填充图案: I5 D0 V- L9 v2 w. X) O' D; W
hatchObj.AppendOuterLoop (outerLoop)
& I1 J6 K/ M ]1 Y* M. A' M, S
hatchObj.Evaluate
8 G- u4 ?9 r2 R. x* P6 k7 M2 a1 t
ThisDrawing.Regen True '全部重生成！
5 k0 }- m. _1 J
End Sub, u0 E5 Z3 `0 _6 w

复制代码

2.11、图案填充(AddHatch).zip (11.58 KB, 下载次数: 17)

kuangben8 · 发表于 2019-3-29 19:27:46

本帖最后由 kuangben8 于 2019-4-14 09:47 编辑

B、填充图案的常用方法

方法	对应作用
AppendInnerLoop	向图案填充中附加内边界。
AppendOuterLoop	向图案填充中附加外边界。
ArrayPolar	以给定的对象数量、填充角度和中心点创建对象的环形阵列。
ArrayRectangular	创建对象的二维或三维矩形阵列。
Copy	在同一位置复制给定对象。
Delete	删除指定对象或一组保存了的图层设置。
Evaluate	计算给定的图案填充或引线。
GetBoundingBox	返回图元对象边框的最大和最小点。
GetExtensionDictionary	获取与对象关联的扩展词典。
GetLoopAt	获取给定索引位置的图案填充边界
GetXData	获取与对象关联的扩展数据(XData) 。
Highlight	设置给定对象或给定选择集中所有对象的亮显状态。
InsertLoopAt	按给定索引在图案填充中插入边界。
IntersectWith	获取对象与图形中其它对象的相交点。
Mirror	围绕轴创建平面对象的镜像图像副本。
Mirror3D	绕由三点定义的平面镜像选定的对象。
Move	将图元对象从源向目标移动。
Rotate	绕一点旋转图元对象。
Rotate3D	绕三维直线旋转图元对象。
ScaleEntity	按指定的基点和比例因子来缩放图元对象。
SetPattern	设置图案填充的图案类型和名称。
SetXData	设置与对象关联的扩展数据 (外部数据) 。
TransformBy	给定4×4转换矩阵移动、缩放或旋转对象。
Update	更新图形屏幕的对象。

1、Object. AppendInnerLoop方法：向图案填充添加内边界。

语法：Object.AppendInnerLoop Loop

Object：使用该方法的对象Hatch

Loop：Variant[变体] (对象，或对象数组); 仅用于输入构成封闭边界的对象数组。该数组可以由一个或多个对象组成。如果使用多于一个对象，它们的端点必须相接以形成一个环。该边界必须包含以下类型的对象：Line, Polyline, Circle, Ellipse, Spline, Region

说明：

在使用 AddHatch 方法创建了 Hatch 对象后，可使用AppendOuterLoop 添加外边界。外边界必须封闭，而且必须在添加内边界之前创建。

当为图案填充定义定了边界后，使用Evaluate 方法计算填充线并填充该边界，然后使用Regen 方法更新该图案填充的显示。
示例参考附件

2、object.AppendOuterLoop方法：向图案填充中添加外边界

语法：Object.AppendOuterLoop loop

Object：使用该方法的对象Hatch

Loop：Object (对象数组); 仅用于输入构成封闭边界的对象数组。该数组可以由一个或多个对象组成。如果使用多于一个对象，它们的端点必须相接以形成一个环。该边界必须包含以下类型的对象： Line, Polyline, Circle, Ellipse, Spline, Region

说明：

在使用 AddHatch 方法创建了 Hatch 对象后，必须添加外边界。外边界必须封闭，而且必须在添加内边界之前创建。在创建了有效的外边界后，可使用 AppendInnerLoop 方法分次每次添加一个任意的内边界。

当为图案填充定义定了边界后，使用Evaluate 方法计算填充线并填充该边界，然后使用Regen 方法更新该图案填充的显示。
示例参考附件

3、填充图案的复制、删除、移动、镜像、旋转、获取交点方法

示例参考附件

示例代码AppendOuterLoop方法中获取交点失败的原因:边界尺寸太小,绘制的填充图案的线宽超出了边界的尺寸,所以显示的填充图案是一整片区域,而且手动画的直线虽然穿过边界区域,但是并没有超过填充图案的线宽,所以获取不到交点!尝试把边界尺寸扩大到100后重新画线即可。5 e. g5 {) C3 ]/ P7 j8 d. ^% ]

示例代码验证交点中获取交点失败的原因：两个填充图案的样式相同,并且角度相同,相当于平行线,所以获取不到交点,将其中一个填充图案的角度修改一下之后即可获取交点。

注意获取的交点坐标组成的数组中每三个元素组成一个点,所以获取的交点个数等于(数组下标最大值+1)/3。

4、object.GetLoopAt方法：获取给定索引位置的图案填充边界

语法：object.GetLoopAt Index, Loop

Object：使用该方法的对象Hatch

Index：Integer[整数]; 仅用于输入从0开始的正整数。

Loop：Variant[变体] (对象或对象数组); 仅用于输出组成边界的一个对象或对象数组。
示例参考附件

5、Object. InsertLoopAt方法：按给定索引在图案填充中插入边界。

语法：object.InsertLoopAt Index, LoopType, Loop

Object：使用该方法的对象Hatch

Index：Integer[整数]; 仅用于输入生成图案填充边界的顶点数组中的索引位置。索引必须从 0 开始的正整数。

LoopType：AcLoopType 常数; 仅用于输入

acHatchLoopTypeDefault

acHatchLoopTypeExternal

acHatchLoopTypePolyline

acHatchLoopTypeDerived

acHatchLoopTypeTextbox

Loop：Variant[变体] (对象或对象数组); 仅用于输入形成封闭边界的对象或对象数组。如果使用是的对象数组，它们的端点必须首尾相连以形成回路。边界，或定义边界的数组，可由以下类型的对象组成：

Line, Polyline, Circle, Ellipse, Spline,Region。

示例参考附件

6、Object.ScaleEntity方法：按指定的基点和比例因子来缩放图元对象,是所有对象的方法.

语法: object.ScaleEntity BasePoint, ScaleFactor

Object:使用该方法的对象, 所有图形对象、 AttributeReference

BasePoint: Variant[变体] (三元素双精度数组); 仅用于输入指定基点的三维WCS 坐标。

ScaleFactor: Double[双精度]; 仅用于输入缩放对象的比例因子。对象的尺寸与该比例因子相乘。比例因子大于 1 将放大对象。比例因子在 0 和 1 之间将缩小对象。比例因子必须大于0.0 。

示例参考附件

7、Object.SetPattern方法：设置图案填充的图案类型和名称(仅限于图案填充，而非渐变填充)。

语法: object.SetPattern PatternType, PatternName

Object: 使用该方法的对象Hatch。

PatternType: AcPatternType 常数; 仅用于输入

acHatchPatternTypePreDefined =0从在 acad.pat 文件的定义中选择图案名称。

acHatchPatternTypeUserDefined =1使用当前线型定义图案线。

acHatchPatternTypeCustomDefined =2从 acad.pat 文件以外的其它 PAT 文件中选择图案名称。

PatternName: String[字符串]; 仅用于输入图案的名称。填充图案名称最多只允许 34个字符，而且不允许带空格。

示例参考附件

为防止所占的一个楼层字数限制，特将程序代码打包成附件供下载：

2.11.2、图案填充的常用方法.zip (12.79 KB, 下载次数: 14)

kuangben8 · 发表于 2019-3-29 19:28:37

本帖最后由 kuangben8 于 2019-4-13 20:49 编辑

C、填充图案的常用属性

属性	对应作用
Application	获取 Application 对象。只读属性
Area	指定构成弧、圆、椭圆、填充图案、优化多段线、多段线、面域或平面闭合样条曲线的封闭区域的面积。对于圆可修改，其他图形是只读属性
AssociativeHatch	决定图案填充是否关联。只读属性, 关联性只能在图案填充创建时设置。
Document	获取对象所属的文档(图形)。只读属性
Elevation	指定图案填充或多段线的当前标高
GradientAngle	指定渐变填充的角度。
GradientCentered	指定是否按中心渐变填充。
GradientColor1	指定渐变填充的起始颜色。针对渐变填充中的双色填充
GradientColor2	指定渐变填充的结束颜色。针对渐变填充中的双色填充
GradientName	指定渐变填充的图案名称。
Handle	获取对象的句柄。只读属性
HasExtensionDictionary	确定对象是否有扩展词典与其关联。只读属性
HatchObjectType	指定图案填充的类型为标准或渐变填充。
HatchStyle	设置图案填充的样式。指孤岛检测样式(普通=0、外部=1、忽略=2)
Hyperlinks	获取图元的 Hyperlinks 集合。只读属性
ISOPenWidth	指定 ISO 填充图案的 ISO 笔宽。
Layer	指定图元的图层。
Linetype	指定图元的线型。针对的是填充的图案的线型
LinetypeScale	指定图元的线型比例因子。针对的填充的图案的线型比例，不是图案整体比例
Lineweight	指定个别图元的线宽或图形的默认线宽。针对填充的图案的线条宽度
Normal	指定图元的三维法向单位矢量。
NumberOfLoops	获取图案填充的整体边界数量。只读属性
ObjectID	获取对象的对象ID。只读属性
OwnerID	获取所有者(上层)对象的对象ID。只读属性
PatternAngle	指定填充图案角度。范围在[0,2π]的double类型
PatternDouble	指定用户定义图案填充是否为双向图案填充。
PatternName	指定填充图案名称。只读属性!需用SetPattern方法设置
PatternType	获取用于图案填充的图案类型。只读属性!需用SetPattern方法设置
PatternScale	指定填充图案比例。针对的是图案的整体比例,等同于PatternSpace 取值范围【＞0】
PatternSpace	指定用户定义填充图案的间距。针对图案的整体比例.等同于PatternScale 取值范围【＞0】
PlotStyleName	指定一个对象、一组对象或图层的打印样式名称。
TrueColor	指定对象的真彩色。
Visible	指定对象或应用程序的可见性.

1、Object.HatchStyle属性：设置图案填充的样式，就是填充界面里的孤岛检测样式。有三个属性值。

表示acHatchStyle 常数; 可读写

1、acHatchStyleNormal：孤岛检测样式中的“普通”。

指定标准的样式，即普通。该选项从最外面的区域边界向内进行图案填充。如果 AutoCAD 遇到内部边界，则关闭填充，直到遇到另一个边界为止。

2、acHatchStyleOuter：孤岛检测样式中的“外部”。

仅填充最外面的区域。该样式也是从最外面的区域边界向内进行图案填充，但是遇到内部边界时会关闭图案填充并且不再打开。

3、acHatchStyleIgnore：孤岛检测样式中的“忽略”。

忽略内部结构。该选项使图案填充通过所有的内部对象。

2、object.GradientName属性:设置渐变填充图案的名称,String[字符串]; 可读写

渐变填充的图案名称，可以是 LINEAR, CYLINDER, INVCYLINDER, SPHERICAL HEMISPHERICAL, CURVED,INVSPHERICAL, INVHEMISPHERICAL 或 INVCURVED。

3、object.HatchObjectType属性: 指定图案填充的类型为标准或渐变填充。

AcHatchObjectType 常数; 可读写. 指定以下常数之一。

AcHatchObject = 0 指定为图案填充

AcGradientObject = 1 指定为渐变填充

说明:

该属性为默认值为 0(acHatchObject),创建的是标准的图案填充。

如果该属性的值为 1(acGradientObject),则通过 AddHatch 方法创建的图案填充是渐变的。如果创建了渐变的图案填充，则 PatternType 为 AcGradientPatternType 并且 PatternName 包含的渐变图案名称为LINEAR,CYLINDER, INVCYLINDER, SPHERICAL, HEMISPHERICAL, CURVED, INVSPHERICAL,INVHEMISPHERICAL, 或 INVCURVED。

4、object.ISOPenWidth属性：指定ISO填充图案的ISO笔宽。

ISOPenWidth是acISOPenWidth 常数, 对于所有 ISO 填充图案为可读写。指定以下常数之一。

acPenWidth000 0.00 mm

acPenWidth013 0.13 mm

acPenWidth018 0.18mm

acPenWidth025 0.25mm

acPenWidth035 0.35mm

acPenWidth050 0.50mm

acPenWidth070 0.70mm

acPenWidth100 1.00mm

acPenWidth140 1.40mm

acPenWidth200 2.00mm

acPenWidthUnk 未知

5、object.PatternDouble属性：指定用户定义图案填充是否为双向图案填充。

PatternDouble是Boolean[布尔值]; 可读写

TRUE: 使用双向图案。 FALSE:不使用双向图案。

系统变量：该属性值保存在系统变量 HPDouble 中。

说明：

如果PatternType被设置为acHatchPatternTypePreDefined或acHatchPatternTypeCustomDefined，那么双向图案属性将不起作用。

6、object.PatternName属性：获取填充图案的名称。【只读属性】

7、object.PatternType属性：获取用于图案填充的图案类型。【只读属性】

以上两个属性值不可重新赋值修改，只能通过SetPattern方法修改！

常用属性示例参考附件(防止一个楼层字数限制)：

2.11.3、图案填充的常用属性.zip (15.83 KB, 下载次数: 11)

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

通知

[分享] 分享学习AutoCAD编程之VBA笔记 (期初完结！)

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

评分

本帖被以下淘专辑推荐:

浏览过的版块