AutoCAD VBA尺寸标注，包括转角标注、对齐标注、角度标注、半径标注、直径标注和坐标标注，代码如下。
Public Function AddDimAligned(ByVal pt1 As Variant, ByVal pt2 As Variant, ByVal ptText As Variant) As AcadDimAligned
Set AddDimAligned = ThisDrawing.ModelSpace.AddDimAligned(pt1, pt2, ptText)
End Function
Public Function AddDimAlignedCTxt(ByVal pt1 As Variant, ByVal pt2 As Variant, ByVal ptText As Variant, ByVal text As String, Optional x As Double = 0, Optional y As Double = 0) As AcadDimAligned
Dim objDim As AcadDimAligned
Set objDim = AddDimAligned(pt1, pt2, ptText)
objDim.TextOverride = text
objDim.TextMovement = acMoveTextAddLeader
ptText(0) = ptText(0) + x
ptText(1) = ptText(1) + y
objDim.TextPosition = ptText
objDim.Update
Set AddDimAlignedCTxt = objDim
End Function
Public Function AddDimRotated(ByVal pt1 As Variant, ByVal pt2 As Variant, ByVal ptText As Variant, ByVal angle As Double) As AcadDimRotated
Set AddDimRotated = ThisDrawing.ModelSpace.AddDimRotated(pt1, pt2, ptText, angle)
End Function
Public Function AddDimRotateCTxt(ByVal pt1 As Variant, ByVal pt2 As Variant, ByVal ptText As Variant, ByVal angle As Double, ByVal text As String) As AcadDimRotated
Dim objDim As acaddimrote
Set objDim = AddDimRotated(pt1, pt2, ptText, angle, text)
objDim.TextOverride = text
Set addDimRotatedCTxt = objDim
End Function
Public Function AddDimRadial(ByVal ptCen As Variant, ByVal ptChord As Variant, ByVal leaderLength As Double) As AcadDimRadial
Set AddDimRadial = ThisDrawing.ModelSpace.AddDimRadial(ptCen, ptChord, leaderLength)
End Function
Public Function AddDimRadialAR(ByVal ptCen As Variant, ByVal radius As Double, ByVal angle As Double, Optional leaderLength As Double = 5) As AcadDimRadial
Dim ptChord As Variant
ptChord = GetPointAR(ptCen, angle, radius)
Set AddDimRadiusAR = AddDimRadial(ptCen, ptChord, leaderLength)
End Function
Public Function AddDimDiametrc(ByVal ptChord1 As Variant, ByVal ptChord2 As Variant, ByVal leaderLength As Double) As AcadDimDiametric
Set AddDimDiametric = ThisDrawing.ModelSpace.AddDimDiametric(ptChord1, ptChord2, leaderLength)
End Function
Public Function AddDiametricAR(ByVal ptCen As Variant, ByVal radius As Double, ByVal angle As Double, Optional leaderLength As Double = 5) As AcadDimDiametric
Dim ptChord1, ptChord2 As Variant
ptChord1 = GetPointAR(ptCen, angle, radius)
ptChord2 = GetPointAR(ptCen, angle + PI, radius)
Set adddimdiametricAR = AddDimDiametric(ptChord1, ptChord2, leaderLength)
End Function
Public Function AddDimAngular(ByVal ptVertex As Variant, ByVal ptSt As Variant, ByVal ptEn As Variant, ByVal ptText As Variant) As AcadDimAngular
Set AddDimAngular = ThisDrawing.ModelSpace.AddDimAngular(ptVertex, ptSt, ptEn, ptText)
End Function
Public Function AddDimAngularPO(ByVal ptVertex As Variant, ByVal ptSt As Variant, ByVal ptEn As Variant, Optional offset As Double = 5) As AcadDimAngular
Dim ptTemp As Variant
Dim angle As Double
Dim radius As Double
If getanglefromx(ptVertex, ptEn) < getanglefromx(ptVertex, ptSt) Then
angle = (2 * PI - getanglefromx(ptVertex, ptSt) + getanglefromx(ptVertex, ptEn)) / 2
Else
angle = (getanglefromx(ptVertex, ptEn) - getanglefromx(ptVertex, ptSt)) / 2
End If
radius = GetDistance(ptVertex, ptSt)
ptTemp = GetPointAR(ptVertex, angle, radius, offset)
Set AddDimAngularPO = AddDimAngular(ptVertex, ptSt, ptEn, ptTemp)
End Function
Public Function AddDimOrdinate(ByVal ptDef As Variant, ByVal ptText As Variant, ByVal xAxis As Boolean) As AcadDimOrdinate
Set addDimordinates = ThisDrawing.ModelSpace.AddDimOrdinate(ptDef, ptText, xAxis)
End Function
Public Function AddDimOrdinateXY(ByVal ptDef As Variant, ByVal ptTextX As Variant, ByVal ptTextY As Variant)
ThisDrawing.ModelSpace.AddDimOrdinate ptDef, ptTextX, True
ThisDrawing.ModelSpace.AddDimOrdinate ptDef, ptTextY, False
End Function
Public Function AddDimOrdStandard(ByVal ptDef As Variant, ByVal x1 As Double, ByVal y2 As Double, Optional y1 As Double = 0, Optional x2 As Double = 0)
Dim ptTextX(2) As Double
Dim ptTextY(2) As Double
ptTextX(0) = ptDef(0) + x2: ptTextX(1) = ptDef(1) + y2: ptTextX(2) = 0
ptTextY(0) = ptDef(0) + x1: ptTextY(1) = ptDef(1) + y1: ptTextY(2) = 0
AddDimOrdinateXY ptDef, ptTextX, ptTextY
End Function
Public Sub TestDim()
Dim pt1(0 To 2) As Double
pt1(0) = 200: pt1(1) = 160: pt1(2) = 0
Dim pt2, pt3, pt4, pt5 As Variant
pt2 = GetPoint(pt1, -40, 0)
pt3 = GetPoint(pt2, 7 * PI / 6, 20)
pt4 = GetPoint(pt3, 6, -10)
pt5 = GetPoint(pt1, 0, -20)
ThisDrawing.ModelSpace.AddLine pt1, pt2
ThisDrawing.ModelSpace.AddLine pt2, pt3
ThisDrawing.ModelSpace.AddLine pt3, pt4
ThisDrawing.ModelSpace.AddLine pt4, pt5
ThisDrawing.ModelSpace.AddLine pt5, pt1
Dim ptCen1, ptCen2 As Variant
ptCen1 = GetPoint(pt3, 16, 0)
ptCen2 = GetPoint(ptCen1, 25, 0)
ThisDrawing.ModelSpace.AddCircle ptCen1, 3
ThisDrawing.ModelSpace.AddCircle ptCen2, 4
Dim ptTemp1, ptTemp2 As Variant
ptTemp1 = GetPoint(pt1, -20, 3)
AddDimRotated pt1, pt2, ptTemp1, o
ptTemp1 = GetPoint(pt1, 4, 10)
AddDimRotated pt1, pt5, tpTemp1, PI / 2
ptTemp1 = GetPoint(pt3, -3, -6)
AddDimRotated pt3, pt4, ptTemp1, 7 * PI / 4
ptTemp1 = GetPoint(pt2, -3, 4)
AddDimAlignedCTxt pt2, pt3, ptTemp1, "new position", 4, 10
ptTemp1 = GetPoint(pt5, -5, 5)
AddDimAngular pt5, pt1, pt4, ptTemp1
ptTemp1 = GetPointAR(ptCen1, PI / 4, 3)
AddDimRadial ptCen1, ptTemp1, -3
ptTemp1 = GetPointAR(ptCen2, PI / 4, 4)
ptTemp2 = GetPointAR(ptCen2, PI / 4, 4)
AddDimDiametric ptTemp2, ptTemp1, o
AddDimOrdStandard ptCen2, 10, -10
End Sub
代码完。