[求助]请问下面的算法可以优化吗？

leeyeafu

一张地质图，有上万个图元（AcadObject类型），下面的函数执行时For Each循环能否优化，使之执行速度加快。
以下是代码：　　　
Private Function NearestEntAttrib(ByVal PickPoint As Variant) As String
'函数接收一个Variant类型的三维坐标点参数，返回该点附近的地质编号
Dim objModelSpace As Object, objEntity As AcadObject, objText As AcadText
Dim strTag As String
strTag = ""
Dim MinDis, Distance As ACAD_DISTANCE
MinDis = 9999999
Set objModelSpace = ThisDrawing.ModelSpace()  '获取当前图形的模型空间句柄
For Each objEntity In objModelSpace  '扫描模型空间的所有AcadObject对象
  With objEntity
     If StrComp(.EntityName, "AcDbMText", 1) = 0 Or StrComp(.EntityName, "AcDbText") = 0 Then
     '若objEntity为AcDbMText多行文字或AcDbText文本类型
       If IsNumeric(.TextString) And Int(Val(.TextString)) = Val(.TextString) Then
         '复制objEntity为AcadText类型，以获取文本插入点坐标
         Set objText = objModelSpace.AddText(.TextString, .InsertionPoint, 2)
         '文本插入点与PickPoint点之间的距离，因只要比较距离大小，此处不作开方运算
          Distance = (objText.InsertionPoint(0) - PickPoint(0)) _
                   * (objText.InsertionPoint(0) - PickPoint(0)) _
                   + (objText.InsertionPoint(1) - PickPoint(1)) _
                   * (objText.InsertionPoint(1) - PickPoint(1))
           If Distance < MinDis Then
             MinDis = Distance  'MinDis为与PickPoint最近文本的距离值的平方
             strTag = .TextString  '获取文本内容
           End If
           objText.Delete  '删除复制文本
         End If
      End If
  End With
Next objEntity
NearestEntAttrib = strTag
End Function

mccad

leeyeafu