|
|
发表于 2002-9-28 20:29:00
|
显示全部楼层
Sub GetLinePnt()
Dim ss As AcadSelectionSet
Set ss = CreateSelectionSet()
Dim fType As Variant
Dim fData As Variant
BuildFilter fType, fData, 0, "Line"
ss.SelectOnScreen fType, fData
Dim Lline As AcadLine
Dim I As Integer
Dim StarPnt As Variant
Dim EndPnt As Variant
Dim DispInfo As String
For I = 0 To ss.Count - 1
Set Lline = ss.Item(I)
StarPnt = Lline.StartPoint
EndPnt = Lline.EndPoint
DispInfo = DispInfo & "第" & I + 1 & "根线的起点坐标：" & PTos(StarPnt) & " 终点坐标：" & PTos(EndPnt) & vbCrLf
Next
MsgBox DispInfo, , "乐筑天下制作例程 http://www.mjtd.com "
End Sub
Public Sub BuildFilter(typeArray, dataArray, ParamArray gCodes())
Dim fType() As Integer, fData()
Dim index As Long, I As Long
index = LBound(gCodes) - 1
For I = LBound(gCodes) To UBound(gCodes) Step 2
index = index + 1
ReDim Preserve fType(0 To index)
ReDim Preserve fData(0 To index)
fType(index) = CInt(gCodes(I))
fData(index) = gCodes(I + 1)
Next
typeArray = fType: dataArray = fData
End Sub
Public Function CreateSelectionSet(Optional ssName As String = "ss") As AcadSelectionSet Dim ss As AcadSelectionSet
On Error Resume Next
Set ss = ThisDrawing.SelectionSets(ssName)
If Err Then Set ss = ThisDrawing.SelectionSets.Add(ssName)
ss.Clear
Set CreateSelectionSet = ss
End Function
Private Function PTos(P As Variant) As String
Dim S As String
Dim pp(2) As Double
pp(0) = P(0)
pp(1) = P(1)
S = RTOS(pp(0)) & ", " & RTOS(pp(1))
If UBound(P) > 1 Then
pp(2) = P(2)
S = S & ", " & RTOS(pp(2))
End If
PTos = S
End Function
Private Function RTOS(Real As Double) As String
RTOS = ThisDrawing.Utility.RealToString(Real, acDefaultUnits, LuPrec)
End Function |
|
置顶卡
