;|							;;
	DARRAY FUNCTION					;;
	By: andrea Andreetti 2009-01-03			;;
							;;
	Update 1.1 By A.A. 2009-01-03			;;
	OrthoMode Added					;;
							;;
	Update 1.2 By A.A. 2009-01-04			;;
	Allow User to enter an Angle Value		;;
							;;
	Update 1.3 By A.A. 2009-01-04			;;
	Allow Polar array				;;
	not abort anymore when anykey is pressed	;;
							;;
	Update 1.4 By A.A. 2009-01-23			;;
	New Features:					;;
	 - Rectangular Polar Arc			;;
	 - Allow to change Qty Dinamicly		;;
	 - Allow to change Angle Dynamicly		;;
	 - Allow to align Object By pressing Shift	;;
	 - New Darray Menu				;;
							|;
(defun c:DArray	(/ sent	Dbasepoint DtoPoint #Copy SSlist P0 ang	dist
		 entcopy input Operation orthm Dmess1 Dmess2 Dmess3)

(if (vl-string-search "FR" (strcase (ver)))
(setq Dmess1 "\nNombre de CopyArray: "      
      Dmess2 "\nPoint d'attache..."
      Dmess3 "\nAppuyez (A)ngle/(Q)uantité : "
      Dmess4 "\n(L)inéaire/(R)ectangulaire/(P)olaire/(A)rc ?: "
      Dmess5 "\nPoint de base..."
      Dmess6 "\nDirection de l'arc..."
      Dmess7 "\nNombre de CopyArray en X: "
      Dmess8 "\nNombre de CopyArray en Y: "

      MTmess1 "Angle du Curseur: "
      MTmess2 "Points du Curseur: "
      MTmess3 "Point de Base: "
      MTmess4 "Qty. X: "
      MTmess5 "Qty. Y: "
      MTmess6 "Orientation Objects: "
      MTmess7 "Angle des Items: "
      MTmess8 "Qtée.: "
)
(setq Dmess1 "\nNumber of CopyArray: "      
      Dmess2 "\nAttach point..."
      Dmess3 "\nPress (A)ngle/(Q)uantity : "
      Dmess4 "\n(L)inear/(R)ectangular/(P)olar/(A)rc ?: "
      Dmess5 "\nBase point..."
      Dmess6 "\nArc direction..."
      Dmess7 "\nNumber of CopyArray X: "
      Dmess8 "\nNumber of CopyArray Y: "

      MTmess1 "Cursor Angle: "
      MTmess2 "Cursor Points: "
      MTmess3 "Base Point: "
      MTmess4 "Qty. X: "
      MTmess5 "Qty. Y: "
      MTmess6 "Object Orientation: "
      MTmess7 "Items Angle: "
      MTmess8 "Qty.: "
      
)        
)


(vl-load-com)
(setvar "CMDECHO" 0)
(setq cecolor (getvar "CECOLOR"))  
  
  (defun *error* (msg)
(DarrayFinishMode T)
(princ (strcat "\n" msg))
  )


(initget "L R P A")
(setq RorP (getKword Dmess4))

  
  (vl-cmdf "._-purge" "_B" "_{DarrayBlock}_" "_N")
  (setq sent (ssget))

(if (eq RorP "R")
  (progn
    (setq #Copy_X (getint Dmess7))
    (setq #Copy_Y (getint Dmess8))
   )
    (setq #Copy (getint Dmess1))
)
  
  (setq Dbasepoint (getpoint Dmess2))
  

(setvar "PDMODE" 34)  
(setq PDitem1
       (entmakex (list
            '(0 . "POINT")
            '(62 . 1)
             (cons 10 Dbasepoint))
          )
)

  
(setq DbasePolar (getpoint Dmess5))
(setq PDitem2
       (entmakex (list
            '(0 . "POINT")
            '(62 . 114)
             (cons 10 DbasePolar))
          )
)

(if (eq RorP "A")
  (progn    
  (setq DbaseArcPoint (getpoint Dmess6))
(setq PDitem3
       (entmakex (list
            '(0 . "POINT")
            '(62 . 8)
             (cons 10 DbaseArcPoint))
          )
)
)
)
  
  
  (vla-StartUndoMark
    (vla-get-ActiveDocument (vlax-get-ACAD-Object))
  )
  (vl-cmdf "._-block" "_{DarrayBlock}_" Dbasepoint sent "")
  (vl-cmdf "._-insert" "_{DarrayBlock}_" Dbasepoint "" "" "")
  (setq item (entlast))
  (setq Bdatax (entget item))
  (setq Ang50 (assoc 50 Bdatax))

(setq snapA (getvar "snapang"))
(setq orthm (getvar "ORTHOMODE"))

(princ Dmess3)  
  
 (DarrayWhile);_while
(while
  (and
     (not (= (car input) 25));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
   )
 (DarrayWhile)
)
  
(redraw)
(DarrayFinishMode Nil)  
  
  (vla-EndUndoMark
    (vla-get-ActiveDocument (vlax-get-ACAD-Object))
  )
  (princ)
)
						;;
;|						;;
	DYNARRAY FUNCTION			;;
						|;






;|						;;
	WHILE FUNCTION				;;
						|;
						;;
(defun DarrayWhile ()
  (while (or
	   (and (setq input (grread t 4 4))(= (car input) 5))
	   (and (= (car input) 2) (= (cadr input) 15))	; F8 Orthomode
	   (and (= (car input) 2) (= (cadr input) 97))	;a
	   (and (= (car input) 2) (= (cadr input) 65))	;A
           (and (= (car input) 2) (= (cadr input) 113))	;q
	   (and (= (car input) 2) (= (cadr input) 81))	;Q
           
         )

(if (= (car input) 5) (setq DtoPoint (cadr input)))


    
(if (and (= (car input) 2)(= (cadr input) 15))
  (setq Operation "ORTHO")
)

(if (or
      (and (= (car input) 2) (= (cadr input) 97))	;a
      (and (= (car input) 2) (= (cadr input) 65))	;A
    )  
(setq Operation "ANGLE")
)


(if (or
      (and (= (car input) 2) (= (cadr input) 113))	;q
      (and (= (car input) 2) (= (cadr input) 81))	;Q
    )  
(setq Operation "QTY")
)

(if (eq Operation "ANGLE")
  (progn
    (setq snapA (dtr (getint "\nSpecific Angle :")))
    (setq orthm 1)
    (setq Operation nil)
    (princ Dmess3)
  )
)
    
(if (eq Operation "QTY")
  (progn
    (setq #Copy (getint "\nArray Qty. :"))
    (if (= #Copy 0)(setq #Copy 1))    
    (setq Operation nil)
    (princ Dmess3)
  )
)
    
   
;;SWITCH ORTHOMODE		;;
				;;
(if (eq Operation "ORTHO")
  (progn
    (if (eq orthm 1)
      (progn (setvar "ORTHOMODE" 0) (setq orthm 0))
      (progn (setvar "ORTHOMODE" 1) (setq orthm 1))
         )
    (setq Operation nil)
  )
)
(if (eq orthM 1)
  (DarrayOrthoMode1)
)      
				;;
;;SWITCH ORTHOMODE		;;

    
;;RECTANGULAR
(if (eq RorP "L")
   (progn    
    (setq ang (angle DbasePolar DtoPoint))
    (setq dist (/ (distance DbasePolar DtoPoint) (1- #Copy)))
    (redraw)    
    (if	SSlist
      (progn
	(foreach n SSlist
	  (vl-cmdf "._erase" n "")
	  (princ)
	)
	(setq SSlist nil)
      )
    )
    (setq P0 DbasePoint)
    (setq FC DbasePolar)
    (DAMTEXT 254 DtoPoint (rtd ang) angP DbasePolar #Copy (acet-sys-shift-down))
    (repeat (1- #Copy)
      (setq P0 (polar P0 ang dist))
      (setq FC (polar FC ang dist))
      (DynArray_go P0)
      (princ)
    )
    )
 )


    
;;Polar
(if (eq RorP "P") 
   (progn 
    (setq ang  (angle DbasePolar DtoPoint))
    (setq dist (distance DbasePolar DtoPoint))
    (redraw)
(if	SSlist
      (progn
	(foreach n SSlist
	  (vl-cmdf "._erase" n "")
	  (princ)

	)
	(setq SSlist nil)
      )
    )
    
(setq angP (/ 360 #Copy))
(setq PC DtoPoint)

(DAMTEXT 254 DtoPoint (rtd ang) angP DbasePolar #Copy (acet-sys-shift-down))    
    
(repeat #Copy 
      (DynArray_go PC)
      (setq ang (dtr (+ (rtd ang) angP)))
      (setq PC (polar DbasePolar ang dist))  
      (princ)
)    
    
)
)

;;ARC
(if (eq RorP "A") 
   (progn
     (if arcitem
       (progn
         (vl-cmdf "._erase" arcitem "")
	 (setq arcitem nil)
       )
     )
(if (and
      (/= (car DbaseArcPoint)(car DtoPoint))
      (/= (cadr DbaseArcPoint)(cadr DtoPoint))
    )
  (progn
     (setvar "CECOLOR" "4")
     (vl-cmdf "._arc" DbasePolar DbaseArcPoint DtoPoint)     
     (setq arcitem (entlast))
     (setq arc10 (cdr (assoc 10 (entget arcitem))))
     (setq arc40 (cdr (assoc 40 (entget arcitem))))
     (setq arc50 (rtd (cdr (assoc 50 (entget arcitem)))))
     (setq arc51 (rtd (cdr (assoc 51 (entget arcitem)))))    

    (setq ang (dtr arc50))
    (setq dist (distance arc10 DtoPoint))
    (redraw)
    
(if SSlist
      (progn
	(foreach n SSlist
	  (vl-cmdf "._erase" n "")
	  (princ)
	)
	(setq SSlist nil)
      )
 )


(setq Tang (- arc50 arc51))
(setq angP (/ Tang #Copy))
(setq PC DtoPoint)
    
;;;(princ (strcat "\n" (vl-princ-to-string angP)))
    
(if (> angP 0)
  (progn
   (setq Tang (- (- arc50 arc51) 360))
   (setq angP (/ Tang #Copy))    
  )
)

(DAMTEXT 254 DtoPoint (rtd ang) angP DbasePolar #Copy (acet-sys-shift-down))    
    
(repeat #Copy 
      (DynArray_go PC)
      (setq ang (dtr (- (rtd ang) angP)))
      (setq PC (polar arc10 ang dist))  
      (princ)
)    
    
)
)
)    
)


(if (eq RorP "R")
   (progn    
    (setq Xbase (list (car DtoPoint) (cadr DbasePolar) (getvar "ELEVATION")))
    (setq Xang (angle DbasePolar Xbase))
    (setq dist_X (/ (distance DbasePolar Xbase) (1- #Copy_X)))

    (setq Ybase (list (car DbasePolar) (cadr DtoPoint) (getvar "ELEVATION")))
    (setq Yang (angle DbasePolar Ybase))
    (setq dist_Y (/ (distance DbasePolar Ybase) (1- #Copy_Y)))

    (setq ang (angle DbasePolar DtoPoint))
    
    (redraw)    
    (if	SSlist
      (progn
	(foreach n SSlist
	  (vl-cmdf "._erase" n "")
	  (princ)
	)
	(setq SSlist nil)
      )
    )
    (setq P0 DbasePolar)
    (setq FC (polar DbasePolar (angle DbasePolar DtoPoint)(/ (distance DbasePolar DtoPoint) 2.0)))
    (setq PQ DbasePolar) 
    (DAMTEXT 254 DtoPoint (rtd ang) #Copy_X DbasePolar #Copy_Y (acet-sys-shift-down))
   (repeat #Copy_Y 
    (repeat #Copy_X
      (DynArray_go P0)
      (setq P0 (polar P0 Xang dist_X))
      (princ)
    )  
   (setq P0 (polar PQ Yang dist_Y))
   (setq PQ P0)
     )
    
    )
 )
)
)
						;;
;|						;;
	WHILE FUNCTION				;;
						|;






;;;;|						;;
;;;	DYNARRAY COPY				;;
;;;						|;
;;;						;;
(defun DynArray_go ( NP / entcopy Bent)


(setq Bdatax (subst (cons 10 NP) (assoc 10 Bdatax) Bdatax))
  
(if (acet-sys-shift-down)
  (progn
    (if (eq RorP "R")
      (progn
        (setq DBC FC)
        (grdraw NP FC 4 1)
      )
    )
    (if (eq RorP "L")
      (progn
        (setq DBC DbasePolar)
        (grdraw DbasePolar FC 4 1)
      )
    )
    (if (eq RorP "P")
      (progn
        (setq DBC DbasePolar)
        (grdraw Dbasepolar NP 4 1)
      )
    )
    (if (eq RorP "A")
      (progn
        (setq DBC arc10)
        (grdraw arc10 NP 4 1)
      )
    )    

    (setq Bdatax (subst (cons 50 (angle NP DBC)) (assoc 50 Bdatax) Bdatax))
   )
  (progn
  (if (eq RorP "R")
        (grdraw DbasePolar NP 4 1)
    )
  (if (eq RorP "L")
      (progn
        (grdraw FC NP 4 1)
        (grdraw Dbasepolar DbasePoint 4 1)
        (grdraw DbasePolar FC 4 1)
      )
    )
  (if (eq RorP "P")
      (grdraw Dbasepolar NP 4 1)
  )
  
  (if (eq RorP "A")      
      (grdraw Dbasepolar NP 4 1)
  )    
    (setq Bdatax (subst Ang50 (assoc 50 Bdatax) Bdatax))
  )
)
  
(entmake Bdatax)
(setq Bent (entlast))

(setq SSlist (append SSlist (list Bent)))
)
;;;						;;
;;;;|						;;
;;;	DYNARRAY COPY				;;
;;;						|;






;|						;;
	DYNARRAY ORTHOMODE			;;
						|;
						;;
(defun DarrayOrthoMode1 (/ distP NorthP WestP EastP SouthP)
  
    (setq distP (distance Dbasepolar DtoPoint))
    (setq NorthP (polar Dbasepolar (+ snapA (dtr 90)) distP))
    (setq WestP  (polar Dbasepolar (+ snapA (dtr 180)) distP))
    (setq EastP  (polar Dbasepolar snapA distP))
    (setq SouthP (polar Dbasepolar (- snapA (dtr 90)) distP))
  
(if (and
      (< (distance DtoPoint NorthP) (distance DtoPoint WestP))
      (< (distance DtoPoint NorthP) (distance DtoPoint EastP))
      (< (distance DtoPoint NorthP) (distance DtoPoint SouthP))
    )
(setq DtoPoint NorthP)
)

(if (and
      (< (distance DtoPoint WestP) (distance DtoPoint NorthP))
      (< (distance DtoPoint WestP) (distance DtoPoint EastP))
      (< (distance DtoPoint WestP) (distance DtoPoint SouthP))
    )
(setq DtoPoint WestP)
)  

(if (and
      (< (distance DtoPoint EastP) (distance DtoPoint WestP))
      (< (distance DtoPoint EastP) (distance DtoPoint NorthP))
      (< (distance DtoPoint EastP) (distance DtoPoint SouthP))
    )
(setq DtoPoint EastP)
)

(if (and
      (< (distance DtoPoint SouthP) (distance DtoPoint WestP))
      (< (distance DtoPoint SouthP) (distance DtoPoint EastP))
      (< (distance DtoPoint SouthP) (distance DtoPoint NorthP))
    )
(setq DtoPoint SouthP)
)  
)
						;;
;|						;;
	DYNARRAY ORTHOMODE			;;
						|;




;;				;;
;;	Degree Conversion	;;
;;				;;
				;;
(defun dtr (a)
(* pi (/ a 180.0))
)

(defun rtd (a) 
(/ (* a 180) pi) 
)
				;;
;;				;;
;;	Degree Conversion	;;
;;				;;




;;(DAMTEXT 254 DtoPoint (rtd Xang) angP DbasePolar #Copy_X (acet-sys-shift-down))
(defun DAMTEXT (bakgr ;background color
                coord ;cursor point
                CA ;CursorAngle
                IA ;Item Angle
                BP ;Base Ppoint
                QT ;Qty
                RV ;Reverse
		)

(if RV
  (setq RVT "Polar")
  (setq RVT "Fix")
)

(if DAMTdata
  (progn (vl-cmdf "._erase" DAMTdata "")
         (setq DAMTdata nil)
  )
)



;;;      MTmess1 "Cursor Angle: "
  
;;;      MTmess2 "Cursor Points: "
;;;      MTmess3 "Base Point: "
;;;      MTmess4 "Qty. X: "
;;;      MTmess5 "Qty. Y: "
;;;      MTmess6 "Object Orientation: "
;;;  
;;;      MTmess7 "Items Angle: "

  
(if (eq RorP "R")
(setq DAMTSTRING (strcat "\\pxsm1.5,ql;{\\fArial|b0|i0|c0|p34;\\L\\O - DARRAY menu -\\P\\ps*,q*;\\l\\o}"
                          "{\\fArial|b0|i0|c0|p34;\\C250;"
                          MTmess1 "\\C5;" (vl-princ-to-string CA) "°\\C250\\P"
                          MTmess2 "\\C5;" (vl-princ-to-string coord) "\\C250\\P"
                          MTmess3 "\\C5;" (vl-princ-to-string BP) "\\C250\\P"
                          MTmess4 "\\C5;" (vl-princ-to-string IA) "\\C250\\P"
                          MTmess5 "\\C5;" (vl-princ-to-string QT) "\\C250\\P"
                          MTmess6 "\\C5;" RVT "\\C250\\P}"
		  )
)
(setq DAMTSTRING (strcat "\\pxsm1.5,ql;{\\fArial|b0|i0|c0|p34;\\L\\O - DARRAY menu -\\P\\ps*,q*;\\l\\o}"
                          "{\\fArial|b0|i0|c0|p34;\\C250;"
                          MTmess1 "\\C5;" (vl-princ-to-string CA) "°\\C250\\P"
                          MTmess7 "\\C5;" (vl-princ-to-string IA) "°\\C250\\P"
                          MTmess2 "\\C5;" (vl-princ-to-string coord) "°\\C250\\P"
                          MTmess3 "\\C5;" (vl-princ-to-string BP) "\\C250\\P"
                          MTmess8 "\\C5;" (vl-princ-to-string QT) "\\C250\\P"
                          MTmess6 "\\C5;" RVT "\\C250\\P}"
		  )
)   
)

  
  

             (setq ViewSize (getvar "VIEWSIZE"))
	     (setq DAMTdata
		    (entmakex
		      (list
			(cons 0 "MTEXT")
			(cons 100 "AcDbEntity")
			(cons 100 "AcDbMText")
			(cons 1 DAMTSTRING)
                        (cons 10
			      (polar coord 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)
		      )
		    )
	     )
 )













;;				;;
;;	FinishMode		;;
;;				;;
				;;
(defun DarrayFinishMode (val)

(setvar "CECOLOR" cecolor)
  

(if DAMTdata
  (progn (vl-cmdf "._erase" DAMTdata "")
         (setq DAMTdata nil)
  )
)


  
(if val
  (progn
(if SSlist
    (progn
      (foreach n SSlist
	(vl-cmdf "._erase" n "")

      )
      (setq SSlist nil)
    )
  )
(if item
  (progn
(vl-cmdf "._explode" item)
(setq item nil)
)
)
(vl-cmdf "._-purge" "_B" "_{DarrayBlock}_" "_N")
)

(progn  
  (if SSlist
    (progn
      (foreach n SSlist
	(vl-cmdf "._explode" n)

      )
      (setq SSlist nil)
    )
  )
(if item
  (progn
(vl-cmdf "._explode" item)
(setq item nil)
)
)
  (vl-cmdf "._-purge" "_B" "_{DarrayBlock}_" "_N")
)

)


(if arcitem
   (progn
     (vl-cmdf "._erase" arcitem "")
     (setq arcitem nil)
   )
)
  
  
(if PDitem1
  (progn
  (vl-cmdf "._erase" PDitem1 "") 
  (setq PDitem1 nil)
  )
)

(if PDitem2
  (progn
  (vl-cmdf "._erase" PDitem2 "")  
  (setq PDitem2 nil)
  )
)

(if PDitem3
  (progn
  (vl-cmdf "._erase" PDitem3 "")
  (setq PDitem3 nil)
  )
)
  (redraw)
)
				;;
;;				;;
;;	FinishMode		;;
;;				;;