[编程交流] VBA-创建标注样式

Option Explicit
Sub New_Layer()
Dim acadApp As AcadApplication
Dim acadDoc As AcadDocument
Dim mSp As AcadModelSpace
Dim dimstyle As AcadDimStyle
Dim sDim As AcadDimAligned
Dim point1(0 To 2) As Double
Dim point2(0 To 2) As Double
Dim location(0 To 2) As Double
'Check if AutoCAD is open.
On Error Resume Next
Set acadApp = GetObject(, "AutoCAD.Application")
On Error GoTo 0
'If AutoCAD is not opened create a new instance and make it visible.
If acadApp Is Nothing Then
Set acadApp = New AcadApplication
acadApp.Visible = True
End If
'Check if there is an active drawing.
On Error Resume Next
Set acadDoc = acadApp.ActiveDocument
On Error GoTo 0
'No active drawing found. Create a new one.
If acadDoc Is Nothing Then
Set acadDoc = acadApp.Documents.Add
acadApp.Visible = True
End If
Set mSp = acadDoc.ModelSpace
'Dimension points
point1(0) = 0#: point1(1) = 5#: point1(2) = 0#
point2(0) = 6.1: point2(1) = 5: point2(2) = 0#
location(0) = 5#: location(1) = 4.4: location(2) = 0#
'Add dimension
Set sDim = acadDoc.ModelSpace.AddDimAligned(point1, point2, location)
'Set dimension properties
sDim.Color = acByLayer
sDim.ExtensionLineExtend = 0
sDim.Arrowhead1Type = acArrowOblique
sDim.Arrowhead2Type = acArrowOblique
sDim.ArrowheadSize = 0.1
sDim.TextColor = acGreen
sDim.TextHeight = 0.2
sDim.UnitsFormat = acDimLDecimal
sDim.PrimaryUnitsPrecision = acDimPrecisionOne
sDim.TextGap = 0.1
sDim.LinearScaleFactor = 100
sDim.ExtensionLineOffset = 0.1
sDim.VerticalTextPosition = acOutside
'Create a new dimension style
Set dimstyle = acadDoc.DimStyles.Add("D100")
'Copy dimension properties from previously added dimension
dimstyle.CopyFrom (sDim)
'Delete dimension
sDim.Delete
End Sub

dimstyle.CopyFrom (sDim)