使用直线，创建一个边界框，然后向其添加一些填充，并使用基于这些边界框点上的交叉选择创建的点构建一个选择集，然后处理该选择集 获取线的边界框，然后向其添加公差变量，以定义要处理的编程选择集的交叉 不确定这是否有帮助
试试我老歌里的这一首，这会让你
要搜索离行最近的文本，请更改选择
根据您的需要进行筛选：
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
以下是可读性更强的源代码，请参阅附件：
FindNearestObject。txt文件
页:
1
[2]