;;  Programm:      ACM-FLAESKAL.LSP
;;  Befehlsaufruf: ACM-FLAESKAL
;;  Funktion:      Skaliert Objekte anhand ihrer Fläche.
;;  Autor:         Gerhard Rampf
;;                 Kundenspezifische Anpassungen für AutoCAD und ZWCAD
;;                 Liebigstr. 3 A
;;                 86399 Bobingen
;;                 E-Mail: rampf@geracad.de
;;  Datum:         13.02.2023
;;  Plattform:     Alle AutoCAD-Versionen ab Version 2005
(defun c:acm-flaeskal ( / afs46 afs47 sfa01 sfa02 sfa03 sfa04 sfa06 sfa07 sfa08 sfa09 sfa10 sfa11 sfa12)
    (defun sfa01 ( / afs07)
      (setq afs07 (strcase (getvar "PRODUCT")))
        (if
          (and
            (= afs07 "AUTOCAD")
            (getvar "HPDRAWORDER")
          )
            (setq afs08 T)
            (setq afs08 nil)
        )
        (if (not afs08)
          (alert "\042acm-flaeskal\042 kann nur unter AutoCAD ab Version 2005 verwendet werden.")
        )
      afs08
    )
    (defun sfa02 (afs01 / )
      (if afs30 (setvar "PICKBOX" afs30))
      (if afs47 (setq *error* afs47))
      (vla-EndUndoMark (vla-get-ActiveDocument (vlax-get-acad-object)))
      (princ)
    )
    (defun sfa03 ( / afs09 afs10 afs11 afs12 afs13)
      (if
        (and
          (setq afs09 (sfa11))
          (setq afs10 (sfa12 afs09))
          (setq afs11 (getpoint "\nBasispunkt angeben: "))
        )
          (progn
              (if (= (nth 3 afs10) 1)
                (setq afs12 (vla-Copy (car afs09)))
                (setq afs12 (car afs09))
              )
              (if (= (car afs10) 0)
                (setq afs13 (/ (* (cadr afs10) (nth 4 afs10)) 100.0))
                (setq afs13 (nth 2 afs10))
              )
            (sfa04 afs12 afs13 afs11)
          )
      )
    )
    (defun sfa04 (afs02 afs03 afs04 / sfa05 afs14 afs15 afs16 afs17 afs18)
      (defun sfa05 (afs05) (- 2.0 afs05))
        (if (= (type afs02) 'ENAME)
          (setq afs02 (vlax-ename->vla-object afs02))
        )
      (setq afs04 (vlax-3D-point (trans afs04 1 0)))
      (setq afs14 (list 0.5 0.75 0.825 0.9 0.95 0.975 0.98 0.99 0.995 0.9975 0.998 0.9985 0.9999 0.99999 0.999999 0.9999999 0.99999999 0.999999999 0.9999999999 0.99999999999 0.999999999999 0.9999999999999 0.99999999999999 0.999999999999999 0.9999999999999999))
      (setq afs15 (mapcar 'sfa05 afs14))
      (setq afs16 -1)
      (setq afs17 (+ 500 (getvar "MILLISECS")))
        (while
          (and
            (< afs16 (1- (length afs14)))
            (/= (setq afs18 (vlax-get afs02 'Area)) afs03)
          )
            (setq afs16 (1+ afs16))
              (if (> afs18 afs03)
                (progn
                  (while
                    (and
                      (< (getvar "MILLISECS") afs17)
                      (> (vlax-get afs02 'Area) afs03)
                    )
                      (vla-ScaleEntity afs02 afs04 (nth afs16 afs14))
                  )
                )
                (progn
                  (while
                    (and
                      (< (getvar "MILLISECS") afs17)
                      (< (vlax-get afs02 'Area) afs03)
                    )
                      (vla-ScaleEntity afs02 afs04 (nth afs16 afs15))
                  )
                )
              )
        )
    )
    (defun sfa06 ( / )
      (if (not (vl-position acm223flaeskal190801 (list 0 1)))
        (setq acm223flaeskal190801 0)
      )
      (if (not (vl-position acm223flaeskal190802 (list 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20)))
        (progn
          (setq acm223flaeskal190801 0)
          (setq acm223flaeskal190802 (getvar "PICKBOX"))
        )
      )
      (if (not (vl-position acm223flaeskal190803 (list 0 1)))
        (setq acm223flaeskal190803 0)
      )
      (prompt
        (strcat
          "\nAktuelle Einstellungen für Flächenangabe per Objektwahl: Pickbox-Größe = "
            (if (= acm223flaeskal190801 0)
              (strcat "Aktuelle (" (itoa (getvar "PICKBOX")) ")")
              (itoa acm223flaeskal190802)
            )
          ", Blockelemente wählbar = "
          (nth acm223flaeskal190803 (list "Nein" "Ja"))
        )
      )
    )
    (defun sfa07 ( / afs22 afs23 afs24)
      (if
        (and
          (setq afs22 (vl-filename-mktemp "acm.dcl"))
          (setq afs23 (open afs22 "w"))
        )
          (progn
            (setq afs24
              (list
                "acm_ccs"
                ":dialog{label=\042Einstellungen\042;"
                ":spacer{height=0.2;}"
                ":popup_list{key=\042pl_01\042;label=\042&Pickbox-Größe:\042;edit_width=8;}"
                ":spacer{height=0.3;}"
                ":toggle{key=\042tg_01\042;label=\042&Blockelemente wählbar\042;}"
                ":spacer{height=0.3;}"
                ":row{"
                ":spacer{width=0;}"
                ":column{width=0;fixed_width=true;"
                ":button{key=\042b_01\042;label=\042OK\042;is_default=true;}"
                ":button{key=\042b_02\042;label=\042Abbrechen\042;is_cancel=true;}}"
                ":spacer{width=0;}}}"
              )
            )
              (while afs24
                (write-line (car afs24) afs23)
                (setq afs24 (cdr afs24))
              )
            (setq afs23 (close afs23))
            afs22
          )
          nil
      )
    )
    (defun sfa08 ( / afs25 afs26 afs27 afs28)
        (if (not (vl-position acm223flaeskal190803 (list 0 1)))
          (setq acm223flaeskal190803 0)
        )
        (if (not (vl-position acm223flaeskal190802 (list 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20)))
          (progn
            (setq acm223flaeskal190801 0)
            (setq acm223flaeskal190802 (getvar "PICKBOX"))
          )
        )
        (if (not (vl-position acm223flaeskal190801 (list 0 1)))
          (setq acm223flaeskal190801 0)
        )
        (if (setq afs25 (sfa07))
          (progn
            (setq afs26 (load_dialog afs25))
              (if (not (new_dialog "acm_ccs" afs26))
                (exit)
              )
            (vl-catch-all-apply 'vl-file-delete (list afs25))
            (start_list "pl_01")
            (mapcar 'add_list (list (strcat "Akt. (" (itoa (getvar "PICKBOX")) ")") "1" "2" "3" "4" "5" "6" "7" "8" "9" "10" "11" "12" "13" "14" "15" "16" "17" "18" "19" "20"))
            (end_list)
            (set_tile "tg_01" (itoa acm223flaeskal190803))
              (if (= acm223flaeskal190801 0)
                (set_tile "pl_01" "0")
                (set_tile "pl_01" (itoa acm223flaeskal190802))
              )
              (action_tile "b_01" "(setq afs27 (atoi (get_tile \"pl_01\")))
                  (if (= afs27 0)
                    (progn
                      (setq acm223flaeskal190801 0)
                      (setq acm223flaeskal190802 (getvar \"PICKBOX\"))
                    )
                    (progn
                      (setq acm223flaeskal190801 1)
                      (setq acm223flaeskal190802 afs27)
                    )
                  )
                (setq afs28 (list (setq acm223flaeskal190803 (atoi (get_tile \"tg_01\"))) acm223flaeskal190801 acm223flaeskal190802))
                (done_dialog)
                (sfa06)"
              )
            (action_tile "b_02" "(setq afs28 nil) (done_dialog)")
            (start_dialog)
            (unload_dialog afs26)
          )
        )
      afs28
    )
    (defun sfa09 ( / afs29 afs30 afs31 afs32 afs33 afs34)
        (if (not (vl-position acm223flaeskal190803 (list 0 1)))
          (setq acm223flaeskal190803 0)
        )
        (if (not (vl-position acm223flaeskal190802 (list 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20)))
          (progn
            (setq acm223flaeskal190801 0)
            (setq acm223flaeskal190802 (getvar "PICKBOX"))
          )
        )
      (setq afs29 (getvar "ERRNO"))
      (setq afs30 (getvar "PICKBOX"))
      (setvar "ERRNO" 7)
        (while (= (getvar "ERRNO") 7)
          (setq afs31 (nth acm223flaeskal190803 (list entsel nentsel)))
          (setvar "ERRNO" 0)
          (setvar "PICKBOX" acm223flaeskal190802)
          (initget "Einstellungen")
          (setq afs32 (afs31 "\nObjekt mit Flächendefinition wählen oder [Einstellungen]: "))
          (setvar "PICKBOX" afs30)
            (if (= (getvar "ERRNO") 7)
              (princ "0 gefunden")
              (progn
                (if afs32
                  (progn
                    (if (= (setq afs33 (type afs32)) 'LIST)
                      (progn
                        (if (= (type (setq afs34 (vl-catch-all-apply 'vlax-get (list (vlax-ename->vla-object (car afs32)) 'Area)))) 'VL-CATCH-ALL-APPLY-ERROR)
                          (progn
                            (prompt "\nGewähltes Objekt besitzt keine Flächendefinition. ")
                            (setvar "ERRNO" 7)
                            (setq afs32 nil)
                          )
                          (progn
                            (if (= afs34 0.0)
                              (progn
                                (prompt "\nGewähltes Objekt muss eine Fläche > 0 besitzen. ")
                                (setvar "ERRNO" 7)
                                (setq afs32 nil)
                              )
                            )
                          )
                        )
                      )
                      (progn
                        (sfa08)
                        (setvar "ERRNO" 7)
                        (setq afs32 nil)
                      )
                    )
                  )
                )
              )
            )
        )
      (setvar "ERRNO" afs29)
      afs34
    )
    (defun sfa10 ( / afs22 afs23 afs24)
      (if
        (and
          (setq afs22 (vl-filename-mktemp "acm.dcl"))
          (setq afs23 (open afs22 "w"))
        )
          (progn
            (setq afs24
              (list
                "acm232_01"
                ":dialog{label=\042Fläche ändern\042;"
                ":spacer{height=0.4;}"
                ":text{key=\042t_01\042;}"
                ":spacer{height=0.4;}"
                ":row{"
                ":column{"
                ":radio_button{key=\042rb_01\042;label=\042&Prozent:\042;}"
                ":radio_button{key=\042rb_02\042;label=\042&Fläche:\042;}}"
                ":column{"
                ":edit_box{key=\042eb_01\042;allow_accept=true;}"
                ":row{"
                ":edit_box{key=\042eb_02\042;width=19;allow_accept=true;}"
                ":button{key=\042b_01\042;label=\042<\042;}}}}"
                ":spacer{height=0.5;}"
                ":toggle{key=\042tg_01\042;label=\042&Kopie ändern\042;}"
                ":spacer{height=0.7;}"
                ":row{"
                ":spacer{width=10;}"
                ":column{width=0;fixed_width=true;"
                ":button{key=\042b_02\042;label=\042OK\042;is_default=true;}"
                ":button{key=\042b_03\042;label=\042Abbrechen\042;is_cancel=true;}}"
                ":spacer{width=10;}}}"
              )
            )
              (while afs24
                (write-line (car afs24) afs23)
                (setq afs24 (cdr afs24))
              )
            (setq afs23 (close afs23))
            afs22
          )
          nil
      )
    )
    (defun sfa11 ( / afs29 afs30 afs31 afs32 afs33 afs34)
      (setq afs29 (getvar "ERRNO"))
      (setvar "ERRNO" 7)
        (while (= (getvar "ERRNO") 7)
          (setvar "ERRNO" 0)
          (setq afs32 (entsel "\nZu änderndes Objekt wählen: "))
            (if (= (getvar "ERRNO") 7)
              (princ "0 gefunden")
              (progn
                (if afs32
                  (progn
                    (if (= (setq afs33 (type afs32)) 'LIST)
                      (progn
                        (if (= (type (setq afs34 (vl-catch-all-apply 'vlax-get (list (vlax-ename->vla-object (car afs32)) 'Area)))) 'VL-CATCH-ALL-APPLY-ERROR)
                          (progn
                            (prompt "\nGewähltes Objekt besitzt keine Flächendefinition. ")
                            (setvar "ERRNO" 7)
                            (setq afs32 nil)
                          )
                          (progn
                            (if
                              (or
                                (= afs34 0.0)
                                (= (vla-get-Lock (vlax-ename->vla-object (tblobjname "LAYER" (vla-get-Layer (setq afs35 (vlax-ename->vla-object (car afs32))))))) :vlax-true)
                              )
                                (progn
                                  (setvar "ERRNO" 7)
                                  (setq afs32 nil)
                                    (if (= afs34 0.0)
                                      (prompt "\nGewähltes Objekt muss eine Fläche > 0 besitzen. ")
                                      (prompt "\nGewähltes Objekt liegt auf einem gesperrten Layer. ")
                                    )
                                )
                            )
                          )
                        )
                      )
                    )
                  )
                )
              )
            )
        )
      (setvar "ERRNO" afs29)
        (if afs32
          (list (vlax-ename->vla-object (car afs32)) afs34)
        )
    )
    (defun sfa12 (afs06 / afs36 afs37 afs25 afs26 afs42 afs43 afs44 afs45)
        (if (not afs36)
          (setq afs36 (list -1 -1))
        )
      (setq afs37 1)
        (if (setq afs25 (sfa10))
          (progn
            (setq afs26 (load_dialog afs25))
            (vl-catch-all-apply 'vl-file-delete (list afs25))
              (while (> afs37 0)
                  (if (not (new_dialog "acm232_01" afs26 "" afs36))
                    (exit)
                  )
                  (if (not (vl-position acm223flaeskal190804 (list 0 1)))
                    (setq acm223flaeskal190804 1)
                  )
                  (if (not (vl-position acm223flaeskal190805 (list 0 1)))
                    (setq acm223flaeskal190805 0)
                  )
                  (if
                    (not
                      (and
                        (vl-position (type acm223flaeskal190806) (list 'INT 'REAL))
                        (> acm223flaeskal190806 0.0)
                      )
                    )
                      (setq acm223flaeskal190806 50.0)
                  )
                  (if
                    (not
                      (and
                        (vl-position (type acm223flaeskal190807) (list 'INT 'REAL))
                        (> acm223flaeskal190807 0.0)
                      )
                    )
                      (setq acm223flaeskal190807 100.0)
                  )
                (set_tile "t_01" (strcat "Aktuelle Fläche:  " (rtos (cadr afs06))))
                (set_tile "eb_01" (rtos acm223flaeskal190806 2 ))
                  (if (= acm223flaeskal190804 0)
                    (progn
                      (set_tile "rb_01" "1")
                      (mode_tile "eb_02" 1)
                      (mode_tile "b_01" 1)
                    )
                    (progn
                      (set_tile "rb_02" "1")
                      (mode_tile "eb_01" 1)
                    )
                  )
                (set_tile "tg_01" (itoa acm223flaeskal190805))
                (set_tile "eb_02" (rtos acm223flaeskal190807))
                  (action_tile "rb_01" "(mode_tile \"eb_01\" 0)
                    (setq acm223flaeskal190804 0)
                    (mode_tile \"eb_02\" 1)
                    (mode_tile \"b_01\" 1)"
                  )
                  (action_tile "rb_02" "(mode_tile \"eb_01\" 1)
                    (setq acm223flaeskal190804 1)
                    (mode_tile \"eb_02\" 0)
                    (mode_tile \"b_01\" 0)"
                  )
                  (action_tile "b_01" "(setq acm223flaeskal190805 (atoi (get_tile \"tg_01\")))
                    (setq acm223flaeskal190806 (distof (get_tile \"eb_01\")))
                    (setq acm223flaeskal190807 (distof (get_tile \"eb_02\")))
                    (setq afs36 (done_dialog 1))"
                  )
                  (action_tile "b_02" "(if (= (get_tile \"rb_01\") \"1\")
                    (progn
                      (if
                        (and
                          (setq afs42 (distof (get_tile \"eb_01\")))
                          (> afs42 0.0)
                        )
                          (setq afs43 (list (setq acm223flaeskal190804 0) (setq acm223flaeskal190806 afs42) (setq acm223flaeskal190807 (distof (get_tile \"eb_02\"))) (setq acm223flaeskal190805 (atoi (get_tile \"tg_01\"))) (cadr afs06)))
                          (progn
                            (setq afs43 nil)
                            (alert \"Ungültige Eingabe für Prozent.\")
                            (mode_tile \"eb_01\" 2)
                          )
                      )
                    )
                    (progn
                      (if
                        (and
                          (setq afs44 (distof (get_tile \"eb_02\")))
                          (> afs44 0.0)
                        )
                          (setq afs43 (list (setq acm223flaeskal190804 1) (setq acm223flaeskal190806 (distof (get_tile \"eb_01\"))) (setq acm223flaeskal190807 afs44) (setq acm223flaeskal190805 (atoi (get_tile \"tg_01\"))) (cadr afs06)))
                          (progn
                            (setq afs43 nil)
                            (alert \"Ungültige Eingabe für Fläche.\")
                            (mode_tile \"eb_02\" 2)
                          )
                      )
                    )
                    )
                    (if afs43
                      (done_dialog 0))"
                  )
                (action_tile "b_03" "(done_dialog 0)")
                (setq afs37 (start_dialog))
                  (if (= afs37 1)
                    (progn
                      (if (setq afs45 (sfa09))
                        (setq acm223flaeskal190807 afs45)
                      )
                    )
                  )
              )
            (unload_dialog afs26)
          )
        )
      afs43
    )
  (if (sfa01)
    (progn
      (vl-load-com)
      (setq afs46 (vla-get-ActiveDocument (vlax-get-acad-object)))
      (setq afs47 *error*)
      (setq *error* sfa02)
      (vla-EndUndoMark afs46)
      (vla-StartUndoMark afs46)
      (sfa03)
        (if afs47
          (setq *error* afs47)
          (setq *error* nil)
        )
      (vla-EndUndoMark afs46)
    )
  )
  (princ)
)
(terpri)
(princ "\nAutoLISP-Tool ACM-FLAESKAL (Copyright © 2023 Gerhard Rampf) geladen.")
(princ "\nRufen Sie den Befehl mit ACM-FLAESKAL auf.")
