选择集法修改尺寸线的标注比例和图层.
主程序Sub DimensionScale()
Dim sSet As AcadSelectionSet
Dim tempStr As String, fType, fData
Set sSet = returnCornerAllSelects()
Dim objDim As AcadDimension, objD As AcadDimRotated
Dim Ent As AcadEntity
For Each Ent In sSet
If InStr(UCase(Ent.ObjectName), "DIMENSION") > 0 Then
Set objDim = Ent
With objDim
.LinearScaleFactor = 10'尺寸标注比例
.Layer = "尺寸线"
End With
End If
Next Ent
End Sub
选择集程序
Function returnCornerAllSelects() As AcadSelectionSet
Dim sSet As AcadSelectionSet
Dim Pt1 As Variant, Pt2 As Variant
With ConnectCad.ActiveDocument
On Error Resume Next
Pt1 = .Utility.GetPoint(, "Select First Point")
Pt2 = .Utility.GetCorner(Pt1, "Select Corner Point")
Set sSet = .SelectionSets.Item(tempsSet)
sSet.Delete
tempsSet = "temp"
Set sSet = .SelectionSets.Add(tempsSet)
sSet.Select acSelectionSetCrossing, Pt1, Pt2
End With
Set returnCornerAllSelects = sSet
End Function
版主是在放代码啊
页:
[1]