[LISP程序]：序号球程序

LUCAS · 发表于 2003-1-22 09:58:30

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

您需要登录才可以下载或查看，没有账号？立即注册

×

;;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 "P")
(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)
)

;;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 "P") 
    (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) 
)

lsjjm · 发表于 2003-2-7 03:25:51

班门弄斧了, 请指教.
(defun itemnum ( / ps pe s)
 (if inum nil (setq inum 1))
 (princ "\nType in Item Number <")
 (princ inum)
 (setq inum0 (getint ">:"))
 (if inum0 (setq inum inum0))
 (mlayer "dim" 4 "continous")
 (setq s (getvar "dimscale"))
 (setq ps (getpoint "\nPick Start Point"))
 (setvar "osmode" 37)
 (setq pe (getpoint "\nPick End Point"))
 (setvar "osmode" 0)
 (command "leader" ps (polar pe (angle pe ps)(* s 0.32)) "" "" "n")
 (vl-cmdf "circle" pe (* s 0.32))
 (vl-cmdf "text" "j" "m" pe (* s 1.5 0.18) 0 (itoa inum) "")
 (setq inum (1+ inum))
);defun_itemnum

mylion · 发表于 2004-4-29 15:09:10

转贴网址就好了!

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

[LISP程序]：序号球程序

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

相关帖子

浏览过的版块