《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