AcadDimRotated的基本用法

兰州人

在平常的画图中有时，标注的尺寸格式不统一，下面的程序能对AcadDimRotated的尺寸格式进行统一。

3. Function CreatSelectionSet(InputEntityObjectName As Variant) As AcadSelectionSet
4.     On Error Resume Next
5.     'Dim SSet As AcadSelectionSet
6.     If Not IsNull(ThisDrawing.SelectionSets.Item("SelectEntity")) Then
7.       Set CreatSelectionSet = ThisDrawing.SelectionSets.Item("SelectEntity")
8.       CreatSelectionSet.Delete
9.     End If
10.     Set CreatSelectionSet = ThisDrawing.SelectionSets.Add("SelectEntity")
11.     Pt1 = ThisDrawing.Utility.GetPoint(, "Input First Point")
12.     Pt2 = ThisDrawing.Utility.GetCorner(Pt1, "Input First Point")
13.     Dim gpCode(0) As Integer
14.     Dim dataValue(0) As Variant
15.     gpCode(0) = 0
16.     For ii = 0 To UBound(InputEntityObjectName)
17.       dataValue(ii) = InputEntityObjectName(ii)
18.     Next ii
19.     CreatSelectionSet.Select acSelectionSetWindow, Pt1, Pt2, gpCode, dataValue
20. End Function
21. Sub ChangeDimensionData()
22.     Dim SSet As AcadSelectionSet
23.     Dim InputEntityObjectName As Variant
24.     InputEntityObjectName = Array("Dimension")
25.     Set SSet = CreatSelectionSet(InputEntityObjectName)
26.     Dim Ent As AcadEntity
27.     Dim objDimension As AcadDimension
28.     Dim RotatedDimensionEntity As AcadDimRotated
29.     'RotatedDimensionEntity.ExtensionLineColor=acByLayer
30.     For Each objDimension In SSet
31.       With objDimension
32.         
33.         If .ObjectName = "AcDbRotatedDimension" _
34.           Or .ObjectName = "AcDbRadialDimension" _
35.           Or .ObjectName = "AcDbAlignedDimension" Then
36.           .LinearScaleFactor = 2
37.         End If
38.         Debug.Print .ObjectName
39.         .Layer = "尺寸线"
40.         .TextHeight = 3.5
41.         .DecimalSeparator = "."
42.         .TextColor = acByLayer
43.         .DimensionLineColor = acByLayer
44.         
45.         
46. If .ObjectName = "AcDbRotatedDimension" _
47.     Or .ObjectName = "AcDbAlignedDimension" Then
48.         .ExtensionLineColor = acByLayer
49. End If
50.         .TextStyle = "WMF-宋体0"
51.         
52.         
53.       End With
54.       'Debug.Print Ent.ObjectName
55.     Next objDimension
56. End Sub

Function CreatSelectionSet(InputEntityObjectName As Variant) As AcadSelectionSet     On Error Resume Next     'Dim SSet As AcadSelectionSet     If Not IsNull(ThisDrawing.SelectionSets.Item("SelectEntity")) Then       Set CreatSelectionSet = ThisDrawing.SelectionSets.Item("SelectEntity")       CreatSelectionSet.Delete     End If     Set CreatSelectionSet = ThisDrawing.SelectionSets.Add("SelectEntity")     Pt1 = ThisDrawing.Utility.GetPoint(, "Input First Point")     Pt2 = ThisDrawing.Utility.GetCorner(Pt1, "Input First Point")     Dim gpCode(0) As Integer     Dim dataValue(0) As Variant     gpCode(0) = 0     For ii = 0 To UBound(InputEntityObjectName)       dataValue(ii) = InputEntityObjectName(ii)     Next ii     CreatSelectionSet.Select acSelectionSetWindow, Pt1, Pt2, gpCode, dataValue End Function Sub ChangeDimensionData()     Dim SSet As AcadSelectionSet     Dim InputEntityObjectName As Variant     InputEntityObjectName = Array("Dimension")     Set SSet = CreatSelectionSet(InputEntityObjectName)     Dim Ent As AcadEntity     Dim objDimension As AcadDimension     Dim RotatedDimensionEntity As AcadDimRotated     'RotatedDimensionEntity.ExtensionLineColor=acByLayer     For Each objDimension In SSet       With objDimension                  If .ObjectName = "AcDbRotatedDimension" _           Or .ObjectName = "AcDbRadialDimension" _           Or .ObjectName = "AcDbAlignedDimension" Then           .LinearScaleFactor = 2         End If         Debug.Print .ObjectName         .Layer = "尺寸线"         .TextHeight = 3.5         .DecimalSeparator = "."         .TextColor = acByLayer         .DimensionLineColor = acByLayer                   If .ObjectName = "AcDbRotatedDimension" _     Or .ObjectName = "AcDbAlignedDimension" Then         .ExtensionLineColor = acByLayer End If         .TextStyle = "WMF-宋体0"                         End With       'Debug.Print Ent.ObjectName     Next objDimension End Sub