CAD实用VBA.doc

。1 创建对象1.1 Sub Ch2_FindFirstEntity()本例返回模型空间中的第一个图元On Error Resume NextDim entity As AcadEntityIf ThisDrawing.ModelSpace.count 0 ThenSet entity = ThisDrawing.ModelSpace.Item(0)MsgBox entity.ObjectName + _ is the first entity in model space. 否则MsgBox There are no objects in model space. End IfEnd Sub1.2 Sub Ch2_IterateLayer()本例遍历集合，并显示集合中所有图层的名称：On Error Resume NextDim I As IntegerDim msg As String msg = For I = 0 To ThisDrawing.Layers.count - 1msg = msg + ThisDrawing.Layers.Item(I).Name + vbCrLf Next MsgBox msgEnd Sub1.3 Sub Ch2_FindLayer()使用 Item 方法查找名为 MyLayer 的图层On Error Resume NextDim ABCLayer As AcadLayerSet ABCLayer = ThisDrawing.Layers(MyLayer)If Err 0 ThenMsgBox The layer MyLayer does not exist. End IfEnd Sub1.4 Sub Ch2_CreateSplineUsingTypedArray()本例使用 CreateTypedArray 方法在模型空间中创建样条曲线对象。Dim splineObj As AcadSplineDim startTan As VariantDim endTan As VariantDim fitPoints As VariantDim utilObj As Object 后期绑定 Utility 对象Set utilObj = 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, 0Set splineObj = ThisDrawing.ModelSpace.AddSpline _ (fitPoints, startTan, endTan) 放大新创建的样条曲线 ZoomAllEnd Sub1.5 Sub Ch4_AddLightWeightPolyline()Dim plineObj As AcadLWPolylineDim points(0 To 5) As Double 定义二维多段线的点points(0) = 2: points(1) = 4points(2) = 4: points(3) = 2points(4) = 6: points(5) = 4在模型空间中创建一个优化多段线对象Set plineObj = ThisDrawing.ModelSpace. _AddLightWeightPolyline(points)ThisDrawing.Application.ZoomAllEnd Sub1.6 Sub Ch4_AddLightWeightPolyline()下例使用坐标 (0,0,0)、(5,0,0)、(5,8,0) 和 (0,8,0) 在模型空间中创建四边形实体。Dim plineObj As AcadLWPolylineDim points(0 To 5) As Double 定义二维多段线的点points(0) = 2: points(1) = 4points(2) = 4: points(3) = 2points(4) = 6: points(5) = 4在模型空间中创建一个优化多段线对象Set plineObj = ThisDrawing.ModelSpace. _AddLightWeightPolyline(points)ThisDrawing.Application.ZoomAllEnd Sub1.7 Sub Ch4_CreateHatch()本例在模型空间中创建关联的图案填充。创建图案填充后，可以修改与图案填充关联的圆的大小。图案填充将自动改变以匹配圆的当前大小。Dim hatchObj As AcadHatchDim patternName As StringDim PatternType As LongDim bAssociativity As Boolean 定义图案填充patternName = ANSI31PatternType = 0bAssociativity = True创建关联的 Hatch 对象Set hatchObj = ThisDrawing.ModelSpace.AddHatch _ (PatternType, patternName, bAssociativity)创建图案填充的外边界。（一个圆）Dim outerLoop(0 To 0) As AcadEntityDim center(0 To 2) As DoubleDim radius As Doublecenter(0) = 3: center(1) = 3: center(2) = 0 radius = 1Set outerLoop(0) = ThisDrawing.ModelSpace. _AddCircle(center, radius)向 Hatch 对象附加外边界， 并显示图案填充hatchObj.AppendOuterLoop (outerLoop)hatchObj.EvaluateThisDrawing.Regen TrueEnd Sub2 使用选择集2.1 Sub Ch4_FilterMtext()以下代码提示用户选择要包含在选择集中的对象，但仅当选择的对象是 Circle 时才将其添加到选择集中：Dim sstext As AcadSelectionSetDim FilterType(0) As IntegerDim FilterData(0) As VariantSet sstext = ThisDrawing.SelectionSets.Add(SS2)FilterType(0) = 0 表示过滤器是对象类型FilterData(0) = Circle 表示对象类型是“Circle”sstext.SelectOnScreen FilterType, FilterDataEnd Sub2.2 Sub Ch4_FilterBlueCircleOnLayer0()以下代码指定了两个标准：对象必须是圆，并且必须在图层 0 上。代码将 FilterType 和 FilterData 声明为两个元素的数组，并将每个条件指定给一个元素：Dim sstext As AcadSelectionSetDim FilterType(1) As IntegerDim FilterData(1) As VariantSet sstext = ThisDrawing.SelectionSets.Add(SS4)FilterType(0) = 0FilterData(0) = CircleFilterType(1) = 8FilterData(1) = 0sstext.SelectOnScreen FilterType, FilterDataEnd Sub2.3 Sub Ch4_FilterRelational()以下代码指定选择半径大于或等于 5.0 的圆：Dim sstext As AcadSelectionSetDim FilterType(2) As IntegerDim FilterData(2) As VariantSet sstext = ThisDrawing.SelectionSets.Add(SS5)FilterType(0) = 0FilterData(0) = CircleFilterType(1) = -4FilterData(1) = =FilterType(2) = 40FilterData(2) = 5#sstext.SelectOnScreen FilterType, FilterDataEnd Sub2.4 Sub Ch4_FilterOrTest()下例指定选择 Text 或 Mtext 对象：Dim sstext As AcadSelectionSetDim FilterType(3) As IntegerDim FilterData(3) As VariantSet sstext = ThisDrawing.SelectionSets.Add(SS6)FilterType(0) = -4FilterData(0) = sstext.SelectOnScreen FilterType, FilterDataEnd Sub2.5 Sub Ch4_FilterPolygonWildcard()以下代码将选择条件定义为选择所有文本字符串中出现“The”的多行文字。本例还说明了 SelectByPolygon 选择方法的用法：Dim sstext As AcadSelectionSetDim FilterType(1) As IntegerDim FilterData(1) As VariantDim pointsArray(0 To 11) As DoubleDim mode As Integermode = 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) = 0Set sstext = ThisDrawing.SelectionSets.Add(SS10)FilterType(0) = 0FilterData(0) = MTEXTFilterType(1) = 1FilterData(1) = *The*sstext.SelectByPolygon mode, pointsArray, FilterType, FilterDataEnd Sub2.6 Sub GetObjInSet()请使用名称来引用已知的现有选择集。下例引用名为“SS10”的选择集：Dim selset As AcadSelectionSetSet selset = ThisDrawing.SelectionSets(SS10)MsgBox (Selection set $ selset.Name $ contains $ _selset.Count $ items)End Sub2.7 Sub ListSelectionSets()以下代码显示图形中每个选择集的名称，同时列出其包含的对象的类型：Dim selsetCollection As AcadSelectionSetsDim selset As AcadSelectionSetDim ent As ObjectDim i, j As IntegerSet selsetCollection = ThisDrawing.SelectionSets查找图形中的每个选择集 i = 0For Each selset In selsetCollectionMsgBox Selection set $ CStr(i) $ is: $ selset.Name现在查找选择集中的每个对象，同时显示其类型 j = 0For Each ent In selsetMsgBox Item $ CStr(j + 1) $ in $ selset.Name _ $ is: $ ent.EntityName j = j + 1 Next i = i + 1 NextEnd Sub3 编辑对象3.1 Sub Ch4_RenamingLayer() 创建图层Dim layerObj As AcadLayerSet layerObj = ThisDrawing.Layers.Add(NewLayer) 更改图层的名称layerObj.Name = MyLayerEnd Sub3.2 Sub Ch4_CopyCircleObjects()本例创建两个 Circle 对象并使用 CopyObjects 方法创建圆的副本。Dim DOC1 As AcadDocumentDim circleObj1 As AcadCircleDim circleObj2 As AcadCircleDim circleObj1Copy As AcadCircleDim circleObj2Copy As AcadCircleDim centerPoint(0 To 2) As DoubleDim radius1 As DoubleDim radius2 As DoubleDim radius1Copy As DoubleDim radius2Copy As DoubleDim objCollection(0 To 1) As ObjectDim retObjects As Variant定义 Circle 对象centerPoint(0) = 0: centerPoint(1) = 0: centerPoint(2) = 0radius1 = 5#: radius2 = 7#radius1Copy = 1#: radius2Copy = 2# 创建新图形Set DOC1 = ThisDrawing.Application.Documents.Add 向图形中添加两个圆Set circleObj1 = DOC1.ModelSpace.AddCircle _ (centerPoint, radius1)Set circleObj2 = DOC1.ModelSpace.AddCircle _ (centerPoint, radius2) ZoomAll 将要复制的对象设置成与 CopyObjects 兼容的形式Set objCollection(0) = circleObj1Set objCollection(1) = circleObj2复制对象并取回新对象（副本） 的集合retObjects = DOC1.CopyObjects(objCollection) 获取新创建的对象并 对副本应用新的特性Set circleObj1Copy = retObjects(0)Set circleObj2Copy = retObjects(1)circleObj1Copy.radius = radius1CopycircleObj1Copy.Color = acRedcircleObj2Copy.radius = radius2CopycircleObj2Copy.Color = acRed ZoomAllEnd Sub3.3 Sub Ch4_OffsetPolyline() 创建多段线本例创建一条优化多段线，然后偏移该多段线。Dim plineObj As AcadLWPolylineDim points(0 To 11) As Doublepoints(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) = 1Set plineObj = ThisDrawing.ModelSpace. _AddLightWeightPolyline(points)plineObj.Closed = True ZoomAll 偏移多段线Dim offsetObj As VariantoffsetObj = plineObj.Offset(0.25)ZoomAllEnd Sub3.4 Sub Ch4_MirrorPolyline() 创建多段线本例创建一条优化多段线，然后绕一个轴镜像该多段线。新创建的多段线会着上蓝色。Dim plineObj As AcadLWPolylineDim points(0 To 11) As Doublepoints(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) = 1Set plineObj = ThisDrawing.ModelSpace. _AddLightWeightPolyline(points)plineObj.Closed = True ZoomAll 定义镜像轴Dim point1(0 To 2) As DoubleDim point2(0 To 2) As Doublepoint1(0) = 0: point1(1) = 4.25: point1(2) = 0point2(0) = 4: point2(1) = 4.25: point2(2) = 0 镜像多段线Dim mirrorObj As AcadLWPolylineSet mirrorObj = plineObj.Mirror(point1, point2)Dim col As New AcadAcCmColorCall col.SetRGB(125, 175, 235)mirrorObj.TrueColor = col ZoomAllEnd Sub3.5 Sub Ch4_ArrayingACircle()本例创建一个圆，然后对圆执行环形阵列操作。这个过程将围绕基点 (4,4,0)，在 180 度内创建四个圆。 创建圆Dim circleObj As AcadCircleDim center(0 To 2) As DoubleDim radius As Doublecenter(0) = 2#: center(1) = 2#: center(2) = 0# radius = 1Set circleObj = ThisDrawing.ModelSpace. _AddCircle(center, radius) ZoomAll 定义环形阵列Dim noOfObjects As IntegerDim angleToFill As DoubleDim basePnt(0 To 2) As DoublenoOfObjects = 4angleToFill = 3.14 180 度basePnt(0) = 4#: basePnt(1) = 4#: basePnt(2) = 0#下例通过绕点 (3,3,0) 旋转和 复制对象而创建四个 对象副本。Dim retObj As VariantretObj = circleObj.ArrayPolar _ (noOfObjects, angleToFill, basePnt) ZoomAllEnd Sub3.6 Sub Ch4_ArrayRectangularExample() 创建圆本例创建一个圆，然后对该圆执行矩形阵列操作，创建 5 行 5 列的圆。Dim circleObj As AcadCircleDim center(0 To 2) As DoubleDim radius As Doublecenter(0) = 2#: center(1) = 2#: center(2) = 0# radius = 0.5Set circleObj = ThisDrawing.ModelSpace. _AddCircle(center, radius) ZoomAll 定义矩形阵列Dim numberOfRows As LongDim numberOfColumns As LongDim numberOfLevels As LongDim distanceBwtnRows As DoubleDim distanceBwtnColumns As DoubleDim distanceBwtnLevels As DoublenumberOfRows = 5numberOfColumns = 5numberOfLevels = 2distanceBwtnRows = 1distanceBwtnColumns = 1distanceBwtnLevels = 1 创建对象的阵列Dim retObj As VariantretObj = circleObj.ArrayRectangular _ (numberOfRows, numberOfColumns, numberOfLevels, _distanceBwtnRows, distanceBwtnColumns, distanceBwtnLevels) ZoomAllEnd Sub3.7 Sub Ch4_MoveCircle()本例创建一个圆，然后将此圆沿着 X 轴移动两个单位。 创建圆Dim circleObj As AcadCircleDim center(0 To 2) As DoubleDim radius As Doublecenter(0) = 2#: center(1) = 2#: center(2) = 0# radius = 0.5Set circleObj = ThisDrawing.ModelSpace. _AddCircle(center, radius) ZoomAll定义组成移动矢量的点。移动矢量将圆沿 x 轴移动 两个单位。Dim point1(0 To 2) As DoubleDim point2(0 To 2) As Doublepoint1(0) = 0: point1(1) = 0: point1(2) = 0point2(0) = 2: point2(1) = 0: point2(2) = 0 移动圆circleObj.Move point1, point2circleObj.UpdateEnd Sub3.8 Sub Ch4_RotatePolyline() 创建多段线本例创建一条闭合的优化多段线，然后将该多段线绕基点 (4,4.25,0) 旋转 45 度。Dim plineObj As AcadLWPolylineDim points(0 To 11) As Doublepoints(0) = 1: points(1) = 2points(2) = 1: points(3) = 3points(4) = 2: points(5) = 3points(6) = 3: points(7) = 3points(8) = 4: points(9) = 4points(10) = 4: points(11) = 2Set plineObj = ThisDrawing.ModelSpace. _AddLightWeightPolyline(points)plineObj.Closed = True ZoomAll定义绕点 (4,4.25,0) 旋转 45 度Dim basePoint(0 To 2) As DoubleDim rotationAngle As DoublebasePoint(0) = 4: basePoint(1) = 4.25: basePoint(2) = 0rotationAngle = 0.7853981 45 degrees 旋转多段线plineObj.Rotate basePoint, rotationAngleplineObj.UpdateEnd Sub3.9 Sub Ch4_DeletePolyline()本例创建一条优化多段线，然后将其删除。 创建多段线Dim lwpolyObj As AcadLWPolylineDim vertices(0 To 5) As Doublevertices(0) = 2: vertices(1) = 4vertices(2) = 4: vertices(3) = 2vertices(4) = 6: vertices(5) = 4Set lwpolyObj = ThisDrawing.ModelSpace. _AddLightWeightPolyline(vertices) ZoomAll 删除多段线lwpolyObj.DeleteThisDrawing.Regen acActiveViewportEnd Sub3.10 Sub Ch4_ScalePolyline()本例创建一条闭合的优化多段线，然后以 0.5 的缩放比例调整该多段线。 创建多段线Dim plineObj As AcadLWPolylineDim points(0 To 11) As Doublepoints(0) = 1: points(1) = 2points(2) = 1: points(3) = 3points(4) = 2: points(5) = 3points(6) = 3: points(7) = 3points(8) = 4: points(9) = 4points(10) = 4: points(11) = 2Set plineObj = ThisDrawing.ModelSpace. _AddLightWeightPolyline(points)plineObj.Closed = True ZoomAll 定义缩放Dim basePoint(0 To 2) As DoubleDim scalefactor As DoublebasePoint(0) = 4: basePoint(1) = 4.25: basePoint(2) = 0scalefactor = 0.5 缩放多段线plineObj.ScaleEntity basePoint, scalefactorplineObj.UpdateEnd Sub3.11 Sub Ch4_LengthenLine()本例创建一条直线，然后修改其端点拉长该直线。 定义和创建直线Dim lineObj As AcadLineDim startPoint(0 To 2) As DoubleDim endPoint(0 To 2) As DoublestartPoint(0) = 0startPoint(1) = 0startPoint(2) = 0endPoint(0) = 1endPoint(1) = 1endPoint(2) = 1Set lineObj = ThisDrawing.ModelSpace. _AddLine(startPoint, endPoint)lineObj.Update将端点更改为 4,4,4 拉长直线endPoint(0) = 4endPoint(1) = 4endPoint(2) = 4lineObj.endPoint = endPointlineObj.UpdateEnd Sub3.12 Sub Ch4_ExplodePolyline()本例创建一个优化多段线对象，然后将多段线分解成多个对象。接着遍历产生的对象，显示含有每个对象名称的消息框，并显示分解对象在列表中的索引。Dim plineObj As AcadLWPolylineDim points(0 To 11) As Double 定义二维多段线的点points(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 创建优化多段线对象Set plineObj = ThisDrawing.ModelSpace. _AddLightWeightPolyline(points)在某个线段上设置凸度以改变 多段线中的对象类型plineObj.SetBulge 3, -0.5plineObj.Update 分解多段线Dim explodedObjects As VariantexplodedObjects = plineObj.Explode 遍历分解的对象 并以消息框来显示 每个对象的类型Dim I As IntegerFor I = 0 To UBound(explodedObjects)explodedObjects(I).UpdateMsgBox Exploded Object $ I $ : $ _explodedObjects(I).ObjectNameexplodedObjects(I).Update NextEnd Sub3.13 Sub Ch4_EditPolyline()本例创建一条优化多段线，然后向多段线的第三段添加凸度，向多段线附加顶点，修改最后一段的宽度，最后闭合多段线。Dim plineObj As AcadLWPolylineDim points(0 To 9) As Double 定义二维多段线的点points(0) = 1: points(1) = 1points(2) = 1: points(3) = 2points(4) = 2: points(5) = 2points(6) = 3: points(7) = 2points(8) = 4: points(9) = 4 创建优化多段线对象Set plineObj = ThisDrawing.ModelSpace. _AddLightWeightPolyline(points) 向线段 3 添加凸度plineObj.SetBulge 3, -0.5 定义新的顶点Dim newVertex(0 To 1) As DoublenewVertex(0) = 4: newVertex(1) = 1 向多段线添加顶点plineObj.AddVertex 5, newVertex 设置新线段的宽度plineObj.SetWidth 4, 0.1, 0.5 闭合多段线plineObj.Closed = TrueplineObj.UpdateEnd Sub3.14 Sub Ch4_AppendInnerLoopToHatch()本例创建一个关联的图案填充，然后创建一个圆并将该圆作为内部环附加到图案填充。Dim hatchObj As AcadHatchDim patternName As StringDim PatternType As LongDim bAssociativity As Boolean 定义和创建图案填充patternName = ANSI31PatternType = 0bAssociativity = TrueSet hatchObj = ThisDrawing.ModelSpace. _AddHatch(PatternType, patternName, bAssociativity) 创建图案填充的外部环Dim outerLoop(0 To 1) As AcadEntityDim center(0 To 2) As DoubleDim radius As DoubleDim startAngle As DoubleDim endAngle As Doublecenter(0) = 5: center(1) = 3: center(2) = 0 radius = 3startAngle = 0endAngle = 3.141592Set outerLoop(0) = ThisDrawing.ModelSpace. _AddArc(center, radius, startAngle, endAngle)Set outerLoop(1) = ThisDrawing.ModelSpace. _AddLine(outerLoop(0).startPoint, outerLoop(0).endPoint)将外部环附加到 Hatch 对象hatchObj.AppendOuterLoop (outerLoop)创建一个圆作为图案填充的内部环Dim innerLoop(0) As AcadEntitycenter(0) = 5: center(1) = 4.5: center(2) = 0 radius = 1Set innerLoop(0) = ThisDrawing.ModelSpace. _AddCircle(center, radius)将圆作为内部环附加到图案填充hatchObj.AppendInnerLoop (innerLoop) 计算并显示图案填充hatchObj.EvaluateThisDrawing.Regen TrueEnd Sub3.15 Sub Ch4_ChangeHatchPatternSpace()本例创建一个图案填充，然后将该图案填充的当前图案间距增加 2。Dim hatchObj As AcadHatchDim patternName As StringDim PatternType As LongDim bAssociativity As Boolean 定义图案填充patternName = ANSI31PatternType = 0bAssociativity = True创建关联的 Hatch 对象Set hatchObj = ThisDrawing.ModelSpace. _AddHatch(PatternType, patternName, bAssociativity) 创建图案填充的外部环Dim outerLoop(0 To 0) As AcadEntityDim center(0 To 2) As DoubleDim radius As Doublecenter(0) = 5center(1) = 3center(2) = 0 radius = 3Set outerLoop(0) = ThisDrawing.ModelSpace. _AddCircle(center, radius)hatchObj.AppendOuterLoop (outerLoop)hatchObj.Evaluate向当前间距加 2，以更改填充图案 的间距hatchObj.patternSpace = hatchObj.patternSpace + 2hatchObj.EvaluateThisDrawing.Regen TrueEnd Sub4 使用图层4.1 Sub Ch4_IteratingLayers()以下代码遍历 Layers 集合，以合并图形中所有图层的名称，然后将这些名称显示在消息框中。Dim layerNames As StringDim entry As AcadLayerlayerNames = For Each entry In ThisDrawing.LayerslayerNames = layerNames + entry.Name + vbCrLf NextMsgBox The layers in this drawing are: + _vbCrLf + layerNamesEnd Sub4.2 Sub Ch4_NewLayer()以下代码创建一个圆和一个新图层。新的图层指定使用红色。圆被指定到该图层，然后其颜色也相应改变。 创建圆Dim circleObj As AcadCircleDim center(0 To 2) As DoubleDim radius As Doublecenter(0) = 2: center(1) = 2: center(2) = 0 radius = 1Set circleObj = ThisDrawing.ModelSpace. _AddCircle(center, radius) 创建颜色对象Dim col As New AcadAcCmColorcol.ColorMethod = AutoCAD.acColorMethodForeground 设置图层的颜色Dim layColor As AcadAcCmColorSet layColor =AcadApplication.GetInterfaceObject(AutoCAD.AcCmColor.18)Call layColor.SetRGB(122, 199, 25)ThisDrawing.ActiveLayer.TrueColor = layColorcol.ColorMethod = AutoCAD.acColorMethodByLayer将圆的颜色指定为“BYLAYER”以便圆自动拾取所在图层的 颜色circleObj.Color = acByLayercircleObj.UpdateEnd Sub4.3 Sub Ch4_LayerInvisible()本例创建一个新的图层并在该图层上添加一个圆，然后关闭图层使圆不可见。 创建圆Dim circleObj As AcadCircleDim center(0 To 2) As DoubleDim radius As Doublecenter(0) = 2: center(1) = 2: center(2) = 0 radius = 1Set circleObj = ThisDrawing.ModelSpace. _AddCircle(center, radius) 创建新图层“ABC”Dim layerObj As AcadLayerSet layerObj = ThisDrawing.Layers.Add(ABC)将圆指定到“ABC”图层circleObj.Layer = ABCcircleObj.Update 关闭图层“ABC”layerObj.LayerOn