Problème avec lisp DBMAN

nen · le 23 juillet 2018

Bonjour,

Je me permets de sollicité l’aide du forum :D

J’ai trouvé un lisp de Andrea Andreetti de la société DuctiSoft (http://www.ductisoft.com) qui me servirait super bien, c’est surtout l’option rotation qui m’intéresse. ;)

Malheureusement il a un ou deux petit bug. :huh:

1. J’ai des attribut dans un blocs et quand j’effectue une rotation avec la commande DBMAN le texte ne tourne pas avec le blocs ?

2. Si on utilise l’option Déplacé, il déplace bien les blocs mais pas les attributs ?

3. L’option Copier fait planter mon AutoCAD 2018 ?

4. L’option Echelle j’ai pas compris comment elle fonctionne ?

Est-ce que quelqu’un aurait une solution ?


;|							;;
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				;;
						|;

(vl-load-com)
(princ "\nDBMAN v. 1.2 by Andrea Andreetti        -Loaded-")


(defun c:DBMan ()
(defun *error* (msg)
 (dbMANFinishMode)
 (redraw)
 (princ (strcat "\n" msg))
)  

;;	FRENCH/ENGLISH DETECTION	;;
				;;
(defun Langage ()
 
 (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")
       (progn
       (setq SpecScale (getreal mess6))
       (UpdateBlocks nil SpecScale)
       )
       (setq SpecScale cursordistance)          
     )
         ;(UpdateBlocks nil (/ cursordistance (abs multiplier)))
     )
       )
     ;(princ "eee")
     (if (/= RotRequest "V")
     ;(UpdateBlocks nil SpecScale)
     (UpdateBlocks nil (/ SpecScale (abs multiplier)))
     )
   )
 )



|

;|	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)
   )
 )

 
|;


;|	A L I G N E D		|;  
 (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			;;
				|;

;|«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! ***|;

Merci d’avance

Meilleures salutations

Patrick_35 · le 24 juillet 2018

Salut

Le plus simple est de contacter son auteur.

Je sais qu'on peut le trouver sur ce site (pseudo : Andrea).

@+

nen · le 25 juillet 2018

Bonjour,

Merci Patrick_35 pour le conseil, en effet je suis allé faire un post sur le site "The Swamp.org". :D

J'ai eu une réponse, mais pas du créateur du lisp, mais de "Augusto". :)

Il a rajouté la fonction "attsync" dans le lisp, ce qui fait que maintenant l'option rotation fonctionne avec des attributs dans un bloc, les autres options je ne les ai pas testées. ;)

Ci-dessous le code modifié :D


;|							;;
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				;;
						|;

(vl-load-com)
(princ "\nDBMAN v. 1.2 by Andrea Andreetti        -Loaded-")


(defun c:DBMan ()
(defun *error* (msg)
 (dbMANFinishMode)
 (redraw)
 (princ (strcat "\n" msg))
)  

;;	FRENCH/ENGLISH DETECTION	;;
				;;
(defun Langage ()
 
 (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")
       (progn
       (setq SpecScale (getreal mess6))
       (UpdateBlocks nil SpecScale)
       )
       (setq SpecScale cursordistance)          
     )
         ;(UpdateBlocks nil (/ cursordistance (abs multiplier)))
     )
       )
     ;(princ "eee")
     (if (/= RotRequest "V")
     ;(UpdateBlocks nil SpecScale)
     (UpdateBlocks nil (/ SpecScale (abs multiplier)))
     )
   )
 )



|

;|	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)
   )
 )

 
|;


;|	A L I G N E D		|;  
 (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)
;--------------------------------------------------------------------
;the "attsync" command has been included here
;--------------------------------------------------------------------
(vl-cmdf "_.attsync" "_N" (cdr (assoc 2 (entget bENAME))))
;--------------------------------------------------------------------

)

(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			;;
				|;

;|«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! ***|;

Merci à bientôt

Meilleures salutations

Connexion

Problème avec lisp DBMAN

Messages recommandés

nen

Patrick_35

nen

Créer un compte ou se connecter pour commenter

Créer un compte

Se connecter

Forums

Naviguer

Activité

Information importante