标题: 利用VBA删除CAD中重复字体 [打印本页] 作者: xipick 时间: 2014-8-27 13:31 标题: 利用VBA删除CAD中重复字体 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