【求助】请问XY坐标横线上下标注该如何修改
本帖最后由 yangchao2005090 于 2020-6-10 07:38 编辑;; (_AddMleader (getpoint) (getpoint) "A" 3.5)
(defun _AddLeader (p1 p2 str Ang TextHeight / HANDLEM OBJL OBJM POINTS)
(setq points (vlax-make-safearray vlax-vbDouble '(0 . 5)))
(vlax-safearray-fill points (append P1 p2))
;;(vla-AddMText modelSpace corner width text)
(setq ObjM (vla-AddMText *MS* (vlax-3d-point p2) 1 str))
;;Height AttachmentPoint Handle Width
(vlax-put ObjM 'Height TextHeight);05版用vla-put-TextHeight不灵
(vlax-put ObjM 'AttachmentPoint 7);左下角
(vlax-put ObjM 'Width 0);没有框，只有左下角一个夹点
;;BackgroundFill 05版及以上16.1
(cond ((> (atof (getvar "ACADVER")) 16) (vlax-put ObjM 'BackgroundFill 1)))
(vlax-put ObjM 'Rotation Ang)
(setq ObjL (vla-AddLeader *MS* points ObjM acLineNoArrow))
(setq HandleM (vlax-get ObjM 'Handle))
;;(vlr-pers (VLR-Object-Reactor (list ObjL) (list HandleM) '((:VLR-modified . _LeaderModify))))
(VLR-Object-Reactor (list ObjL) (list HandleM) '((:VLR-modified . _LeaderModify)))
(list ObjM ObjL)
)
(defun _LeaderModify (ObjL ObjMList parameter-list / EL EM EN PTS STR)
(setq eL (vlax-vla-object->ename ObjL))
(setq pts (vlax-get ObjL 'Coordinates))
(setq eM (handent (car (vlr-data ObjMList)))) ;文本
(setq en (entget em))
(setq str (strcat "X="
(VL-PRINC-TO-STRING (cadr pts))
"\\P"
"Y="
(VL-PRINC-TO-STRING (car pts))
)
)
(entmod (subst (cons 1 str) (assoc 1 en) en))
)
;;坐标标注(全局*Ang_ZBBZ*)
(defun C:ZBBZ (/ ANS FLAG GR OBJ P1 P2 STR TEXTHEIGHT zbbz1 zbbz2)
(defun zbbz1 ()
(initget "S ")
(setq p1 (getpoint "\n 坐标点, or [输入角度S] <S>:"))
)
(defun zbbz2 ()
(setq AnS (zbbz1))
(cond
((= AnS "S") (setq *Ang_ZBBZ* (getangle "\n文字倾角")) (zbbz2))
((= (type AnS) 'List)
(princ "\n放置")
(while (equal (setq p2 (cadr (grread T 8))) AnS TextHeight))
(setq str (strcat "X="
(VL-PRINC-TO-STRING (cadr AnS))
"\\P"
"Y="
(VL-PRINC-TO-STRING (car AnS))
)
)
(setq Obj (_AddLeader AnS p2 str *Ang_ZBBZ* TextHeight))
;;(vlax-put ObjL 'Coordinates (append AnS p2))
;;(vlax-put ObjM 'InsertionPoint p2)
(while (and (setq gr (grread T 8)) (= (car gr) 5))
(setq p2 (cadr gr))
(cond ((not(equal p2 AnS TextHeight))
(vlax-put (car Obj) 'InsertionPoint p2)
(vlax-put (cadr Obj) 'Coordinates (append AnS p2))
;;(vla-update (cadr Obj));更新不了
)
)
)
)
(T (setq Flag nil))
)
)
(vl-Load-COM)
(or *ACAD* (setq *ACAD* (vlax-get-acad-object)))
(or *DOC* (setq *DOC* (vla-get-ActiveDocument *ACAD*)))
(or *MS* (setq *MS* (vla-get-modelSpace *DOC*)))
(cond((not *Ang_ZBBZ*)(setq *Ang_ZBBZ* 0)))
(SETQ TextHeight (* (GETVAR "DIMTXT") (GETVAR "DIMSCALE"))) ;字高
(setq Flag T)
(while Flag (zbbz2))
(princ)
)
求大神帮忙修改一下
页:
[1]