[原创]锁定dim标注数值VBA版(支持公差等格式)

mccad · 发表于 2004-10-14 21:17:00

'锁定标注文字
'作者：明经通道 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

'锁定标注文字
'作者：明经通道 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"开头的匿名块，该块就是生成所复制标注对象的块了，通过块就可以取得文字内容。

雪山飞狐_lzh · 发表于 2004-10-14 22:27:00

不错，这倒是个好办法

王咣生 · 发表于 2004-10-15 09:41:00

很少用过dim标注,学习一下.

龙龙仔 · 发表于 2004-10-22 09:38:00

;;不要忘了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))
(setq ERR (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-for OBJ
(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)
)

;;不要忘了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))
   (setq  ERR (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-for  OBJ
           (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)
)

mccad · 发表于 2004-10-22 21:08:00

不错的思路，但这样的程序只能使用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

iwx007 · 发表于 2021-1-20 12:08:06

2004年，标注的ownerID是modelspace

iwx007 · 发表于 2021-1-20 12:11:40

所以用getsubentity

账号		自动登录	找回密码
密码			注册

[原创]锁定dim标注数值VBA版(支持公差等格式)

回复