LinetypeScale应用一例
<p>在一张图上的中心线，有的长，有的短，如果LinetypeScale都用1的话，有的中心线间距拉的开，有的就成为一条直线。</p><p>Sub lsls()<br/> Dim pt1, pt2<br/> Dim sSet As AcadSelectionSet<br/> pt1 = ThisDrawing.Utility.GetPoint(, "Input First Point")<br/> pt2 = ThisDrawing.Utility.GetCorner(pt1, "Input First Point")<br/> Set sSet = CreateSelectionSetCrossingText(pt1, pt2)<br/> Dim objText As AcadText<br/> Dim objLine As AcadLine<br/> For ii = 0 To sSet.Count - 1<br/> Set objLine = sSet.Item(ii)<br/> With objLine<br/> Debug.Print .Length</p><p>通过判断长度，来设置LinetypeScale的值。<br/> Select Case .Length<br/> Case Is <= 5<br/> .LinetypeScale = 0.1<br/> Case Is <= 10<br/> .LinetypeScale = 0.2<br/> <br/> Case Is > 50<br/> .LinetypeScale = 0.8<br/> <br/> End Select<br/> End With<br/> Next ii<br/>End Sub</p><p>Function CreateSelectionSetCrossingText(pt1 As Variant, pt2 As Variant) As AcadSelectionSet<br/> On Error Resume Next<br/> Dim sSet As AcadSelectionSet<br/> 'Dim SSet As AcadSelectionSet<br/> If Not IsNull(ThisDrawing.SelectionSets.Item("SelectEntity")) Then<br/> Set sSet = ThisDrawing.SelectionSets.Item("SelectEntity")<br/> sSet.Delete<br/> End If<br/> Set sSet = ThisDrawing.SelectionSets.Add("SelectEntity")<br/> Dim gpCode(0) As Integer<br/> Dim dataValue(0) As Variant<br/> gpCode(0) = 0<br/> dataValue(0) = "Line"<br/> <br/> sSet.Select acSelectionSetCrossing, pt1, pt2, gpCode, dataValue</p><p> Set CreateSelectionSetCrossingText = sSet</p><p>End Function<br/></p>
页:
[1]