动态块机械手
本帖最后由 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 ;;
学习了，好东西啊 有创意。学习了
以前只接触到框选的形式，用点击的方式值得学习
谢谢楼主的分享 顶........ 哇,好好玩耶,能不能发我一份,小弟的邮箱cm88666@163.com 竟然是双语版的。 本帖最后由 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 "图层: ")
)
)
)
第二处：
(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)) ; +
)
)
dear sir,
why buy ???
it's freeware this code original by Andrea 好资源，要顶一个，买一个，留着再学习 回复 sachindkini 的帖子
where to download this software for free?
it's freeware this code original by Andrea
where is her? 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 (angleent10 (polar ent10 (angle NBpoint cursorpoint) cursordistance)))
(if (eq rotrequest "R");Relatif
(progn
(SetqIBangle (+ value (cadr (assoc SSblock ANGpoints))))
(SetqitemAngle (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
(SetqitemXscale (+ value (caadr (assoc SSblock SCALEpoints))))
(SetqitemYscale (+ 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
cursorpointcursoranglecursordistance entbdata npoint npoint2
ent10 _val _ssblock _entbdata ass41 ass42 cursorpoint2
cursorangle2 cursordistance2 orthm snapa snapang
)
(setq var nil)
)
)
;;
;| ;;
RESET VARIABLES ;;
|;
;|«Visual LISP© Format Options»
(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! ***|;
页:
[1]
2