|
|
发表于 2007-11-28 14:28:00
|
显示全部楼层
更改标注尺寸值的为真实值
来自
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
|
|
置顶卡
