CAD实用VBA.docx
《CAD实用VBA.docx》由会员分享,可在线阅读,更多相关《CAD实用VBA.docx(47页珍藏版)》请在冰豆网上搜索。
![CAD实用VBA.docx](https://file1.bdocx.com/fileroot1/2023-2/9/c0d17572-6340-43a3-82d9-49b806fbafdd/c0d17572-6340-43a3-82d9-49b806fbafdd1.gif)
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