选择集法修改尺寸线的标注比例和图层.

兰州人

主程序

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

zzyong00

版主是在放代码啊