;|====================================================

Выравнивание (перенос, поворот, наклон , масштабирование с
разными коэф. по осям и подрезка, если выбран растр) объектов по
трем вершинам исходного и нового контуров-параллелограммов.
Если правый клик при первом диалоге, то только наклон.

Программа Дениса Флюстикова "Align_Den" от 18.11.12:
Возможность отключения всех функций кроме наклона выбранных объектов для построения аксонометрий.

Макрос для кнопки: ^C^C^P(load "Align_Den");Align_Den
Замечания и предложения по адресу fd-@mail.ru
====================================================|;

(defun C:Align_Den  (/	   *error*     im    x	   y	 q1    q2
		     z1	   z2	 z3    s1    s2	   s3	 d0    a0
		     a10   b0	 b10   a     a1	   b	 b1    x1
		     x2	   osmode      explmode	   aa0	 aa1   aa2
		     aa3   aa4	 aa5   aa6   aa7   vers)

  (setq	osmode	 (getvar "OSMODE")
	explmode (getvar "EXPLMODE")
	vers	 (atof (getvar "ACADVER")))

  (setq	s1 (if (< vers 16.2)
	     0
	     1))

  (setq	aa0 (list 1 0 1 s1 2)
	q1  (ssget "_i")
	q2  "temp"
	im  0
	)

  (sssetfirst nil nil)

  (setq	a0  nil
	d0  (ssadd)
	aa7 nil)

  (if q1
    (princ (strcat "\nВыбрано объектов: " (rtos (sslength q1))))
    (setq q1 (ssget))
    )

  (if (not q1)
    (progn
      (princ "\nОбъекты не выбраны")
      (exit)))

  (setq	s3 (/ pi 4)
	z1 (getpoint
	     "\nБазовая точка для наклона на 45° или <Изменить угол>:"))

  (if (not z1)
    (progn
      (setq s3 nil)
      (while (not s3)
	(initget 7)
	(setq s3 (getangle "\nУкажите угол наклона:"))
	(if (zerop (rem s3 (/ pi 2)))
	  (progn
	    (princ "\nНедопустимый угол")
	    (setq s3 nil))))
      (initget 7)
      (setq z1 (getpoint "\nБазовая точка наклона:"))
      ))

  (setq	s1 z1
	z2 (polar z1 0 1)
	s2 z2
	z3 (polar z1 (/ pi 2) 1)
	s3 (polar z1 (- (/ pi 2) s3) 1))

  (setq	z2 (polar z1 pi 2)
	s2 (polar z1 pi 2))

  (setq	b  (/ pi -2)
	b1 (angle s3 s1))

  (setq	a0 z1
	z1 z3
	z3 a0
	a0 s1
	s1 s3
	s3 a0
	b  (- (/ pi 2) (angle z2 z1))
	b1 (- (angle s3 s1) (angle s2 s1))
	)

  (setq	a0  (distance z1 z2)
	a10 (distance s1 s2)
	b0  1
	b10 1
	k   (/ a10 a0)
	x1  (+ (* (cos b) (cos b1)) (- k) (* (expt (sin b) 2) k))
	x2  (sqrt
	      (+ (* 4 (expt (cos b1) 2) (expt k 2) (expt (cos b) 4))
		 (* -4 (cos b1) k (expt (cos b) 3))
		 (* 4 (cos b1) (expt k 3) (expt (cos b) 3))
		 (* -8 (cos b1) (expt k 3) (expt (cos b) 5))
		 (expt (cos b) 2)
		 (* -2 (expt k 2) (expt (cos b) 2))
		 (* 4 (expt k 2) (expt (cos b) 4))
		 (* (expt k 4) (expt (cos b) 2))
		 (* -4 (expt k 4) (expt (cos b) 4))
		 (* 4 (expt k 4) (expt (cos b) 6))
		 (* 4
		    (expt k 2)
		    (expt (cos b) 2)
		    (expt (cos b1) 2)
		    (expt (sin b) 2))
		 (* -8 (expt k 3) (cos b) (cos b1) (expt (sin b) 2))
		 (* 8 (expt k 3) (cos b) (cos b1) (expt (sin b) 4))
		 (* 4 (expt (sin b) 2) (expt k 4))
		 (* -8 (expt (sin b) 4) (expt k 4))
		 (* 4 (expt (sin b) 6) (expt k 4)))))

  (if (= x1 0)
    (setq x1 pi))
  (if (= x2 0)
    (setq x2 pi))

  (setq
    a (- (atan (/ (+ (* -2 (cos b1) k (expt (cos b) 2))
		     (cos b)
		     (* (- (expt k 2)) (cos b))
		     (* 2 (expt k 2) (expt (cos b) 3))
		     (- x2))
		  (* 2 k (sin b) x1)))))

  (setq	a1
	 (atan (/ (+ (* (- k) (cos b))
		     (/	(+ (* -2 (cos b1) k (expt (cos b) 2))
			   (cos b)
			   (* (- (expt k 2)) (cos b))
			   (* 2 (expt k 2) (expt (cos b) 3))
			   (- x2))
			-2
			x1)
		     (cos b1))
		  (sin b1))))

  (setq	y  (/ (* a10 (sin a1)) (* a0 (sin a)))
	x  (/ (* a10 (cos a1)) (* a0 (cos a)))
	b  (entlast)
	b0 '())

  (vl-load-com)
  (vla-startundomark
    (vla-get-activedocument (vlax-get-acad-object)))
  (setvar "CMDECHO" 0)
  (setvar "OSMODE" 0)
  (setvar "explmode" 1)

  (defun *error*  (msg)
    (vla-endundomark
      (vla-get-activedocument (vlax-get-acad-object)))
    (if	(and (>= vers 16.2)
	     (< vers 17.1))
      (vla-sendcommand
	(vla-get-activedocument
	  (vlax-get-acad-object))
	"_.undo 1 ")
      (command nil nil nil nil "_.undo" 1))
    (princ "\nВыход во время обработки данных\n")
    )

  (while (/= (tblsearch "block" q2) nil)
    (setq q2 (strcat q2 "1")))

  (while (setq a0 (entnext b))
    (setq b a0))

  (repeat (setq k (sslength q1))
    (setq k   (1- k)
	  a0  (ssname q1 k)
	  a10 (cdr (assoc 0 (entget a0))))

    (if	(wcmatch a10 "*DIMENSION")
      (progn
	(vl-cmdf "_.explode" a0)
	(while (entnext b)
	  (setq	b  (entnext b)
		q1 (ssadd b q1))
	  )
	))

    (if	aa7
      (if (wcmatch a10 "INSERT")
	(setq aa7 (ssadd a0 aa7)
	      q1  (ssdel a0 q1))
	))

    (if	(= 1 1)
      (if (wcmatch a10 "INSERT")
	(progn
	  (setq	aa3 (entget a0)
		aa2 '()
		aa4 (entget
		      (tblobjname "layer" (cdr (assoc 8 aa3))))
		aa2 (cons (list	(assoc 370 aa3)
				(assoc 370 aa4))
			  aa2)
		aa2 (cons (list	(assoc 6 aa3)
				(assoc 6 aa4))
			  aa2)
		aa2 (cons (list	(assoc 62 aa3)
				(assoc 62 aa4))
			  aa2)
		aa4 a0
		aa5 '())

	  (if (= (cdr (assoc 66 aa3)) 1)
	    (progn


	      (while (/= "SEQEND" (cdr (assoc 0 aa3)))

		(if (= (cdr (assoc 0 aa3)) "ATTRIB")
		  (progn

		    (setq aa6 '())

		    (foreach aa1  '(2 1	7 8 10 11 39 40	41 50 51 62 71
				    73 370)
		      (progn
			(if (/= (assoc aa1 aa3) nil)
			  (setq	aa6
				 (append
				   aa6
				   (list (assoc	aa1
						aa3)))))))

		    (setq aa5 (cons aa6 aa5))

		    ))

		(setq aa4 (entnext aa4)
		      aa3 (entget aa4))

		)
	      ))

	  (command "_.explode" a0)

	  (while (entnext b)
	    (setq b   (entnext b)
		  aa3 (entget b)
		  aa4 (entget (tblobjname
				"layer"
				(cdr (assoc 8 aa3)))))

	    (if
	      (= (setq aa1 (cdr (setq aa6 (assoc 62 aa3))))
		 0)
	       (if (setq aa1 (car (nth 0 aa2)))
		 (entmod (setq aa3 (subst aa1 aa6 aa3)))
		 (entmod (setq aa3 (subst (cadr (nth 0 aa2))
					  aa6
					  aa3)))
		 )
	       (if (null aa1)
		 (entmod (setq aa3
				(append	aa3
					(list (assoc 62 aa4)))))
		 ))

	    (if
	      (and (setq aa1 (cdr (setq aa6 (assoc 6 aa3))))
		   (= (strcase aa1) "BYBLOCK"))
	       (if (setq aa1 (car (nth 1 aa2)))
		 (entmod (setq aa3 (subst aa1 aa6 aa3)))
		 (entmod (setq aa3 (subst (cadr (nth 1 aa2))
					  aa6
					  aa3)))
		 )
	       (if (null aa1)
		 (entmod
		   (setq
		     aa3 (append aa3
				 (list (assoc 6 aa4)))))
		 ))

	    (if
	      (= (setq
		   aa1 (cdr (setq aa6 (assoc 370 aa3))))
		 -2)
	       (if (setq aa1 (car (nth 2 aa2)))
		 (entmod (setq aa3 (subst aa1 aa6 aa3)))
		 (entmod (setq aa3 (subst (cadr (nth 2 aa2))
					  aa6
					  aa3)))
		 )
	       (if (null aa1)
		 (entmod (setq aa3
				(append	aa3
					(list (assoc 370 aa4)))))
		 ))

	    (cond
	      ((= (cdr (assoc 0 aa3)) "ATTDEF")
	       (entdel b)
	       (setq aa6 (assoc 2 aa3)
		     aa1 (cdr (assoc aa6 aa5)))
	       (if aa1
		 (if
		   (/= (vl-string-trim " " (cdar aa1)) "")
		    (progn
		      (if (setq aa6 (assoc 370 aa3))
			(if (null (assoc 370 aa1))
			  (setq	aa1
				 (append aa1 (list aa6)))
			  ))
		      (entmake (cons '(0 . "TEXT") aa1))
		      (if d0
			(setq d0 (ssadd (entlast) d0))
			(setq q1 (ssadd (entlast) q1))
			)
		      )))
	       )
	      ((wcmatch (cdr (assoc 0 aa3)) "*TEXT")
	       (if d0
		 (setq d0 (ssadd b d0))
		 (setq q1 (ssadd b q1))
		 )
	       )
	      ((not (wcmatch (cdr (assoc 0 aa3))
			     "VERTEX,SEQEND")) ;T
	       (setq q1 (ssadd b q1))
	       )
	      )
	    )
	  ))
      )

    (if	(= (cadddr aa0) 1)		;(list 1 0 1 s1 2)
      (if (= a10 "REGION")
	(progn

	  (setq	aa3 (vlax-ename->vla-object a0)
		b0  (cons (list	(vla-get-TrueColor aa3)
				(vla-get-Layer aa3)
				(vla-get-Linetype aa3)
				(vla-get-LinetypeScale aa3)
				(vla-get-Lineweight aa3)
				)
			  b0))

	  (command "_.bhatch"
		   "_s"
		   a0
		   ""
		   "_p"
		   "_s"
		   ""
		   "_.draworder"
		   (entlast)
		   ""
		   "_u"
		   q1
		   ""
		   "_.erase"
		   a0
		   "")

	  (vla-put-Visible
	    (vlax-ename->vla-object (entlast))
	    :vlax-false)

	  (setq q1 (ssadd (entlast) q1))

	  )))

    (if	d0
      (if (wcmatch a10 "*TEXT")
	(setq d0 (ssadd a0 d0)
	      q1 (ssdel a0 q1))))

    )

  (princ "\nПодождите, выполняется обработка данных...\n")

  (if (> (sslength q1) 0)
    (progn
       (command "_.rotate"
	       q1
	       ""
	       z1
	       (* 180 (/ (- a (angle z1 z2)) pi)))
      (command "-block"
	       q2
	       z1
	       q1
	       "")
      (command "-insert"
	       q2
	       "_x"
	       x
	       "_y"
	       y
	       "_z"
	       1
	       "_r"
	       (* 180 (/ (- (angle s1 s2) a1) pi))
	       s1)
      (while (= (getvar 'cmdactive) 1)
	(vl-cmdf ""))
      (setq a1 (entlast))
      (vl-cmdf "_.explode" (entlast))
      (setvar "explmode" explmode)

      (repeat (length b0)
	(setq a1 (entnext a1)
	      b1 (entlast))

	(command "_.-hatchedit" a1 "_b" "_r" "_n")
	(if (null (entnext b1))
	  (command "_.rotate3d"		 a1	    ""
		   '(0 0 0)   '(1 0 0)	 180	    "_.mirror"
		   a1	      ""	 '(0 0 0)   '(1 0 0)
		   "_y"	      "_.-hatchedit"	    a1
		   "_b"	      "_r"	 "_n")
	  )
	(command "_.erase" a1 "")

	(setq b1 (vlax-ename->vla-object (entlast)))

	(vla-put-TrueColor b1 (nth 0 (car b0)))
	(vla-put-Layer b1 (nth 1 (car b0)))
	(vla-put-Linetype b1 (nth 2 (car b0)))
	(vla-put-LinetypeScale b1 (nth 3 (car b0)))
	(vla-put-Lineweight b1 (nth 4 (car b0)))

	(setq b0 (cdr b0))
	)

      (if (/= im 0)
	(progn
	  (if (= (cdr (assoc 280 (entget (entlast)))) 1)
	    (entmod (subst '(280 . 0)
			   '(280 . 1)
			   (entget (entlast)))))
	  (if (= im 1)
	    (vl-cmdf
	      "_.imageclip"
	      (entlast)
	      "_n"
	      "_p"
	      s1
	      s2
	      s3
	      (polar s3 (angle s2 s1) (distance s1 s2))
	      "_c")
	    (vl-cmdf
	      "_.imageclip"
	      (entlast)
	      "_n"
	      "_p"
	      s1
	      s3
	      s2
	      (polar s2 (angle s3 s1) (distance s1 s3))
	      "_c"))))

      (setq q1
	     (vla-get-Blocks
	       (vla-get-activedocument (vlax-get-acad-object))))

      (if
	(eq (type (vl-catch-all-apply 'vla-Item (list q1 q2)))
	    'VLA-OBJECT)
	 (vl-catch-all-apply
	   'vla-Delete
	   (list (vla-Item q1 q2))))

      ))

  (if d0
    (repeat (setq b0 (- (angle z3 z1) (angle s3 s1))
		  k  (sslength d0))

      (setq k	(1- k)
	    a0	(ssname d0 k)
	    x2	(entget a0)
	    b10	(cdr (assoc 10 x2))
	    b10	(trans b10 0 1)
	    a10	(cdr (assoc 50 x2))
	    z2	(atan (/ (cos b0)
			 (+ (sin b0)
			    (/ (cos a10) (sin (+ (* 2 pi) a10))))))
	    a10	(rem (* 180 (/ (- z2 a10) pi)) 180)
	    z2	(- (cadr b10) (cadr z1))
	    z2	(list (* z2 (sin b0)) (* z2 (- (cos b0) 1))))

      (command "_.rotate" a0 "" b10 a10 "_.move" a0 "" '(0 0) z2)

      ))

  (if aa7
    (repeat (setq b0 (- (angle z3 z1) (angle s3 s1))
		  k  (sslength aa7))

      (setq k  (1- k)
	    a0 (ssname aa7 k))

      (if (= (last aa0) 1)
	(setq z3  (vla-GetBoundingBox
		    (vlax-ename->vla-object a0)
		    'a10
		    'b10)
	      a10 (vlax-safearray->list a10)
	      b10 (vlax-safearray->list b10)
	      b10 (mapcar '+ a10 b10)
	      b10 (mapcar '/ b10 '(2 2 2)))
	(setq x2  (entget a0)
	      b10 (cdr (assoc 10 x2)))
	)

      (setq b10	(trans b10 0 1)
	    z2	(- (cadr b10) (cadr z1))
	    z2	(list (* z2 (sin b0)) (* z2 (- (cos b0) 1))))

      (command "_.move" a0 "" '(0 0) z2)

      ))

  (setvar "OSMODE" osmode)
  (setvar "CMDECHO" 1)
  (vla-endundomark
    (vla-get-activedocument (vlax-get-acad-object)))
  (princ)
  )
 ;|«Visual LISP© Format Options»
(72 2 40 0 nil "конец " 60 9 0 0 0 T T nil T)
;*** НЕ добавляйте текст под комментариями! ***|;