明经CAD社区

 找回密码
 注册

QQ登录

只需一步,快速开始

搜索
查看: 4688|回复: 11

[资源] 动态块机械手

  [复制链接]
发表于 2011-1-7 09:11:42 | 显示全部楼层 |阅读模式
本帖最后由 xiaxiang 于 2011-1-9 17:17 编辑

Author: TheSwamp@Andrea
动态块整体操作,看演示.

  1.     (progn
  2.       (setq LANG "EN")
  3.       (setq mess1 "\nPlease Select your Block...")
  4.       (setq mess2 "\n(R)otation/(S)cale/(M)ove/(C)opy/(A)ligned: ")
  5.       (setq mess3 "\n(D)ynamic/(V)alue: ")
  6.       (setq mess4 "\n(A)bsolute/(R)elative/(V)alue: ")
  7.       (setq mess5 "Angle: ")
  8.       (setq mess6 "Scale: ")
  9.       (setq mess7 "\nCopy... ")
  10.       
  11.       (setq mTss1 "Cursor Angle: ")
  12.       (setq mTss2 "Object Angle: ")
  13.       (setq mTss3 "Object Scale X: ")
  14.       (setq mTss4 "Object Scale Y: ")
  15.       (setq mTss5 "Insertion Point: ")
  16.       (setq mTss6 "Layer: ")

- + - added for scale factor
- English/French messages added   ;;
- Rotate Relative/Absolute/Value option added ;;
- Mtext info added    ;;
  .Cursor Angle    ;;
  .Angle Object    ;;
   .X Scale Object    ;;
   .Y Scale Object    ;;
    .Base Point    ;;
    .Block Layer    ;;
    - Switch MTEXT information with TAB key  ;;
    - Mtext for distance added   ;;
    - Copy option added    ;;










本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有账号?注册

x
"觉得好,就打赏"
还没有人打赏,支持一下
发表于 2019-11-23 20:15:56 | 显示全部楼层
学习了,好东西啊
发表于 2011-1-7 09:20:44 | 显示全部楼层
有创意。学习了
以前只接触到框选的形式,用点击的方式值得学习
谢谢楼主的分享
发表于 2011-1-7 15:59:17 | 显示全部楼层
顶........
发表于 2011-7-15 22:02:55 | 显示全部楼层
哇,好好玩耶,能不能发我一份,小弟的邮箱cm88666@163.com
发表于 2011-7-16 00:36:36 | 显示全部楼层
竟然是双语版的。
发表于 2011-7-16 01:59:18 | 显示全部楼层
本帖最后由 zhynt 于 2011-7-16 02:02 编辑

改了两处地方,以增加对中文的支持。
第一处:

  1. (defun Langage ()
  2.     (vl-load-com)
  3.     (setq lang (substr (strcase (ver)) (- (strlen (ver)) 2) 2))
  4.     (cond
  5.       ((= lang "FR")
  6.        (setq mess1 "\nSelectionnez votre block...")
  7.        (setq mess2 "\n(R)otation/(E)chelle/(D)閜lacer/(C)opier/(A)ligner: ")
  8.        (setq mess3 "\n(D)ynamique/(V)aleur: ")
  9.        (setq mess4 "\n(A)bsolu/(R)elatif/(V)aleur: ")
  10.        (setq mess5 "Angle: ")
  11.        (setq mess6 "蒫helle: ")
  12.        (setq mess7 "\nCopie... ")
  13.        (setq mTss1 "Angle Curseur: ")
  14.        (setq mTss2 "Angle Object: ")
  15.        (setq mTss3 "蒫helle Object X: ")
  16.        (setq mTss4 "蒫helle Object Y: ")
  17.        (setq mTss5 "Point d'insertion: ")
  18.        (setq mTss6 "Calque: ")
  19.       )
  20.       ((= lang "EN")
  21.        (setq mess1 "\nPlease Select your Block...")
  22.        (setq mess2 "\n(R)otation/(S)cale/(M)ove/(C)opy/(A)ligned: ")
  23.        (setq mess3 "\n(D)ynamic/(V)alue: ")
  24.        (setq mess4 "\n(A)bsolute/(R)elative/(V)alue: ")
  25.        (setq mess5 "Angle: ")
  26.        (setq mess6 "Scale: ")
  27.        (setq mess7 "\nCopy... ")
  28.        (setq mTss1 "Cursor Angle: ")
  29.        (setq mTss2 "Object Angle: ")
  30.        (setq mTss3 "Object Scale X: ")
  31.        (setq mTss4 "Object Scale Y: ")
  32.        (setq mTss5 "Insertion Point: ")
  33.        (setq mTss6 "Layer: ")
  34.       )
  35.       ((= lang "SC")
  36.        (setq mess1 "\n请选择图块...")
  37.        (setq mess2 "\n旋转(R)/比例(S)/移动(M)/复制(C)/排列(A): ")
  38.        (setq mess3 "\n动态(D)/数值(V): ")
  39.        (setq mess4 "\n绝对(A)/相对(R)/数值(V): ")
  40.        (setq mess5 "角度: ")
  41.        (setq mess6 "比例: ")
  42.        (setq mess7 "\n复制到... ")
  43.        (setq mTss1 "游标角度: ")
  44.        (setq mTss2 "对象角度: ")
  45.        (setq mTss3 "对象比例 X: ")
  46.        (setq mTss4 "对象比例 Y: ")
  47.        (setq mTss5 "插入点: ")
  48.        (setq mTss6 "图层: ")
  49.       )
  50.     )
  51.   )
第二处:


  1. (while
  2.     (and (setq input (grread t 4 4))
  3.          (or (= (car input) 5)                ; *cursor
  4.              (and (= (car input) 2) (= (cadr input) 9))   ;TAB
  5.              (and (= (car input) 2) (= (cadr input) 15))  ; F8 Orthomode
  6.              (and (= (car input) 2) (= (cadr input) 114)) ; r = Rotation                                       
  7.              (and (= (car input) 2) (= (cadr input) 82))  ; R = Rotation
  8.              (and (= (car input) 2) (= (cadr input) 115)) ; s = Scale
  9.              (and (= (car input) 2) (= (cadr input) 83))  ; S = Scale
  10.              (and (= (car input) 2) (= (cadr input) 101)) ; e = Echelle
  11.              (and (= (car input) 2) (= (cadr input) 69))  ; E = Echelle
  12.              (and (= (car input) 2) (= (cadr input) 100)) ; d = Dynamic
  13.              (and (= (car input) 2) (= (cadr input) 68))  ; D = Dynamic                                
  14.              (and (= (car input) 2) (= (cadr input) 109)) ; m = Move
  15.              (and (= (car input) 2) (= (cadr input) 77))  ; M = Move        
  16.              (and (= (car input) 2) (= (cadr input) 99)) ; c = Copy
  17.              (and (= (car input) 2) (= (cadr input) 67)) ; C = Copy
  18.              (and (= (car input) 2) (= (cadr input) 97)) ; a = Aligned
  19.              (and (= (car input) 2) (= (cadr input) 65)) ; A = Aligned
  20.              (and (= (car input) 2) (= (cadr input) 45)) ; -
  21.              (and (= (car input) 2) (= (cadr input) 61)) ; =
  22.              (and (= (car input) 2) (= (cadr input) 43)) ; +
  23.          )
  24.     )
发表于 2011-7-16 02:00:51 | 显示全部楼层
dear sir,
why buy ???
it's freeware this code original by Andrea

点评

Who is Andrea? Italian? French?  发表于 2011-10-30 09:03
发表于 2011-7-16 11:29:04 | 显示全部楼层
好资源,要顶一个,买一个,留着再学习
发表于 2011-7-16 12:33:29 | 显示全部楼层
回复 sachindkini 的帖子

where to download this software for free?

it's freeware this code original by Andrea
where is her?
发表于 2011-7-16 13:50:25 | 显示全部楼层
Dear Sir,
This Source
  1. ;|                                                        ;;
  2.         DBMAN Dynamic Block MANipulator                 ;;
  3.         By: Andrea Andreetti 2009-01 10                        ;;
  4.         V.1.0                                                ;;
  5.                                                         ;;
  6.         v.1.1        By Andre Andreetti                        ;;
  7.         - + - added for scale factor                        ;;
  8.                                                         ;;
  9.         v.1.2        By Andre Andreetti 16-03-2009                ;;
  10.         - English/French messages added                        ;;
  11.         - Rotate Relative/Absolute/Value option added        ;;
  12.         - Mtext info added                                ;;
  13.                 .Cursor Angle                                ;;
  14.                 .Angle Object                                ;;
  15.                 .X Scale Object                                ;;
  16.                 .Y Scale Object                                ;;
  17.                 .Base Point                                ;;
  18.                 .Block Layer                                ;;
  19.         - Switch MTEXT information with TAB key                ;;
  20.         - Mtext for distance added                        ;;
  21.         - Copy option added                                ;;
  22.                                                         |;
  23.                                                         ;;
  24. (defun c:DBMan ()

  25. (defun *error* (msg)
  26.   (dbMANFinishMode)
  27.   (redraw)
  28.   (princ (strcat "\n" msg))
  29. )  

  30. ;;        FRENCH/ENGLISH DETECTION        ;;
  31.                                         ;;
  32. (defun Langage ()
  33.   (vl-load-com)
  34.   (if (vl-string-search "(FR)" (strcase (ver)))
  35.     (progn
  36.       (setq LANG "FR")
  37.       (setq mess1 "\nSelectionnez votre block...")
  38.       (setq mess2 "\n(R)otation/(E)chelle/(D)éplacer/(C)opier/(A)ligner: ")
  39.       (setq mess3 "\n(D)ynamique/(V)aleur: ")
  40.       (setq mess4 "\n(A)bsolu/(R)elatif/(V)aleur: ")
  41.       (setq mess5 "Angle: ")
  42.       (setq mess6 "échelle: ")
  43.       (setq mess7 "\nCopie... ")      

  44.       (setq mTss1 "Angle Curseur: ")
  45.       (setq mTss2 "Angle Object: ")
  46.       (setq mTss3 "échelle Object X: ")
  47.       (setq mTss4 "échelle Object Y: ")
  48.       (setq mTss5 "Point d'insertion: ")
  49.       (setq mTss6 "Calque: ")
  50.       
  51.     )
  52.     (progn
  53.       (setq LANG "EN")
  54.       (setq mess1 "\nPlease Select your Block...")
  55.       (setq mess2 "\n(R)otation/(S)cale/(M)ove/(C)opy/(A)ligned: ")
  56.       (setq mess3 "\n(D)ynamic/(V)alue: ")
  57.       (setq mess4 "\n(A)bsolute/(R)elative/(V)alue: ")
  58.       (setq mess5 "Angle: ")
  59.       (setq mess6 "Scale: ")
  60.       (setq mess7 "\nCopy... ")
  61.       
  62.       (setq mTss1 "Cursor Angle: ")
  63.       (setq mTss2 "Object Angle: ")
  64.       (setq mTss3 "Object Scale X: ")
  65.       (setq mTss4 "Object Scale Y: ")
  66.       (setq mTss5 "Insertion Point: ")
  67.       (setq mTss6 "Layer: ")
  68.     )
  69.   )
  70. )
  71. (Langage)
  72.                                         ;;
  73. ;;        FRENCH/ENGLISH DETEXTION        ;;






  74. ;;        Degree Conversion        ;;
  75.                                 ;;
  76. (defun dtr (a)
  77. (* pi (/ a 180.0))
  78. )

  79. (defun rtd (a)
  80. (/ (* a 180) pi)
  81. )
  82.                                 ;;
  83. ;;        Degree Conversion        ;;



  84.   
  85.   

  86. ;;        ENTITY SELECTION                ;;
  87.                                         ;;
  88. (setq dr_sel1 nil)
  89. (while        (or
  90.           (= dr_sel1 nil)
  91.           (/= (cdr (assoc 0 (setq dr_sel1data (entget (car dr_sel1)))))
  92.               "INSERT"
  93.           )
  94.         )
  95.    (setq dr_sel1 (entsel mess1))
  96. )

  97. (setq Bedata (entget (car dr_sel1)))
  98. (setq Bselec (cdar Bedata))
  99. (setq Bname (cdr (assoc 2 Bedata)))
  100. (setq Bbase (cdr (assoc 10 Bedata)))
  101. (setq bENAME (cdr (assoc -1 Bedata)))
  102. (setq insPblock Bbase)

  103. (setq allBlock (ssget "X" (list (cons 0 "INSERT") (cons 2 Bname))))
  104. (setq #block (1- (sslength allBlock)))
  105. (setq #block2 #block)
  106.                                         ;;
  107. ;;        ENTITY SELECTION                ;;


  108. (setq ANGpoints nil)
  109.      (setq _val -1)
  110.       (repeat (1+ #block2)
  111.         (setq _SSblock (ssname allBlock (setq _val (1+ _val))))
  112.         (setq _entBdata (entget _SSblock))
  113.         (setq ANGpoints
  114.                (append
  115.                  ANGpoints
  116.                  (list (list _SSblock (cdr (assoc 50 _entBdata))))
  117.                )
  118.         )
  119.       )

  120. (setq snapang (getvar "snapang"))  
  121.   
  122. (vla-StartUndoMark (vla-get-ActiveDocument (vlax-get-ACAD-Object)))
  123. (DBM_go) ;_while
  124. (while
  125.    (and
  126.      (not (= (car input) 25))                ;RIGHT CLICK
  127.      (not (= (car input) 11))                ;RIGHT CLICK
  128.      (not (= (car input) 3))                ;LEFT CLICK
  129.      (not (and (= (car input) 2) (= (cadr input) 32))) ;ESCAPE
  130.      (not (and (= (car input) 2) (= (cadr input) 13))) ;ENTER
  131.    )
  132.     (DBM_go)
  133. )  
  134. (dbMANFinishMode)
  135. (vla-EndUndoMark (vla-get-ActiveDocument (vlax-get-ACAD-Object)))  
  136. )
  137.                                                 ;;
  138. ;|                                                ;;
  139.         DBMAN Dynamic Block MANipulator         ;;
  140.                                                 |;







  141. ;|                                        ;;
  142.         DBMAN KEY PRESSED DETECTION        ;;
  143.                                         |;
  144.                                         ;;
  145. (defun DBM_GO ()
  146. (setvar "CMDECHO" 0)
  147. (setq orthm (getvar "ORTHOMODE"))
  148. (setq snapa (getvar "SNAPANG"))  
  149. (setq ToDo nil)
  150. (setq INSpoints nil
  151.       ANGpoints nil
  152.       SCALEpoints nil
  153.       DBMTdata nil
  154.       DBMTdataDI nil)
  155.   
  156. (setq val -1)
  157. (repeat        (1+ #block)
  158.   (setq SSblock (ssname allBlock (setq val (1+ val))))
  159.   (setq entBdata (entget SSblock))
  160.   (setq
  161.     INSpoints (append INSpoints
  162.                       (list (list SSblock (cdr (assoc 10 entBdata))))
  163.               )
  164.   )
  165.   (setq INSlocation INSpoints)
  166.   (setq
  167.     ANGpoints (append ANGpoints
  168.                       (list (list SSblock (cdr (assoc 50 entBdata))))
  169.               )
  170.   )
  171.   (setq
  172.     SCALEpoints (append SCALEpoints
  173.                       (list (list SSblock (list (cdr (assoc 41 entBdata)) (cdr (assoc 42 entBdata)))))
  174.               )
  175.   )
  176. )

  177. (setq LLent (vl-list-length INSpoints))
  178. (setq #iblock 0)
  179.   
  180. (setq multiplier 1.4)
  181. (setq RotRequest nil)
  182. (princ mess2)
  183. (setq messPRINT T)  
  184. (setq input (grread t 4 4))  
  185. (while (and (setq input (grread t 4 4))
  186.             (or        (= (car input) 5)        ; *cursor
  187.                 (and (= (car input) 2) (= (cadr input) 9))
  188.                                         ;TAB
  189.                 (and (= (car input) 2) (= (cadr input) 15))
  190.                                         ; F8 Orthomode
  191.                 (and (= (car input) 2) (= (cadr input) 114))
  192.                                         ; r = Rotation
  193.                 (and (= (car input) 2) (= (cadr input) 82))
  194.                                         ; R = Rotation
  195.                 (and (= (car input) 2) (= (cadr input) 115))
  196.                                         ; s = Scale
  197.                 (and (= (car input) 2) (= (cadr input) 83)) ; S = Scale
  198.                 (and (= (car input) 2) (= (cadr input) 101))
  199.                                         ; e = Echelle
  200.                 (and (= (car input) 2) (= (cadr input) 69))
  201.                                         ; E = Echelle
  202.                 (and (eq LANG "FR")(= (car input) 2) (= (cadr input) 100)) ; d = Déplacer
  203.                 (and (eq LANG "FR")(= (car input) 2) (= (cadr input) 68))  ; D = Déplacer
  204.                                  
  205.                 (and (eq LANG "EN") (= (car input) 2) (= (cadr input) 109)) ; m = Move
  206.                 (and (eq LANG "EN")(= (car input) 2) (= (cadr input) 77))  ; M = Move
  207.                
  208.                 (and (= (car input) 2) (= (cadr input) 99))  ; c = Copy
  209.                 (and (= (car input) 2) (= (cadr input) 67))  ; C = Copy
  210.                
  211.                 (and (= (car input) 2) (= (cadr input) 97))
  212.                                         ; a = Aligned
  213.                 (and (= (car input) 2) (= (cadr input) 65))
  214.                                         ; A = Aligned
  215.                 (and (= (car input) 2) (= (cadr input) 45))

  216.                 ;(and (= (car input) 2) (= (cadr input) 51))  ; 3D
  217.                                         ; -
  218.                 (and (= (car input) 2) (= (cadr input) 61))
  219.                 (and (= (car input) 2) (= (cadr input) 43))
  220.                                         ; +
  221.             )
  222.        )

  223.   (redraw)

  224. (if (not messPRINT)
  225.    (progn
  226.      (princ mess2)
  227.      (setq messPRINT T)
  228.    )
  229. )

  230. (if (not cursorpoint)
  231.   (setq cursorpoint (getvar "Lastpoint"))
  232.   )

  233. ; Cursor Point
  234.   (if (= (car input) 5)
  235.     (progn
  236.       (setq cursorpoint (cadr input))
  237.       (setq cursorangle (angle Bbase cursorpoint))
  238.       (setq cursordistance (distance Bbase cursorpoint))
  239.     )
  240.   )

  241.   
  242. ; TAB
  243. (if (and (= (car input) 2) (= (cadr input) 9))
  244.   (progn
  245. (if (eq #iblock (1- LLent))
  246.   (setq #iblock 0)
  247.   (setq #iblock (1+ #iblock))
  248. )
  249. (setq bENAME        (car (nth #iblock INSpoints)))
  250. (setq insPblock (cdr (assoc 10 (entget (car (nth #iblock INSpoints))))))
  251. (setq itemLayer (cdr (assoc 8 (entget bENAME))))        ;Block Layer bENAME
  252. )
  253. )

  254.   
  255.   (if (or
  256.         (and (= (car input) 2) (= (cadr input) 114))         ; r = Rotation
  257.         (and (= (car input) 2) (= (cadr input) 82))         ; R
  258.       )
  259.     (progn
  260.       (setq RotRequest nil)
  261.       (setq messPRINT nil)
  262.       (setq Todo "ROTATION")
  263.     )
  264.   )

  265.   (if (or
  266.         (and (= (car input) 2) (= (cadr input) 109)) ; m = Move
  267.         (and (= (car input) 2) (= (cadr input) 77))  ; M
  268.         (and (= (car input) 2) (= (cadr input) 100)) ; D = Déplacer
  269.         (and (= (car input) 2) (= (cadr input) 68))  ; D
  270.       )
  271.     (progn
  272.       (setq RotRequest nil)
  273.       (setq Todo "MOVE")
  274.     )
  275.   )

  276.   
  277.   (if (or
  278.         (and (= (car input) 2) (= (cadr input) 99)) ; c = Copy
  279.         (and (= (car input) 2) (= (cadr input) 67))  ; C
  280.       )
  281.     (progn
  282.       (setq RotRequest nil)
  283.       (setq Todo "COPY")
  284.     )
  285.   )

  286.   
  287.   (if (vl-string-search "(FR)" (strcase (ver)))
  288.     (if        (or
  289.           (and (= (car input) 2) (= (cadr input) 101))         ; e = Echelle
  290.           (and (= (car input) 2) (= (cadr input) 69))         ; E
  291.         )
  292.       (progn
  293.       (setq RotRequest nil)
  294.       (setq messPRINT nil)
  295.       (setq Todo "SCALE")
  296.       )
  297.     )
  298.     (if        (or
  299.           (and (= (car input) 2) (= (cadr input) 115)) ; s = Scale
  300.           (and (= (car input) 2) (= (cadr input) 83)) ; S
  301.         )
  302.       (progn
  303.       (setq RotRequest nil)
  304.       (setq Todo "SCALE")
  305.       )
  306.     )
  307.   )


  308.   (if (or
  309.         (and (= (car input) 2) (= (cadr input) 97)) ; m = Move
  310.         (and (= (car input) 2) (= (cadr input) 65)) ; M
  311.       )
  312.     (progn
  313.       (setq RotRequest nil)
  314.       (setq Todo "ALIGNED")
  315.     )
  316.   )
  317.   
  318. (if (and (= (car input) 2) (= (cadr input) 15))
  319.   (setq Todo "ORTHO")
  320. )

  321.   

  322. ; +
  323. (if (or
  324.       (and (= (car input) 2) (= (cadr input) 61))
  325.       (and (= (car input) 2) (= (cadr input) 43))
  326.     )
  327.     (setq multiplier (1+ multiplier))
  328. )

  329.   
  330.   
  331. ; -
  332. (if (and (= (car input) 2) (= (cadr input) 45))
  333.       (setq multiplier (1- multiplier))
  334. )  


  335.   

  336. ;;SWITCH ORTHOMODE                ;;
  337.                                 ;;
  338. (if (eq ToDo "ORTHO")
  339.   (progn
  340.     (if (eq orthm 1)
  341.            (progn (setvar "ORTHOMODE" 0) (setq orthm 0))
  342.            (progn (setvar "ORTHOMODE" 1) (setq orthm 1))
  343.          )
  344.     (setq ToDo PreviousToDo)
  345.   )
  346. )
  347. (if (eq orthM 1)
  348.   (DBMANortho)
  349.   )      
  350.                                 ;;
  351. ;;SWITCH ORTHOMODE                ;;







  352. ;|        R O T A T I O N         |;  
  353.   (setq val -1)
  354.   (if (eq ToDo "ROTATION")
  355.     (progn
  356.       (if (not RotRequest)
  357.         (progn
  358.           (initget "R A V" 1)
  359.           (setq RotRequest (getKword mess4))               

  360.       (if (eq RotRequest "V")
  361.         (progn
  362.         (setq snapA (dtr (getreal mess5)))
  363.         (command "SNAPANG" (rtd snapA))
  364.         (setvar "ORTHOMODE" 1) (setq orthm 1)  
  365.         )        
  366.       )
  367.       )
  368.       )
  369.       (UpdateBlocks 50 nil)
  370.     )
  371.   )







  372.   
  373. ;|        M O V E         |;
  374.   (setq val -1)
  375.   (if (eq ToDo "MOVE")
  376.     (progn
  377.       (setq _val -1)
  378.       (repeat (1+ #block2)
  379.         (setq _SSblock (ssname allBlock (setq _val (1+ _val))))
  380.         (setq _entBdata (entget _SSblock))
  381.         (setq INSlocation
  382.                (append
  383.                  INSlocation
  384.                  (list (list _SSblock (cdr (assoc 10 _entBdata))))
  385.                )
  386.         )
  387.       )
  388.       (UpdateBlocks 10 nil)
  389.     )
  390.   )




  391.   

  392. ;|        C O P Y         |;  
  393.   (setq val -1)
  394.   (if (eq todo "COPY")
  395.     (progn (setq newobjects (ssadd))
  396.            (princ mess7)
  397.            (setq messprint t)
  398.            (setq input2 (grread t 5 0))
  399.           (while input2
  400.              (if (= (car input2) 3)
  401.                  (setq copycursor (cadr input2))
  402.              )
  403.             
  404.              (if newobjects
  405.                (vl-cmdf "._erase" newobjects "")            
  406.              )
  407.              (if (= (car input2) 5)
  408.                (progn (redraw)

  409. (setq cursorpos (cadr input2))
  410. (DBMANtextDI 254 (polar Bbase (angle Bbase cursorpos) (/ (distance Bbase cursorpos) 2))
  411.                      (distance Bbase cursorpos))
  412.                  
  413.                       (foreach n inspoints
  414.                         (setq copypoint (polar (cadr n)
  415.                                                (angle bbase (cadr input2))
  416.                                                (distance bbase (cadr input2))
  417.                                         )
  418.                         )
  419.                         (entmake (subst (cons 10 copypoint)
  420.                                         (assoc 10 (entget (car n)))
  421.                                         (entget (car n))
  422.                                  )
  423.                         )
  424.                         (setq newobject (entlast))
  425.                         (ssadd newobject newobjects)
  426.                         (grdraw (cadr n)
  427.                                 (polar (cadr n)
  428.                                        (angle bbase (cadr input2))
  429.                                        (distance bbase (cadr input2))
  430.                                 )
  431.                                 4
  432.                                 1
  433.                         )
  434.                       )
  435.                )
  436.              )
  437.              (if (and copycursor (= (car input2) 3))
  438.                (progn (foreach n inspoints
  439.                         (setq copypoint (polar (cadr n)
  440.                                                (angle bbase copycursor)
  441.                                                (distance bbase copycursor)
  442.                                         )
  443.                         )
  444.                         (entmake (subst (cons 10 copypoint)
  445.                                         (assoc 10 (entget (car n)))
  446.                                         (entget (car n))
  447.                                  )
  448.                         )
  449.                       )
  450.                )
  451.              )


  452. (if (= (car input2) 11)
  453.                  (setq input2 nil)
  454.   (setq input2 (grread t 5 0))
  455.              )
  456.             
  457. );_while


  458.       
  459. (if (eq (car input2) 11)
  460. (if newobjects
  461.                (vl-cmdf "._erase" newobjects "")            
  462.              )
  463.   )      
  464.     )
  465.   )

  466. (if NewObjects
  467.     (setq NewObjects nil)
  468. )  
  469.   





  470.   
  471. ;|        S C A L E         |;
  472.   (setq val -1)
  473.   (if (eq ToDo "SCALE")
  474.     (progn
  475.       (if (not RotRequest)
  476.         (progn
  477.           (initget "R A V" 1)
  478.           (setq RotRequest (getKword mess4))               

  479.       (if (eq RotRequest "V")        
  480.         (setq SpecScale (getreal mess6))  
  481.         (setq SpecScale cursordistance)         
  482.       )
  483.       )
  484.         )
  485.       (UpdateBlocks nil (/ cursordistance (abs multiplier)))
  486.     )
  487.   )

  488.   
  489.   (setq val -1)
  490.   (if (eq ToDo "ALIGNED")
  491.     (UpdateBlocks 50 cursorpoint)
  492.   )

  493.   
  494. (setq PreviousToDo ToDo)  

  495. )


  496. (if DBMTdata
  497.   (progn (vl-cmdf "._erase" DBMTdata "")
  498.          (setq DBMTdata nil)
  499.   )
  500. )
  501. (if DBMTdataDI
  502.   (progn (vl-cmdf "._erase" DBMTdataDI "")
  503.          (setq DBMTdataDI nil)
  504.   )
  505. )  
  506.   
  507. (redraw)
  508. )
  509.                                         ;;
  510. ;|                                        ;;
  511.         DBMAN KEY PRESSED DETECTION        ;;
  512.                                         |;















  513. ;|                                        ;;
  514.         BLOCK UPDATE                        ;;
  515.                                         |;
  516.                                         ;;
  517. (defun UpdateBlocks (cons1 value)


  518.   (setq NBpoint (cadr (assoc Bselec INSlocation)))
  519.   (repeat (1+ #block)
  520.     (setq SSblock (ssname allBlock (setq val (1+ val))))
  521.     (setq entBdata (entget SSblock))
  522.     (setq ent10 (cdr (assoc 10 entBdata)))        ;insertion point
  523.     (setq itemangle (cdr (assoc 50 entBdata)))        ;Block Angle

  524.     (setq cursorpoint2 cursorpoint)
  525.     (setq cursorangle2 (angle NBpoint cursorpoint))   
  526.     (setq cursordistance2 (distance NBpoint cursorpoint))  
  527.    
  528.     (if        (eq ToDo "MOVE")
  529.       (progn
  530.         (setq Npoint2 (polar (cadr (assoc SSblock INSpoints)) cursorangle2 cursordistance2))
  531.         
  532.         (grdraw (cadr (assoc SSblock INSpoints))
  533.                 Npoint2
  534.                 4
  535.                 1
  536.              )
  537.                         
  538.         (setq cursorangle2 (angle (cadr (assoc SSblock INSpoints)) Npoint2))
  539.         (setq entBdata (subst (cons cons1 Npoint2)
  540.                               (assoc cons1 entBdata)
  541.                               entBdata
  542.                        )
  543.         )
  544. (setq insPblock (cdr (assoc 10 (entget (car (nth #iblock INSpoints))))))
  545.         
  546.       )
  547.     )



  548.     (if (eq todo "ROTATION")
  549.       (progn (grdraw ent10
  550.                      (polar ent10 (angle NBpoint cursorpoint) cursordistance)
  551.                      4
  552.                      1
  553.              )

  554. (setq value (angle  ent10 (polar ent10 (angle NBpoint cursorpoint) cursordistance)))
  555.         
  556.              (if (eq rotrequest "R");Relatif
  557.                (progn
  558.                (Setq  IBangle (+ value (cadr (assoc SSblock ANGpoints))))
  559.                (Setq  itemAngle (cdr (assoc cons1 entbdata)))
  560.                )
  561.              )
  562.              (if (eq rotrequest "A");Absolu
  563.                (progn
  564.                (setq itemangle value)
  565.                (setq IBangle value)
  566.                )
  567.              )
  568.              (if (eq rotrequest "V");Valeur
  569.                (progn
  570.                (setq itemangle value)
  571.                (setq IBangle value)
  572.                )
  573.              )
  574.              (setq entbdata (subst (cons cons1 IBangle)
  575.                                    (assoc cons1 entbdata)
  576.                                    entbdata
  577.                             )
  578.              )
  579.       )
  580.     )



  581.     (if        (eq ToDo "SCALE")
  582.       (progn
  583.         (grdraw        ent10
  584.                 (polar ent10
  585.                        cursorangle2
  586.                        cursordistance2
  587.                 )
  588.                 4
  589.                 1
  590.         )      
  591.         (if (eq rotrequest "R");Relatif
  592.                (progn
  593.                (Setq  itemXscale   (+ value (caadr (assoc SSblock SCALEpoints))))
  594.                (Setq  itemYscale   (+ value (cadadr (assoc SSblock SCALEpoints))))  
  595.                )
  596.           )
  597.         (if (eq rotrequest "A");Absolu
  598.                (progn
  599.                  (setq itemXscale value)
  600.                  (setq itemYscale value)
  601.                )
  602.           )
  603.         (if (eq rotrequest "V");Valeur
  604.                (progn
  605.                  (setq itemXscale value)
  606.                  (setq itemYscale value)
  607.                )
  608.           )
  609.         (setq entBdata (subst (cons 41 itemXscale) (assoc 41 entBdata)  entBdata ))
  610.         (setq entBdata (subst (cons 42 itemYscale) (assoc 42 entBdata)  entBdata ))
  611.       )  
  612.     )


  613.    
  614.     (if        (eq ToDo "ALIGNED")
  615.       (progn
  616.         (setq e10 (cdr (assoc 10 entBdata)))
  617.         (grdraw        e10
  618.                 (polar e10 (angle e10 value) (distance e10 value))
  619.                 4
  620.                 1
  621.         )
  622.         (setq entBdata (subst (cons cons1 (angle e10 value))
  623.                               (assoc cons1 entBdata)
  624.                               entBdata
  625.                        )
  626.         )
  627.       )
  628.     )



  629. (setq itemAngle (rtd (cdr (assoc 50 (entget bENAME)))))
  630. (setq itemXscale (cdr (assoc 41 (entget bENAME))))
  631. (setq itemYscale (cdr (assoc 42 (entget bENAME))))
  632.    
  633. (if (> itemAngle 360.0)
  634.   (setq itemAngle (- itemAngle 360.0))
  635. )
  636.    
  637. (DBMANtext 252 (rtd cursorangle2) itemAngle itemXscale itemYscale insPblock itemLayer)
  638. (entmod entBdata)
  639. )

  640. (if (or
  641.       (eq ToDo "MOVE")
  642.       (eq ToDo "COPY")
  643.     )
  644.   (DBMANtextDI 254 (polar NBpoint (angle NBpoint cursorpoint) (/ (distance NBpoint cursorpoint) 2))
  645.                      (distance NBpoint cursorpoint))
  646.   )

  647.   
  648. (setq cursorpoint2 nil)  
  649. )
  650.                                         ;;
  651. ;|                                        ;;
  652.         BLOCK UPDATE                        ;;
  653.                                         |;






  654.                                        
  655. ;|                                        ;;
  656.         DBMAN ORTHOMODE                        ;;
  657.                                         |;
  658.                                         ;;
  659. (defun DBMANortho (/ distP NorthP WestP EastP SouthP)
  660.   
  661.     (setq distP (distance Bbase cursorpoint))
  662.     (setq NorthP (polar Bbase (+ snapA (dtr 90)) distP))
  663.     (setq WestP  (polar Bbase (+ snapA (dtr 180)) distP))
  664.     (setq EastP  (polar Bbase snapA distP))
  665.     (setq SouthP (polar Bbase (- snapA (dtr 90)) distP))
  666.   
  667. (if (and
  668.       (< (distance cursorpoint NorthP) (distance cursorpoint WestP))
  669.       (< (distance cursorpoint NorthP) (distance cursorpoint EastP))
  670.       (< (distance cursorpoint NorthP) (distance cursorpoint SouthP))
  671.     )
  672. (setq cursorpoint NorthP)
  673. )

  674. (if (and
  675.       (< (distance cursorpoint WestP) (distance cursorpoint NorthP))
  676.       (< (distance cursorpoint WestP) (distance cursorpoint EastP))
  677.       (< (distance cursorpoint WestP) (distance cursorpoint SouthP))
  678.     )
  679. (setq cursorpoint WestP)
  680. )  

  681. (if (and
  682.       (< (distance cursorpoint EastP) (distance cursorpoint WestP))
  683.       (< (distance cursorpoint EastP) (distance cursorpoint NorthP))
  684.       (< (distance cursorpoint EastP) (distance cursorpoint SouthP))
  685.     )
  686. (setq cursorpoint EastP)
  687. )

  688. (if (and
  689.       (< (distance cursorpoint SouthP) (distance cursorpoint WestP))
  690.       (< (distance cursorpoint SouthP) (distance cursorpoint EastP))
  691.       (< (distance cursorpoint SouthP) (distance cursorpoint NorthP))
  692.     )
  693. (setq cursorpoint SouthP)
  694. )  
  695. )
  696.                                         ;;
  697. ;|                                        ;;
  698.         DBMAN ORTHOMODE                        ;;
  699.                                         |;







  700. ;|                                        ;;
  701.         MTEXT CREATION DISTANCE                ;;
  702.                                         |;
  703.                                         ;;
  704. (defun DBMANtextDI (
  705.                           bakgr         ;background color
  706.                             po        ;Position
  707.                         DI         ;DIstance
  708.                    )
  709.   
  710. (if DBMTdataDI
  711.   (progn (vl-cmdf "._erase" DBMTdataDI "")
  712.          (setq DBMTdataDI nil)
  713.   )
  714. )

  715. (setq DBMTstringDI (strcat  "{\\fArial|b0|i0|c0|p34;\\C250;"
  716.                           "\\C5;" (vl-princ-to-string DI) "\\C250\\P"
  717.                   )
  718. )
  719.              (setq ViewSize (getvar "VIEWSIZE"))
  720.              (setq DBMTdataDI
  721.                     (entmakex
  722.                       (list
  723.                         (cons 0 "MTEXT")
  724.                         (cons 100 "AcDbEntity")
  725.                         (cons 100 "AcDbMText")
  726.                         (cons 1 DBMTstringDI)
  727.                         (cons 10
  728.                               (polar po 0 (/ ViewSize 90.0))
  729.                         )
  730.                         (cons 40 (/ ViewSize 70.0))
  731.                         (cons 50 0.0)
  732.                         (cons 62 250)
  733.                         (cons 71 5)                        
  734.                         (cons 72 5)
  735.                         (cons 73 1)
  736.                         (cons 90 1)
  737.                         (cons 63 bakgr)
  738.                         (cons 45 1.2)
  739.                       )
  740.                     )
  741.              )
  742. )
  743.                                         ;;
  744. ;|                                        ;;
  745.         MTEXT CREATION DISTANCE                ;;
  746.                                         |;










  747. ;|                                        ;;
  748.         MTEXT CREATION INFO                ;;
  749.                                         |;
  750.                                         ;;
  751. (defun DBMANtext (
  752.                           bakgr         ;background color
  753.                         CA         ;Cursor Angle
  754.                         AO         ;Angle Object
  755.                           xSO        ;X Scale Object
  756.                           ySO        ;Y Scale Object
  757.                         BP         ;Base Ppoint
  758.                           BL        ;Block Layer
  759.                 )

  760. (if DBMTdata
  761.   (progn (vl-cmdf "._erase" DBMTdata "")
  762.          (setq DBMTdata nil)
  763.   )
  764. )
  765. (setq DBMTstring (strcat  "{\\fArial|b0|i0|c0|p34;\\C250;"
  766.                           mTss1 "\\C5;" (vl-princ-to-string CA) "°\\C250\\P"
  767.                           mTss2 "\\C5;" (vl-princ-to-string AO) "°\\C250\\P"
  768.                           mTss3 "\\C5;" (vl-princ-to-string xSO) "\\C250\\P"
  769.                           mTss4 "\\C5;" (vl-princ-to-string ySO) "\\C250\\P"
  770.                           mTss5 "\\C5;" (vl-princ-to-string BP) "\\C250\\P"
  771.                           mTss6 "\\C5;" (vl-princ-to-string BL) "\\C250\\P"
  772.                   )
  773. )
  774.              (setq ViewSize (getvar "VIEWSIZE"))
  775.              (setq DBMTdata
  776.                     (entmakex
  777.                       (list
  778.                         (cons 0 "MTEXT")
  779.                         (cons 100 "AcDbEntity")
  780.                         (cons 100 "AcDbMText")
  781.                         (cons 1 DBMTstring)
  782.                         (cons 10
  783.                               (polar BP 0 (/ ViewSize 90.0))
  784.                         )
  785.                         (cons 40 (/ ViewSize 70.0))
  786.                         (cons 50 0.0)
  787.                         (cons 62 250)
  788.                         (cons 71 1)
  789.                         (cons 72 5)
  790.                         (cons 90 1)
  791.                         (cons 63 bakgr)
  792.                         (cons 45 1.2)
  793.                       )
  794.                     )
  795.              )
  796. )
  797.                                         ;;
  798. ;|                                        ;;
  799.         MTEXT CREATION INFO                ;;
  800.                                         |;








  801. ;|                                        ;;
  802.         RESET VARIABLES                        ;;
  803.                                         |;
  804.                                         ;;
  805. (defun dbmanfinishmode ()
  806.   (redraw)
  807.   (if dbmtdata
  808.     (progn (vl-cmdf "._erase" dbmtdata "") (setq dbmtdata nil))
  809.   )
  810.   (if dbmtdatadi
  811.     (progn (vl-cmdf "._erase" dbmtdatadi "")
  812.            (setq dbmtdatadi nil)
  813.     )
  814.   )
  815.   (command "SNAPANG" (rtd snapang))
  816.   
  817.   (foreach var '(mess1        mess2        dr_sel1      bedata       bename       bname        #block
  818.                  bbase        allblock     todo         inspoints    cal          ssblock      entbdata
  819.                  cursorpoint  cursorangle  cursordistance            entbdata     npoint       npoint2
  820.                  ent10        _val         _ssblock     _entbdata    ass41        ass42        cursorpoint2
  821.                  cursorangle2 cursordistance2           orthm        snapa          snapang
  822.                 )
  823.     (setq var nil)
  824.   )
  825. )
  826.                                         ;;
  827. ;|                                        ;;
  828.         RESET VARIABLES                        ;;
  829.                                         |;

  830. ;|&#171;Visual LISP&#169; Format Options&#187;
  831. (120 2 1 2 nil "Ende von " 60 20 1 1 0 nil nil nil T)
  832. ;*** NE PAS AJOUTER de texte au-dessous du commentaire! ***|;
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|CAD论坛|CAD教程|CAD下载|联系我们|关于明经|明经通道 ( 粤ICP备05003914号 )  
©2000-2023 明经通道 版权所有 本站代码,在未取得本站及作者授权的情况下,不得用于商业用途

GMT+8, 2025-10-1 04:49 , Processed in 0.202639 second(s), 30 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

快速回复 返回顶部 返回列表