|
|
在一张图上的中心线，有的长，有的短，如果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 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 |
|
置顶卡
