求类似燕秀和中望的尺寸驱动

ynhh

有没有类似燕秀的尺寸驱动
这和中望CAD中的看上去一模一样
只是感觉这功能很好玩
如有的朋友
敬上十个币来分享一下

http://bbs.mjtd.com/forum.php?mo ... F%B4%E7%C7%FD%B6%AF

甜兮兮

燕秀工具箱支持中望和浩正CAD

vladimirputin

这么好的工具箱，谢谢楼主分享錒

fangseng

以前在网上下载了一个尺寸驱动的LISP,但是是我太笨，还是搞不定，请网上的高手，看下问题出在哪里？


(vl-ACAD-defun (DEFUN C:YX_QD( / ANG01 ANG02 ANG03 C10 CEN D10 D15 EN ENT L2 L3 NEWL1 OLDL1 PT1 PT10 PT11 PT12 PT13 PT14 PT15 PT16 PT17 PT2 PT3 PT31 PT3A1 PT3A2 PT3A3 PT3A4 PT3A6 PT4 PT41 PT5 PT6 PT7 PT8 PTTY SEL SS1 TY WW ZPT1 ZPT1A ZPT1B ZPT1C ZPT1D ZPT2 )  (DEFUN QD-TY3()  (if (OR (EQUAL ANG01 0.0 0.001 ) (EQUAL ANG01 (* PI 0.5 ) 0.001 ) (EQUAL ANG01 (* PI 1.0 ) 0.001 ) (EQUAL ANG01 (* PI 1.5 ) 0.001 ) (EQUAL ANG01 (* PI 2.0 ) 0.001 ) ) (PROGN   (setq PT5 PT4) (setq PT6 (POLAR PT4 ANG02 (/ L2 2.0 ) )) (setq PT7 PT3) (setq PT8 (POLAR PT3 ANG01 (/ L2 2.0 ) )) (setq ZPT1A (POLAR PT3 ANG02 (/ OLDL1 2.0 ) )) (setq ZPT1B (POLAR ZPT1A (+ ANG02 (* PI 0.5 ) ) 1.0 )) (setq ZPT1C (POLAR PT1 ANG02 1.0 )) (setq ZPT1D (POLAR PT2 ANG02 1.0 )) (setq ZPT1 (INTERS ZPT1A ZPT1B PT1 ZPT1C nil )) (setq ZPT2 (INTERS ZPT1A ZPT1B PT2 ZPT1D nil )) (setq PT10 ZPT1) (setq PT12 ZPT2)  (if (OR (EQUAL (CAR ZPT1 ) (CAR PT1 ) 0.001 ) (EQUAL (CADR ZPT1 ) (CADR PT1 ) 0.001 ) ) (PROGN   (setq PT11 PT2) (setq PT13 PT1) )(PROGN   (setq PT11 PT1) (setq PT13 PT2) )) (setq L3 (* (DISTANCE PT1 PT2 ) 0.01 ))  (if (LXX-PDPTX2PT PT10 PT11 PT5 ) (PROGN   (setq PT14 PT5) (setq PT15 PT6) (setq PT16 PT7) (setq PT17 PT8) (setq PT10 (POLAR PT10 ANG02 L3 )) (setq PT12 (POLAR PT12 ANG01 L3 )) )(PROGN   (setq PT14 PT7) (setq PT15 PT8) (setq PT16 PT5) (setq PT17 PT6) (setq PT10 (POLAR PT10 ANG01 L3 )) (setq PT12 (POLAR PT12 ANG02 L3 )) )) (command "_.zoom" ) (command "_w" ) (command (TRANS PT1 0 1 ) ) (command (TRANS PT2 0 1 ) ) (command "_.stretch" ) (command (SSGET "c" (TRANS PT10 0 1 ) (TRANS PT11 0 1 ) ) ) (command "" ) (command (TRANS PT14 0 1 ) ) (command (TRANS PT15 0 1 ) ) (command "_.stretch" ) (command (SSGET "c" (TRANS PT12 0 1 ) (TRANS PT13 0 1 ) ) ) (command "" ) (command (TRANS PT16 0 1 ) ) (command (TRANS PT17 0 1 ) ) (command "_.zoom" ) (command "_p" ) (PRINC "\t->尺寸修改完成!" ) )(PROGN   (PRINC "\n->斜的标注不能对称修改,只能单边修改!" ) ))  ) (LXX-BEGIN nil ) (LXX-BEGMSG "尺寸驱动" ) (setq WW T) (while (and WW  ) (SETVAR "errno" 0 ) (setq SEL (ENTSEL "\n->请选取标注或 <退出>: " ))  (if (= (GETVAR "errno" ) 52 ) (PROGN   (setq WW nil) ))  (if SEL (PROGN   (setq EN (CAR SEL )) (setq ENT (ENTGET EN )) (setq TY (LXX-DXF 0 ENT ))  (if (= TY "DIMENSION" ) (PROGN   (COND ((MEMBER '(100 . "AcDbDiametricDimension") ENT ) (INITGET 6 ) (setq OLDL1 (LXX-DXF 42 ENT )) (setq NEWL1 (GETREAL (STRCAT "\n->请输入圆的新直径 <" (RTOS OLDL1 2 6 ) ">: " ) ))  (if (= NEWL1 nil ) (PROGN   (setq NEWL1 OLDL1) ))  (if (/= NEWL1 OLDL1 ) (PROGN    (if (NOT (AND (setq  CEN (LXX-DXF 330 ENT )) (setq  CEN (LXX-DXF 331 (ENTGET CEN ) )) ) ) (PROGN   (setq D10 (LXX-DXF 10 ENT )) (setq D15 (LXX-DXF 15 ENT )) (setq C10 (LXX-POINTMID D10 D15 )) (setq SS1 (SSGET "x" (LIST '(-4 . "<AND") '(0 . "CIRCLE") (CONS 10 C10 ) (CONS 40 (/ OLDL1 2.0 ) ) '(-4 . "AND>") ) ))  (if SS1 (PROGN   (setq CEN (SSNAME SS1 0 )) (setq D10 (POLAR C10 (ANGLE C10 D10 ) (/ NEWL1 2.0 ) )) (setq D15 (POLAR C10 (ANGLE C10 D15 ) (/ NEWL1 2.0 ) )) (LXX-UPD2 ENT (LIST (CONS 10 D10 ) (CONS 15 D15 ) ) ) )) ))  (if CEN (PROGN   (LXX-UPD1 (ENTGET CEN ) 40 (/ NEWL1 2.0 ) ) )(PROGN   (PRINC "\n->没有找到和选取标注关联的圆!" ) )) )(PROGN   (PRINC "\n->输入的新尺寸和原尺寸相同,没有改变!" ) )) ) ((MEMBER '(100 . "AcDbRadialDimension") ENT ) (INITGET 6 ) (setq OLDL1 (LXX-DXF 42 ENT )) (setq NEWL1 (GETREAL (STRCAT "\n->请输入圆弧的新半径 <" (RTOS OLDL1 2 6 ) ">: " ) ))  (if (= NEWL1 nil ) (PROGN   (setq NEWL1 OLDL1) ))  (if (/= NEWL1 OLDL1 ) (PROGN    (if (NOT (AND (setq  CEN (LXX-DXF 330 ENT )) (setq  CEN (LXX-DXF 331 (ENTGET CEN ) )) ) ) (PROGN   (setq C10 (LXX-DXF 10 ENT )) (setq SS1 (SSGET "x" (LIST '(-4 . "<AND") '(0 . "ARC") (CONS 10 C10 ) (CONS 40 OLDL1 ) '(-4 . "AND>") ) ))  (if SS1 (PROGN   (setq CEN (SSNAME SS1 0 )) (setq D15 (POLAR C10 (ANGLE C10 (LXX-DXF 15 ENT ) ) NEWL1 )) (LXX-UPD1 ENT 15 D15 ) )) ))  (if CEN (PROGN   (LXX-UPD1 (ENTGET CEN ) 40 NEWL1 ) )(PROGN   (PRINC "\n->没有找到和选取标注关联的圆弧!" ) )) )(PROGN   (PRINC "\n->输入的新尺寸和原尺寸相同,没有改变!" ) )) ) ((OR (MEMBER '(100 . "AcDb2LineAngularDimension") ENT ) (MEMBER '(100 . "AcDb3PointAngularDimension") ENT ) ) (INITGET 6 ) (setq OLDL1 (LXX-DXF 42 ENT )) (setq NEWL1 (GETANGLE (STRCAT "\n->请输入新角度 <" (RTOS (LXX-R2D OLDL1 ) 2 6 ) ">: " ) ))  (if (= NEWL1 nil ) (PROGN   (setq NEWL1 OLDL1) ))  (if (AND (NOT (EQUAL NEWL1 OLDL1 0.001 ) ) (PRINC "\n->请选取要旋转的对象!" ) ) (PROGN    (if (setq  SS1 (SSGET )) (PROGN    (if (setq  PT1 (GETPOINT "\n->请指定要旋转的一侧或 <退出>: " )) (PROGN   (setq PT1 (TRANS PT1 1 0 )) (setq L2 (- NEWL1 OLDL1 ))  (if (MEMBER '(100 . "AcDb3PointAngularDimension") ENT ) (PROGN   (setq PT3 (LXX-DXF 15 ENT )) (setq PT4 (LXX-DXF 13 ENT )) (setq PT5 (LXX-DXF 14 ENT )) )(PROGN   (setq PT3A1 (LXX-DXF 10 ENT )) (setq PT3A2 (LXX-DXF 15 ENT )) (setq PT3A3 (LXX-DXF 13 ENT )) (setq PT3A4 (LXX-DXF 14 ENT )) (setq PT3A6 (LXX-DXF 16 ENT )) (setq PT3 (INTERS PT3A1 PT3A2 PT3A3 PT3A4 nil ))  (if (EQUAL PT3 PT3A1 0.001 ) (PROGN   (setq PT4 PT3A2) )(PROGN   (setq PT4 PT3A1) ))  (if (EQUAL PT3 PT3A3 0.001 ) (PROGN   (setq PT5 PT3A4) )(PROGN   (setq PT5 PT3A3) ))  (if (AND (NOT (EQUAL (LXX-PTONLINE PT3 PT5 PT3A1 ) 0.0 0.001 ) ) (= (> (LXX-PTONLINE PT3 PT5 PT3A6 ) 0.0 ) (> (LXX-PTONLINE PT3 PT5 PT3A1 ) 0.0 ) ) ) (PROGN   (setq PT4 PT3A1) )(PROGN   (setq PT4 PT3A2) ))  (if (AND (NOT (EQUAL (LXX-PTONLINE PT3 PT4 PT3A3 ) 0.0 0.001 ) ) (= (> (LXX-PTONLINE PT3 PT4 PT3A6 ) 0.0 ) (> (LXX-PTONLINE PT3 PT4 PT3A3 ) 0.0 ) ) ) (PROGN   (setq PT5 PT3A3) )(PROGN   (setq PT5 PT3A4) )) )) (setq ANG01 (ANGLE PT3 PT4 )) (setq ANG02 (ANGLE PT3 PT5 ))  (if (AND (EQUAL ANG01 0.0 0.001 ) (NOT (EQUAL (+ ANG01 OLDL1 ) ANG02 0.001 ) ) ) (PROGN   (setq ANG01 (* PI 2.0 )) ))  (if (AND (EQUAL ANG02 0.0 0.001 ) (NOT (EQUAL (+ ANG02 OLDL1 ) ANG01 0.001 ) ) ) (PROGN   (setq ANG02 (* PI 2.0 )) ))  (if (AND (> OLDL1 PI ) (EQUAL ANG01 (* 2.0 PI ) 0.001 ) ) (PROGN   (setq ANG01 0.0) ))  (if (AND (> OLDL1 PI ) (EQUAL ANG02 (* 2.0 PI ) 0.001 ) ) (PROGN   (setq ANG02 0.0) ))  (if (OR (AND (<= OLDL1 PI ) (< ANG01 ANG02 ) ) (AND (> OLDL1 PI ) (> ANG01 ANG02 ) ) ) (PROGN   (setq ANG03 (- (ANGLE PT3 PT5 ) (/ OLDL1 2.0 ) )) )(PROGN   (setq ANG03 (+ (ANGLE PT3 PT5 ) (/ OLDL1 2.0 ) )) )) (setq PT6 (POLAR PT3 ANG03 10.0 ))  (if (MINUSP (LXX-PTONLINE PT3 PT6 PT1 ) ) (PROGN   (setq L2 (- L2 (* 2.0 L2 ) )) )) (LXX-CM0 ) (SETVAR "osmode" 0 ) (command "_.rotate" ) (command SS1 ) (command "" ) (command (TRANS PT3 0 1 ) ) (command (LXX-R2D L2 ) ) )) )(PROGN   (PRINC "\n->没有选取对象!" ) )) )(PROGN   (PRINC "\n->输入的新尺寸和原尺寸相同,没有改变!" ) )) ) ((MEMBER '(100 . "AcDbAlignedDimension") ENT ) (INITGET 6 ) (setq OLDL1 (LXX-DXF 42 ENT )) (setq NEWL1 (GETREAL (STRCAT "\n->请输入新长度 <" (RTOS OLDL1 2 6 ) ">: " ) ))  (if (= NEWL1 nil ) (PROGN   (setq NEWL1 OLDL1) ))  (if (/= NEWL1 OLDL1 ) (PROGN    (if (setq  PT1 (GETPOINT "\n->请指定要修改区域的第一角点或 <退出>: " )) (PROGN    (if (setq  PT2 (GETCORNER PT1 "\n->请指定对角点或 <退出>: " )) (PROGN   (setq PT1 (TRANS PT1 1 0 )) (setq PT2 (TRANS PT2 1 0 )) (setq L2 (- NEWL1 OLDL1 )) (setq PT3 (LXX-DXF 13 ENT )) (setq PT4 (LXX-DXF 14 ENT )) (COND ((AND (LXX-PDPTX2PT PT1 PT2 PT3 ) (LXX-PDPTX2PT PT1 PT2 PT4 ) ) (setq PTTY "3") ) ((LXX-PDPTX2PT PT1 PT2 PT3 ) (setq PTTY "1") ) ((LXX-PDPTX2PT PT1 PT2 PT4 ) (setq PTTY "2") ) (T (PRINC "\n->指定的修改区域超出范围!" ) ) ) (LXX-CM0 ) (SETVAR "osmode" 0 )  (if (MEMBER '(100 . "AcDbRotatedDimension") ENT ) (PROGN   (setq ANG01 (LXX-DXF 50 ENT )) (setq PT31 (POLAR PT3 (+ ANG01 (/ PI 2.0 ) ) 1.0 )) (setq PT41 (POLAR PT4 (+ ANG01 (/ PI 2.0 ) ) 1.0 )) (COND ((= PTTY "1" )  (if (MINUSP (LXX-PTONLINE PT3 PT31 PT4 ) ) (PROGN   (setq ANG02 PI) )(PROGN   (setq ANG02 0.0) )) (setq PT10 PT3) (setq PT11 (POLAR PT3 (+ ANG01 ANG02 ) L2 )) ) ((= PTTY "2" )  (if (MINUSP (LXX-PTONLINE PT4 PT41 PT3 ) ) (PROGN   (setq ANG02 PI) )(PROGN   (setq ANG02 0.0) )) (setq PT10 PT4) (setq PT11 (POLAR PT4 (+ ANG01 ANG02 ) L2 )) ) ((= PTTY "3" )  (if (MINUSP (LXX-PTONLINE PT3 PT31 PT4 ) ) (PROGN   (setq ANG01 (+ ANG01 PI )) (setq ANG02 (- ANG01 PI )) )(PROGN   (setq ANG01 (+ ANG01 0 )) (setq ANG02 (- ANG01 PI )) )) (QD-TY3 ) ) ) )(PROGN   (COND ((= PTTY "1" ) (setq ANG01 (ANGLE PT4 PT3 )) (setq PT10 PT4) (setq PT11 (POLAR PT4 ANG01 L2 )) ) ((= PTTY "2" ) (setq ANG01 (ANGLE PT3 PT4 )) (setq PT10 PT3) (setq PT11 (POLAR PT3 ANG01 L2 )) ) ((= PTTY "3" ) (setq ANG01 (ANGLE PT4 PT3 )) (setq ANG02 (ANGLE PT3 PT4 )) (QD-TY3 ) ) ) ))  (if (OR (= PTTY "1" ) (= PTTY "2" ) ) (PROGN   (command "_.stretch" ) (command (SSGET "c" (TRANS PT1 0 1 ) (TRANS PT2 0 1 ) ) ) (command "" ) (command (TRANS PT10 0 1 ) ) (command (TRANS PT11 0 1 ) ) (PRINC "\t->尺寸修改完成!" ) )) )) )) )(PROGN   (PRINC "\n->输入的新尺寸和原尺寸相同,没有改变!" ) )) ) (T (PRINC "\n->选取的标注类型不支持修改!" ) ) ) (setq WW nil) )(PROGN   (PRINC "\n->选取的对象不是标注!" ) )) )) ) (setq QD-TY3 nil) (LXX-END ) (PRINC )  ) )

fangseng

好象是燕秀的！！

ynhh

fangseng 发表于 2023-2-20 18:50
好象是燕秀的！！

主要是差了一些
LXX-******
之类的几个函数
导致程序无法运行

vladimirputin

非常不错的代码，谢谢楼主分享啊

迷失1786

找到没有？？？

迷失1786

fangseng 发表于 2023-2-20 18:45
以前在网上下载了一个尺寸驱动的LISP,但是是我太笨，还是搞不定，请网上的高手，看下问题出在哪里？

这个很多函数没有，所以用不了