[原创]锁定dim标注数值VBA版(支持公差等格式)
'锁定标注文字'作者：明经通道 mccad
Function FixDimText(Dimension As AcadDimension) As String
Dim BlockCount As Long
BlockCount = ThisDrawing.Blocks.Count
Dim CopyDimension As AcadDimension
Set CopyDimension = Dimension.Copy
Dim NewBlockCount As Long
NewBlockCount = ThisDrawing.Blocks.Count
If NewBlockCount = BlockCount + 1 And Left(ThisDrawing.Blocks(BlockCount).Name, 2) = "*D" Then
Dim EntityInBlock As AcadEntity
For Each EntityInBlock In ThisDrawing.Blocks(BlockCount)
If EntityInBlock.ObjectName = "AcDbMText" Then
Dimension.TextOverride = EntityInBlock.TextString
Exit For
End If
Next
End If
CopyDimension.Delete
FixDimText = Dimension.TextOverride
End Function'解锁标注文字
Function UnFixDimText(Dimension As AcadDimension) As String
Dimension.TextOverride = ""
UnFixDimText = Dimension.TextOverride
End Function程序原理：
标注对象其实就是由系统控制的匿名块，块名均以“*D”开头。
对于LISP，可以通过取DXF代码中的组码2来取得其块名，再通过块来取得文字。
而对于VBA，没有直接的方法可以取得标注对象所属的块的名称。
本程序通过对复制标注对象，然后查看系统中增加了的以"*D"开头的匿名块，该块就是生成所复制标注对象的块了，通过块就可以取得文字内容。 不错，这倒是个好办法
回复
很少用过dim标注,学习一下. ;;不要忘了ownerid,下列是点选的实现(全用ActiveX___应可转为vba)(defun C:TTT (/ BLKS CONTEXTDATA
DOC ENTOBJ ENTOBJ_OWNER
ENTOBJ_OWNER_NAME TEXTSTRING
UTILITY PICKEDPOINT TRANSMATRIX
)
(setq DOC (vla-get-activedocument (vlax-get-acad-object)))
(setq BLKS (vla-get-blocks DOC))
(setq UTILITY (vla-get-utility DOC))
(setqERR (vl-catch-all-apply
'vla-getsubentity
(list UTILITY 'ENTOBJ 'PICKEDPOINT
'TRANSMATRIX 'CONTEXTDATA "\n选取标註: "
)
)
)
(if (not (vl-catch-all-error-p ERR))
(progn
(setq ENTOBJ_OWNER (vla-get-ownerid ENTOBJ))
(setq ENTOBJ_OWNER_NAME
(vla-get-name
(vla-objectidtoobject
DOC
ENTOBJ_OWNER
)
)
)
(if (= "*D" (substr ENTOBJ_OWNER_NAME 1 2))
(progn
(vlax-for OBJ(vla-item BLKS ENTOBJ_OWNER_NAME)
(if(= (vla-get-objectname OBJ) "AcDbMText")
(setq TEXTSTRING (vla-get-textstring OBJ))
)
)
(vla-put-textoverride
(vla-objectidtoobject
DOC
(nth 0 (vlax-safearray->list CONTEXTDATA))
)
TEXTSTRING
)
)
)
)
)
(vlax-release-object DOC)
(vlax-release-object BLKS)
(vlax-release-object UTILITY)
(princ)
);;当然用vlisp+lisp会更简单
(defun C:TT1 (/ ENT ENTT OBJ)
(setq ENT (nentselp "\n选取标註: "))
(if (and ENT
(= "DIMENSION"
(cdr (assoc 0 (entget (setq ENTT (last (last ENT))))))
)
)
(progn
(vlax-forOBJ
(vla-item
(vla-get-blocks
(vla-get-activedocument (vlax-get-acad-object))
)
(cdr (assoc 2 (entget ENTT)))
)
(if (equal (vla-get-objectname OBJ) "AcDbMText")
(setq TXT (vla-get-textstring OBJ))
)
)
(vla-put-textoverride
(vlax-ename->vla-object ENTT)
TXT
)
)
)
(princ)
) 不错的思路，但这样的程序只能使用GetSubEntity来处理，而不能写成函数。Sub FixDimText()
Dim Ent As AcadEntity
Dim Pnt As Variant
ThisDrawing.Utility.GetSubEntity Ent, Pnt, transMatrix, contextdata, "选择标注对象："
Dim BlkId As Long
BlkId = Ent.OwnerID
Dim BlkName As String
Dim TextString As String
BlkName = ThisDrawing.ObjectIdToObject(BlkId).Name
If Left(BlkName, 2) = "*D" Then
Dim EntityInBlock As AcadEntity
For Each EntityInBlock In ThisDrawing.ObjectIdToObject(BlkId)
If EntityInBlock.ObjectName = "AcDbMText" Then
TextString = EntityInBlock.TextString
Exit For
End If
Next
'Debug.Print TextString
If TextString <> "" Then ThisDrawing.ObjectIdToObject(contextdata(0)).TextOverride = TextString
End If
End Sub 2004年，标注的ownerID是modelspace 所以用getsubentity
页:
[1]