[编程交流] 直线附近的对象

Option Explicit
Const pi As Double = 3.14159265358979
Public Sub 
TouchNearestText()
Dim oEnt As AcadEntity
Dim oLine As 
AcadLine
Dim pickPt
On Error GoTo Err_Report
Call 
ThisDrawing.Utility.GetEntity(oEnt, pickPt, vbLf & "Select a Line: 
")
     If Not TypeOf oEnt Is AcadLine 
Then
     MsgBox "Not a 
Line!"
     Exit 
Sub
     End If
Set oLine = oEnt
     Dim minExt As 
Variant
     Dim maxExt As 
Variant
   ' Return the bounding box 
for the line and return the minimum
   ' and maximum extents 
of the box in the minExt and maxExt variables.
oLine.GetBoundingBox minExt, maxExt
   Dim pts(0 To 11) As 
Double
   pts(0) = minExt(0): pts(1) = minExt(1): pts(2) = 
0#
   pts(3) = maxExt(0): pts(4) = minExt(1): pts(5) = 
0#
   pts(6) = maxExt(0): pts(7) = maxExt(1): pts( = 
0#
   pts(9) = minExt(0): pts(10) = maxExt(1): pts(11) = 
0#
     Dim setObj As 
AcadSelectionSet
    Dim setColl As 
AcadSelectionSets
    Dim oText As 
AcadText
    Dim pickPnt As 
Variant
    Dim setName As 
String
    Dim selMod As 
Long
    Dim vertPts As 
Variant
    Dim dblElv As 
Double
    Dim gpCode(1) As 
Integer
    Dim dataValue(1) As 
Variant
    Dim dxfcode, 
dxfdata
    '' build your filter 
here:
    gpCode(0) = 0: gpCode(1) = 
8
    dataValue(0) = "TEXT": dataValue(1) = 
"0"
    dxfcode = gpCode: dxfdata = 
dataValue
    setName = "$CrossSelect$"
    With 
ThisDrawing
         Set 
setColl = 
.SelectionSets
         For 
Each setObj In 
setColl
If setObj.Name = setName 
Then
.SelectionSets.item(setName).Delete
Exit 
For
End If
Next
         Set setObj = 
.SelectionSets.Add(setName)
    End With
    selMod = 
AcSelect.acSelectionSetCrossingPolygon     ' <-- can use 
also acSelectionSetWindowPolygon   '
    setObj.SelectByPolygon selMod, pts, dxfcode, 
dxfdata
    setObj.Highlight 
True
    Dim objEnt As 
AcadEntity
    Dim dblDist As Double
If setObj.Count 
= 0 Then Exit Sub
    Dim distArr As Variant
Dim ang As Double
    Dim angLine As 
Double
    ReDim arr(1000, 1) As Variant ''put maximum 
number of nearer items you 
need
        ' >> do your 
stuffs here
        Dim 
n
    For Each objEnt In 
setObj
         Set oText = 
objEnt
         Dim ptIns As 
Variant
         ptIns = 
oText.InsertionPoint
angLine = oLine.Angle
ang = ThisDrawing.Utility.AngleFromXAxis(oLine.StartPoint, 
ptIns)
         ang = ang - 
angLine
         dblDist = 
Distance(ptIns, 
oLine.StartPoint)
dblDist = Abs(dblDist * 
Sin(ang))
         arr(n, 0) = 
oText.Handle: arr(n, 1) = 
dblDist
         n = n + 
1
    Next
    Dim strHandle As String
Dim minDist
    minDist = arr(0, 
1)
    For n = 0 To UBound(arr, 
1)
     If arr(n, 0) <> "" And arr(n, 1) < 
minDist Then
    minDist = arr(n, 
1)
    strHandle = arr(n, 0)
End If
    Next
    '' change 
some properties of a text you've found
Set objEnt = 
ThisDrawing.HandleToObject(strHandle)
    objEnt.Layer = 
oLine.Layer
objEnt.TrueColor = 
oLine.TrueColor
objEnt.Update
    MsgBox "Minimum distance: " & minDist
Err_Report:
If Err.Number <> 0 Then
MsgBox Err.Description
End 
If
End Sub
'' by Bryco
Public Function Distance(ByVal pt1 As Variant, ByVal pt2 As 
Variant) As Double
Dim x As Double, y As Double, z As Double
Dim dist As 
Double
' Calculate the distance between pt1 and pt2
x = pt1(0) - 
pt2(0)
y = pt1(1) - pt2(1)
z = pt1(2) - pt2(2)
dist = Sqr((Sqr((x ^ 2) 
+ (y ^ 2)) ^ 2) + (z ^ 2))
Distance = dist
End Function