CAD实用VBA.docx
《CAD实用VBA.docx》由会员分享，可在线阅读，更多相关《CAD实用VBA.docx（47页珍藏版）》请在冰豆网上搜索。
CAD实用VBA
1创建对象
1.1SubCh2_FindFirstEntity（）
'本例返回模型空间中的第一个图元
OnErrorResumeNext
DimentityAsAcadEntity
IfThisDrawing.ModelSpace.count<>0Then
Setentity=ThisDrawing.ModelSpace」tem（0）
MsgBoxentity.ObjectName+_
"isthefirstentityinmodelspace."否贝U
MsgBox"Therearenoobjectsinmodelspace."
EndIf
EndSub
1.2SubCh2_lterateLayer（）
'本例遍历集合，并显示集合中所有图层的名称:
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,0utilObj.CreateTypedArray_endTan,vbDouble,0.5,0.5,0utilObj.CreateTypedArray_fitPoints,vbDouble,0,0,0,5,5,0,10,0,0SetsplineObj=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（O）=2:
points
（1）=4
points
（2）=4:
points（3）=2
points（4）=6:
points（5）=4
'在模型空间中创建一个优化多段线对象
SetplineObj=ThisDrawing.ModelSpace._
AddLightWeightPolyline（points）
ThisDrawing.Application.ZoomAII
EndSub
1.7SubCh4_CreateHatch（）
'本例在模型空间中创建关联的图案填充。
创建图案填充后，可以修改与图案填充关联的圆的大小。
图案填充将自动改变以匹配圆的当前大小。
DimhatchObjAsAcadHatch
DimpatternNameAsString
DimPatternTypeAsLong
DimbAssociativityAsBoolean
'定义图案填充
patternName="ANSI31"
PatternType=0bAssociativity=True
'创建关联的Hatch对象
SethatchObj=ThisDrawing.ModelSpace.AddHatch_
（PatternType,patternName,bAssociativity）
'创建图案填充的外边界。
（一个圆）
DimouterLoop（0To0）AsAcadEntity
Dimcenter（0To2）AsDouble
DimradiusAsDouble
center（0）=3:
center
（1）=3:
center⑵=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_FilterBlueCircleOnLayerO（）
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,FilterDataEndSub
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,FilterDataEndSub
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.5
card（）
SubCh4_FilterPolygonWild
“The”多行文字。
本例还说明了
'以下代码将选择条件定义为选择所有文本字符串中出现
SelectByPolygon选择方法的用法：
DimsstextAsAcadSelectionSet
DimFilterType
（1）AsIntegerDimFilterData
（1）AsVariantDimpointsArray（0To11）AsDoubleDimmodeAsIntegermode=acSelectionSetWindowPolygonpointsArray（0）=-12#:
pointsArray
（1）=-7#:
pointsArray
（2）=0pointsArray（3）=-12#:
pointsArray（4）=10#:
pointsArray（5）=0pointsArray（6）=10#:
pointsArray（7）=10#:
pointsArray（8）=0pointsArray（9）=10#:
pointsArray（10）=-7#:
pointsArray（11）=0Setsstext=ThisDrawing.SelectionSets.Add（"SS10"）FilterType（0）=0FilterData（0）="MTEXT"FilterType
（1）=1FilterData
（1）="*The*"sstext.SelectByPolygonmode,pointsArray,FilterType,FilterData
EndSub
2.6SubGetObjInSetO
“SS1的选择集:
'请使用名称来引用已知的现有选择集。
下例引用名为
DimselsetAsAcadSelectionSet
Setselset=ThisDrawing.SelectionSets（"SS10"）
MsgBox（"Selectionset"$selset.Name$"contains"$_selset.Count$"items"）
EndSub
2.7SubListSelectionSetsO
'以下代码显示图形中每个选择集的名称，同时列出其包含的对象的类型:
DimselsetCollectionAsAcadSelectionSets
DimselsetAsAcadSelectionSet
DimentAsObject
Dimi,jAsInteger
SetselsetCollection=ThisDrawing.SelectionSets
'查找图形中的每个选择集
i=0
ForEachselsetInselsetCollection
MsgBox"Selectionset"$CStr（i）$"is:
"$selset.Name'现在查找选择集中的每个对象，同时显示其类型
j=0
ForEachentInselset
MsgBox"Item"$CStr（j+1）$"in"$selset.Name_'$"is:
"$ent.EntityName
j=j+1
Next
i=i+1
Next
EndSub
3编辑对象
3.1SubCh4_RenamingLayer（）
'创建图层
DimlayerObjAsAcadLayer
SetlayerObj=ThisDrawing.Layers.Add（"NewLayer"）
'更改图层的名称
layerObj.Name="MyLayer"
EndSub
3.2SubCh4_CopyCircIeObjects（）
'本例创建两个Circle对象并使用CopyObjects方法创建圆的副本。
DimDOC1AsAcadDocument
DimcircleObj1AsAcadCircle
DimcircleObj2AsAcadCircle
DimcircleObj1CopyAsAcadCircle
DimcircleObj2CopyAsAcadCircle
DimcenterPoint（OTo2）AsDouble
Dimradius1AsDouble
Dimradius2AsDouble
Dimradius1CopyAsDouble
Dimradius2CopyAsDouble
DimobjCollection（0To1）AsObject
DimretObjectsAsVariant
'定义Circle对象
centerPoint（O）=0:
centerPoint
（1）=0:
centerPoint
（2）=0
radius1=5#:
radius2=7#radiusICopy=1#:
radius2Copy=2#
'创建新图形
SetDOC1=ThisDrawing.Appiication.Documents.Add'向图形中添加两个圆
SetcircleObjl=DOCl.ModelSpace.AddCircle_
（centerPoint,radiusi）
SetcircleObj2=DOCl.ModelSpace.AddCircle_
（centerPoint,radius2）
ZoomAll
'将要复制的对象设置成
'与CopyObjects兼容的形式
SetobjCollection（0）=circleObjl
SetobjCollection
（1）=circleObj2
'复制对象并取回新对象（副本）
'的集合
retObjects=DOC1.CopyObjects（objCollection）
'获取新创建的对象并
'对副本应用新的特性
SetcircleObjICopy=retObjects（0）
SetcircleObj2Copy=retObjects（l）circleObjICopy.radius=radiusICopycircleObjICopy.Color=acRedcircleObj2Copy.radius=radius2CopycircleObj2Copy.Color=acRed
ZoomAll
EndSub
3.3SubCh4_0ffsetPolyline（）
'创建多段线
'本例创建一条优化多段线，然后偏移该多段线。
DimplineObjAsAcadLWPolyline
Dimpoints（0To11）AsDoublepoints（0）=1:
points
（1）=1points
（2）=1:
points（3）=2points（4）=2:
points（5）=2points（6）=3:
points（7）=2points（8）=4:
points（9）=4points（10）=4:
points（11）=1
SetplineObj=ThisDrawing.ModelSpace._AddLightWeightPolyline（points）plineObj.Closed=True
ZoomAll
'偏移多段线
DimoffsetObjAsVariant
offsetObj=plineObj.Ofset（0.25）ZoomAll
EndSub
3.4SubCh4_MirrorPolyline（）
'创建多段线
'本例创建一条优化多段线，然后绕一个轴镜像该多段线。
新创建的多段线会着上蓝色。
DimplineObjAsAcadLWPolyline
Dimpoints（OTo11）AsDouble
points（0）=1:
points
（1）=1
points
（2）=1:
points（3）=2
points（4）=2:
points（5）=2
points（6）=3:
points（7）=2
points（8）=4:
points（9）=4
points（10）=4:
points（11）=1
SetplineObj=ThisDrawing.ModelSpace._
AddLightWeightPolyline（points）
plineObj.Closed=True
ZoomAll
'定义镜像轴
Dimpoint1（0To2）AsDouble
Dimpoint2（0To2）AsDouble
point1（0）=0:
point1
（1）=4.25:
point1
（2）=0
point2（0）=4:
point2
（1）=4.25:
point2
（2）=0
'镜像多段线
DimmirrorObjAsAcadLWPolyline
SetmirrorObj=plineObj.Mirror（point1,point2）
DimcolAsNewAcadAcCmColor
Callcol.SetRGB（125,175,235）mirrorObj.TrueColor=col
ZoomAll
EndSub
3.5SubCh4_ArrayingACircle（）
（4,4,0），在180度内
'本例创建一个圆，然后对圆执行环形阵列操作。
这个过程将围绕基点创建四个圆。
'创建圆
DimcircleObjAsAcadCircle
Dimcenter（0To2）AsDouble
DimradiusAsDouble
center（0）=2#:
center
（1）=2#:
center
（2）=0#radius=1
SetcircleObj=ThisDrawing.ModelSpace._AddCircle（center,radius）
ZoomAll
'定义环形阵列
DimnoOfObjectsAsInteger
DimangleToFillAsDouble
DimbasePnt（0To2）AsDouble
noOfObjects=4
angleToFill=3.14'180度
basePnt（0）=4#:
basePnt
（1）=4#:
basePnt
（2）=0#
'下例通过绕点（3,3,0）旋转和
'复制对象而创建四个
'对象副本。
DimretObjAsVariant
retObj=circleObj.ArrayPolar_
（noOfObjects,angleToFill,basePnt）
ZoomAll
EndSub
3.6SubCh4_ArrayRectangularExample（）
'创建圆
5行5列的圆。
'本例创建一个圆，然后对该圆执行矩形阵列操作，创建
DimcircleObjAsAcadCircle
Dimcenter（0To2）AsDouble
DimradiusAsDouble
center（0）=2#:
center
（1）=2#:
center
（2）=0#
radius=0.5
SetcircleObj=ThisDrawing.ModelSpace._
AddCircle（center,radius）
ZoomAll
'定义矩形阵列
DimnumberOfRowsAsLong
DimnumberOfColumnsAsLong
Di
升级会员 