;;-----------------------=={ Incremental Array }==----------------------;;
;;                                                                      ;;
;;  This program will array a selection of objects, whilst incrementing ;;
;;  any numerical content found in annotation objects within the        ;;
;;  selection.                                                          ;;
;;                                                                      ;;
;;  The program has two modes of operation: standard & dynamic. The     ;;
;;  standard command: 'incarray' will not display the dynamic preview,  ;;
;;  but in turn will run faster and smoother than the dynamic version   ;;
;;  - this difference is especially significant when attempting to      ;;
;;  array a large number of objects.                                    ;;
;;                                                                      ;;
;;  The dynamic mode: 'incarrayd' will display a preview of the         ;;
;;  arrayed objects as the mouse is dragged across the screen. However, ;;
;;  due to the method used to generate this preview, this mode is only  ;;
;;  suitable when using the program to array a small number of objects. ;;
;;                                                                      ;;
;;  Upon starting the program, the user is prompted to specify an       ;;
;;  increment value and then prompted to make a selection of objects    ;;
;;  to array. This selection may include any drawing object with the    ;;
;;  exception of viewports.                                             ;;
;;                                                                      ;;
;;  Following a valid selection, the user should specify a base point   ;;
;;  and array vector relative to the base point. The angle and length   ;;
;;  of this vector will determine the direction and density of the      ;;
;;  array respectively; a shorter vector will result in a denser array. ;;
;;                                                                      ;;
;;  The array may now be generated by dragging the mouse across the     ;;
;;  screen until the array reaches a desired size. If the object        ;;
;;  selection includes Text, MText, Attribute Definitions, Dimensions,  ;;
;;  or Multileader objects, any numerical data found in the text        ;;
;;  content of these objects will be automatically incremented by the   ;;
;;  given increment value as the object is arrayed.                     ;;
;;----------------------------------------------------------------------;;
;;  Author:  Lee Mac, Copyright © 2014  -  www.lee-mac.com              ;;
;;----------------------------------------------------------------------;;
;;  Version 1.0    -    2011-07-27                                      ;;
;;                                                                      ;;
;;  - First Release.                                                    ;;
;;----------------------------------------------------------------------;;
;;  Version 1.1    -    2011-07-29                                      ;;
;;                                                                      ;;
;;  - Fixed UCS bug by adding displacement flag to trans expressions.   ;;
;;    With thanks to Swamp user HighflyingBird for finding this.        ;;
;;----------------------------------------------------------------------;;
;;  Version 1.2    -    2011-07-29                                      ;;
;;                                                                      ;;
;;  - Added non-dynamic version of the program.                         ;;
;;  - Added ability to increment Attribute Def Tags, Prompts & Text.    ;;
;;  - Improved increment functionality to retain all leading and        ;;
;;    trailing zeros.                                                   ;;
;;----------------------------------------------------------------------;;
;;  Version 1.3    -    2011-08-05                                      ;;
;;                                                                      ;;
;;  - Added ability to array all objects, not just annotation objects.  ;;
;;    Any annotation objects in the selection which contain numerical   ;;
;;    data will still be incremented.                                   ;;
;;  - Attributes within arrayed attributed blocks are now incremented.  ;;
;;  - MLeader Text & Dimension Override Text are incremented.           ;;
;;----------------------------------------------------------------------;;
;;  Version 1.4    -    2011-09-30                                      ;;
;;                                                                      ;;
;;  - Fixed bug when arraying attributes on locked layers.              ;;
;;----------------------------------------------------------------------;;
;;  Version 1.5    -    2014-04-13                                      ;;
;;                                                                      ;;
;;  - Program completely rewritten.                                     ;;
;;  - Added prompt for increment value.                                 ;;
;;----------------------------------------------------------------------;;
;;  Version 1.6    -    2014-04-13                                      ;;
;;                                                                      ;;
;;  - Fixed variable name clash and grvecs bug present in AutoCAD 2006  ;;
;;    as reported by Swamp user CAB - many thanks.                      ;;
;;----------------------------------------------------------------------;;
;;  Version 1.7    -    2014-06-07                                      ;;
;;                                                                      ;;
;;  - Fixed accumulated rounding errors appearing at 44 onwards when    ;;
;;    incrementing a value of 1 by an increment of 1.                   ;;
;;----------------------------------------------------------------------;;
;;  Version 1.8    -    2016-10-26                                      ;;
;;                                                                      ;;
;;  - Fixed a bug causing the program to crash if parentheses or double ;;
;;    quotes are present in the text content.                           ;;
;;----------------------------------------------------------------------;;


;ÎÄ×ÖµÝÔö¸´ÖÆ[LM_incarray].lsp

(defun c:LM_incarray  nil (mai_last_com "LM_incarray")(LM:incarray)) ;; Standard version
; (defun c:incarrayd nil (LM:incarray  t )) ;; Dynamic  version

;;----------------------------------------------------------------------;;

(defun LM:incarray ( / *error* bpt dim dis ept inc lst obl qty tmp vxu vxw  dyn ssfirst )

    (defun *error* ( msg )
        (if (= 'int (type dim))
            (setvar 'dimzin dim)
        )
        (foreach obj obl
            (and (= 'vla-object (type obj))
                 (not (vlax-erased-p obj))
                 (vlax-write-enabled-p obj)
                 (vla-delete obj)
            )
        )
        (incarray:endundo (incarray:acdoc))
        (or (wcmatch (strcase msg t) "*break,*cancel*,*exit*")
            (princ (strcat "\nError: " msg))
        )
        (redraw) (princ)
    )

    (or (and (setq inc (getenv "LMac\\incarray")) (setq inc (distof inc)))
        (setq inc 1)
    )
    (setq ssfirst (ssgetfirst)
          ssfirst (cond ((car ssfirst)) ((cadr ssfirst)))
    )
    (if (setq tmp (getreal (strcat "\nÎÄ×ÖµÝÔö¸´ÖÆÔöÁ¿,0ÎªÆÕÍ¨¸´ÖÆ:<" (incarray:num->str inc) ">")))
        (setenv "LMac\\incarray" (incarray:num->str (setq inc tmp)))
    )
    (incarray:startundo (incarray:acdoc))
    (setq dim (getvar 'dimzin))
    (setvar 'dimzin 0)
    
    
   (prompt "\nÑ¡ÔñµÝÔö¸´ÖÆÊµÌå:<»Ø³µ¿ÕÑ¡Îª·Ç¶¯Ì¬Ä£Ê½>")
   (and ssfirst (setq lst ssfirst))
   (or lst
       (setq dyn T lst (ssget "_:L" '((0 . "~VIEWPORT"))))
       (setq dyn nil lst (ssget "_:L" '((0 . "~VIEWPORT"))))
   )
   (or lst (exit))

    (cond
        (   (not
                (and
                    (setq lst (incarray:selection->list lst))
                    (setq bpt (getpoint "\nµÝÔö¸´ÖÆ»ùµã:<ÍË³ö>"))
                    (progn
                        (while
                            (and
                                (setq vxu (getpoint "\nµÝÔö¸´ÖÆÏòÁ¿µã:<ÍË³ö>" bpt))
                                (equal bpt vxu 1e-8)
                            )
                            (princ "\n´íÎóµÄÏòÁ¿µã.")
                        )
                        vxu
                    )
                    (setq vxu (mapcar '- vxu bpt)
                          vxw (trans vxu 1 0 t)
                          dis (distance '(0.0 0.0 0.0) vxw)
                    )
                )
            )
        )
        (   dyn
            (princ "\nµÝÔö¸´ÖÆÖÕµã:<ÍË³ö>")
            (while (= 5 (car (setq ept (grread t 13 0))))
                (redraw)
                (foreach obj obl (vla-delete obj))
                (setq qty (/ (caddr (trans (mapcar '- (cadr ept) bpt) 1 vxw t)) dis)
                      obl (incarray:copyvector lst (mapcar (if (minusp qty) '- '+) vxw) (abs (fix qty)) inc)
                )
                (grvecs (list -3 bpt (mapcar '(lambda ( a b ) (+ (* a qty) b)) vxu bpt)))
            )
        )
        (   (setq ept (getpoint bpt "\nµÝÔö¸´ÖÆÖÕµã:<ÍË³ö>"))
            (setq qty (fix (/ (caddr (trans (mapcar '- ept bpt) 1 vxw t)) dis)))
            (incarray:copyvector lst (mapcar (if (minusp qty) '- '+) vxw) (abs (fix qty)) inc)
        )
    )
    (setvar 'dimzin dim)
    (incarray:endundo (incarray:acdoc))
    (redraw) (princ)
)

;;----------------------------------------------------------------------;;

(defun incarray:num->str ( x / dim rtn )
    (if (equal x (atof (rtos x 2 0)) 1e-8)
        (rtos x 2 0)
        (progn
            (setq dim (getvar 'dimzin))
            (setvar 'dimzin 8)
            (setq rtn (vl-catch-all-apply 'rtos (list x 2 15)))
            (setvar 'dimzin dim)
            (if (not (vl-catch-all-error-p rtn)) rtn)
        )
    )
)

;;----------------------------------------------------------------------;;

(defun incarray:copyvector ( lst vec qty inc / cnt obj obl org )
    (setq org (vlax-3D-point 0 0)
          cnt 0
    )
    (repeat qty
        (setq cnt (1+ cnt))
        (foreach itm lst
            (setq obj (vla-copy (car itm))
                  obl (cons obj obl)
            )
            (vla-move obj org (vlax-3D-point (mapcar '* vec (list cnt cnt cnt))))
            (or (equal inc 0 0.000001)
                (if (= "AcDbBlockReference" (vla-get-objectname obj))
                    (mapcar
                        (function
                            (lambda ( att prp )
                                (vl-catch-all-apply 'vlax-put-property
                                    (list att (car prp)
                                        (apply 'strcat
                                            (mapcar '(lambda ( x ) (incarray:increment x (* cnt inc)))
                                                (cdr prp)
                                            )
                                        )
                                    )
                                )
                            )
                        )
                        (vlax-invoke obj 'getattributes)
                        (cdr itm)
                    )
                    (foreach prp (cdr itm)
                        (vlax-put-property obj (car prp)
                            (apply 'strcat
                                (mapcar '(lambda ( x ) (incarray:increment x (* cnt inc)))
                                    (cdr prp)
                                )
                            )
                        )
                    )
                )
            )
        )
    )
    obl
)

;;----------------------------------------------------------------------;;

(defun incarray:selection->list ( sel / idx lst obj obn )
    (if sel
        (repeat (setq idx (sslength sel))
            (setq obj (vlax-ename->vla-object (ssname sel (setq idx (1- idx))))
                  obn (vla-get-objectname obj)
            )
            (if (and (= "AcDbBlockReference" obn) (= :vlax-true (vla-get-hasattributes obj)))
                (setq lst
                    (cons
                        (cons obj
                            (mapcar '(lambda ( a ) (vl-list* 'textstring (incarray:splitstring (vla-get-textstring a))))
                                (vlax-invoke obj 'getattributes)
                            )
                        )
                        lst
                    )
                )
                (setq lst
                    (cons
                        (cons obj
                            (mapcar '(lambda ( p ) (vl-list* p (incarray:splitstring (vlax-get-property obj p))))
                                (cond
                                    (   (wcmatch obn "AcDb*Text,AcDbMLeader") '(textstring))
                                    (   (wcmatch obn "AcDb*Dimension")        '(textoverride))
                                    (   (= "AcDbAttributeDefinition" obn)     '(tagstring promptstring textstring))
                                )
                            )
                        )
                        lst
                    )
                )
            )
        )
    )
)

;;----------------------------------------------------------------------;;

(defun incarray:splitstring ( str / lst )
    (setq lst (vl-string->list str))
    (read (vl-list->string (vl-list* 40 34 (incarray:split lst (< 47 (car lst) 58)))))
)

;;----------------------------------------------------------------------;;

(defun incarray:split ( lst flg )
    (cond
        (   (null lst) '(34 41))
        (   (member (car lst) '(34 92))
            (if flg
                (vl-list* 34 32 34 92 (car lst) (incarray:split (cdr lst) nil))
                (vl-list* 92 (car lst) (incarray:split (cdr lst) flg))
            )
        )
        (   (or (< 47 (car lst) 58) (and (= 46 (car lst)) flg (< 47 (cadr lst) 58)))
            (if flg
                (vl-list* (car lst) (incarray:split (cdr lst) flg))
                (vl-list* 34 32 34 (car lst) (incarray:split (cdr lst) t))
            )
        )
        (   flg (vl-list* 34 32 34 (car lst) (incarray:split (cdr lst) nil)))
        (   (vl-list* (car lst) (incarray:split (cdr lst) nil)))
    )
)

;;----------------------------------------------------------------------;;

(defun incarray:increment ( str inc / dci dcs len num )
    (if (distof str 2)
        (progn
            (setq num (+ (distof str) inc)
                  inc (incarray:num->str inc)
                  str (vl-string-left-trim "-" str)
                  inc (vl-string-left-trim "-" inc)
                  dci (incarray:decimalplaces inc)
                  dcs (incarray:decimalplaces str)
                  len (strlen str)
                  str (vl-string-left-trim "-" (rtos num 2 (max dci dcs)))
            )
            (cond
                (   (< 0 dcs) (setq len (+ (- len dcs) (max dci dcs))))
                (   (< 0 dci) (setq len (+ dci len 1)))
            )
            (repeat (- len (strlen str))
                (setq str (strcat "0" str))
            )
            (if (minusp num)
                (strcat "-" str)
                str
            )
        )
        str
    )
)

;;----------------------------------------------------------------------;;

(defun incarray:decimalplaces ( str / pos )
    (if (setq pos (vl-string-position 46 str))
        (- (strlen str) pos 1)
        0
    )
)

;;----------------------------------------------------------------------;;

(defun incarray:startundo ( doc )
    (incarray:endundo doc)
    (vla-startundomark doc)
)

;;----------------------------------------------------------------------;;

(defun incarray:endundo ( doc )
    (while (= 8 (logand 8 (getvar 'undoctl)))
        (vla-endundomark doc)
    )
)

;;----------------------------------------------------------------------;;

(defun incarray:acdoc nil
    (eval (list 'defun 'incarray:acdoc 'nil (vla-get-activedocument (vlax-get-acad-object))))
    (incarray:acdoc)
)

(princ)
