动态移动标注中的文字,用lsp程序实现

yaokui25 · 发表于 2014-3-17 15:14:38

本帖最后由 yaokui25 于 2014-3-17 15:48 编辑

(defun c:TT( / Flag ObjName ObjType VlaObj )

(princ "\n **********************************")
(setq *error* *myerror*)
(SD1028)

(setq Flag nil)
(while (null Flag)
(setvar "ERRNO" 0)
(setq ObjName nil ObjType nil)
(setq ObjName (car (entsel "\n Select DIMENSION :")))       ;追加
(if ObjName
(setq ObjType (SD3511 0 ObjName))
(setq Flag nil)
)
(cond ((= ObjType "DIMENSION")(Procedure_1316 ObjName))
((= (getvar "ERRNO") 52)(setq Flag T))
)
)

(SD2056)
(setq *error* nil)
(princ)
)

;**********************
(defun Procedure_1316 (ObjName / )
(setq VlaObj (vlax-ename->vla-object ObjName))
(vlax-put-property VlaObj 'TextMovement acMoveTextAddLeader)
(vlax-put-property VlaObj 'Fit acBestFit)
(command "dim" "TE" ObjName pause "exit")
)

(defun SD1028 ()
  (setq OldCmdEcho (getvar "CMDECHO"))
  (setvar "CMDECHO" 0)
  (command "undo" "be")
  (setq OldOsmode (getvar "OSMODE"))
  (setq OldLayer (getvar "CLAYER"))
  (setq OldLType (getvar "CeLType"))
  (setq OldCeLWeight (getvar "CeLWeight"))
  (setq OldColor (getvar "CeColor"))
  (setq OldOrtho (getvar "ORTHOMODE"))
  (setq OldDStyle  (getvar "DIMSTYLE"))
  (setq OldExpert (getvar "Expert"))
  (setvar "EXPERT" 0)
  (setq Path_Lang "HKEY_CURRENT_USER\\Software\\SpeedDraftLT")
  (if (vl-registry-read Path_Lang "SD_Language" )
    (setq SD:Lang (vl-registry-read Path_Lang "SD_Language" ))
    (progn (setq SD:Lang "J")
    (vl-registry-write Path_Lang "SD_Language" "J")
    )
  )
  (princ)
)
;********************************
(defun SD2056 ()
  (setvar "OSMODE" OldOsmode)
  (command "undo" "end")
  (setvar "CLAYER" OldLayer)
  (setvar "CeLType" OldLType)
  (setvar "CeLWeight" OldCeLWeight)
  (setvar "CeColor" OldColor)
  (setvar "ORTHOMODE" OldOrtho)
  (setvar "Expert" OldExpert)
  (if (and (/= (getvar "DIMSTYLE") OldDStyle)(tblsearch "DIMSTYLE" OldDStyle))
    (command "-dimstyle" "Restore" OldDStyle)
  )
  (princ "\n (C)OffshoreCad&Management")
  (setvar "CMDECHO" OldCmdEcho)
  (princ)
)

;**********************
(defun SD3511 (g e)
(cond
((= (type e) 'ename) (cdr (assoc g (entget e))))
((= (type e) 'list) (cdr (assoc g e)))
)
)
;********************************
(defun *myerror* (msg)
(setq *error* nil)
(SD2056)
(princ "\n Error in SpeedDraftLT")
(princ)
)
(princ)

李青松 · 发表于 2014-3-17 15:28:20

运行不了,acad提示 **********************************
(C)OffshoreCad&Management
Error in SpeedDraftLT

只调整标注文字的位置而标注线不移动

期待高手浮出水面

yaokui25 · 发表于 2014-3-17 15:49:30

李青松发表于 2014-3-17 15:28
运行不了,acad提示 **********************************
(C)OffshoreCad&Management
Error in SpeedDra ...

楼上修改了，再试试

菜卷鱼 · 发表于 2014-3-18 11:59:00

aidimtextmove 不行？

李青松 · 发表于 2014-3-19 11:04:42

菜卷鱼发表于 2014-3-18 11:59
aidimtextmove 不行？

回复yaokui25 不要出现引出线望修改一下

完整武器 · 发表于 2020-4-30 21:51:04

这个cad不是有自带的命令吗

zhoupeng220 · 发表于 2024-1-5 00:10:04

yaokui25 发表于 2014-3-17 15:14
(defun c:TT( / Flag ObjName ObjType VlaObj )

(princ "\n **********************************")

这个软件真熟

燕乐王 · 发表于 2024-1-12 17:18:21

源泉工具箱里有这样的功能！

YuHB · 发表于 2024-6-20 17:34:16

菜卷鱼发表于 2014-3-18 11:59
aidimtextmove 不行？

啊哈哈。又碰到这种事情。。。我得好好了解下cad自带命令先。

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

[提问] 动态移动标注中的文字,用lsp程序实现

相关帖子

本帖子中包含更多资源