动态块机械手

xiaxiang · 发表于 2011-1-7 09:11:42

本帖最后由 xiaxiang 于 2011-1-9 17:17 编辑

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

(progn
(setq LANG "EN")
(setq mess1 "\nPlease Select your Block...")
(setq mess2 "\n(R)otation/(S)cale/(M)ove/(C)opy/(A)ligned: ")
(setq mess3 "\n(D)ynamic/(V)alue: ")
(setq mess4 "\n(A)bsolute/(R)elative/(V)alue: ")
(setq mess5 "Angle: ")
(setq mess6 "Scale: ")
(setq mess7 "\nCopy... ")
(setq mTss1 "Cursor Angle: ")
(setq mTss2 "Object Angle: ")
(setq mTss3 "Object Scale X: ")
(setq mTss4 "Object Scale Y: ")
(setq mTss5 "Insertion Point: ")
(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 ;;

tianbeiyuan · 发表于 2019-11-23 20:15:56

学习了，好东西啊

461045462 · 发表于 2011-1-7 09:20:44

有创意。学习了
以前只接触到框选的形式，用点击的方式值得学习
谢谢楼主的分享

edsion24 · 发表于 2011-1-7 15:59:17

顶........

先进者 · 发表于 2011-7-15 22:02:55

哇,好好玩耶,能不能发我一份,小弟的邮箱cm88666@163.com

zhynt · 发表于 2011-7-16 00:36:36

竟然是双语版的。

zhynt · 发表于 2011-7-16 01:59:18

本帖最后由 zhynt 于 2011-7-16 02:02 编辑

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

(defun Langage ()
(vl-load-com)
(setq lang (substr (strcase (ver)) (- (strlen (ver)) 2) 2))
(cond
((= lang "FR")
(setq mess1 "\nSelectionnez votre block...")
(setq mess2 "\n(R)otation/(E)chelle/(D)閜lacer/(C)opier/(A)ligner: ")
(setq mess3 "\n(D)ynamique/(V)aleur: ")
(setq mess4 "\n(A)bsolu/(R)elatif/(V)aleur: ")
(setq mess5 "Angle: ")
(setq mess6 "蒫helle: ")
(setq mess7 "\nCopie... ")
(setq mTss1 "Angle Curseur: ")
(setq mTss2 "Angle Object: ")
(setq mTss3 "蒫helle Object X: ")
(setq mTss4 "蒫helle Object Y: ")
(setq mTss5 "Point d'insertion: ")
(setq mTss6 "Calque: ")
)
((= lang "EN")
(setq mess1 "\nPlease Select your Block...")
(setq mess2 "\n(R)otation/(S)cale/(M)ove/(C)opy/(A)ligned: ")
(setq mess3 "\n(D)ynamic/(V)alue: ")
(setq mess4 "\n(A)bsolute/(R)elative/(V)alue: ")
(setq mess5 "Angle: ")
(setq mess6 "Scale: ")
(setq mess7 "\nCopy... ")
(setq mTss1 "Cursor Angle: ")
(setq mTss2 "Object Angle: ")
(setq mTss3 "Object Scale X: ")
(setq mTss4 "Object Scale Y: ")
(setq mTss5 "Insertion Point: ")
(setq mTss6 "Layer: ")
)
((= lang "SC")
(setq mess1 "\n请选择图块...")
(setq mess2 "\n旋转(R)/比例(S)/移动(M)/复制(C)/排列(A): ")
(setq mess3 "\n动态(D)/数值(V): ")
(setq mess4 "\n绝对(A)/相对(R)/数值(V): ")
(setq mess5 "角度: ")
(setq mess6 "比例: ")
(setq mess7 "\n复制到... ")
(setq mTss1 "游标角度: ")
(setq mTss2 "对象角度: ")
(setq mTss3 "对象比例 X: ")
(setq mTss4 "对象比例 Y: ")
(setq mTss5 "插入点: ")
(setq mTss6 "图层: ")
)
)
)

(defun Langage () 
    (vl-load-com) 
    (setq lang (substr (strcase (ver)) (- (strlen (ver)) 2) 2)) 
    (cond 
      ((= lang "FR") 
       (setq mess1 "\nSelectionnez votre block...") 
       (setq mess2 "\n(R)otation/(E)chelle/(D)閜lacer/(C)opier/(A)ligner: ") 
       (setq mess3 "\n(D)ynamique/(V)aleur: ") 
       (setq mess4 "\n(A)bsolu/(R)elatif/(V)aleur: ") 
       (setq mess5 "Angle: ") 
       (setq mess6 "蒫helle: ") 
       (setq mess7 "\nCopie... ") 
       (setq mTss1 "Angle Curseur: ") 
       (setq mTss2 "Angle Object: ") 
       (setq mTss3 "蒫helle Object X: ") 
       (setq mTss4 "蒫helle Object Y: ") 
       (setq mTss5 "Point d'insertion: ") 
       (setq mTss6 "Calque: ") 
      ) 
      ((= lang "EN") 
       (setq mess1 "\nPlease Select your Block...") 
       (setq mess2 "\n(R)otation/(S)cale/(M)ove/(C)opy/(A)ligned: ") 
       (setq mess3 "\n(D)ynamic/(V)alue: ") 
       (setq mess4 "\n(A)bsolute/(R)elative/(V)alue: ") 
       (setq mess5 "Angle: ") 
       (setq mess6 "Scale: ") 
       (setq mess7 "\nCopy... ") 
       (setq mTss1 "Cursor Angle: ") 
       (setq mTss2 "Object Angle: ") 
       (setq mTss3 "Object Scale X: ") 
       (setq mTss4 "Object Scale Y: ") 
       (setq mTss5 "Insertion Point: ") 
       (setq mTss6 "Layer: ") 
      ) 
      ((= lang "SC") 
       (setq mess1 "\n请选择图块...") 
       (setq mess2 "\n旋转(R)/比例(S)/移动(M)/复制(C)/排列(A): ") 
       (setq mess3 "\n动态(D)/数值(V): ") 
       (setq mess4 "\n绝对(A)/相对(R)/数值(V): ") 
       (setq mess5 "角度: ") 
       (setq mess6 "比例: ") 
       (setq mess7 "\n复制到... ") 
       (setq mTss1 "游标角度: ") 
       (setq mTss2 "对象角度: ") 
       (setq mTss3 "对象比例 X: ") 
       (setq mTss4 "对象比例 Y: ") 
       (setq mTss5 "插入点: ") 
       (setq mTss6 "图层: ") 
      ) 
    ) 
  )

第二处：

(while
(and (setq input (grread t 4 4))
(or (= (car input) 5) ; *cursor
(and (= (car input) 2) (= (cadr input) 9)) ;TAB
(and (= (car input) 2) (= (cadr input) 15)) ; F8 Orthomode
(and (= (car input) 2) (= (cadr input) 114)) ; r = Rotation
(and (= (car input) 2) (= (cadr input) 82)) ; R = Rotation
(and (= (car input) 2) (= (cadr input) 115)) ; s = Scale
(and (= (car input) 2) (= (cadr input) 83)) ; S = Scale
(and (= (car input) 2) (= (cadr input) 101)) ; e = Echelle
(and (= (car input) 2) (= (cadr input) 69)) ; E = Echelle
(and (= (car input) 2) (= (cadr input) 100)) ; d = Dynamic
(and (= (car input) 2) (= (cadr input) 68)) ; D = Dynamic
(and (= (car input) 2) (= (cadr input) 109)) ; m = Move
(and (= (car input) 2) (= (cadr input) 77)) ; M = Move
(and (= (car input) 2) (= (cadr input) 99)) ; c = Copy
(and (= (car input) 2) (= (cadr input) 67)) ; C = Copy
(and (= (car input) 2) (= (cadr input) 97)) ; a = Aligned
(and (= (car input) 2) (= (cadr input) 65)) ; A = Aligned
(and (= (car input) 2) (= (cadr input) 45)) ; -
(and (= (car input) 2) (= (cadr input) 61)) ; =
(and (= (car input) 2) (= (cadr input) 43)) ; +
)
)

(while 
    (and (setq input (grread t 4 4)) 
         (or (= (car input) 5)                ; *cursor 
             (and (= (car input) 2) (= (cadr input) 9))   ;TAB 
             (and (= (car input) 2) (= (cadr input) 15))  ; F8 Orthomode 
             (and (= (car input) 2) (= (cadr input) 114)) ; r = Rotation                                        
             (and (= (car input) 2) (= (cadr input) 82))  ; R = Rotation 
             (and (= (car input) 2) (= (cadr input) 115)) ; s = Scale 
             (and (= (car input) 2) (= (cadr input) 83))  ; S = Scale 
             (and (= (car input) 2) (= (cadr input) 101)) ; e = Echelle 
             (and (= (car input) 2) (= (cadr input) 69))  ; E = Echelle 
             (and (= (car input) 2) (= (cadr input) 100)) ; d = Dynamic 
             (and (= (car input) 2) (= (cadr input) 68))  ; D = Dynamic                                 
             (and (= (car input) 2) (= (cadr input) 109)) ; m = Move 
             (and (= (car input) 2) (= (cadr input) 77))  ; M = Move         
             (and (= (car input) 2) (= (cadr input) 99)) ; c = Copy 
             (and (= (car input) 2) (= (cadr input) 67)) ; C = Copy 
             (and (= (car input) 2) (= (cadr input) 97)) ; a = Aligned 
             (and (= (car input) 2) (= (cadr input) 65)) ; A = Aligned 
             (and (= (car input) 2) (= (cadr input) 45)) ; - 
             (and (= (car input) 2) (= (cadr input) 61)) ; = 
             (and (= (car input) 2) (= (cadr input) 43)) ; + 
         ) 
    )

sachindkini · 发表于 2011-7-16 02:00:51

dear sir,
why buy ???
it's freeware this code original by Andrea

zwqgdhl · 发表于 2011-7-16 11:29:04

好资源，要顶一个，买一个，留着再学习

LLXXZZ · 发表于 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?

sachindkini · 发表于 2011-7-16 13:50:25

Dear Sir,
This Source

;| ;;
DBMAN Dynamic Block MANipulator ;;
By: Andrea Andreetti 2009-01 10 ;;
V.1.0 ;;
;;
v.1.1 By Andre Andreetti ;;
- + - added for scale factor ;;
;;
v.1.2 By Andre Andreetti 16-03-2009 ;;
- 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 ;;
|;
;;
(defun c:DBMan ()
(defun *error* (msg)
(dbMANFinishMode)
(redraw)
(princ (strcat "\n" msg))
)
;; FRENCH/ENGLISH DETECTION ;;
;;
(defun Langage ()
(vl-load-com)
(if (vl-string-search "(FR)" (strcase (ver)))
(progn
(setq LANG "FR")
(setq mess1 "\nSelectionnez votre block...")
(setq mess2 "\n(R)otation/(E)chelle/(D)éplacer/(C)opier/(A)ligner: ")
(setq mess3 "\n(D)ynamique/(V)aleur: ")
(setq mess4 "\n(A)bsolu/(R)elatif/(V)aleur: ")
(setq mess5 "Angle: ")
(setq mess6 "échelle: ")
(setq mess7 "\nCopie... ")
(setq mTss1 "Angle Curseur: ")
(setq mTss2 "Angle Object: ")
(setq mTss3 "échelle Object X: ")
(setq mTss4 "échelle Object Y: ")
(setq mTss5 "Point d'insertion: ")
(setq mTss6 "Calque: ")
)
(progn
(setq LANG "EN")
(setq mess1 "\nPlease Select your Block...")
(setq mess2 "\n(R)otation/(S)cale/(M)ove/(C)opy/(A)ligned: ")
(setq mess3 "\n(D)ynamic/(V)alue: ")
(setq mess4 "\n(A)bsolute/(R)elative/(V)alue: ")
(setq mess5 "Angle: ")
(setq mess6 "Scale: ")
(setq mess7 "\nCopy... ")
(setq mTss1 "Cursor Angle: ")
(setq mTss2 "Object Angle: ")
(setq mTss3 "Object Scale X: ")
(setq mTss4 "Object Scale Y: ")
(setq mTss5 "Insertion Point: ")
(setq mTss6 "Layer: ")
)
)
)
(Langage)
;;
;; FRENCH/ENGLISH DETEXTION ;;
;; Degree Conversion ;;
;;
(defun dtr (a)
(* pi (/ a 180.0))
)
(defun rtd (a)
(/ (* a 180) pi)
)
;;
;; Degree Conversion ;;
;; ENTITY SELECTION ;;
;;
(setq dr_sel1 nil)
(while (or
(= dr_sel1 nil)
(/= (cdr (assoc 0 (setq dr_sel1data (entget (car dr_sel1)))))
"INSERT"
)
)
(setq dr_sel1 (entsel mess1))
)
(setq Bedata (entget (car dr_sel1)))
(setq Bselec (cdar Bedata))
(setq Bname (cdr (assoc 2 Bedata)))
(setq Bbase (cdr (assoc 10 Bedata)))
(setq bENAME (cdr (assoc -1 Bedata)))
(setq insPblock Bbase)
(setq allBlock (ssget "X" (list (cons 0 "INSERT") (cons 2 Bname))))
(setq #block (1- (sslength allBlock)))
(setq #block2 #block)
;;
;; ENTITY SELECTION ;;
(setq ANGpoints nil)
(setq _val -1)
(repeat (1+ #block2)
(setq _SSblock (ssname allBlock (setq _val (1+ _val))))
(setq _entBdata (entget _SSblock))
(setq ANGpoints
(append
ANGpoints
(list (list _SSblock (cdr (assoc 50 _entBdata))))
)
)
)
(setq snapang (getvar "snapang"))
(vla-StartUndoMark (vla-get-ActiveDocument (vlax-get-ACAD-Object)))
(DBM_go) ;_while
(while
(and
(not (= (car input) 25)) ;RIGHT CLICK
(not (= (car input) 11)) ;RIGHT CLICK
(not (= (car input) 3)) ;LEFT CLICK
(not (and (= (car input) 2) (= (cadr input) 32))) ;ESCAPE
(not (and (= (car input) 2) (= (cadr input) 13))) ;ENTER
)
(DBM_go)
)
(dbMANFinishMode)
(vla-EndUndoMark (vla-get-ActiveDocument (vlax-get-ACAD-Object)))
)
;;
;| ;;
DBMAN Dynamic Block MANipulator ;;
|;
;| ;;
DBMAN KEY PRESSED DETECTION ;;
|;
;;
(defun DBM_GO ()
(setvar "CMDECHO" 0)
(setq orthm (getvar "ORTHOMODE"))
(setq snapa (getvar "SNAPANG"))
(setq ToDo nil)
(setq INSpoints nil
ANGpoints nil
SCALEpoints nil
DBMTdata nil
DBMTdataDI nil)
(setq val -1)
(repeat (1+ #block)
(setq SSblock (ssname allBlock (setq val (1+ val))))
(setq entBdata (entget SSblock))
(setq
INSpoints (append INSpoints
(list (list SSblock (cdr (assoc 10 entBdata))))
)
)
(setq INSlocation INSpoints)
(setq
ANGpoints (append ANGpoints
(list (list SSblock (cdr (assoc 50 entBdata))))
)
)
(setq
SCALEpoints (append SCALEpoints
(list (list SSblock (list (cdr (assoc 41 entBdata)) (cdr (assoc 42 entBdata)))))
)
)
)
(setq LLent (vl-list-length INSpoints))
(setq #iblock 0)
(setq multiplier 1.4)
(setq RotRequest nil)
(princ mess2)
(setq messPRINT T)
(setq input (grread t 4 4))
(while (and (setq input (grread t 4 4))
(or (= (car input) 5) ; *cursor
(and (= (car input) 2) (= (cadr input) 9))
;TAB
(and (= (car input) 2) (= (cadr input) 15))
; F8 Orthomode
(and (= (car input) 2) (= (cadr input) 114))
; r = Rotation
(and (= (car input) 2) (= (cadr input) 82))
; R = Rotation
(and (= (car input) 2) (= (cadr input) 115))
; s = Scale
(and (= (car input) 2) (= (cadr input) 83)) ; S = Scale
(and (= (car input) 2) (= (cadr input) 101))
; e = Echelle
(and (= (car input) 2) (= (cadr input) 69))
; E = Echelle
(and (eq LANG "FR")(= (car input) 2) (= (cadr input) 100)) ; d = Déplacer
(and (eq LANG "FR")(= (car input) 2) (= (cadr input) 68)) ; D = Déplacer
(and (eq LANG "EN") (= (car input) 2) (= (cadr input) 109)) ; m = Move
(and (eq LANG "EN")(= (car input) 2) (= (cadr input) 77)) ; M = Move
(and (= (car input) 2) (= (cadr input) 99)) ; c = Copy
(and (= (car input) 2) (= (cadr input) 67)) ; C = Copy
(and (= (car input) 2) (= (cadr input) 97))
; a = Aligned
(and (= (car input) 2) (= (cadr input) 65))
; A = Aligned
(and (= (car input) 2) (= (cadr input) 45))
;(and (= (car input) 2) (= (cadr input) 51)) ; 3D
; -
(and (= (car input) 2) (= (cadr input) 61))
(and (= (car input) 2) (= (cadr input) 43))
; +
)
)
(redraw)
(if (not messPRINT)
(progn
(princ mess2)
(setq messPRINT T)
)
)
(if (not cursorpoint)
(setq cursorpoint (getvar "Lastpoint"))
)
; Cursor Point
(if (= (car input) 5)
(progn
(setq cursorpoint (cadr input))
(setq cursorangle (angle Bbase cursorpoint))
(setq cursordistance (distance Bbase cursorpoint))
)
)
; TAB
(if (and (= (car input) 2) (= (cadr input) 9))
(progn
(if (eq #iblock (1- LLent))
(setq #iblock 0)
(setq #iblock (1+ #iblock))
)
(setq bENAME (car (nth #iblock INSpoints)))
(setq insPblock (cdr (assoc 10 (entget (car (nth #iblock INSpoints))))))
(setq itemLayer (cdr (assoc 8 (entget bENAME)))) ;Block Layer bENAME
)
)
(if (or
(and (= (car input) 2) (= (cadr input) 114)) ; r = Rotation
(and (= (car input) 2) (= (cadr input) 82)) ; R
)
(progn
(setq RotRequest nil)
(setq messPRINT nil)
(setq Todo "ROTATION")
)
)
(if (or
(and (= (car input) 2) (= (cadr input) 109)) ; m = Move
(and (= (car input) 2) (= (cadr input) 77)) ; M
(and (= (car input) 2) (= (cadr input) 100)) ; D = Déplacer
(and (= (car input) 2) (= (cadr input) 68)) ; D
)
(progn
(setq RotRequest nil)
(setq Todo "MOVE")
)
)
(if (or
(and (= (car input) 2) (= (cadr input) 99)) ; c = Copy
(and (= (car input) 2) (= (cadr input) 67)) ; C
)
(progn
(setq RotRequest nil)
(setq Todo "COPY")
)
)
(if (vl-string-search "(FR)" (strcase (ver)))
(if (or
(and (= (car input) 2) (= (cadr input) 101)) ; e = Echelle
(and (= (car input) 2) (= (cadr input) 69)) ; E
)
(progn
(setq RotRequest nil)
(setq messPRINT nil)
(setq Todo "SCALE")
)
)
(if (or
(and (= (car input) 2) (= (cadr input) 115)) ; s = Scale
(and (= (car input) 2) (= (cadr input) 83)) ; S
)
(progn
(setq RotRequest nil)
(setq Todo "SCALE")
)
)
)
(if (or
(and (= (car input) 2) (= (cadr input) 97)) ; m = Move
(and (= (car input) 2) (= (cadr input) 65)) ; M
)
(progn
(setq RotRequest nil)
(setq Todo "ALIGNED")
)
)
(if (and (= (car input) 2) (= (cadr input) 15))
(setq Todo "ORTHO")
)
; +
(if (or
(and (= (car input) 2) (= (cadr input) 61))
(and (= (car input) 2) (= (cadr input) 43))
)
(setq multiplier (1+ multiplier))
)
; -
(if (and (= (car input) 2) (= (cadr input) 45))
(setq multiplier (1- multiplier))
)
;;SWITCH ORTHOMODE ;;
;;
(if (eq ToDo "ORTHO")
(progn
(if (eq orthm 1)
(progn (setvar "ORTHOMODE" 0) (setq orthm 0))
(progn (setvar "ORTHOMODE" 1) (setq orthm 1))
)
(setq ToDo PreviousToDo)
)
)
(if (eq orthM 1)
(DBMANortho)
)
;;
;;SWITCH ORTHOMODE ;;
;| R O T A T I O N |;
(setq val -1)
(if (eq ToDo "ROTATION")
(progn
(if (not RotRequest)
(progn
(initget "R A V" 1)
(setq RotRequest (getKword mess4))
(if (eq RotRequest "V")
(progn
(setq snapA (dtr (getreal mess5)))
(command "SNAPANG" (rtd snapA))
(setvar "ORTHOMODE" 1) (setq orthm 1)
)
)
)
)
(UpdateBlocks 50 nil)
)
)
;| M O V E |;
(setq val -1)
(if (eq ToDo "MOVE")
(progn
(setq _val -1)
(repeat (1+ #block2)
(setq _SSblock (ssname allBlock (setq _val (1+ _val))))
(setq _entBdata (entget _SSblock))
(setq INSlocation
(append
INSlocation
(list (list _SSblock (cdr (assoc 10 _entBdata))))
)
)
)
(UpdateBlocks 10 nil)
)
)
;| C O P Y |;
(setq val -1)
(if (eq todo "COPY")
(progn (setq newobjects (ssadd))
(princ mess7)
(setq messprint t)
(setq input2 (grread t 5 0))
(while input2
(if (= (car input2) 3)
(setq copycursor (cadr input2))
)
(if newobjects
(vl-cmdf "._erase" newobjects "")
)
(if (= (car input2) 5)
(progn (redraw)
(setq cursorpos (cadr input2))
(DBMANtextDI 254 (polar Bbase (angle Bbase cursorpos) (/ (distance Bbase cursorpos) 2))
(distance Bbase cursorpos))
(foreach n inspoints
(setq copypoint (polar (cadr n)
(angle bbase (cadr input2))
(distance bbase (cadr input2))
)
)
(entmake (subst (cons 10 copypoint)
(assoc 10 (entget (car n)))
(entget (car n))
)
)
(setq newobject (entlast))
(ssadd newobject newobjects)
(grdraw (cadr n)
(polar (cadr n)
(angle bbase (cadr input2))
(distance bbase (cadr input2))
)
4
1
)
)
)
)
(if (and copycursor (= (car input2) 3))
(progn (foreach n inspoints
(setq copypoint (polar (cadr n)
(angle bbase copycursor)
(distance bbase copycursor)
)
)
(entmake (subst (cons 10 copypoint)
(assoc 10 (entget (car n)))
(entget (car n))
)
)
)
)
)
(if (= (car input2) 11)
(setq input2 nil)
(setq input2 (grread t 5 0))
)
);_while
(if (eq (car input2) 11)
(if newobjects
(vl-cmdf "._erase" newobjects "")
)
)
)
)
(if NewObjects
(setq NewObjects nil)
)
;| S C A L E |;
(setq val -1)
(if (eq ToDo "SCALE")
(progn
(if (not RotRequest)
(progn
(initget "R A V" 1)
(setq RotRequest (getKword mess4))
(if (eq RotRequest "V")
(setq SpecScale (getreal mess6))
(setq SpecScale cursordistance)
)
)
)
(UpdateBlocks nil (/ cursordistance (abs multiplier)))
)
)
(setq val -1)
(if (eq ToDo "ALIGNED")
(UpdateBlocks 50 cursorpoint)
)
(setq PreviousToDo ToDo)
)
(if DBMTdata
(progn (vl-cmdf "._erase" DBMTdata "")
(setq DBMTdata nil)
)
)
(if DBMTdataDI
(progn (vl-cmdf "._erase" DBMTdataDI "")
(setq DBMTdataDI nil)
)
)
(redraw)
)
;;
;| ;;
DBMAN KEY PRESSED DETECTION ;;
|;
;| ;;
BLOCK UPDATE ;;
|;
;;
(defun UpdateBlocks (cons1 value)
(setq NBpoint (cadr (assoc Bselec INSlocation)))
(repeat (1+ #block)
(setq SSblock (ssname allBlock (setq val (1+ val))))
(setq entBdata (entget SSblock))
(setq ent10 (cdr (assoc 10 entBdata))) ;insertion point
(setq itemangle (cdr (assoc 50 entBdata))) ;Block Angle
(setq cursorpoint2 cursorpoint)
(setq cursorangle2 (angle NBpoint cursorpoint))
(setq cursordistance2 (distance NBpoint cursorpoint))
(if (eq ToDo "MOVE")
(progn
(setq Npoint2 (polar (cadr (assoc SSblock INSpoints)) cursorangle2 cursordistance2))
(grdraw (cadr (assoc SSblock INSpoints))
Npoint2
4
1
)
(setq cursorangle2 (angle (cadr (assoc SSblock INSpoints)) Npoint2))
(setq entBdata (subst (cons cons1 Npoint2)
(assoc cons1 entBdata)
entBdata
)
)
(setq insPblock (cdr (assoc 10 (entget (car (nth #iblock INSpoints))))))
)
)
(if (eq todo "ROTATION")
(progn (grdraw ent10
(polar ent10 (angle NBpoint cursorpoint) cursordistance)
4
1
)
(setq value (angle ent10 (polar ent10 (angle NBpoint cursorpoint) cursordistance)))
(if (eq rotrequest "R");Relatif
(progn
(Setq IBangle (+ value (cadr (assoc SSblock ANGpoints))))
(Setq itemAngle (cdr (assoc cons1 entbdata)))
)
)
(if (eq rotrequest "A");Absolu
(progn
(setq itemangle value)
(setq IBangle value)
)
)
(if (eq rotrequest "V");Valeur
(progn
(setq itemangle value)
(setq IBangle value)
)
)
(setq entbdata (subst (cons cons1 IBangle)
(assoc cons1 entbdata)
entbdata
)
)
)
)
(if (eq ToDo "SCALE")
(progn
(grdraw ent10
(polar ent10
cursorangle2
cursordistance2
)
4
1
)
(if (eq rotrequest "R");Relatif
(progn
(Setq itemXscale (+ value (caadr (assoc SSblock SCALEpoints))))
(Setq itemYscale (+ value (cadadr (assoc SSblock SCALEpoints))))
)
)
(if (eq rotrequest "A");Absolu
(progn
(setq itemXscale value)
(setq itemYscale value)
)
)
(if (eq rotrequest "V");Valeur
(progn
(setq itemXscale value)
(setq itemYscale value)
)
)
(setq entBdata (subst (cons 41 itemXscale) (assoc 41 entBdata) entBdata ))
(setq entBdata (subst (cons 42 itemYscale) (assoc 42 entBdata) entBdata ))
)
)
(if (eq ToDo "ALIGNED")
(progn
(setq e10 (cdr (assoc 10 entBdata)))
(grdraw e10
(polar e10 (angle e10 value) (distance e10 value))
4
1
)
(setq entBdata (subst (cons cons1 (angle e10 value))
(assoc cons1 entBdata)
entBdata
)
)
)
)
(setq itemAngle (rtd (cdr (assoc 50 (entget bENAME)))))
(setq itemXscale (cdr (assoc 41 (entget bENAME))))
(setq itemYscale (cdr (assoc 42 (entget bENAME))))
(if (> itemAngle 360.0)
(setq itemAngle (- itemAngle 360.0))
)
(DBMANtext 252 (rtd cursorangle2) itemAngle itemXscale itemYscale insPblock itemLayer)
(entmod entBdata)
)
(if (or
(eq ToDo "MOVE")
(eq ToDo "COPY")
)
(DBMANtextDI 254 (polar NBpoint (angle NBpoint cursorpoint) (/ (distance NBpoint cursorpoint) 2))
(distance NBpoint cursorpoint))
)
(setq cursorpoint2 nil)
)
;;
;| ;;
BLOCK UPDATE ;;
|;
;| ;;
DBMAN ORTHOMODE ;;
|;
;;
(defun DBMANortho (/ distP NorthP WestP EastP SouthP)
(setq distP (distance Bbase cursorpoint))
(setq NorthP (polar Bbase (+ snapA (dtr 90)) distP))
(setq WestP (polar Bbase (+ snapA (dtr 180)) distP))
(setq EastP (polar Bbase snapA distP))
(setq SouthP (polar Bbase (- snapA (dtr 90)) distP))
(if (and
(< (distance cursorpoint NorthP) (distance cursorpoint WestP))
(< (distance cursorpoint NorthP) (distance cursorpoint EastP))
(< (distance cursorpoint NorthP) (distance cursorpoint SouthP))
)
(setq cursorpoint NorthP)
)
(if (and
(< (distance cursorpoint WestP) (distance cursorpoint NorthP))
(< (distance cursorpoint WestP) (distance cursorpoint EastP))
(< (distance cursorpoint WestP) (distance cursorpoint SouthP))
)
(setq cursorpoint WestP)
)
(if (and
(< (distance cursorpoint EastP) (distance cursorpoint WestP))
(< (distance cursorpoint EastP) (distance cursorpoint NorthP))
(< (distance cursorpoint EastP) (distance cursorpoint SouthP))
)
(setq cursorpoint EastP)
)
(if (and
(< (distance cursorpoint SouthP) (distance cursorpoint WestP))
(< (distance cursorpoint SouthP) (distance cursorpoint EastP))
(< (distance cursorpoint SouthP) (distance cursorpoint NorthP))
)
(setq cursorpoint SouthP)
)
)
;;
;| ;;
DBMAN ORTHOMODE ;;
|;
;| ;;
MTEXT CREATION DISTANCE ;;
|;
;;
(defun DBMANtextDI (
bakgr ;background color
po ;Position
DI ;DIstance
)
(if DBMTdataDI
(progn (vl-cmdf "._erase" DBMTdataDI "")
(setq DBMTdataDI nil)
)
)
(setq DBMTstringDI (strcat "{\\fArial|b0|i0|c0|p34;\\C250;"
"\\C5;" (vl-princ-to-string DI) "\\C250\\P"
)
)
(setq ViewSize (getvar "VIEWSIZE"))
(setq DBMTdataDI
(entmakex
(list
(cons 0 "MTEXT")
(cons 100 "AcDbEntity")
(cons 100 "AcDbMText")
(cons 1 DBMTstringDI)
(cons 10
(polar po 0 (/ ViewSize 90.0))
)
(cons 40 (/ ViewSize 70.0))
(cons 50 0.0)
(cons 62 250)
(cons 71 5)
(cons 72 5)
(cons 73 1)
(cons 90 1)
(cons 63 bakgr)
(cons 45 1.2)
)
)
)
)
;;
;| ;;
MTEXT CREATION DISTANCE ;;
|;
;| ;;
MTEXT CREATION INFO ;;
|;
;;
(defun DBMANtext (
bakgr ;background color
CA ;Cursor Angle
AO ;Angle Object
xSO ;X Scale Object
ySO ;Y Scale Object
BP ;Base Ppoint
BL ;Block Layer
)
(if DBMTdata
(progn (vl-cmdf "._erase" DBMTdata "")
(setq DBMTdata nil)
)
)
(setq DBMTstring (strcat "{\\fArial|b0|i0|c0|p34;\\C250;"
mTss1 "\\C5;" (vl-princ-to-string CA) "°\\C250\\P"
mTss2 "\\C5;" (vl-princ-to-string AO) "°\\C250\\P"
mTss3 "\\C5;" (vl-princ-to-string xSO) "\\C250\\P"
mTss4 "\\C5;" (vl-princ-to-string ySO) "\\C250\\P"
mTss5 "\\C5;" (vl-princ-to-string BP) "\\C250\\P"
mTss6 "\\C5;" (vl-princ-to-string BL) "\\C250\\P"
)
)
(setq ViewSize (getvar "VIEWSIZE"))
(setq DBMTdata
(entmakex
(list
(cons 0 "MTEXT")
(cons 100 "AcDbEntity")
(cons 100 "AcDbMText")
(cons 1 DBMTstring)
(cons 10
(polar BP 0 (/ ViewSize 90.0))
)
(cons 40 (/ ViewSize 70.0))
(cons 50 0.0)
(cons 62 250)
(cons 71 1)
(cons 72 5)
(cons 90 1)
(cons 63 bakgr)
(cons 45 1.2)
)
)
)
)
;;
;| ;;
MTEXT CREATION INFO ;;
|;
;| ;;
RESET VARIABLES ;;
|;
;;
(defun dbmanfinishmode ()
(redraw)
(if dbmtdata
(progn (vl-cmdf "._erase" dbmtdata "") (setq dbmtdata nil))
)
(if dbmtdatadi
(progn (vl-cmdf "._erase" dbmtdatadi "")
(setq dbmtdatadi nil)
)
)
(command "SNAPANG" (rtd snapang))
(foreach var '(mess1 mess2 dr_sel1 bedata bename bname #block
bbase allblock todo inspoints cal ssblock entbdata
cursorpoint cursorangle cursordistance entbdata npoint npoint2
ent10 _val _ssblock _entbdata ass41 ass42 cursorpoint2
cursorangle2 cursordistance2 orthm snapa snapang
)
(setq var nil)
)
)
;;
;| ;;
RESET VARIABLES ;;
|;
(120 2 1 2 nil "Ende von " 60 20 1 1 0 nil nil nil T)
;*** NE PAS AJOUTER de texte au-dessous du commentaire! ***|;

;|                                                        ;; 
        DBMAN Dynamic Block MANipulator                 ;; 
        By: Andrea Andreetti 2009-01 10                        ;; 
        V.1.0                                                ;; 
                                                        ;; 
        v.1.1        By Andre Andreetti                        ;; 
        - + - added for scale factor                        ;; 
                                                        ;; 
        v.1.2        By Andre Andreetti 16-03-2009                ;; 
        - 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                                ;; 
                                                        |; 
                                                        ;; 
(defun c:DBMan () 
 
(defun *error* (msg) 
  (dbMANFinishMode) 
  (redraw) 
  (princ (strcat "\n" msg)) 
)   
 
;;        FRENCH/ENGLISH DETECTION        ;; 
                                        ;; 
(defun Langage () 
  (vl-load-com) 
  (if (vl-string-search "(FR)" (strcase (ver))) 
    (progn 
      (setq LANG "FR") 
      (setq mess1 "\nSelectionnez votre block...") 
      (setq mess2 "\n(R)otation/(E)chelle/(D)éplacer/(C)opier/(A)ligner: ") 
      (setq mess3 "\n(D)ynamique/(V)aleur: ") 
      (setq mess4 "\n(A)bsolu/(R)elatif/(V)aleur: ") 
      (setq mess5 "Angle: ") 
      (setq mess6 "échelle: ") 
      (setq mess7 "\nCopie... ")       
 
      (setq mTss1 "Angle Curseur: ") 
      (setq mTss2 "Angle Object: ") 
      (setq mTss3 "échelle Object X: ") 
      (setq mTss4 "échelle Object Y: ") 
      (setq mTss5 "Point d'insertion: ") 
      (setq mTss6 "Calque: ") 
       
    ) 
    (progn 
      (setq LANG "EN") 
      (setq mess1 "\nPlease Select your Block...") 
      (setq mess2 "\n(R)otation/(S)cale/(M)ove/(C)opy/(A)ligned: ") 
      (setq mess3 "\n(D)ynamic/(V)alue: ") 
      (setq mess4 "\n(A)bsolute/(R)elative/(V)alue: ") 
      (setq mess5 "Angle: ") 
      (setq mess6 "Scale: ") 
      (setq mess7 "\nCopy... ") 
       
      (setq mTss1 "Cursor Angle: ") 
      (setq mTss2 "Object Angle: ") 
      (setq mTss3 "Object Scale X: ") 
      (setq mTss4 "Object Scale Y: ") 
      (setq mTss5 "Insertion Point: ") 
      (setq mTss6 "Layer: ") 
    ) 
  ) 
) 
(Langage) 
                                        ;; 
;;        FRENCH/ENGLISH DETEXTION        ;; 
 
 
 
 
 
 
;;        Degree Conversion        ;; 
                                ;; 
(defun dtr (a) 
(* pi (/ a 180.0)) 
) 
 
(defun rtd (a) 
(/ (* a 180) pi) 
) 
                                ;; 
;;        Degree Conversion        ;; 
 
 
 
   
   
 
;;        ENTITY SELECTION                ;; 
                                        ;; 
 (setq dr_sel1 nil) 
 (while        (or 
          (= dr_sel1 nil) 
          (/= (cdr (assoc 0 (setq dr_sel1data (entget (car dr_sel1))))) 
              "INSERT" 
          ) 
        ) 
   (setq dr_sel1 (entsel mess1)) 
 ) 
 
 (setq Bedata (entget (car dr_sel1))) 
 (setq Bselec (cdar Bedata)) 
 (setq Bname (cdr (assoc 2 Bedata))) 
 (setq Bbase (cdr (assoc 10 Bedata))) 
 (setq bENAME (cdr (assoc -1 Bedata))) 
 (setq insPblock Bbase) 
 
 (setq allBlock (ssget "X" (list (cons 0 "INSERT") (cons 2 Bname)))) 
 (setq #block (1- (sslength allBlock))) 
 (setq #block2 #block) 
                                         ;; 
 ;;        ENTITY SELECTION                ;; 
 
 
(setq ANGpoints nil) 
     (setq _val -1) 
      (repeat (1+ #block2) 
        (setq _SSblock (ssname allBlock (setq _val (1+ _val)))) 
        (setq _entBdata (entget _SSblock)) 
        (setq ANGpoints 
               (append 
                 ANGpoints 
                 (list (list _SSblock (cdr (assoc 50 _entBdata)))) 
               ) 
        ) 
      ) 
 
(setq snapang (getvar "snapang"))   
   
(vla-StartUndoMark (vla-get-ActiveDocument (vlax-get-ACAD-Object))) 
(DBM_go) ;_while 
 (while 
   (and 
     (not (= (car input) 25))                ;RIGHT CLICK 
     (not (= (car input) 11))                ;RIGHT CLICK 
     (not (= (car input) 3))                ;LEFT CLICK 
     (not (and (= (car input) 2) (= (cadr input) 32))) ;ESCAPE 
     (not (and (= (car input) 2) (= (cadr input) 13))) ;ENTER 
   ) 
    (DBM_go) 
 )   
 (dbMANFinishMode) 
(vla-EndUndoMark (vla-get-ActiveDocument (vlax-get-ACAD-Object)))   
) 
                                                ;; 
;|                                                ;; 
        DBMAN Dynamic Block MANipulator         ;; 
                                                |; 
 
 
 
 
 
 
 
;|                                        ;; 
        DBMAN KEY PRESSED DETECTION        ;; 
                                        |; 
                                        ;; 
(defun DBM_GO () 
(setvar "CMDECHO" 0) 
(setq orthm (getvar "ORTHOMODE")) 
(setq snapa (getvar "SNAPANG"))   
(setq ToDo nil) 
(setq INSpoints nil 
      ANGpoints nil 
      SCALEpoints nil 
      DBMTdata nil 
      DBMTdataDI nil) 
   
(setq val -1) 
(repeat        (1+ #block) 
  (setq SSblock (ssname allBlock (setq val (1+ val)))) 
  (setq entBdata (entget SSblock)) 
  (setq 
    INSpoints (append INSpoints 
                      (list (list SSblock (cdr (assoc 10 entBdata)))) 
              ) 
  ) 
  (setq INSlocation INSpoints) 
  (setq 
    ANGpoints (append ANGpoints 
                      (list (list SSblock (cdr (assoc 50 entBdata)))) 
              ) 
  ) 
  (setq 
    SCALEpoints (append SCALEpoints 
                      (list (list SSblock (list (cdr (assoc 41 entBdata)) (cdr (assoc 42 entBdata))))) 
              ) 
  ) 
) 
 
(setq LLent (vl-list-length INSpoints)) 
(setq #iblock 0) 
   
(setq multiplier 1.4) 
(setq RotRequest nil) 
(princ mess2) 
(setq messPRINT T)   
(setq input (grread t 4 4))   
(while (and (setq input (grread t 4 4)) 
            (or        (= (car input) 5)        ; *cursor 
                (and (= (car input) 2) (= (cadr input) 9)) 
                                        ;TAB 
                (and (= (car input) 2) (= (cadr input) 15)) 
                                        ; F8 Orthomode 
                (and (= (car input) 2) (= (cadr input) 114)) 
                                        ; r = Rotation 
                (and (= (car input) 2) (= (cadr input) 82)) 
                                        ; R = Rotation 
                (and (= (car input) 2) (= (cadr input) 115)) 
                                        ; s = Scale 
                (and (= (car input) 2) (= (cadr input) 83)) ; S = Scale 
                (and (= (car input) 2) (= (cadr input) 101)) 
                                        ; e = Echelle 
                (and (= (car input) 2) (= (cadr input) 69)) 
                                        ; E = Echelle 
                (and (eq LANG "FR")(= (car input) 2) (= (cadr input) 100)) ; d = Déplacer 
                (and (eq LANG "FR")(= (car input) 2) (= (cadr input) 68))  ; D = Déplacer 
                                  
                (and (eq LANG "EN") (= (car input) 2) (= (cadr input) 109)) ; m = Move 
                (and (eq LANG "EN")(= (car input) 2) (= (cadr input) 77))  ; M = Move 
                
                (and (= (car input) 2) (= (cadr input) 99))  ; c = Copy 
                (and (= (car input) 2) (= (cadr input) 67))  ; C = Copy 
                
                (and (= (car input) 2) (= (cadr input) 97)) 
                                        ; a = Aligned 
                (and (= (car input) 2) (= (cadr input) 65)) 
                                        ; A = Aligned 
                (and (= (car input) 2) (= (cadr input) 45)) 
 
                ;(and (= (car input) 2) (= (cadr input) 51))  ; 3D 
                                        ; - 
                (and (= (car input) 2) (= (cadr input) 61)) 
                (and (= (car input) 2) (= (cadr input) 43)) 
                                        ; + 
            ) 
       ) 
 
  (redraw) 
 
 (if (not messPRINT) 
   (progn 
     (princ mess2) 
     (setq messPRINT T) 
   ) 
 ) 
 
(if (not cursorpoint) 
  (setq cursorpoint (getvar "Lastpoint")) 
  ) 
 
; Cursor Point 
  (if (= (car input) 5) 
    (progn 
      (setq cursorpoint (cadr input)) 
      (setq cursorangle (angle Bbase cursorpoint)) 
      (setq cursordistance (distance Bbase cursorpoint)) 
    ) 
  ) 
 
   
; TAB 
(if (and (= (car input) 2) (= (cadr input) 9)) 
  (progn 
(if (eq #iblock (1- LLent)) 
  (setq #iblock 0) 
  (setq #iblock (1+ #iblock)) 
) 
(setq bENAME        (car (nth #iblock INSpoints))) 
(setq insPblock (cdr (assoc 10 (entget (car (nth #iblock INSpoints)))))) 
(setq itemLayer (cdr (assoc 8 (entget bENAME))))        ;Block Layer bENAME 
) 
) 
 
   
  (if (or 
        (and (= (car input) 2) (= (cadr input) 114))         ; r = Rotation 
        (and (= (car input) 2) (= (cadr input) 82))         ; R 
      ) 
    (progn 
      (setq RotRequest nil) 
      (setq messPRINT nil) 
      (setq Todo "ROTATION") 
    ) 
  ) 
 
  (if (or 
        (and (= (car input) 2) (= (cadr input) 109)) ; m = Move 
        (and (= (car input) 2) (= (cadr input) 77))  ; M 
        (and (= (car input) 2) (= (cadr input) 100)) ; D = Déplacer 
        (and (= (car input) 2) (= (cadr input) 68))  ; D 
      ) 
    (progn 
      (setq RotRequest nil) 
      (setq Todo "MOVE") 
    ) 
  ) 
 
   
  (if (or 
        (and (= (car input) 2) (= (cadr input) 99)) ; c = Copy 
        (and (= (car input) 2) (= (cadr input) 67))  ; C 
      ) 
    (progn 
      (setq RotRequest nil) 
      (setq Todo "COPY") 
    ) 
  ) 
 
   
  (if (vl-string-search "(FR)" (strcase (ver))) 
    (if        (or 
          (and (= (car input) 2) (= (cadr input) 101))         ; e = Echelle 
          (and (= (car input) 2) (= (cadr input) 69))         ; E 
        ) 
      (progn 
      (setq RotRequest nil) 
      (setq messPRINT nil) 
      (setq Todo "SCALE") 
      ) 
    ) 
    (if        (or 
          (and (= (car input) 2) (= (cadr input) 115)) ; s = Scale 
          (and (= (car input) 2) (= (cadr input) 83)) ; S 
        ) 
      (progn 
      (setq RotRequest nil) 
      (setq Todo "SCALE") 
      ) 
    ) 
  ) 
 
 
  (if (or 
        (and (= (car input) 2) (= (cadr input) 97)) ; m = Move 
        (and (= (car input) 2) (= (cadr input) 65)) ; M 
      ) 
    (progn 
      (setq RotRequest nil) 
      (setq Todo "ALIGNED") 
    ) 
  ) 
   
(if (and (= (car input) 2) (= (cadr input) 15)) 
  (setq Todo "ORTHO") 
) 
 
   
 
; + 
(if (or 
      (and (= (car input) 2) (= (cadr input) 61)) 
      (and (= (car input) 2) (= (cadr input) 43)) 
    ) 
    (setq multiplier (1+ multiplier)) 
) 
 
   
   
; - 
(if (and (= (car input) 2) (= (cadr input) 45)) 
      (setq multiplier (1- multiplier)) 
)   
 
 
   
 
;;SWITCH ORTHOMODE                ;; 
                                ;; 
(if (eq ToDo "ORTHO") 
  (progn 
    (if (eq orthm 1) 
           (progn (setvar "ORTHOMODE" 0) (setq orthm 0)) 
           (progn (setvar "ORTHOMODE" 1) (setq orthm 1)) 
         ) 
    (setq ToDo PreviousToDo) 
  ) 
) 
(if (eq orthM 1) 
  (DBMANortho) 
  )       
                                ;; 
;;SWITCH ORTHOMODE                ;; 
 
 
 
 
 
 
 
;|        R O T A T I O N         |;   
  (setq val -1) 
  (if (eq ToDo "ROTATION") 
    (progn 
      (if (not RotRequest) 
        (progn 
          (initget "R A V" 1) 
          (setq RotRequest (getKword mess4))                
 
      (if (eq RotRequest "V") 
        (progn 
        (setq snapA (dtr (getreal mess5))) 
        (command "SNAPANG" (rtd snapA)) 
        (setvar "ORTHOMODE" 1) (setq orthm 1)   
        )         
      ) 
      ) 
      ) 
      (UpdateBlocks 50 nil) 
    ) 
  ) 
 
 
 
 
 
 
 
   
;|        M O V E         |; 
  (setq val -1) 
  (if (eq ToDo "MOVE") 
    (progn 
      (setq _val -1) 
      (repeat (1+ #block2) 
        (setq _SSblock (ssname allBlock (setq _val (1+ _val)))) 
        (setq _entBdata (entget _SSblock)) 
        (setq INSlocation 
               (append 
                 INSlocation 
                 (list (list _SSblock (cdr (assoc 10 _entBdata)))) 
               ) 
        ) 
      ) 
      (UpdateBlocks 10 nil) 
    ) 
  ) 
 
 
 
 
   
 
;|        C O P Y         |;   
  (setq val -1) 
  (if (eq todo "COPY") 
    (progn (setq newobjects (ssadd)) 
           (princ mess7) 
           (setq messprint t) 
           (setq input2 (grread t 5 0)) 
          (while input2 
             (if (= (car input2) 3) 
                 (setq copycursor (cadr input2)) 
             ) 
             
             (if newobjects 
               (vl-cmdf "._erase" newobjects "")             
             ) 
             (if (= (car input2) 5) 
               (progn (redraw) 
 
(setq cursorpos (cadr input2)) 
(DBMANtextDI 254 (polar Bbase (angle Bbase cursorpos) (/ (distance Bbase cursorpos) 2)) 
                     (distance Bbase cursorpos)) 
                  
                      (foreach n inspoints 
                        (setq copypoint (polar (cadr n) 
                                               (angle bbase (cadr input2)) 
                                               (distance bbase (cadr input2)) 
                                        ) 
                        ) 
                        (entmake (subst (cons 10 copypoint) 
                                        (assoc 10 (entget (car n))) 
                                        (entget (car n)) 
                                 ) 
                        ) 
                        (setq newobject (entlast)) 
                        (ssadd newobject newobjects) 
                        (grdraw (cadr n) 
                                (polar (cadr n) 
                                       (angle bbase (cadr input2)) 
                                       (distance bbase (cadr input2)) 
                                ) 
                                4 
                                1 
                        ) 
                      ) 
               ) 
             ) 
             (if (and copycursor (= (car input2) 3)) 
               (progn (foreach n inspoints 
                        (setq copypoint (polar (cadr n) 
                                               (angle bbase copycursor) 
                                               (distance bbase copycursor) 
                                        ) 
                        ) 
                        (entmake (subst (cons 10 copypoint) 
                                        (assoc 10 (entget (car n))) 
                                        (entget (car n)) 
                                 ) 
                        ) 
                      ) 
               ) 
             ) 
 
 
(if (= (car input2) 11) 
                 (setq input2 nil) 
  (setq input2 (grread t 5 0)) 
             ) 
             
);_while 
 
 
       
(if (eq (car input2) 11) 
(if newobjects 
               (vl-cmdf "._erase" newobjects "")             
             ) 
  )       
    ) 
  ) 
 
(if NewObjects 
    (setq NewObjects nil) 
)   
   
 
 
 
 
 
   
;|        S C A L E         |; 
  (setq val -1) 
  (if (eq ToDo "SCALE") 
    (progn 
      (if (not RotRequest) 
        (progn 
          (initget "R A V" 1) 
          (setq RotRequest (getKword mess4))                
 
      (if (eq RotRequest "V")         
        (setq SpecScale (getreal mess6))   
        (setq SpecScale cursordistance)          
      ) 
      ) 
        ) 
      (UpdateBlocks nil (/ cursordistance (abs multiplier))) 
    ) 
  ) 
 
   
  (setq val -1) 
  (if (eq ToDo "ALIGNED") 
    (UpdateBlocks 50 cursorpoint) 
  ) 
 
   
(setq PreviousToDo ToDo)   
 
) 
 
 
(if DBMTdata 
  (progn (vl-cmdf "._erase" DBMTdata "") 
         (setq DBMTdata nil) 
  ) 
) 
(if DBMTdataDI 
  (progn (vl-cmdf "._erase" DBMTdataDI "") 
         (setq DBMTdataDI nil) 
  ) 
)   
   
(redraw) 
) 
                                        ;; 
;|                                        ;; 
        DBMAN KEY PRESSED DETECTION        ;; 
                                        |; 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
;|                                        ;; 
        BLOCK UPDATE                        ;; 
                                        |; 
                                        ;; 
(defun UpdateBlocks (cons1 value) 
 
 
  (setq NBpoint (cadr (assoc Bselec INSlocation))) 
  (repeat (1+ #block) 
    (setq SSblock (ssname allBlock (setq val (1+ val)))) 
    (setq entBdata (entget SSblock)) 
    (setq ent10 (cdr (assoc 10 entBdata)))        ;insertion point 
    (setq itemangle (cdr (assoc 50 entBdata)))        ;Block Angle 
 
    (setq cursorpoint2 cursorpoint) 
    (setq cursorangle2 (angle NBpoint cursorpoint))    
    (setq cursordistance2 (distance NBpoint cursorpoint))   
    
    (if        (eq ToDo "MOVE") 
      (progn 
        (setq Npoint2 (polar (cadr (assoc SSblock INSpoints)) cursorangle2 cursordistance2)) 
         
        (grdraw (cadr (assoc SSblock INSpoints)) 
                Npoint2 
                4 
                1 
             ) 
                         
        (setq cursorangle2 (angle (cadr (assoc SSblock INSpoints)) Npoint2)) 
        (setq entBdata (subst (cons cons1 Npoint2) 
                              (assoc cons1 entBdata) 
                              entBdata 
                       ) 
        ) 
(setq insPblock (cdr (assoc 10 (entget (car (nth #iblock INSpoints)))))) 
         
      ) 
    ) 
 
 
 
    (if (eq todo "ROTATION") 
      (progn (grdraw ent10 
                     (polar ent10 (angle NBpoint cursorpoint) cursordistance) 
                     4 
                     1 
             ) 
 
(setq value (angle  ent10 (polar ent10 (angle NBpoint cursorpoint) cursordistance))) 
         
             (if (eq rotrequest "R");Relatif 
               (progn 
               (Setq  IBangle (+ value (cadr (assoc SSblock ANGpoints)))) 
               (Setq  itemAngle (cdr (assoc cons1 entbdata))) 
               ) 
             ) 
             (if (eq rotrequest "A");Absolu 
               (progn 
               (setq itemangle value) 
               (setq IBangle value) 
               ) 
             ) 
             (if (eq rotrequest "V");Valeur 
               (progn 
               (setq itemangle value) 
               (setq IBangle value) 
               ) 
             ) 
             (setq entbdata (subst (cons cons1 IBangle) 
                                   (assoc cons1 entbdata) 
                                   entbdata 
                            ) 
             ) 
      ) 
    ) 
 
 
 
    (if        (eq ToDo "SCALE") 
      (progn 
        (grdraw        ent10 
                (polar ent10 
                       cursorangle2 
                       cursordistance2 
                ) 
                4 
                1 
        )       
        (if (eq rotrequest "R");Relatif 
               (progn 
               (Setq  itemXscale   (+ value (caadr (assoc SSblock SCALEpoints)))) 
               (Setq  itemYscale   (+ value (cadadr (assoc SSblock SCALEpoints))))   
               ) 
          ) 
        (if (eq rotrequest "A");Absolu 
               (progn 
                 (setq itemXscale value) 
                 (setq itemYscale value) 
               ) 
          ) 
        (if (eq rotrequest "V");Valeur 
               (progn 
                 (setq itemXscale value) 
                 (setq itemYscale value) 
               ) 
          ) 
        (setq entBdata (subst (cons 41 itemXscale) (assoc 41 entBdata)  entBdata )) 
        (setq entBdata (subst (cons 42 itemYscale) (assoc 42 entBdata)  entBdata )) 
      )   
    ) 
 
 
    
    (if        (eq ToDo "ALIGNED") 
      (progn 
        (setq e10 (cdr (assoc 10 entBdata))) 
        (grdraw        e10 
                (polar e10 (angle e10 value) (distance e10 value)) 
                4 
                1 
        ) 
        (setq entBdata (subst (cons cons1 (angle e10 value)) 
                              (assoc cons1 entBdata) 
                              entBdata 
                       ) 
        ) 
      ) 
    ) 
 
 
 
(setq itemAngle (rtd (cdr (assoc 50 (entget bENAME))))) 
(setq itemXscale (cdr (assoc 41 (entget bENAME)))) 
(setq itemYscale (cdr (assoc 42 (entget bENAME)))) 
    
(if (> itemAngle 360.0) 
  (setq itemAngle (- itemAngle 360.0)) 
) 
    
(DBMANtext 252 (rtd cursorangle2) itemAngle itemXscale itemYscale insPblock itemLayer) 
(entmod entBdata) 
) 
 
(if (or 
      (eq ToDo "MOVE") 
      (eq ToDo "COPY") 
    ) 
  (DBMANtextDI 254 (polar NBpoint (angle NBpoint cursorpoint) (/ (distance NBpoint cursorpoint) 2)) 
                     (distance NBpoint cursorpoint)) 
  ) 
 
   
(setq cursorpoint2 nil)   
) 
                                        ;; 
;|                                        ;; 
        BLOCK UPDATE                        ;; 
                                        |; 
 
 
 
 
 
 
                                        
;|                                        ;; 
        DBMAN ORTHOMODE                        ;; 
                                        |; 
                                        ;; 
(defun DBMANortho (/ distP NorthP WestP EastP SouthP) 
   
    (setq distP (distance Bbase cursorpoint)) 
    (setq NorthP (polar Bbase (+ snapA (dtr 90)) distP)) 
    (setq WestP  (polar Bbase (+ snapA (dtr 180)) distP)) 
    (setq EastP  (polar Bbase snapA distP)) 
    (setq SouthP (polar Bbase (- snapA (dtr 90)) distP)) 
   
(if (and 
      (< (distance cursorpoint NorthP) (distance cursorpoint WestP)) 
      (< (distance cursorpoint NorthP) (distance cursorpoint EastP)) 
      (< (distance cursorpoint NorthP) (distance cursorpoint SouthP)) 
    ) 
(setq cursorpoint NorthP) 
) 
 
(if (and 
      (< (distance cursorpoint WestP) (distance cursorpoint NorthP)) 
      (< (distance cursorpoint WestP) (distance cursorpoint EastP)) 
      (< (distance cursorpoint WestP) (distance cursorpoint SouthP)) 
    ) 
(setq cursorpoint WestP) 
)   
 
(if (and 
      (< (distance cursorpoint EastP) (distance cursorpoint WestP)) 
      (< (distance cursorpoint EastP) (distance cursorpoint NorthP)) 
      (< (distance cursorpoint EastP) (distance cursorpoint SouthP)) 
    ) 
(setq cursorpoint EastP) 
) 
 
(if (and 
      (< (distance cursorpoint SouthP) (distance cursorpoint WestP)) 
      (< (distance cursorpoint SouthP) (distance cursorpoint EastP)) 
      (< (distance cursorpoint SouthP) (distance cursorpoint NorthP)) 
    ) 
(setq cursorpoint SouthP) 
)   
) 
                                        ;; 
;|                                        ;; 
        DBMAN ORTHOMODE                        ;; 
                                        |; 
 
 
 
 
 
 
 
;|                                        ;; 
        MTEXT CREATION DISTANCE                ;; 
                                        |; 
                                        ;; 
(defun DBMANtextDI ( 
                          bakgr         ;background color 
                            po        ;Position 
                        DI         ;DIstance 
                   ) 
   
(if DBMTdataDI 
  (progn (vl-cmdf "._erase" DBMTdataDI "") 
         (setq DBMTdataDI nil) 
  ) 
) 
 
(setq DBMTstringDI (strcat  "{\\fArial|b0|i0|c0|p34;\\C250;" 
                          "\\C5;" (vl-princ-to-string DI) "\\C250\\P" 
                  ) 
) 
             (setq ViewSize (getvar "VIEWSIZE")) 
             (setq DBMTdataDI 
                    (entmakex 
                      (list 
                        (cons 0 "MTEXT") 
                        (cons 100 "AcDbEntity") 
                        (cons 100 "AcDbMText") 
                        (cons 1 DBMTstringDI) 
                        (cons 10 
                              (polar po 0 (/ ViewSize 90.0)) 
                        ) 
                        (cons 40 (/ ViewSize 70.0)) 
                        (cons 50 0.0) 
                        (cons 62 250) 
                        (cons 71 5)                         
                        (cons 72 5) 
                        (cons 73 1) 
                        (cons 90 1) 
                        (cons 63 bakgr) 
                        (cons 45 1.2) 
                      ) 
                    ) 
             ) 
 ) 
                                        ;; 
;|                                        ;; 
        MTEXT CREATION DISTANCE                ;; 
                                        |; 
 
 
 
 
 
 
 
 
 
 
;|                                        ;; 
        MTEXT CREATION INFO                ;; 
                                        |; 
                                        ;; 
(defun DBMANtext ( 
                          bakgr         ;background color 
                        CA         ;Cursor Angle 
                        AO         ;Angle Object 
                          xSO        ;X Scale Object 
                          ySO        ;Y Scale Object 
                        BP         ;Base Ppoint 
                          BL        ;Block Layer 
                ) 
 
(if DBMTdata 
  (progn (vl-cmdf "._erase" DBMTdata "") 
         (setq DBMTdata nil) 
  ) 
) 
(setq DBMTstring (strcat  "{\\fArial|b0|i0|c0|p34;\\C250;" 
                          mTss1 "\\C5;" (vl-princ-to-string CA) "°\\C250\\P" 
                          mTss2 "\\C5;" (vl-princ-to-string AO) "°\\C250\\P" 
                          mTss3 "\\C5;" (vl-princ-to-string xSO) "\\C250\\P" 
                          mTss4 "\\C5;" (vl-princ-to-string ySO) "\\C250\\P" 
                          mTss5 "\\C5;" (vl-princ-to-string BP) "\\C250\\P" 
                          mTss6 "\\C5;" (vl-princ-to-string BL) "\\C250\\P" 
                  ) 
) 
             (setq ViewSize (getvar "VIEWSIZE")) 
             (setq DBMTdata 
                    (entmakex 
                      (list 
                        (cons 0 "MTEXT") 
                        (cons 100 "AcDbEntity") 
                        (cons 100 "AcDbMText") 
                        (cons 1 DBMTstring) 
                        (cons 10 
                              (polar BP 0 (/ ViewSize 90.0)) 
                        ) 
                        (cons 40 (/ ViewSize 70.0)) 
                        (cons 50 0.0) 
                        (cons 62 250) 
                        (cons 71 1) 
                        (cons 72 5) 
                        (cons 90 1) 
                        (cons 63 bakgr) 
                        (cons 45 1.2) 
                      ) 
                    ) 
             ) 
 ) 
                                        ;; 
;|                                        ;; 
        MTEXT CREATION INFO                ;; 
                                        |; 
 
 
 
 
 
 
 
 
;|                                        ;; 
        RESET VARIABLES                        ;; 
                                        |; 
                                        ;; 
(defun dbmanfinishmode () 
  (redraw) 
  (if dbmtdata 
    (progn (vl-cmdf "._erase" dbmtdata "") (setq dbmtdata nil)) 
  ) 
  (if dbmtdatadi 
    (progn (vl-cmdf "._erase" dbmtdatadi "") 
           (setq dbmtdatadi nil) 
    ) 
  ) 
  (command "SNAPANG" (rtd snapang)) 
   
  (foreach var '(mess1        mess2        dr_sel1      bedata       bename       bname        #block 
                 bbase        allblock     todo         inspoints    cal          ssblock      entbdata 
                 cursorpoint  cursorangle  cursordistance            entbdata     npoint       npoint2 
                 ent10        _val         _ssblock     _entbdata    ass41        ass42        cursorpoint2 
                 cursorangle2 cursordistance2           orthm        snapa          snapang 
                ) 
    (setq var nil) 
  ) 
) 
                                        ;; 
;|                                        ;; 
        RESET VARIABLES                        ;; 
                                        |; 
 
;|&#171;Visual LISP&#169; Format Options&#187; 
(120 2 1 2 nil "Ende von " 60 20 1 1 0 nil nil nil T) 
;*** NE PAS AJOUTER de texte au-dessous du commentaire! ***|;

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

[资源] 动态块机械手

本帖子中包含更多资源

点评