第一篇：AutoCAD实体类



《AutoCADVBA开发精彩实例教程》书中源码

Option Explicit

'*********************************************************************************
'创建点的基准函数
Public Function AddPoint(ByVal pt As Variant) As AcadPoint
    Set AddPoint = ThisDrawing.ModelSpace.AddPoint
End Function

'使用点的X、Y坐标创建点
Public Function AddPointXY(ByVal x As Double, ByVal y As Double) As AcadPoint
    Dim pt(2) As Double
   
    pt(0) = x: pt(1) = y: pt(2) = 0
    Set AddPointXY = AddPoint(pt)
End Function

'*************************************************************************************
'创建直线的基准函数
Public Function AddLine(ByVal ptSt As Variant, ByVal ptEn As Variant) As AcadLine
    Set AddLine = ThisDrawing.ModelSpace.AddLine(ptSt, ptEn)
End Function

'直接根据坐标创建直线
Public Function AddLineXY(ByVal x1 As Double, ByVal y1 As Double, ByVal x2 As Double, _
    ByVal y2 As Double) As AcadLine
   
    Dim pt1(2), pt2(2) As Double
   
    pt1(0) = x1: pt1(1) = y1: pt1(2) = 0
    pt2(0) = x2: pt2(1) = y2: pt2(2) = 0
   
    Set AddLineXY = AddLine(pt1, pt2)
End Function

'*****************************************************************************************
'创建新图层
Public Function AddLayer(ByVal name As String) As AcadLayer
    Dim i As Integer
   
    For i = 0 To ThisDrawing.Layers.Count - 1
        If ThisDrawing.Layers.Item(i).name = name Then
            MsgBox "该图层已存在！"
            Exit Function
        End If
    Next
   
    Set AddLayer = ThisDrawing.Layers.Add(name)
End Function

'**********************************************************************************************
'创建圆弧
'基本方法：圆心、起点和终点角度
Public Function AddArcCSEA(ByVal ptCen As Variant, ByVal radius As Double, _
    ByVal stAng As Double, ByVal enAng As Double) As AcadArc
    '定义错误处理的方法
    On Error GoTo errHandle
   
    Dim objArc As AcadArc
   
    Set objArc = ThisDrawing.ModelSpace.AddArc(ptCen, radius, stAng, enAng)
    '下面的两个语句为示例所用，如果在正式工程中，请删去(下同)
    objArc.color = acBlue
    objArc.Update
   
    '返回创建的对象
    Set AddArcCSEA = objArc
   
errHandle:
    MsgBox Err.Description
End Function

'圆心、起点和终点
Public Function AddArcCSEP(ByVal ptCen As Variant, ByVal ptSt As Variant, ByVal ptEn As Variant) As AcadArc
    Dim objArc As AcadArc
    Dim radius As Double
    Dim stAng, enAng As Double
   
    '计算半径
    radius = GetDistance(ptCen, ptSt)
    '计算起点角度和终点角度
    stAng = ThisDrawing.Utility.AngleFromXAxis(ptCen, ptSt)
    enAng = ThisDrawing.Utility.AngleFromXAxis(ptCen, ptEn)
   
    Set objArc = ThisDrawing.ModelSpace.AddArc(ptCen, radius, stAng, enAng)
    objArc.color = acCyan
    objArc.Update
   
    Set AddArcCSEP = objArc
End Function

'圆心、起点和角度
Public Function AddArcCSPA(ByVal ptCen As Variant, ByVal ptSt As Variant, ByVal angle As Double) As AcadArc
    Dim objArc As AcadArc
    Dim ptEn As Variant
    Dim angTemp As Double
    Dim radius As Double
   
    angTemp = ThisDrawing.Utility.AngleFromXAxis(ptCen, ptSt)
    angTemp = angTemp + angle
    radius = distance(ptCen, ptSt)
   
    ptEn = ThisDrawing.Utility.PolarPoint(ptCen, angTemp, radius)
   
    '调用已经定义的函数
    Set AddArcCSPA = AddArcCSEP(ptCen, ptSt, ptEn)
End Function

'三点法
Public Function AddArc3Pt(ByVal ptSt As Variant, ByVal ptSc As Variant, ByVal ptEn As Variant) As AcadArc
    'Dim objarc As AcadArc
    Dim ptCen As Variant
    Dim radius As Double
   
    ptCen = GetCenOf3Pt(ptSt, ptSc, ptEn, radius)
   
    Set AddArc3Pt = AddArcCSEP(ptCen, ptSt, ptEn)
End Function

'圆心、起点和圆弧长度
Public Function AddArcCSPL(ByVal ptCen As Variant, ByVal ptSt As Variant, ByVal length As Double) As AcadArc
    Dim radius As Double
    Dim angle As Double
   
    radius = distance(ptCen, ptSt)
    angle = length / radius
   
    Set AddArcCSPL = AddArcCSPA(ptCen, ptSt, angle)
End Function

'***********************************************************************************************
'创建圆形
'圆心、半径方法
Public Function AddCirCR(ByVal ptCen As Variant, ByVal radius As Variant) As AcadCircle
    'Dim ptCen(0 To 2) As Double
    'Dim radius As Double
    Dim objCir As AcadCircle
   
    'ptCen(0) = 50: ptCen(1) = 50: ptCen(2) = 0
    'radius = 30
    Set objCir = ThisDrawing.ModelSpace.AddCircle(ptCen, radius)
   
    objCir.color = acBlue
    objCir.Update
   
    Set AddCirCR = objCir
End Function

'圆心、直径方法
Public Function AddCirCD(ByVal ptCen As Variant, ByVal diameter As Variant) As AcadCircle
    'Dim ptCen(0 To 2) As Double
    'Dim diameter As Double
    Dim objCir As AcadCircle
   
    'ptCen(0) = 100: ptCen(1) = 50: ptCen(2) = 0
    'diameter = 80
    Set objCir = ThisDrawing.ModelSpace.AddCircle(ptCen, diameter / 2)
   
    objCir.color = acCyan
    objCir.Update
   
    Set AddCirCD = objCir
End Function

'两点法
Public Function AddCir2P(ByVal pt1 As Variant, ByVal pt2 As Variant) As AcadCircle
    Dim ptCen(0 To 2) As Double
    Dim objCir As AcadCircle
    Dim diameter As Double
   
    '获得圆心位置
    ptCen(0) = (pt1(0) + pt2(0)) / 2
    ptCen(1) = (pt1(1) + pt2(1)) / 2
    ptCen(2) = 0
    '获得直径
    diameter = Sqr((pt2(0) - pt1(0)) ^ 2 + (pt2(1) - pt1(1)) ^ 2) / 2
   
    Set objCir = ThisDrawing.ModelSpace.AddCircle(ptCen, diameter / 2)
    objCir.color = acGreen
    objCir.Update
   
    '返回值
    Set AddCir2P = objCir
End Function

'三点法
'算法基础
'/*  +-----------------------------------------------------------------+ */
'/*  |  The equation of a arc based on 3 points is :                   | */
'/*  |        | X**2+Y**2-x1**2-y1**2      X-X1       Y-y1 |           | */
'/*  |        |                                            |           | */
'/*  |        | x1**2+y1**2-x2**2-y2**2   x1-x2      y1-y2 | = 0       | */
'/*  |        |                                            |           | */
'/*  |        | x2**2+y2**2-x3**2-y3**2   x2-x3      y2-y3 |           | */
'/*  |                                                                 | */
'/*  +-----------------------------------------------------------------+ */
Public Function AddCir3P(ByVal pt1 As Variant, ByVal pt2 As Variant, ByVal pt3 As Variant) As AcadCircle

    Dim xysm, xyse, xy As Double
    Dim ptCen(0 To 2) As Double
    Dim radius As Double
    Dim objCir As AcadCircle
   
    xy = pt1(0) ^ 2 + pt1(1) ^ 2
    xyse = xy - pt3(0) ^ 2 - pt3(1) ^ 2
    xysm = xy - pt2(0) ^ 2 - pt2(1) ^ 2
    xy = (pt1(0) - pt2(0)) * (pt1(1) - pt3(1)) - (pt1(0) - pt3(0)) * (pt1(1) - pt2(1))
   
    '判断参数有效性
    If Abs(xy) < 0.000001 Then
        MsgBox "所输入的参数无法创建圆形！"
        Exit Function
    End If
   
    '获得圆心和半径
    ptCen(0) = (xysm * (pt1(1) - pt3(1)) - xyse * (pt1(1) - pt2(1))) / (2 * xy)
    ptCen(1) = (xyse * (pt1(0) - pt2(0)) - xysm * (pt1(0) - pt3(0))) / (2 * xy)
    ptCen(2) = 0
    radius = Sqr((pt1(0) - ptCen(0)) * (pt1(0) - ptCen(0)) + (pt1(1) - ptCen(1)) * (pt1(1) - ptCen(1)))
   
    If radius < 0.000001 Then
        MsgBox "半径过小！"
        Exit Function
    End If
   
    Set objCir = ThisDrawing.ModelSpace.AddCircle(ptCen, radius)
    objCir.color = acRed
    objCir.Update
   
    '由于返回值是对象，必须加上set
    Set AddCir3P = objCir
   
End Function

'****************************************************************************************
'创建多段线
'创建轻量多段线（只有两个顶点的直线多段线）
Public Function AddLPlineSeg(ByVal ptSt As Variant, ByVal ptEn As Variant, ByVal width As Double) As AcadLWPolyline
    Dim objPline As AcadLWPolyline
    Dim ptArr(0 To 3) As Double
   
    ptArr(0) = ptSt(0)
    ptArr(1) = ptSt(1)
    ptArr(2) = ptEn(0)
    ptArr(3) = ptEn(1)
   
    Set objPline = ThisDrawing.ModelSpace.AddLightWeightPolyline(ptArr)
    objPline.ConstantWidth = width
    objPline.Update
    Set AddLightPline = objPline
End Function

'使用点数组创建轻量多段线(number为数组的元素个数)
Public Function AddLPline(ByRef pt() As Double, ByVal width As Double) As AcadLWPolyline
    Dim objPline As AcadLWPolyline
    On Error GoTo errHandle
   
    If UBound(pt) + 1 Mod 2 <> 0 Then
        MsgBox "数组元素个数必须为偶数！"
    End If
   
    Set objPline = ThisDrawing.ModelSpace.AddLightWeightPolyline(pt)
    objPline.ConstantWidth = width
    objPline.Update
   
    Set AddLPline = objPline
    Exit Function
errHandle:
    MsgBox "数组元素个数与参数不符！"
    'MsgBox Err.Description
End Function

'创建单段多段线
Public Function AddPlineSeg(ByVal ptSt As Variant, ByVal ptEn As Variant, ByVal width As Double) As AcadPolyline
    Dim objPline As AcadPolyline
    Dim ptArr(0 To 5) As Double
   
    ptArr(0) = ptSt(0)
    ptArr(1) = ptSt(1)
    ptArr(2) = ptSt(2)
    ptArr(3) = ptEn(0)
    ptArr(4) = ptEn(1)
    ptArr(5) = ptEn(2)
   
    Set objPline = ThisDrawing.ModelSpace.AddPolyline(ptArr)
    objPline.ConstantWidth = width
    objPline.Update
   
    Set AddPlineSeg = objPline
End Function

'使用点组创建多段线
Public Function AddPline(ByRef pt() As Double, ByVal width As Double) As AcadPolyline
    Dim objPline As AcadPolyline
    On Error GoTo errHandle
   
    If UBound(pt) + 1 Mod 3 <> 0 Then
        MsgBox "数组元素个数必须为3的倍数！"
    End If
   
    Set objPline = ThisDrawing.ModelSpace.AddPolyline(ptArr)
    objPline.ConstantWidth = width
    objPline.Update
   
    Set AddLPline = objPline
    Exit Function
errHandle:
    MsgBox "数组元素个数与参数不符！"
    'MsgBox Err.Description
End Function

'************************************************************************************************
'创建矩形
Public Function AddRectangle(ByVal pt1 As Variant, ByVal pt2 As Variant, ByVal width As Double) As AcadLWPolyline
    Dim ptArr(7) As Double
    Dim objPline As AcadLWPolyline
   
    If pt1(0) = pt2(0) Or pt1(1) = pt2(1) Then
        MsgBox "创建矩形失败！"
        Exit Function
    End If
   
    ptArr(0) = MinDouble(pt1(0), pt2(0)): ptArr(1) = MaxDouble(pt1(1), pt2(1))
    ptArr(2) = MinDouble(pt1(0), pt2(0)): ptArr(3) = MinDouble(pt1(1), pt2(1))
    ptArr(4) = MaxDouble(pt1(0), pt2(0)): ptArr(5) = MinDouble(pt1(1), pt2(1))
    ptArr(6) = MaxDouble(pt1(0), pt2(0)): ptArr(7) = MaxDouble(pt1(1), pt2(1))
   
    Set objPline = ThisDrawing.ModelSpace.AddLightWeightPolyline(ptArr)
    objPline.Closed = True
    Set AddRectangle = objPline
End Function

'创建正多边形
Public Function AddPolygon()
   
End Function

'**************************************************************************************************
'创建多线的基准函数
Public Function AddMline(ByRef ptArr() As Double) As AcadMLine
    If (UBound(ptArr) + 1) Mod 3 <> 0 Then
        MsgBox "数组元素有误！"
        Exit Function
    End If
   
    Set AddMline = ThisDrawing.ModelSpace.AddMline(ptArr)
End Function

'********************************************************************************************
'创建椭圆和椭圆弧
'创建椭圆的函数(点ptMajAxis定义了一个矢量)
Public Function AddEllipse(ByVal ptCen As Variant, ByVal ptmajAxis As Variant, ByVal radRatio As Double) As AcadEllipse
    Set AddEllipse = ThisDrawing.ModelSpace.AddEllipse(ptCen, ptmajAxis, radRatio)
End Function

'通过外接矩形创建椭圆
Public Function AddEllipseRec(ByVal pt1 As Variant, ByVal pt2 As Variant) As AcadEllipse
    Dim majAxisLen, minAxisLen As Double
    Dim ptCen As Variant
    Dim radRatio As Double
    Dim ptmajAxis(0 To 2) As Double
   
    majAxisLen = Abs(pt1(0) - pt2(0))
    minAxisLen = Abs(pt1(1) - pt2(1))
    radRatio = minAxisLen / majAxisLen
   
    '根据长轴所在的坐标轴调整数据
    If radRatio < 1 Then
        ptmajAxis(0) = majAxisLen / 2: ptmajAxis(1) = 0: ptmajAxis(2) = 0
    ElseIf radRatio > 1 Then
        ptmajAxis(0) = 0: ptmajAxis(1) = minAxisLen / 2: ptmajAxis(2) = 0
        radRatio = 1 / radRatio
    Else
        MsgBox "参数错误，无法创建椭圆！"
        Exit Function
    End If
   
    ptCen = GetMidPt(pt1, pt2)
    Set AddEllipseRec = AddEllipse(ptCen, ptmajAxis, radRatio)
End Function

'*******************************************************************************************
'创建样条曲线
Public Function AddSpline(ByRef ptArr() As Double, ByVal vecSt As Variant, _
    ByVal vecEn As Variant) As AcadSpline
   
    '错误处理：判断数组的有效性
    If (UBound(ptArr) + 1) Mod 3 <> 0 Then
        MsgBox "数组参数无法创建样条曲线！"
        Exit Function
    End If
   
    Set AddSpline = ThisDrawing.ModelSpace.AddSpline(ptArr, vecSt, vecEn)
End Function

'*********************************************************************************************
'创建填充对象的基准函数
'patType:0为预定义图案，1为用户定义图案。HatchObjectType:0为普通填充，1为渐变填充
Public Function AddHatch(ByVal patType As Integer, ByVal patName As String, _
    ByVal Associativity As Boolean, ByVal HatchObjectType As Integer) As AcadHatch
    Dim hatchObj As AcadHatch
   
    Set hatchObj = ThisDrawing.ModelSpace.AddHatch(PatternType, PatternName, bAssociativity, acGradientObject)
    Dim col1 As AcadAcCmColor, col2 As AcadAcCmColor
    Set col1 = AcadApplication.GetInterfaceObject("AutoCAD.AcCmColor.16")
    Set col2 = AcadApplication.GetInterfaceObject("AutoCAD.AcCmColor.16")
    Call col1.SetRGB(255, 0, 0)
    Call col2.SetRGB(0, 255, 0)
    hatchObj.GradientColor1 = col1
    hatchObj.GradientColor2 = col2
   
    ' Create the outer boundary for the hatch (a circle)
    Dim outerLoop(0 To 0) As AcadEntity
    Dim center(0 To 2) As Double
    Dim radius As Double
    center(0) = 3: center(1) = 3: center(2) = 0
    radius = 1
    Set outerLoop(0) = ThisDrawing.ModelSpace.AddCircle(center, radius)
   
    hatchObj.AppendOuterLoop (outerLoop)
    hatchObj.Evaluate
    ThisDrawing.Regen True

End Function

'*******************************************************************************************
'创建一定角度的单行文字
Public Function AddTextA(ByVal text As String, ByVal ptInsert As Variant, _
    ByVal height As Double, ByVal angle As Double) As AcadText
    Dim objText As AcadText
   
    Set objText = ThisDrawing.ModelSpace.AddText(text, ptInsert, height)
    objText.Rotate ptInsert, angle
    objText.Update
   
    Set AddText = objText
End Function

'基准的单行文字函数
Public Function AddText(ByVal text As String, ByVal ptInsert As Variant, ByVal height As Double) As AcadText
    Set AddText = ThisDrawing.ModelSpace.AddText(text, ptInsert, height)
End Function

'********************************************************************************************
'基准的多行文字函数
Public Function AddMtext(ByVal ptInsert As Variant, ByVal width As Double, ByVal text As String) As AcadMText
    Set AddMtext = ThisDrawing.ModelSpace.AddMtext(ptInsert, width, text)
End Function