;;;   Programm:      ACM-SEGMENTIEREN.LSP
;;;   Befehlsaufruf: ACM-SEGMENTIEREN
;;;   Funktion:      Objekte mit Linien oder Polylinien nachzeichnen
;;;   Autor:         Gerhard Rampf
;;;                  Kundenspezifische Anpassungen für AutoCAD und ZWCAD
;;;                  Liebigstr. 3 A
;;;                  86399 Bobingen
;;;                  E-Mail: rampf@geracad.de
;;;   Datum:         02.01.2024
;;;   Plattform:     Alle AutoCAD-Versionen ab Version 2005
(defun c:acm-segmentieren ( / rta97 rta98 atr01 atr02 atr03 atr04 atr05 atr06 atr07 atr08 atr09 atr10 atr11 atr12 atr13 atr14 atr15 atr16 atr17 atr18 atr19 atr20)
    (defun atr01 (rta01 rta02 / rta23 rta20 rta21 rta22)
      (setq rta20 (strlen rta01))
        (if (> rta20 rta02)
          (progn
            (setq rta21 (substr rta01 1 (/ (- rta02 3) 2)))
            (setq rta22 (substr rta01 (- rta20 (1- (/ (- rta02 3) 2)))))
            (setq rta23 (strcat rta21 "\056\056\056" rta22))
          )
        )
        (if rta23
          rta23
          rta01
        )
    )
    (defun atr02 ( / rta24 rta100 rta26)
      (setq rta24 (vla-get-Layers (vla-get-ActiveDocument (vlax-get-acad-object))))
        (vlax-for rta100 rta24
          (if (not (vl-string-search "|" (setq rta25 (vlax-get rta100 'Name))))
            (setq rta26 (cons rta25 rta26))
          )
        )
      (acad_strlsort rta26)
    )
    (defun atr03 (rta03 / rta27 rta28 rta29 rta30 rta32 rta33)
        (if (setq rta27 (atr04))
          (progn
            (setq rta28 (load_dialog rta27))
              (if (not (new_dialog "segment" rta28))
                (exit)
              )
            (vl-catch-all-apply 'vl-file-delete (list rta27))
            (setq rta29 (atr02))
            (setq rta30 (mapcar 'strcase rta29))
              (if
                (or
                  (/= (type rhacsinmreartrreum01) 'STR)
                  (and
                    (= (type rhacsinmreartrreum01) 'STR)
                    (not (tblsearch "LAYER" rhacsinmreartrreum01))
                  )
                )
                  (setq rhacsinmreartrreum01 (car rta30))
              )
            (setq rhacsinmreartrreum01 (strcase rhacsinmreartrreum01))
            (start_list "lb_01")
            (mapcar 'add_list rta29)
            (end_list)
            (setq rta32 (vl-position rhacsinmreartrreum01 rta30))
            (set_tile "lb_01" (itoa rta32))
            (action_tile "b_01" "(prompt (strcat \"\nGewählter Layer = \" (atr01 (nth (atoi (get_tile \"lb_01\")) rta29) 39) \" \")) (setq rta33 (list 1 (setq rhacsinmreartrreum01 (nth (atoi (get_tile \"lb_01\")) rta30)))) (done_dialog)")
            (action_tile "b_02" "(prompt (strcat \"\nGewählter Layer = Von Quelle (\" (atr01 rta03 39) \") \")) (setq rta33 (list 0)) (done_dialog)")
            (start_dialog)
            (unload_dialog rta28)
          )
        )
      rta33
    )
    (defun atr04 ( / rta34 rta35 rta36 rta37)
      (if
        (and
          (setq rta34 (vl-filename-mktemp "acm.dcl"))
          (setq rta35 (open rta34 "w"))
        )
          (progn
              (if (= (getvar "PLINETYPE") 0)
                (setq rta36 (list "Linienzug" "2D-Polylinie"))
                (setq rta36 (list "Linienzug" "Polylinie"))
              )
            (setq rta37
              (list
                "segment"
                (strcat ":dialog{label=\042Layer für " (nth rhacsinmreartrreum03 rta36) " wählen\042;")
                ":spacer{height=0;}"
                ":list_box{key=\042lb_01\042;height=10;allow_accept=true;}"
                ":spacer{height=0.3;}"
                ":row{"
                ":spacer{width=8;}"
                ":column{width=0;"
                ":button{key=\042b_01\042;label=\042Verwenden\042;is_default=true;}"
                ":button{key=\042b_02\042;label=\042Von Quelle\042;is_cancel=true;}}"
                ":spacer{width=8;}}}"
              )
            )
              (while rta37
                (write-line (car rta37) rta35)
                (setq rta37 (cdr rta37))
              )
            (setq rta35 (close rta35))
            rta34
          )
          nil
      )
    )
    (defun atr05 ( / rta38)
      (setq rta38 (strcase (getvar "PRODUCT")))
        (if
          (and
            (= rta38 "AUTOCAD")
            (getvar "HPDRAWORDER")
          )
            (setq rta33 T)
            (setq rta33 nil)
        )
        (if (not rta33)
          (alert "\042acm-segment\042 kann nur unter AutoCAD ab Version 2005 verwendet werden.")
        )
      rta33
    )
    (defun atr06 ( / rta39 rta40 rta41 rta42 rta43 rta44 rta45 rta46)
      (setq rta39 (list "AcDb2dPolyline" "AcDbArc" "AcDbCircle" "AcDbEllipse" "AcDbLine" "AcDbPolyline" "AcDbSpline"))
      (setq rta40 (getvar "ERRNO"))
      (setq rta41 T)
        (while rta41
          (atr07 "ERRNO" 7)
            (while (= (getvar "ERRNO") 7)
              (atr07 "ERRNO" 0)
              (setq rta42 (entsel "\nZu segmentierendes Objekt wählen: "))
                (if (= (getvar "ERRNO") 7)
                  (princ "0 gefunden")
                )
            )
            (if rta42
              (progn
                (if (not (vl-position rta42 rta69))
                  (progn
                    (setq rta43 (atr08 (entget (car rta42)) 100))
                    (setq rta44 (cdr (assoc 8 (entget (car rta42)))))
                      (if
                        (or 
                          (not(setq rta45 (atr09 rta43 rta39)))
                          (and
                            rta45
                            (not (atr10 (car rta42)))
                          )
                          (= 4 (logand (cdr (assoc 70 (tblsearch "LAYER" rta44))) 4))
                        )
                          (progn
                              (if (= 4 (logand (cdr (assoc 70 (tblsearch "LAYER" rta44))) 4))
                                (princ "\nDas Objekt ist auf einem gesperrten Layer.")
                                (progn
                                  (if (not (atr09 rta43 rta39))
                                    (prompt "\nDieses Objekt kann nicht bearbeitet werden. ")
                                  )
                                )
                              )
                            (setq rta43 nil rta44 nil rta41 T)
                          )
                          (setq rta41 nil)
                      )
                    )
                    (setq rta41 nil rta101 T)
                  )
                )
              (setq rta41 nil rta46 nil)
            )
          (setq rta46 nil)
        )
        (if rta40
          (atr07 "ERRNO" rta40)
        )
        (if rta43
          (setq rta46 (list (car rta42) (car (atr09 rta43 rta39))))
        )
        (if rta101
          (setq rta46 (list rta42 rta42))
        )
        (if rta46
          (setq rta46 (car rta46))
          rta46
        )
        (if (= (type rta46) 'ENAME)
          (redraw rta46 3)
        )
      rta46
    )
    (defun atr07 (rta04 rta05 / )
      (vl-catch-all-apply 'setvar (list rta04 rta05))
    )
    (defun atr08 (rta06 rta07 / rta33)
        (foreach elem rta06
          (if (= (car elem) rta07)
            (setq rta33 (cons (cdr elem) rta33))
          )
        )
      rta33
    )
    (defun atr09 (rta08 rta09 / rta47 rta48 rta49 rta50 rta51 rta52 rta53)
      (setq rta47 rta08)
      (setq rta48 rta09)
        (repeat (length rta47)
          (setq rta49 (cons (strcase (car rta47)) rta49))
          (setq rta47 (cdr rta47))
        )
        (repeat (length rta48)
          (setq rta50 (cons (strcase (car rta48)) rta50))
          (setq rta48 (cdr rta48))
        )
      (setq rta49 (reverse rta49))
      (setq rta50 (reverse rta50))
        (repeat (length rta49)
          (setq rta51 (member (car rta49) rta50))
            (if rta51
              (progn
                (setq rta52 (- (length rta50) (length rta51)))
                (setq rta53 (cons (nth rta52 rta09) rta53))
              )
            )
          (setq rta49 (cdr rta49))
        )
      (reverse rta53)
    )
    (defun atr10 (rta10 / rta54 rta46)
      (setq rta54 (strcase (cdr (assoc 0 (entget rta10)))))
        (if (vl-position rta54 '("ARC" "CIRCLE" "ELLIPSE" "LINE" "LWPOLYLINE" "POLYLINE" "SPLINE"))
          (progn
            (if (> (atr11 rta10) 0.0)
              (setq rta46 T)
              (progn
                (setq rta46 nil)
                (princ "\nDieses Objekt kann nicht versetzt werden. ")
              )
            )
          )
          (setq rta46 T)
        )
      rta46
    )
    (defun atr11 (rta10 / rta55 rta56)
      (vl-load-com)
        (if (= (type rta10) 'LIST)
          (setq rta55 (car rta10))
          (setq rta55 rta10)
        )
        (if
          (and
            (setq rta56 (vla-get-ObjectName (vlax-ename->vla-object rta55)))
            (vl-position (strcase rta56) (list "ACDB2DPOLYLINE" "ACDB3DPOLYLINE" "ACDBARC" "ACDBCIRCLE" "ACDBELLIPSE" "ACDBHELIX" "ACDBLINE" "ACDBPOLYLINE" "ACDBSPLINE"))
          )
            (vlax-curve-getDistAtParam rta55 (vlax-curve-getEndParam rta55))
            1.0
        )
    )
    (defun atr12 (rta11 / rta57)
      (setq rta57 (fix rta11))
        (if (= (type rta57) 'INT)
          (itoa rta57)
          (rtos rta57 (getvar "LUNITS") 0)
        )
    )
    (defun atr13 ( / rta59 rta60)
        (if
          (not
            (and
              (= (type rhacsinmreartrreum02) 'INT)
              (> rhacsinmreartrreum02 1)
              (< rhacsinmreartrreum02 1025)
            )
          )
            (setq rhacsinmreartrreum02 2)
        )
      (setq rta59 (getvar "PICKBOX"))
      (atr07 "PICKBOX" 0)
      (setq rta60 (atr14 rhacsinmreartrreum02 "Anzahl der Segmente eingeben" 2 1024))
        (if rta59
          (atr07 "PICKBOX" rta59)
        )
      (setq rhacsinmreartrreum02 rta60)
      rta60
    )
    (defun atr14 (rta12 rta13 rta14 rta15 / rta46)
        (if (= "" (setq rta46 (getstring (strcat "\n" rta13 " <" (atr12 rta12) ">: "))))
          (setq rta46 (atr12 rta12))
          (progn
            (while
              (or
                (not (atr15 rta46))
                (< (atoi rta46) rta14)
                (> (atoi rta46) rta15)
              )
                (prompt (strcat "\nWert muss eine Ganzzahl zwischen " (atr12 rta14) " und " (atr12 rta15) " sein. "))
                  (if (= "" (setq rta46 (getstring (strcat "\n" rta13 " <" (atr12 rta12) ">: "))))
                    (setq rta46 (atr12 rta12))
                  )
            )
          )
        )
      (atoi rta46)
    )
    (defun atr15 (rta16 / rta61 rta62)
      (setq rta61 (atr17 (setq rta16 (atr16 rta16))))
        (if rta61
          (setq rta62 rta16)
        )
        (while
          (and
            rta61
            rta62
          )
              (if (not (vl-position (car rta61) '("0" "1" "2" "3" "4" "5" "6" "7" "8" "9")))
                (setq rta62 nil)
              )
            (setq rta61 (cdr rta61))
        )
      rta62
    )
    (defun atr16 (rta17 / rta20 rta63 rta64 rta65)
      (setq rta20 (strlen rta17))
      (setq rta63 (substr rta17 1 1))
      (setq rta64 0)
        (while
          (and
            (= rta63 "\040")
            (/= rta64 rta20)
          )
            (setq rta17 (substr rta17 2))
            (setq rta63 (substr rta17 1 1))
            (setq rta64 (+ rta64 1))
        )
        (if (/= rta64 rta20)
          (progn
            (setq rta20 (strlen rta17))
            (setq rta65 (substr rta17 rta20 1))
            (setq rta64 rta20)
              (while
                (and
                  (= rta65 "\040")
                  (/= rta64 0)
                )
                  (setq rta17 (substr rta17 1 rta64))
                  (setq rta65 (substr rta17 rta64 1))
                  (setq rta64 (- rta64 1))
              )
          )
        )
      rta17
    )
    (defun atr17 (rta18 / rta64 rta66)
        (if (= (type rta18) 'STR)
          (progn
            (setq rta64 1)
              (repeat (strlen rta18)
                (setq rta66 (cons (substr rta18 rta64 1) rta66))
                (setq rta64 (1+ rta64))
              )
          )
        )
      (reverse rta66)
    )
    (defun atr18 ( / rta68 rta69 rta70 rta71 rta72)
        (if (not (vl-position rhacsinmreartrreum03 (list 0 1)))
          (setq rhacsinmreartrreum03 0)
        )
        (if (= (getvar "PLINETYPE") 0)
          (progn
            (setq rta68 "Linienzug 2d-polylinie")
            (setq rta69 "Linienzug/2d-polylinie")
          )
          (progn
            (setq rta68 "Linienzug Polylinie")
            (setq rta69 "Linienzug/Polylinie")
          )
        )
        (if (= rhacsinmreartrreum03 0)
          (setq rta70 "Linienzug")
          (progn
            (if (= (getvar "PLINETYPE") 0)
              (setq rta70 "2D-Polylinie")
              (setq rta70 "Polylinie")
            )
          )
        )
        (if (= (getvar "PLINETYPE") 0)
          (setq rta71 "2D-Polylinie")
          (setq rta71 "Polylinie")
        )
      (initget rta68)
        (if (not (setq rta72 (getkword (strcat "\nLinienzug oder "  rta71 " erstellen? [" rta69 "] <" rta70 ">: "))))
          (setq rta72 rta70)
        )
        (if (vl-position (strcase rta72) (list "2D-POLYLINIE" "POLYLINIE"))
          (setq rhacsinmreartrreum03 1)
          (setq rhacsinmreartrreum03 0)
        )
      rhacsinmreartrreum03
    )
    (defun atr19 ( / rta73 rta74 rta76 rta77 rta78 rta79 rta80 rta81 rta82 rta83 rta84 rta85 rta86 rta87 rta88 rta89 rta90 rta91 rta92 rta93 rta94 rta95 rta96)
      (setq rta73 (getvar "OSMODE"))
      (setq rta74 (getvar "CMDECHO"))
      (setvar "OSMODE" 0)
      (setvar "CMDECHO" 0)
        (if
          (or
            (/= (type rhacsinmreartrreum04) 'STR)
            (and
              (= (type rhacsinmreartrreum04) 'STR)
              (not (tblobjname "LAYER" rhacsinmreartrreum04))
            )
          )
            (setq rhacsinmreartrreum04 (getvar "CLAYER"))
        )
        (if (setq rta76 (atr06))
          (progn
            (setq rta77 (atr13))
            (setq rta78 (atr18))
            (setq rta79 (atr03 rhacsinmreartrreum04))
              (if (= (car rta79) 1)
                (progn
                  (if (= (vla-get-Lock (setq rta80 (vlax-ename->vla-object (tblobjname "LAYER" (cadr rta79))))) :vlax-true)
                    (progn
                      (setq rta81 1)
                      (vla-put-Lock rta80 :vlax-false)
                    )
                  )
                )
              )
              (if (= rta78 0)
                (setq rta82 "._line")
                (setq rta82 "._pline")
              )
              (if (= rta82 "._pline")
                (progn
                  (command "._ucs" "_e" rta76)
                  (setq rta83 1)
                )
              )
            (setq rta84 (trans (vlax-curve-getStartPoint (setq rta85 (vlax-ename->vla-object rta76))) 0 1))
            (setq rta86 (trans (vlax-curve-getEndPoint rta85) 0 1))
            (setq rta87 (vla-get-Layer rta85))
            (setq rta88 (getvar "CLAYER"))
              (if (= (car rta79) 0)
                (setvar "CLAYER" rta87)
                (setvar "CLAYER" (cadr rta79))
              )
            (setq rta89 (getvar "CLAYER"))
              (if (= (vla-get-Lock (setq rta90 (vlax-ename->vla-object (tblobjname "LAYER" rta89)))) :vlax-true)
                (progn
                  (setq rta91 1)
                  (vla-put-Lock rta90 :vlax-false)
                )
              )
            (setq rta92 (getvar "PDMODE"))
            (setvar "PDMODE" 1)
            (command "._divide" rta76 rta77)
            (setq rta93 (ssget "_p"))
            (setq rta94 (sslength rta93))
            (setq rta95 0)
            (setq rta96 (cons (trans (vlax-get (vlax-ename->vla-object (ssname rta93 rta95)) 'Coordinates) 0 1) rta96))
              (repeat (1- rta94)
                (setq rta95 (1+ rta95))
                (setq rta96 (cons (trans (vlax-get (vlax-ename->vla-object (ssname rta93 rta95)) 'Coordinates) 0 1) rta96))
              )
            (command "._erase" rta93 "")
            (setvar "PDMODE" rta92)
            (setq rta96 (reverse rta96))
              (if (= (length rta96) rta77)
                (setq rta96 (cdr rta96))
              )
            (command rta82 rta84)
              (while rta96
                (command (car rta96))
                (setq rta96 (cdr rta96))
              )
            (command rta86 "")
              (if (= rta83 1)
                (command "._ucs" "_p")
              )
          )
        )
      (vl-catch-all-apply 'setvar (list "CLAYER" rta88))
        (if (= rta91 1)
          (vla-put-Lock rta90 :vlax-true)
        )
        (if (= rta81 1)
          (vla-put-Lock rta80 :vlax-true)
        )
      (setvar "OSMODE" rta73)
      (setvar "CMDECHO" rta74)
    )
    (defun atr20 (rta19 / )
        (if rta98 (setq *error* rta98))
        (if (= (type rta76) 'ENAME)
          (vl-catch-all-apply 'redraw (list rta76 4))
        )
        (if rta59
          (vl-catch-all-apply 'setvar (list "PICKBOX" rta59))
        )
        (if rta92
          (vl-catch-all-apply 'setvar (list "PDMODE" rta92))
        )
        (if rta73
          (vl-catch-all-apply 'setvar (list "OSMODE" rta73))
        )
        (if rta74
          (vl-catch-all-apply 'setvar (list "CMDECHO" rta74))
        )
      (vla-EndUndoMark (vla-get-ActiveDocument (vlax-get-acad-object)))
      (princ)
    )
  (if (atr05)
    (progn
      (vl-load-com)
      (setq rta97 (vla-get-ActiveDocument (vlax-get-acad-object)))
      (setq rta98 *error*)
      (setq *error* atr20)
      (vla-EndUndoMark rta97)
      (vla-StartUndoMark rta97)
      (atr19)
        (if rta98
          (setq *error* rta98)
          (setq *error* nil)
        )
      (vla-EndUndoMark rta97)
    )
  )
  (princ)
)
(terpri)
(princ "\nAutoLISP-Tool ACM-SEGMENTIEREN (Copyright © 2024 Gerhard Rampf) geladen.")
(princ "\nRufen Sie den Befehl mit ACM-SEGMENTIEREN auf.")
