;;;Programm für die Änderung des Basis-Punktes von AEC-POLYGONEN
;;;damit kann der Ursprung der Schraffur (zb. bei Fliesen) festgelegt werden
;;;In der Objekt(Stil)-Darstellung muss bei -> Schraffur ->Ausrichtung  "Objekt" statt "global"
;;;eingestellt sein, sonst sieht man die Wirkung nicht.
;;;Programm funktioniert auch bei gedrehten und gespiegelten AEC-Polygonen.
;;;(c) Have Fun - Gruß Claudio!

(defun c:AECPOLU(/ ELE PA PAX PAY Vx_o Vy_o AcadDoc UCS_AX PN PNX PNY DX DY ELE1 ELE2 ELE3 ELE_LEN Teil m n)
(setq SYS_CMD (getvar "CMDECHO"))(setvar "CMDECHO" 0)			;;;Befehls-echo auschalten
(setq SYS_BKS (getvar "UCSICON"))(setvar "UCSICON" 0)			;;;BKS-Symbol ausblenden
(defun MOD_KOOR()							;;;Subprogramm zur Vertex-verschiebung
  (setq PA (cdr TEIL) PAX (car PA) PAY (cadr PA) 			;;;alte Vertex-Koordinaten
        PN (list (+ PAX DX) (+ PAY DY) (last PA))			;;;neue Vertex-Koordinaten
        Teil (cons 10 PN))						;;;Vertex
  (if (= m 1)(setq m 0))                                        	;;;bei m=0 keine Umwandlung sondern Originaldaten nehmen
)
(setq ELE (entsel "\nAEC-POLYLINIE wählen :"))
(if ELE (setq ELE (entget (car ELE)) ))
(if (or (= ELE nil) (/= (cdr (assoc 0 ELE)) "AEC_POLYGON"))		;;;Startif1
  (alert "Element war kein AEC-Polygon! \nBitte nochmal wählen..")
  (Progn								;;;Startprogn1
  (command "_ucs" "_d" "$Sav1")(command "_ucs" "_d" "$Sav2")		;;;Falls Ucs vorhanden->löschen
  (command "_ucs" "_s" "$Sav1")(command "_ucs" "_w")			;;;Aktives Bks speichern, Welt-BKS herstellen
  (setq PA (cdr (assoc 10 ELE))  PAX (car PA) PAY (cadr PA) )		;;;Alter Basispunkt
  (setq Vx_o (assoc 15 ele) Vy_o (assoc 16 ele) )			;;;Bks-XVektor,Bks-YVektor von AEC-Polygon
  (command "_ucs" "_o" PA)						;;;Ursprung nach PA verschieben
  (command "_ucs" "_s" "$Sav2")	(vl-load-com)				;;;BKS für Zugriff speichern ,Aktivex-Aufruf
  (setq AcadDoc (vla-get-ActiveDocument (vlax-get-Acad-Object)))	;;;Autocaddokument abfragen
  (setq UCS_AX (vla-get-ActiveUCS AcadDoc))				;;;Aktives Bks
  (vla-put-XVector UCS_AX (vlax-3D-point (cdr VX_o)) )			;;;Aktiven BKS-XVektor verdrehen
  (vla-put-YVector UCS_AX (vlax-3D-point (cdr VY_o)) )			;;;Aktiven BKS-YVektor verdrehen
  (command "_ucs" "_r" "$Sav2")						;;;Bks aktualisieren
  (command "_ucs" "_o" (mapcar '(lambda (x) (* x -1)) PA ))		;;;Bks-Ursprung nach Ausgangslage AEC-Polygon 
(setq PN (getpoint "\n Neuer Basispunkt :" (trans PA 0 1 )))		;;;Neuer Basispunkt
(setq  PNX (car PN) PNY (cadr PN))
(setq DX (- PAX PNX) DY (- PAY PNY))					;;;Delta-Y Delta-Y für Vertex-verschiebung
 (if (< (ABS DX) 0.000001)(setq DX 0.0))				;;;Ungenauigkeit der Bks-Drehung eliminieren
 (if (< (ABS DY) 0.000001)(setq DY 0.0))
(setq PN (Trans PN 1 0))						;;;Basispunkt nach Welt-Bks
(setq ELE1 (reverse (member (cons 100  "AecImpGeo") (reverse ELE))))	;;;Anfangsliste Polygon
(setq ELE1 (append ELE1 (list (cons 10 PN)) ))				;;;Neuen Basispunkt anhängen
(setq ELE2 (cdr (member (assoc 10 ele) ELE)))				;;;Restliste
(setq ELE_LEN (length ELE2))
(setq ELE3 (list) n 0 m 1)                                              ;;;Zähler m=1 für 1. Punktkoordinate
(while (< n  ELE_LEN)							;;;Restliste auswerten
  (setq Teil (nth n ELE2))
  (if (and (= m 1)(= (car Teil) 10))  (MOD_KOOR) (setq m 1)) 		;;;bei m=1->Punkt,bei m=0->Vektor (nur jedes 2te(assoc 10))
  (setq ELE3 (append ELE3 (list Teil)))
  (setq n (+ n 1))
 )
(setq ELE (append ELE1 ELE3)) (entmod ELE)(princ)			;;;geändertes AEC-Polygon aktualisieren
(command "_ucs" "_r" "$Sav1")						;;;Ausgangs-BKS wiederherstellen
(command "_ucs" "_d" "$Sav1")(command "_ucs" "_d" "$Sav2")		;;;gespeicherte BKS löschen
))									;;;Endprogn1,Endif1
(setvar "UCSICON" SYS_BKS)(princ))					;;;Enddefun
(princ "AEC-POLYGON - Basispunkt ändern, Programmaufruf mit: AECPOLU ")(princ)