[转帖]序号球程序

2443725 · 发表于 2004-5-6 15:56

;;By LUCAS(龙龙仔) ;;注意:序号球是属性图块,用ddatte指令修改 ;;引线箭头用'_dimstyle修改 ;;只要增加一些属性,就可做料表了!!!! (defun C:OS (/ HOLDOSMODE HOLDDIA HOLDREQ INS A AZ B2 B1 AL PT PT1 PT2 ANG) (defun OPTION () (initget 6) (setq A (getreal (strcat "\n记号直径<" (rtos (getvar "userr4")) ">: ") ) ) (if (/= NIL A) (setvar "userr4" A) ) (initget 6) (setq NOS (getint (strcat "\n起始数字<" (rtos (1+ (getvar "useri4"))) ">: " ) ) ) (if (= NIL NOS) (setq NOS (1+ (getvar "useri4"))) ) (setvar "useri4" (- NOS 1)) ) (command "_.undo" "_group") (setq HOLDOSMODE (getvar "osmode")) (setq HOLDDIA (getvar "ATTDIA")) (setq HOLDREQ (getvar "ATTREQ")) (setvar "osmode" 0) (if (= (getvar "userr4") 0) (setvar "userr4" (* 4 (getvar "DIMSCALE"))) ) (while (= NIL INS) (initget "

") (setq INS (getpoint (strcat "\n指定引线起点 /[记号直径<" (rtos (getvar "userr4")) ">][数字<" (rtos (1+ (getvar "useri4"))) ">](选项
): " ) ) ) (setq PT2 NIL) (cond ((= INS NIL) (setq INS 1) ) ((= INS "P") (OPTION) ) (t (setq PT1 INS) (command "_.LEADER" PT1) (while (= 1 (getvar "CMDACTIVE")) (setq PT PT1) (prompt "\n指定下一点: ") (command PAUSE) (if (/= PT2 NIL) (setq PT1 PT2) ) (if (equal (getvar "lastpoint") PT2) (progn (if (equal PT PT1) (setq ANG (angle PT (setq PT1 (getvar "lastpoint")))) (setq ANG (angle PT PT1)) ) (setq INS (polar PT1 ANG (/ (getvar "userr4") 2.0))) (setq NOS (1+ (getvar "useri4"))) (setvar "useri4" NOS) (setvar "ATTDIA" 0) (setvar "ATTREQ" 1) (if (not (tblsearch "BLOCK" "NOS1")) (MBA) ) (command "" "B" "NOS1" INS (getvar "userr4") "" "" NOS) (setvar "ATTDIA" HOLDDIA) (setvar "ATTREQ" HOLDREQ) (setq AZ (ssget "l")) (setq B2 (ssname AZ 0)) (while (/= "数字" (cdr (assoc 2 (entget B2)))) (setq B2 (entnext B2)) ) (setq B2 (entget B2)) (setq B1 (cdr (assoc 1 B2))) (setq AL (strlen B1)) (cond ((= AL 3) (setq B2 (subst (cons 41 0.64) (assoc 41 B2) B2)) (entmod B2) (entupd (ssname AZ 0)) ) ((= AL 4) (setq B2 (subst (cons 41 0.475) (assoc 41 B2) B2)) (entmod B2) (entupd (ssname AZ 0)) ) ((= AL 5) (setq B2 (subst (cons 41 0.38) (assoc 41 B2) B2)) (entmod B2) (entupd (ssname AZ 0)) ) ) ) (setq PT2 (getvar "lastpoint")) ) ) (setq INS NIL) ) ) ) (setvar "osmode" HOLDOSMODE) (command "_.undo" "_end") (princ) ) ;;;生成带属性图块。 (defun MBA () (entmake (append '((0 . "LAYER") (100 . "AcDbSymbolTableRecord") (100 . "AcDbLayerTableRecord") (70 . 0) (2 . "TEXT") (62 . 6) (6 . "Continuous") ) ) ) (entmake '((0 . "STYLE") (100 . "AcDbSymbolTableRecord") (100 . "AcDbTextStyleTableRecord") (2 . "OS") (70 . 0) (40 . 0.0) (41 . 1.0) (50 . 0.0) (71 . 0) (42 . 26.7011) (3 . "SIMPLEX.shx") ;;修改字体 (4 . "") ) ) (entmake '((0 . "block") (2 . "NOS1") (70 . 2) (10 0.0 0.0 0.0)) ) (entmake '((0 . "CIRCLE") (100 . "AcDbEntity") (67 . 0) (410 . "Model") (8 . "0") (62 . 256) (100 . "AcDbCircle") (10 0.0 0.0 0.0) (40 . 0.5) (210 0.0 0.0 1.0) ) ) (entmake '((0 . "ATTDEF") (100 . "AcDbEntity") (67 . 0) (410 . "Model") (8 . "text") (100 . "AcDbText") (10 -0.519828 -0.225 0.0) (40 . 0.45) (1 . "1") (50 . 0.0) (41 . 1.0) (51 . 0.0) (62 . 256) (7 . "OS") (71 . 0) (72 . 1) (11 0.0 0.0 0.0) (210 0.0 0.0 1.0) (100 . "AcDbAttributeDefinition") (3 . "数字") (2 . "数字") (70 . 0) (73 . 0) (74 . 2) ) ) (entmake '((0 . "ENDBLK"))) (princ) )