zoukankan      html  css  js  c++  java
  • AutoCAD VBA实体填充

    AutoCAD VBA图案填充,包括图案填充、真彩色填充和渐变填充,代码如下。

    Public Function AddHatch(ByRef objList() As AcadEntity, ByVal patType As Integer, ByVal parName As String, ByVal associativity As Boolean) As AcadHatch
    On Error GoTo errHandle
    Dim objHatch As AcadHatch
    Set objHatch = ThisDrawing.ModelSpace.AddHatch(patType, patName, associativity, acHatchObject)
    objHatch.AppendOuterLoop (objList)
    objHatch.Evaluate
    ThisDrawing.Regen True
    Set AddHatch = objHatch
    Exit Function
    errHandle:
    If Err.Number = -2145386493 Then
    MsgBox "填充定义边界未闭合", vbCritical
    End If
    Err.Clear
    End Function
    Public Function AddHatchGC(ByRef objList() As AcadEntity, ByVal parType As Integer, ByVal parName As String, ByVal associativity As Double, ByVal color1 As AcadAcCmColor, ByVal color2 As AcadAcCmColor) As AcadHatch
    On Error GoTo errHandle
    Dim objHatch As AcadHatch
    Set objHatch = ThisDrawing.ModelSpace.AddHatch(patType, patName, True, acGradientObject)
    objHatch.GradientColor1 = color1
    objHatch.GradientColor2 = color2
    objHatch.AppendOuterLoop (objList)
    objHatch.Evaluate
    ThisDrawing.Regen True
    Set AddHatchGC = objHatch
    Exit Function
    errHandle:
    If Err.Number = -2145386493 Then
    MsgBox "填充定义边界未闭合", vbCritical
    End If
    Err.Clear
    End Function
    Public Function AddHatchPt(ByRef ptArr() As Double, ByVal parType As Integer, ByVal patName As String, ByVal associativity As Boolean) As AcadHatch
    Dim objPline As AcadLWPolyline
    If (UBound(ptArr) + 1) Mod 2 Then
    MsgBox "数组元素必须为偶数"
    Exit Function
    End If
    Set objPline = ThisDrawing.ModelSpace.AddLightWeightPolyline(ptArr)
    objPline.Closed = True
    Dim objList(0) As AcadEntity
    Set objList(0) = objPline
    Set AddHatchPt = AddHatch(objList, patType, patName, associativity)
    End Function
    Public Function AddHatchTC(ByRef objList() As AcadEntity, ByVal patName As Integer, ByVal associativity As Boolean, ByVal color As AcadAcCmColor) As AcadHatch
    On Error GoTo errHandle
    Dim objHatch As AcadHatch
    Set objHatch = ThisDrawing.ModelSpace.AddHatch(patType, "LINEAR", True, acGradientObject)
    objHatch.GradientColor1 = color
    objHatch.GradientColor2 = color
    objHatch.AppendOuterLoop (objList)
    objHatch.Evaluate
    ThisDrawing.Regen True
    Set AddHatchTC = objHatch
    Exit Function
    errHandle:
    If Err.Number = -2145386493 Then
    MsgBox "填充边界闭合!", vbCritical
    End If
    Err.Clear
    End Function
    Public Function MoveEntity(ByVal objEntity As AcadEntity, ByVal x As Double, ByVal y As Double, Optional z As Double = 0)
    Dim ptBase(2) As Double
    Dim ptDest(2) As Double
    ptBase(0) = 0: ptBase(1) = 0: ptBase(2) = 0
    ptDest(0) = x: ptDest(1) = y: ptDest(2) = z
    objEntity.Move ptBase, ptDest
    End Function
    Public Sub TestHatch()
    Dim objList(1) As AcadEntity
    Dim pt(0 To 2) As Double
    Dim objArc As AcadArc
    Dim objLine As AcadLine
    Dim objCircle As AcadCircle
    pt(0) = 100: pt(1) = 100: pt(2) = 0
    Set objArc = ThisDrawing.ModelSpace.AddArc(pt, 30, 0, 2.5)
    Set objLine = ThisDrawing.ModelSpace.AddLine(objArc.StartPoint, objArc.EndPoint)
    Set objList(0) = objArc
    Set objList(1) = objLine
    AddHatch objList, 0, "ANSI31", True
    Dim color As AcadAcCmColor
    Set color = AcadApplication.GetInterfaceObject("AutoCAD.AcCmColor.16")
    Call color.SetRGB(0, 255, 127)
    Set objList(0) = objArc.Copy
    MoveEntity objList(0), 0, 30
    Set objList(1) = objLine.Copy
    MoveEntity objList(1), 0, 30
    AddHatchTC objList, 0, True, color
    Dim color2 As AcadAcCmColor
    Set color2 = AcadApplication.GetInterfaceObject("autocad.accmcolor.16")
    color2.SetRGB 255, 0, 25
    Set objList(0) = objArc.Copy
    MoveEntity objList(0), 80, 30
    Set objList(1) = objLine.Copy
    MoveEntity objList(1), 80, 30
    AddHatchTC objList, 0, True, color
    AddHatchGC objList, 0, "LINEAR", True, color, color2
    Dim ptArr(7) As Double
    ptArr(0) = 160: ptArr(1) = 90: ptArr(2) = 200: ptArr(3) = 90
    ptArr(4) = 200: ptArr(5) = 120: ptArr(6) = 160: ptArr(7) = 120
    AddHatchPt ptArr, o, "ANSI31", True
    End Sub

    代码完。

    作者:codee
    文章千古事,得失寸心知。


  • 相关阅读:
    分治与线段树
    PAT甲级 1006
    PAT甲级 1001
    单源最短路 Dijkstra
    图的邻接矩阵与邻接表
    Huffman树 建树方法代码实现
    小根堆模板类
    二叉搜索树的搜索和插入与删除算法优化
    完全二叉树模板
    二叉树模板及二叉树的无递归遍历
  • 原文地址:https://www.cnblogs.com/bimgoo/p/2502918.html
Copyright © 2011-2022 走看看