;;-----------------------=={ 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 obj old_selectioncycling )

	(defun *error* ( msg / obj )
		(if (= 'int (type dim))
			(setvar 'dimzin dim)
		)
		(if old_selectioncycling (setvar "selectioncycling" old_selectioncycling))
		(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)
	(setq old_selectioncycling (getvar "selectioncycling"))
	(if old_selectioncycling (setvar "selectioncycling" 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 itm prp )
	(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 (mai_str_split (vla-get-textstring a))))
								(vlax-invoke obj 'getattributes)
							)
						)
						lst
					)
				)
				(setq lst
					(cons
						(cons obj
							(mapcar
								'(lambda ( p ) (vl-list* p (mai_str_split (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:increment ( str inc / dci dcs len num decimalplaces )

;;----------------------------------------------------------------------;;
;小数点后文本长度
(defun decimalplaces ( str / pos )
	(if (setq pos (vl-string-position 46 str))
		(- (strlen str) pos 1)
		0
	)
)

	(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 (decimalplaces inc)
				  dcs (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: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)
