LinetypeScale应用一例

兰州人

在一张图上的中心线，有的长，有的短，如果LinetypeScale都用1的话，有的中心线间距拉的开，有的就成为一条直线。

Sub lsls()
  Dim pt1, pt2
  Dim sSet As AcadSelectionSet
  pt1 = ThisDrawing.Utility.GetPoint(, "Input First Point")
  pt2 = ThisDrawing.Utility.GetCorner(pt1, "Input First Point")
  Set sSet = CreateSelectionSetCrossingText(pt1, pt2)
  Dim objText As AcadText
  Dim objLine As AcadLine
  For ii = 0 To sSet.Count - 1
    Set objLine = sSet.Item(ii)
    With objLine
      Debug.Print .Length

通过判断长度，来设置LinetypeScale的值。
      Select Case .Length
        Case Is <= 5
          .LinetypeScale = 0.1
        Case Is <= 10
          .LinetypeScale = 0.2
         
        Case Is > 50
          .LinetypeScale = 0.8
       
      End Select
    End With
  Next ii
End Sub

Function CreateSelectionSetCrossingText(pt1 As Variant, pt2 As Variant) As AcadSelectionSet
   On Error Resume Next
   Dim sSet As AcadSelectionSet
   'Dim SSet As AcadSelectionSet
   If Not IsNull(ThisDrawing.SelectionSets.Item("SelectEntity")) Then
     Set sSet = ThisDrawing.SelectionSets.Item("SelectEntity")
     sSet.Delete
   End If
   Set sSet = ThisDrawing.SelectionSets.Add("SelectEntity")
   Dim gpCode(0) As Integer
   Dim dataValue(0) As Variant
   gpCode(0) = 0
   dataValue(0) = "Line"
  
   sSet.Select acSelectionSetCrossing, pt1, pt2, gpCode, dataValue

   Set CreateSelectionSetCrossingText = sSet

End Function