CAD实用VBA.docx

CAD实用VBA.docx

《CAD实用VBA.docx》由会员分享，可在线阅读，更多相关《CAD实用VBA.docx（43页珍藏版）》请在冰豆网上搜索。

CAD实用VBA

1创建对象

1.1SubCh2_FindFirstEntity（）

'本例返回模型空间中的第一个图元

OnErrorResumeNext

DimentityAsAcadEntity

IfThisDrawing.ModelSpace.count<>0Then

Setentity=ThisDrawing.ModelSpace.Item（0）

MsgBoxentity.ObjectName+_

"isthefirstentityinmodelspace."否则

MsgBox"Therearenoobjectsinmodelspace."

EndIf

EndSub

1.2SubCh2_IterateLayer（）

'本例遍历集合，并显示集合中所有图层的名称：

OnErrorResumeNext

DimIAsInteger

DimmsgAsString

msg=""

ForI=0ToThisDrawing.Layers.count-1

msg=msg+ThisDrawing.Layers.Item（I）.Name+vbCrLf

Next

MsgBoxmsg

EndSub

1.3SubCh2_FindLayer（）

'使用Item方法查找名为MyLayer的图层

OnErrorResumeNext

DimABCLayerAsAcadLayer

SetABCLayer=ThisDrawing.Layers（"MyLayer"）

IfErr<>0Then

MsgBox"Thelayer'MyLayer'doesnotexist."

EndIf

EndSub

1.4SubCh2_CreateSplineUsingTypedArray（）

'本例使用CreateTypedArray方法

'在模型空间中创建样条曲线对象。

DimsplineObjAsAcadSpline

DimstartTanAsVariant

DimendTanAsVariant

DimfitPointsAsVariant

DimutilObjAsObject'后期绑定Utility对象

SetutilObj=ThisDrawing.Utility

'定义Spline对象

utilObj.CreateTypedArray_

startTan,vbDouble,0.5,0.5,0

utilObj.CreateTypedArray_

endTan,vbDouble,0.5,0.5,0

utilObj.CreateTypedArray_

fitPoints,vbDouble,0,0,0,5,5,0,10,0,0

SetsplineObj=ThisDrawing.ModelSpace.AddSpline_

（fitPoints,startTan,endTan）

'放大新创建的样条曲线

ZoomAll

EndSub

1.5SubCh4_AddLightWeightPolyline（）

DimplineObjAsAcadLWPolyline

Dimpoints（0To5）AsDouble

'定义二维多段线的点

points（0）=2:

points

（1）=4

points

（2）=4:

points（3）=2

points（4）=6:

points（5）=4

'在模型空间中创建一个优化多段线对象

SetplineObj=ThisDrawing.ModelSpace._

AddLightWeightPolyline（points）

ThisDrawing.Application.ZoomAll

EndSub

1.6SubCh4_AddLightWeightPolyline（）

'下例使用坐标（0,0,0）、（5,0,0）、（5,8,0）和（0,8,0）在模型空间中创建四边形实体。

DimplineObjAsAcadLWPolyline

Dimpoints（0To5）AsDouble

'定义二维多段线的点

points（0）=2:

points

（1）=4

points

（2）=4:

points（3）=2

points（4）=6:

points（5）=4

'在模型空间中创建一个优化多段线对象

SetplineObj=ThisDrawing.ModelSpace._

AddLightWeightPolyline（points）

ThisDrawing.Application.ZoomAll

EndSub

1.7SubCh4_CreateHatch（）

'本例在模型空间中创建关联的图案填充。

创建图案填充后，可以修改与图案填充关联的圆的大小。

图案填充将自动改变以匹配圆的当前大小。

DimhatchObjAsAcadHatch

DimpatternNameAsString

DimPatternTypeAsLong

DimbAssociativityAsBoolean

'定义图案填充

patternName="ANSI31"

PatternType=0

bAssociativity=True

'创建关联的Hatch对象

SethatchObj=ThisDrawing.ModelSpace.AddHatch_

（PatternType,patternName,bAssociativity）

'创建图案填充的外边界。

（一个圆）

DimouterLoop（0To0）AsAcadEntity

Dimcenter（0To2）AsDouble

DimradiusAsDouble

center（0）=3:

center

（1）=3:

center

（2）=0

radius=1

SetouterLoop（0）=ThisDrawing.ModelSpace._

AddCircle（center,radius）

'向Hatch对象附加外边界，

'并显示图案填充

hatchObj.AppendOuterLoop（outerLoop）

hatchObj.Evaluate

ThisDrawing.RegenTrue

EndSub

2使用选择集

2.1SubCh4_FilterMtext（）

'以下代码提示用户选择要包含在选择集中的对象，但仅当选择的对象是Circle时才将其添加到选择集中：

DimsstextAsAcadSelectionSet

DimFilterType（0）AsInteger

DimFilterData（0）AsVariant

Setsstext=ThisDrawing.SelectionSets.Add（"SS2"）

FilterType（0）=0'表示过滤器是对象类型

FilterData（0）="Circle"'表示对象类型是“Circle”

sstext.SelectOnScreenFilterType,FilterData

EndSub

2.2SubCh4_FilterBlueCircleOnLayer0（）

'以下代码指定了两个标准：

对象必须是圆，并且必须在图层0上。

代码将FilterType和FilterData声明为两个元素的数组，并将每个条件指定给一个元素：

DimsstextAsAcadSelectionSet

DimFilterType

（1）AsInteger

DimFilterData

（1）AsVariant

Setsstext=ThisDrawing.SelectionSets.Add（"SS4"）

FilterType（0）=0

FilterData（0）="Circle"

FilterType

（1）=8

FilterData

（1）="0"

sstext.SelectOnScreenFilterType,FilterData

EndSub

2.3SubCh4_FilterRelational（）

'以下代码指定选择半径大于或等于5.0的圆：

DimsstextAsAcadSelectionSet

DimFilterType

（2）AsInteger

DimFilterData

（2）AsVariant

Setsstext=ThisDrawing.SelectionSets.Add（"SS5"）

FilterType（0）=0

FilterData（0）="Circle"

FilterType

（1）=-4

FilterData

（1）=">="

FilterType

（2）=40

FilterData

（2）=5#

sstext.SelectOnScreenFilterType,FilterData

EndSub

2.4SubCh4_FilterOrTest（）

'下例指定选择Text或Mtext对象：

DimsstextAsAcadSelectionSet

DimFilterType（3）AsInteger

DimFilterData（3）AsVariant

Setsstext=ThisDrawing.SelectionSets.Add（"SS6"）

FilterType（0）=-4

FilterData（0）="

FilterType

（1）=0

FilterData

（1）="TEXT"

FilterType

（2）=0

FilterData

（2）="MTEXT"

FilterType（3）=-4

FilterData（3）="or>"

sstext.SelectOnScreenFilterType,FilterData

EndSub

2.5SubCh4_FilterPolygonWildcard（）

'以下代码将选择条件定义为选择所有文本字符串中出现“The”的多行文字。

本例还说明了SelectByPolygon选择方法的用法：

DimsstextAsAcadSelectionSet

DimFilterType

（1）AsInteger

DimFilterData

（1）AsVariant

DimpointsArray（0To11）AsDouble

DimmodeAsInteger

mode=acSelectionSetWindowPolygon

pointsArray（0）=-12#:

pointsArray

（1）=-7#:

pointsArray

（2）=0

pointsArray（3）=-12#:

pointsArray（4）=10#:

pointsArray（5）=0

pointsArray（6）=10#:

pointsArray（7）=10#:

pointsArray（8）=0

pointsArray（9）=10#:

points