CAD实用VBA.docx

1、CAD实用VBA1创建对象1.1Sub Ch2_FindFirstEntity()本例返回模型空间中的第一个图元On Error Resume NextDim en tity As AcadE ntityIf ThisDraw in g.ModelS pace.co unt 0 ThenSet en tity = ThisDraw in g.ModelS pacetem(0)MsgBox en tity.ObjectName + _is the first en tity in model sp ace. 否贝 UMsgBox There are no objects in model sp

2、ace.End IfEnd Sub1.2Sub Ch2_lterateLayer()本例遍历集合，并显示集合中所有图层的名称:On Error Resume NextDim I As In tegerDim msg As Stri ngmsg =For I = 0 To ThisDrawi ng. Layers.co unt - 1msg = msg + ThisDraw in g.Layers.Item(I).Name + vbCrLfNextMsgBox msgEnd Sub1.3Sub Ch2_FindLayer()使用Item方法查找名为 MyLayer的图层On Error Resu

3、me NextDim ABCLayer As AcadLayerSet ABCLayer = ThisDrawi ng.Layers(MyLayer)If Err 0 The nMsgBox The layer MyLayer does n ot exist.End IfEnd Sub1.4Sub Ch2_CreateSplineUsingTypedArray()本例使用 CreateTypedArray方法在模型空间中创建样条曲线对象。Dim sp li neObj As AcadS pli neDim startTa n As Varia ntDim en dTa n As Varia n

4、tDim fitPoints As Varia ntDim utilObj As Object 后期绑定 Utility 对象Set utilObj = ThisDrawi ng.Utility定义Spline对象utilObj.CreateT yp edArray _ startTa n, vbDouble, 0.5, 0.5, 0 utilObj.CreateT yp edArray _ en dTa n, vbDouble, 0.5, 0.5, 0 utilObj.CreateT yp edArray _ fitPoin ts, vbDouble, 0, 0, 0, 5, 5, 0, 1

5、0, 0, 0 Set splin eObj = ThisDrawi ng.ModelS pace.AddS pli ne _(fit Poin ts, startTa n, en dTa n)放大新创建的样条曲线ZoomAllEnd Sub1.5Sub Ch4_AddLightWeightPolyline()Dim pli neObj As AcadLWPolyli neDim poin ts(0 To 5) As Double定义二维多段线的点poi nts(0) = 2: poi nts(1) = 4poi nts(2) = 4: p oi nts(3) = 2poi nts(4) =

6、6: p oi nts(5) = 4在模型空间中创建一个优化多段线对象Set pli neObj = ThisDraw in g.ModelS pace. _AddLightWeight Polyli ne( poi nts)ThisDraw in g.A pp licati on. ZoomAllEnd Sub1.6Sub Ch4_AddLightWeightPolyline()下例使用坐标(0,0,0)、(5,0,0)、(5,8,0)和(0,8,0)在模型空间中创建四边形实体。Dim pli neObj As AcadLWPolyli neDim poin ts(0 To 5) As Do

7、uble定义二维多段线的点poi nts(O) = 2: poi nts(1) = 4poi nts(2) = 4: p oi nts(3) = 2poi nts(4) = 6: p oi nts(5) = 4在模型空间中创建一个优化多段线对象Set pli neObj = ThisDrawi ng.ModelS pace. _AddLightWeight Polyli ne(p oi nts)ThisDrawi ng.A pp licatio n.ZoomAIIEnd Sub1.7Sub Ch4_CreateHatch()本例在模型空间中创建关联的图案填充。创建图案填充后，可以修改与图案填充

8、关联的圆 的大小。图案填充将自动改变以匹配圆的当前大小。Dim hatchObj As AcadHatchDim p atter nN ame As Stri ngDim P atter nType As LongDim bAssociativity As Boolea n定义图案填充patternName = ANSI31P atter nType = 0 bAssociativity = True创建关联的 Hatch对象Set hatchObj = ThisDrawi ng.ModelS pace.AddHatch _(P atter nType, p atter nN ame, bAs

9、sociativity)创建图案填充的外边界。(一个圆)Dim outerLoo p(0 To 0) As AcadE ntityDim cen ter(0 To 2) As DoubleDim radius As Doublecen ter(0) = 3: cen ter(1) = 3: cen ter =0radius = 1Set outerLo op(0) = ThisDraw in g.ModelS pace. _ AddCircle(ce nter, radius)向Hatch对象附加外边界，并显示图案填充hatchObj.A ppen dOuterLo op (outerLo o

10、p) hatchObj.EvaluateThisDraw in g.Rege n TrueEnd Sub2使用选择集2.1Sub Ch4_FilterMtext()Circle时才将其添以下代码提示用户选择要包含在选择集中的对象，但仅当选择的对象是 加到选择集中：Dim sstext As AcadSelect ion SetDim FilterT yp e(0) As In tegerDim FilterData(0) As Varia ntSet sstext = ThisDrawi ng.Selectio nSets.Add(SS2) FilterType(0) = 0 表示过滤器是对象

11、类型 FilterData(0) = Circle表示对象类型是 “Circle ”sstext.Select On Scree n FilterT ype, FilterDataEnd Sub2.2Sub Ch4_FilterBlueCircl eOnLayerO()0上。代码将 FilterType和以下代码指定了两个标准：对象必须是圆，并且必须在图层FilterData声明为两个元素的数组，并将每个条件指定给一个元素:Dim sstext As AcadSelect ion SetDim FilterTy pe(1) As In tegerDim FilterData(1) As Var

12、ia ntSet sstext = ThisDrawi ng.Selectio nSets.Add(SS4)FilterTy pe(0) = 0FilterData(0) = CircleFilterTy pe(1) = 8FilterData(1) = 0 sstext.Select On Scree n FilterT ype, FilterData End Sub2.3Sub Ch4_FilterRelational()以下代码指定选择半径大于或等于 5.0的圆:Dim sstext As AcadSelect ion SetDim FilterT yp e(2) As In teger

13、Dim FilterData(2) As Varia ntSet sstext = ThisDrawi ng.Selectio nSets.Add(SS5)FilterTy pe(0) = 0FilterData(0) = CircleFilterTy pe(1) = -4FilterData(1)=FilterTy pe(2) = 40FilterData(2) = 5# sstext.Select On Scree n FilterT ype, FilterData End Sub2.4Sub Ch4_FilterOrTest()下例指定选择 Text或Mtext对象：Dim sstext

14、 As AcadSelect ion SetDim FilterTy pe(3) As In tegerDim FilterData(3) As Varia ntSet sstext = ThisDrawi ng.Selectio nSets.Add(SS6)FilterTy pe(0) = -4FilterData(0) = sstext.Select On Scree n FilterT ype, FilterDataEnd Sub2.5card()Sub Ch4_FilterPolygonWild“The”多行文字。本例还说明了以下代码将选择条件定义为选择所有文本字符串中出现Select

15、By Polygo n选择方法的用法：Dim sstext As AcadSelect ion SetDim FilterT yp e(1) As In teger Dim FilterData(1) As Varia nt Dim poi ntsArray(0 To 11) As Double Dim mode As In teger mode = acSelect ion SetWi ndow Po lygo n poi ntsArray(0) = -12#: poi ntsArray(1) = -7#: poi ntsArray(2) = 0 poi ntsArray(3) = -12#

16、: poi ntsArra y(4) = 10#: poin tsArray(5) = 0 poi ntsArray(6) = 10#: poi ntsArray(7) = 10#: poin tsArray(8) = 0 poi ntsArray(9) = 10#: poi ntsArray(10) = -7#: poin tsArray(11) = 0 Set sstext = ThisDrawi ng.Selectio nSets.Add(SS10) FilterTy pe(0) = 0 FilterData(0) = MTEXT FilterTy pe(1) = 1 FilterDat

17、a(1) = *The* sstext.SelectB yPo lygo n mode, poin tsArray, FilterT ype, FilterDataEnd Sub2.6Sub GetObjInSetO“SS1的选择集:请使用名称来引用已知的现有选择集。下例引用名为Dim selset As AcadSelect ion SetSet selset = ThisDrawi ng.Selectio nSets(SS10)MsgBox (Selection set $ selset.Name $ co ntai ns $ _ selset.Cou nt $ items)End Sub

18、2.7Sub ListSelectionSetsO以下代码显示图形中每个选择集的名称，同时列出其包含的对象的类型:Dim selsetCollectio n As AcadSelect ion SetsDim selset As AcadSelect ion SetDim ent As ObjectDim i, j As In tegerSet selsetCollectio n = ThisDrawi ng.Selectio nSets查找图形中的每个选择集i = 0For Each selset In selsetCollect ionMsgBox Selection set $ CStr

19、(i) $ is: $ selset.Name 现在查找选择集中的每个对象，同时显示其类型j = 0For Each ent In selsetMsgBox Item $ CStr(j + 1) $ in $ selset.Name _ $ is: $ en t.E ntityNamej = j + 1Nexti = i + 1NextEnd Sub3编辑对象3.1Sub Ch4_RenamingLayer()创建图层Dim layerObj As AcadLayerSet layerObj = ThisDrawi ng.Layers.Add(NewLayer)更改图层的名称layerObj.

20、Name = MyLayerEnd Sub3.2Sub Ch4_CopyCircI eObjects()本例创建两个 Circle对象并使用CopyObjects方法创建圆的副本。Dim DOC1 As AcadDocume ntDim circleObj1 As AcadCircleDim circleObj2 As AcadCircleDim circleObj1Co py As AcadCircleDim circleObj2Co py As AcadCircleDim cen terPoi nt(O To 2) As DoubleDim radius1 As DoubleDim rad

21、ius2 As DoubleDim radius1C opy As DoubleDim radius2C opy As DoubleDim objCollectio n(0 To 1) As ObjectDim retObjects As Varia nt定义Circle对象cen terPoi nt(O) = 0: cen terPoi nt(1) = 0: cen terPoi nt(2) = 0radius1 = 5#: radius2 = 7# radiusICo py = 1#: radius2Co py = 2#创建新图形Set DOC1 = ThisDrawi ng.A ppi

22、icatio n.Docume nts.Add 向图形中添加两个圆Set circleObjl = DOCl.ModelS pace.AddCircle _(cen terP oint, radiusi)Set circleObj2 = DOCl.ModelS pace.AddCircle _(cen terP oint, radius2)ZoomAll将要复制的对象设置成与Copy Objects兼容的形式Set objCollectio n(0) = circleObjlSet objCollectio n(1) = circleObj2复制对象并取回新对象(副本)的集合retObject

23、s = DOC1.C op yObjects(objCollectio n)获取新创建的对象并对副本应用新的特性Set circleObjIC opy = retObjects(0)Set circleObj2C opy = retObjects(l) circleObjIC op y.radius = radiusIC opy circleObjIC op y.Color = acRed circleObj2C op y.radius = radius2C opy circleObj2C opy .Color = acRedZoomAllEnd Sub3.3Sub Ch4_0ffsetPol

24、yline()创建多段线本例创建一条优化多段线，然后偏移该多段线。Dim pli neObj As AcadLWPolyli neDim p oi nts(0 To 11) As Double poin ts(0) = 1: p oi nts(1) = 1 poi nts(2) = 1: p oi nts(3) = 2 poi nts(4) = 2: p oi nts(5) = 2 poi nts(6) = 3: p oi nts(7) = 2 poi nts(8) = 4: p oi nts(9) = 4 poi nts(10) = 4: poin ts(11) = 1Set pli neO

25、bj = ThisDraw in g.ModelS pace. _ AddLightWeight Polyli ne( poi nts) pli neObj.Closed = TrueZoomAll偏移多段线Dim offsetObj As Varia ntoffsetObj = pli neObj.Ofset(0.25) ZoomAllEnd Sub3.4Sub Ch4_MirrorPolyline()创建多段线本例创建一条优化多段线，然后绕一个轴镜像该多段线。新创建的多段线会着上蓝色。Dim pli neObj As AcadLWPolyli neDim p oi nts(O To 11)

26、 As Doublepoin ts(0) = 1: p oi nts(1) = 1poi nts(2) = 1: p oi nts(3) = 2poi nts(4) = 2: p oi nts(5) = 2poi nts(6) = 3: p oi nts(7) = 2poi nts(8) = 4: p oi nts(9) = 4poi nts(10) = 4: poin ts(11) = 1Set pli neObj = ThisDrawi ng.ModelS pace. _AddLightWeight Polyli ne(p oi nts)p li neObj.Closed = TrueZo

27、omAll定义镜像轴Dim p oi nt1(0 To 2) As DoubleDim p oi nt2(0 To 2) As Doublepoi nt1(0) = 0: p oi nt1(1) = 4.25: p oi nt1(2) = 0poi nt2(0) = 4: poi nt2(1) = 4.25: p oi nt2(2) = 0镜像多段线Dim mirrorObj As AcadLWPolyli neSet mirrorObj = pli neObj.Mirror( poi nt1, poi nt2)Dim col As New AcadAcCmColorCall col.SetR

28、GB(125, 175, 235) mirrorObj.TrueColor = colZoomAllEnd Sub3.5Sub Ch4_ArrayingACircl e()(4,4,0)，在 180 度内本例创建一个圆，然后对圆执行环形阵列操作。这个过程将围绕基点 创建四个圆。创建圆Dim circleObj As AcadCircleDim cen ter(0 To 2) As DoubleDim radius As Doublecen ter(0) = 2#: cen ter(1) = 2#: cen ter(2) = 0# radius = 1Set circleObj = ThisDr

29、aw in g.ModelS pace. _ AddCircle(ce nter, radius)ZoomAll定义环形阵列Dim noO fObjects As In tegerDim an gleToFill As DoubleDim base Pnt(0 To 2) As DoublenoO fObjects = 4an gleToFill = 3.14180 度base Pn t(0) = 4#: base Pn t(1) = 4#: base Pnt(2) = 0#下例通过绕点(3,3,0)旋转和复制对象而创建四个对象副本。Dim retObj As Varia ntretObj =

30、 circleObj.Arra yP olar _(no OfObjects, an gleToFill, base Pnt)ZoomAllEnd Sub3.6Sub Ch4_ArrayRectangularExample()创建圆5行5列的圆。本例创建一个圆，然后对该圆执行矩形阵列操作，创建Dim circleObj As AcadCircleDim cen ter(0 To 2) As DoubleDim radius As Doublecen ter(0) = 2#: cen ter(1) = 2#: cen ter(2) = 0#radius = 0.5Set circleObj = ThisDraw in g.ModelS pace. _AddCircle(ce nter, radius)ZoomAll定义矩形阵列Dim nu mberOfRows As LongDim nu mberOfC olumns As LongDi