[求助]请问下面的算法可以优化吗？
一张地质图，有上万个图元（AcadObject类型），下面的函数在VBA中执行速度还行，我想在VB6中编译成exe文件，执行时For Each循环就太慢了，请各位看看能否优化，使之执行速度加快。以下是代码： 'MyDocument是全局变量
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 = MyDocument.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
选择集的问题
本帖最后由 作者 于 2002-8-5 14:27:08 编辑我在以上代码中For Each循环前添加了一段代码，增加一个选择集，但运行时出错。
Dim SSel As AcadSelectionSet
Dim pt1(0 To 2), pt2(0 To 2)As Double
Set SSel = MyDocument.SelectionSets.Add("ss")
pt1(0) = PickPoint(0) - 100: pt1(1) = PickPoint(1) - 100: pt1(2) = PickPoint(2)
pt2(0) = PickPoint(0) + 100: pt2(1) = PickPoint(1) + 100: pt2(2) = PickPoint(2)
SSel.Select acSelectionSetCrossing, pt1, pt2
'程序运行到这出错,错误为“对象'Select'的方法'IAcadSelectionSets'失败”
'这是怎么回事望指教
For Each objEntity In SSel
.........
Next objEntity
[此贴子已经被作者于2002-8-5 11:51:03编辑过]
页:
[1]