更改标注尺寸值的<>为真实值 来自http://www.mjtd.com/Develop/ArticleShow.asp?ArticleID=665 Public Sub SelfOverRide(objDim As AcadDimension) Dim objBlk As AcadBlock Dim objEnt As AcadEntity Dim varPos As Variant Dim varInsPnt As Variant Dim objDimText As AcadMText Dim objBlocks As AcadBlocks Dim blnDone As Boolean Set objBlocks = ThisDrawing.Blocks varPos = objDim.TextPosition For Each objBlk In objBlocks If Not blnDone Then If Left(objBlk.Name, 2) = "*D" Then For Each objEnt In objBlk If TypeOf objEnt Is AcadMText Then Set objDimText = objEnt varInsPnt = objDimText.InsertionPoint If varInsPnt(0) = varPos(0) Then If varInsPnt(1) = varPos(1) Then objDim.TextOverride = objDimText.TextString blnDone = True Exit For End If End If End If Next objEnt End If Else Exit For End If Next objBlk End Sub
Sub TEST_SelfOverRide() Dim strPrmt As String Dim objEnt As AcadEntity Dim varPnt As Variant Dim IsDimension As Boolean Dim objDim As AcadDimension
On Error GoTo Err_Handler strPrmt = vbCr & "选择标注对象:" ThisDrawing.Utility.GetEntity objEnt, varPnt, strPrmt
Set objDim = objEnt SelfOverRide objDim
Exit Sub Err_Handler: MsgBox Err.Number & vbCrLf & Err.Description End Sub |