;;;   Programm:      ACM-STPNUMMERN.LSP
;;;   Befehlsaufruf: ACM-STPNUMMERN
;;;   Funktion:      Stützpunkte von 2D-, 3D- und LW-Polylinien sowie Polygonnetzen nummerieren.
;;;   Autor:         Gerhard Rampf
;;;                  Kundenspezifische Anpassungen für AutoCAD und ZWCAD
;;;                  Liebigstr. 3 A
;;;                  86399 Bobingen
;;;                  E-Mail: rampf@geracad.de
;;;   Datum:         06.05.2024
;;;   Plattform:     Alle AutoCAD-Versionen ab Version 2005
(defun c:acm-stpnummern ( / spn68 spn31 spn84 snp01 snp02 snp03 snp04 snp05 snp06 snp07 snp08 snp09 snp13 snp14 snp15 snp16)
    (defun snp01 (spn01 / )
        (if spn84
          (setq *error* spn84)
        )
        (if spn68
          (vl-catch-all-apply 'setvar (list "CMDECHO" spn68))
        )
      (vla-EndUndoMark (vla-get-ActiveDocument (vlax-get-acad-object)))
      (princ)
    )
    (defun snp02 ( / spn10)
      (setq spn10 (strcase (getvar "PRODUCT")))
        (if
          (and
            (= spn10 "AUTOCAD")
            (getvar "HPDRAWORDER")
          )
            (setq spn11 T)
            (setq spn11 nil)
        )
        (if (not spn11)
          (alert "\042acm-stpnummern\042 kann nur unter AutoCAD ab Version 2005 verwendet werden.")
        )
      spn11
    )
    (defun snp03 ( / spn12 spn99 spn13 spn14)
      (setq spn12 (vla-get-TextStyles (vla-get-ActiveDocument (vlax-get-acad-object))))
        (vlax-for spn99 spn12
          (if (not (vl-string-search "|" (setq spn13 (vlax-get spn99 'Name))))
            (setq spn14 (cons spn13 spn14))
          )
        )
      (acad_strlsort spn14)
    )
    (defun snp04 ( / spn15 spn99 spn13 spn14)
      (setq spn15 (vla-get-Layers (vla-get-ActiveDocument (vlax-get-acad-object))))
        (vlax-for spn99 spn15
          (if (not (vl-string-search "|" (setq spn13 (vlax-get spn99 'Name))))
            (setq spn14 (cons spn13 spn14))
          )
        )
      (acad_strlsort spn14)
    )
    (defun snp05 ( / spn16 spn17 spn18 spn19 spn21 spn22 spn23 spn25 spn27 spn11)
        (if (setq spn16 (snp06))
          (progn
            (setq spn17 (load_dialog spn16))
              (if (not (new_dialog "acm424" spn17))
                (exit)
              )
            (vl-catch-all-apply 'vl-file-delete (list spn16))
            (setq spn18 (snp04))
            (setq spn19 (mapcar 'strcase spn18))
              (if
                (or
                  (/= (type mztco83_kg-a2doal-a) 'STR)
                  (and
                    (/= (type mztco83_kg-a2doal-a) 'STR)
                    (not (vl-position (strcase mztco83_kg-a2doal-a) spn19))
                  )
                )
                  (setq mztco83_kg-a2doal-a (getvar "CLAYER"))
              )
            (setq spn21 (vl-position (strcase mztco83_kg-a2doal-a) spn19))
            (start_list "pl_01")
            (mapcar 'add_list spn18)
            (end_list)
            (set_tile "pl_01" (itoa spn21))
            (setq spn22 (snp03))
            (setq spn23 (mapcar 'strcase spn22))
              (if
                (or
                  (/= (type mztco83_kg-a2dobl-a) 'STR)
                  (and
                    (/= (type mztco83_kg-a2dobl-a) 'STR)
                    (not (vl-position (strcase mztco83_kg-a2dobl-a) spn23))
                  )
                )
                  (setq mztco83_kg-a2dobl-a (getvar "TEXTSTYLE"))
              )
            (setq spn25 (vl-position (strcase mztco83_kg-a2dobl-a)  spn23))
            (start_list "pl_02")
            (mapcar 'add_list spn22)
            (end_list)
            (set_tile "pl_02" (itoa spn25))
              (if
                (or
                  (not (vl-position (type mztzo83_kg-a2dobl-a) (list 'INT 'REAL)))
                  (and
                    (vl-position mztzo83_kg-a2dobl-a (list 'INT 'REAL))
                    (<= mztzo83_kg-a2dobl-a 0.0)
                  )
                )
                  (setq mztzo83_kg-a2dobl-a 2.5)
              )
            (set_tile "eb_01" (rtos mztzo83_kg-a2dobl-a))
              (action_tile "b_01" "(if
                (or
                  (not (setq spn27 (distof (get_tile \"eb_01\"))))
                  (and
                    (setq spn27 (distof (get_tile \"eb_01\")))
                    (<= spn27 0.0)
                  )
                )
                  (progn
                    (alert \"Ungültige Texthöhe.\")
                    (mode_tile \"eb_01\" 2)
                  )
                  (progn
                      (setq spn11
                        (list 
                          (setq mztco83_kg-a2doal-a (nth (atoi (get_tile \"pl_01\")) spn18))
                          (setq mztco83_kg-a2dobl-a (nth (atoi (get_tile \"pl_02\")) spn22))
                          (setq mztzo83_kg-a2dobl-a spn27)
                        )
                      )
                    (snp14)
                    (done_dialog)
                  )
                )"
              )
            (action_tile "b_02" "(setq spn11 nil) (done_dialog)")
            (start_dialog)
            (unload_dialog spn17)
          )
        )
      spn11
    )
    (defun snp06 ( / spn28 spn29 spn30)
      (if
        (and
          (setq spn28 (vl-filename-mktemp "acm.dcl"))
          (setq spn29 (open spn28 "w"))
        )
          (progn
            (setq spn30
              (list
                "acm424"
                ":dialog{label=\042Einstellungen\042;"
                ":spacer{height=0.2;}"
                ":row{"
                ":column{"
                ":spacer{height=0;}"
                ":text{label=\042Layer:\042;}"
                ":text{label=\042Textstil:\042;}"
                ":text{label=\042Texthöhe:\042;}}"
                ":column{width=25;"
                ":popup_list{key=\042pl_01\042;}"
                ":popup_list{key=\042pl_02\042;}"
                ":edit_box{key=\042eb_01\042;allow_accept=true;}}}"
                ":spacer{height=0.8;}"
                ":row{"
                ":spacer{width=6;}"
                ":column{width=0;"
                ":button{key=\042b_01\042;label=\042OK\042;is_default=true;}"
                ":button{key=\042b_02\042;label=\042Abbrechen\042;is_cancel=true;}}"
                ":spacer{width=6;}}}"
              )
            )
              (while spn30
                (write-line (car spn30) spn29)
                (setq spn30 (cdr spn30))
              )
            (setq spn29 (close spn29))
            spn28
          )
          nil
      )
    )
    (defun snp07 ( / spn31 spn32)
      (setq spn31 (vla-get-ActiveDocument (vlax-get-acad-object)))
        (if (< (getvar "TILEMODE") 1)
          (progn
            (if (= (vla-get-MSpace spn31) :vlax-true)
              (setq spn32 (vla-get-ModelSpace spn31))
              (setq spn32 (vla-get-PaperSpace spn31))
            )
          )
          (setq spn32 (vla-get-ModelSpace spn31))
        )
      spn32
    )
    (defun snp08 (spn02 / spn33 spn34)
        (if (= (type spn02) 'ENAME)
          (setq spn02 (vlax-ename->vla-object spn02))
        )
      (setq spn33 (vlax-get spn02 'Coordinates))
        (if (= (strcase (vlax-get spn02 'ObjectName)) "ACDBPOLYLINE")
          (progn
            (while spn33
              (setq spn34 (cons (list (car spn33) (cadr spn33)) spn34))
              (setq spn33 (cdr (cdr spn33)))
            )
          )
          (progn
            (while spn33
              (setq spn34 (cons (list (car spn33) (cadr spn33) (caddr spn33)) spn34))
              (setq spn33 (cdr (cdr (cdr spn33))))
            )
          )
        )
      (setq spn34 (reverse spn34))
    )
    (defun snp09 ( / snp10 snp11 snp12 spn47 spn48 spn51 spn54 p84_08 spn49 spn50 spn52 spn53 spn55)
        (defun snp10 (spn03 / spn35 spn36 spn37 spn38)
          (setq spn35 (strlen spn03))
          (setq spn36 (substr spn03 1 1))
          (setq spn37 0)
            (while
              (and
                (= spn36 "\040")
                (/= spn37 spn35)
              )
                (setq spn03 (substr spn03 2))
                (setq spn36 (substr spn03 1 1))
                (setq spn37 (+ spn37 1))
            )
            (if (/= spn37 spn35)
              (progn
                (setq spn35 (strlen spn03))
                (setq spn38 (substr spn03 spn35 1))
                (setq spn37 spn35)
                  (while
                    (and
                      (= spn38 "\040")
                      (/= spn37 0)
                    )
                      (setq spn03 (substr spn03 1 spn37))
                      (setq spn38 (substr spn03 spn37 1))
                      (setq spn37 (- spn37 1))
                  )
              )
            )
          spn03
        )
        (defun snp11 (spn04 spn05 / spn39)
          (setq spn39 nil)
            (foreach elem spn04
              (if (= (car elem) spn05)
                (setq spn39 (cons (cdr elem) spn39))
              )
            )
          spn39
        )
        (defun snp12 (spn06 spn07 / spn40 spn41 spn42 spn43 spn44 spn45 spn46)
          (setq spn40 spn06)
          (setq spn41 spn07)
            (repeat (length spn40)
              (setq spn42 (cons (strcase (car spn40)) spn42))
              (setq spn40 (cdr spn40))
            )
            (repeat (length spn41)
              (setq spn43 (cons (strcase (car spn41)) spn43))
              (setq spn41 (cdr spn41))
            )
          (setq spn42 (reverse spn42))
          (setq spn43 (reverse spn43))
            (repeat (length spn42)
              (setq spn44 (member (car spn42) spn43))
                (if spn44
                  (progn
                    (setq spn45 (- (length spn43) (length spn44)))
                    (setq spn46 (cons (nth spn45 spn07) spn46))
                  )
                )
              (setq spn42 (cdr spn42))
            )
          (reverse spn46)
        )
      (setq spn47 (getvar "ERRNO"))
      (setq spn48 T spn51 nil spn54 nil p84_08 nil)
      (setq spn49 (list "Einstellungen"))
      (setq spn50 "")
        (repeat (length spn49)
          (setq spn50 (strcat spn50 (car spn49) " "))
          (setq spn49 (cdr spn49))
        )
      (setq spn50 (snp10 spn50))
        (while spn48
          (setvar "ERRNO" 7)
            (while (equal (getvar "ERRNO") 7)
              (setvar "ERRNO" 0)
              (initget spn50)
              (setq spn51 (entsel (strcat "\n" "Zu beschriftendes Objekt wählen oder [Einstellungen]" ": ")))
                (if (= (getvar "ERRNO") 7)
                  (prompt "0 gefunden")
                )
            )
            (if spn51
              (progn
                (if (not (member spn51 (list "Einstellungen")))
                  (progn
                    (setq spn52 (entget (car spn51)))
                    (setq spn53 (list (cdr (assoc 0 spn52))))
                    (setq spn54 (snp11 spn52 100))
                      (if
                        (or
                          (not
                            (snp12 spn53 (list "POLYLINE" "LWPOLYLINE"))
                          )
                          (not
                            (snp12 spn54 (list "AcDb2dPolyline" "AcDb3dPolyline" "AcDbPolygonMesh" "AcDbPolyline"))
                          )
                        )
                          (progn
                            (prompt "\nUngültiges Objekt gewählt. ")
                            (setq spn54 nil spn48 T)
                          )
                          (setq spn48 nil)
                      )
                  )
                  (progn
                    (snp05)
                    (setq spn54 nil spn48 T)
                  )
                )
              )
              (setq spn48 nil spn55 nil)
            )
        )
        (if spn47 
          (setvar "ERRNO" spn47)
        )
        (if spn54
          (setq spn55 (list (car spn51) (list (car spn53) (car (snp12 spn54 (list "AcDb2dPolyline" "AcDb3dPolyline" "AcDbPolygonMesh" "AcDbPolyline"))))))
        )
        (if p84_08
          (setq spn55 (list spn51 spn51))
        )
      spn55
    )
    (defun snp13 (spn08 / spn56 spn57 spn58 spn59 spn60 spn61 spn32 spn62 spn63 spn64 spn65 spn66 spn67 spn68 spn69 spn70 spn71 spn72 spn73 spn74 spn75 spn76 spn77 spn78)
        (if (= (type spn08) 'ENAME)
          (setq spn08 (vlax-ename->vla-object spn08))
        )
        (if (= (vla-get-Lock (setq spn56 (vlax-ename->vla-object (tblobjname "LAYER" (getvar "CLAYER"))))) :vlax-true)
          (progn
            (setq spn57 1)
            (vla-put-Lock spn56 :vlax-false)
          )
        )
        (if (= (vla-get-Lock (setq spn58 (vlax-ename->vla-object (tblobjname "LAYER" (vlax-get spn08 'Layer))))) :vlax-true)
          (progn
            (setq spn59 1)
            (vla-put-Lock spn58 :vlax-false)
          )
        )
        (if (= (vla-get-Lock (setq spn60 (vlax-ename->vla-object (tblobjname "LAYER" mztco83_kg-a2doal-a)))) :vlax-true)
          (progn
            (setq spn61 1)
            (vla-put-Lock spn60 :vlax-false)
          )
        )
      (setq spn32 (snp07))
      (setq spn62 (vlax-get spn08 'Normal))
      (setq spn63 (vlax-curve-getStartPoint spn08))
      (setq spn64 (vla-AddCircle spn32 (vlax-3D-point spn63) 3.0))
      (vlax-put spn64 'Normal spn62)
      (setq spn65 (vlax-get spn64 'Center))
      (setq spn66 0)
        (while (tblsearch "BLOCK" (setq spn67 (strcat "sac" (itoa spn66))))
          (setq spn66 (1+ spn66))
        )
      (setq spn68 (getvar "CMDECHO"))
      (setvar "CMDECHO" 0)
      (setq spn69 (getvar "UCSICON"))
      (setvar "UCSICON" 0)
      (vl-cmdf "._ucs" "_e" (vlax-vla-object->ename spn64))
      (vl-cmdf "._-block" spn67 (trans spn65 0 1) (vlax-vla-object->ename spn08) "")
      (vl-cmdf "._ucs" "_previous")
      (vl-cmdf "._ucs" "_world")
      (vl-cmdf "._-insert" spn67 (list 0.0 0.0 0.0) 1.0 1.0 0.0)
      (setq spn70 (entlast))
      (setq spn71 (vlax-invoke (vlax-ename->vla-object spn70) 'Explode))
      (setq spn72 (car spn71))
      (vl-catch-all-apply 'vla-Delete (list (vlax-ename->vla-object spn70)))
      (vl-catch-all-apply 'vla-Delete (list (vla-Item (vla-get-Blocks (vla-get-ActiveDocument (vlax-get-acad-object))) spn67)))
      (setq spn73 (entlast))
      (snp15 (snp08 spn72))
      (setq spn74 (ssadd))
      (ssadd (vlax-vla-object->ename spn72) spn74)
        (while (setq spn75 (entnext spn73))
          (ssadd spn75 spn74)
          (setq spn73 spn75)
        )
      (setq spn66 0)
        (while (tblsearch "BLOCK" (setq spn76 (strcat "cas" (itoa spn66))))
          (setq spn66 (1+ spn66))
        )
      (vl-cmdf "._-block" spn76 (list 0.0 0.0 0.0) spn74 "")
      (vl-cmdf "._ucs" "_previous")
      (vl-cmdf "._ucs" "_e" (vlax-vla-object->ename spn64))
      (vl-cmdf "._-insert" spn76 (trans (vlax-get spn64 'Center) 0 1) 1.0 1.0 0.0)
      (setq spn77 (entlast))
      (vlax-invoke (setq spn78 (vlax-ename->vla-object spn77)) 'Explode)
      (vl-catch-all-apply 'vla-Delete (list spn78))
      (vl-catch-all-apply 'vla-Delete (list (vla-Item (vla-get-Blocks (vla-get-ActiveDocument (vlax-get-acad-object))) spn76)))
      (vl-catch-all-apply 'vla-Delete (list spn64))
        (if (= spn57 1)
          (vla-put-Lock spn56 :vlax-true)
        )
        (if (= spn59 1)
          (vla-put-Lock spn58 :vlax-true)
        )
        (if (= spn61 1)
          (vla-put-Lock spn60 :vlax-true)
        )
      (vl-cmdf "._ucs" "_previous")
      (setvar "UCSICON" spn69)
      (setvar "CMDECHO" spn68)
    )
    (defun snp14 ( / )
      (if
        (or
          (/= (type mztco83_kg-a2doal-a) 'STR)
          (and
            (/= (type mztco83_kg-a2doal-a) 'STR)
            (not (vl-position (strcase mztco83_kg-a2doal-a) spn19))
          )
        )
          (setq mztco83_kg-a2doal-a (getvar "CLAYER"))
      )
      (if
        (or
          (/= (type mztco83_kg-a2dobl-a) 'STR)
          (and
            (/= (type mztco83_kg-a2dobl-a) 'STR)
            (not (vl-position (strcase mztco83_kg-a2dobl-a) spn23))
          )
        )
          (setq mztco83_kg-a2dobl-a (getvar "TEXTSTYLE"))
      )
      (if
        (or
          (not (vl-position (type mztzo83_kg-a2dobl-a) (list 'INT 'REAL)))
          (and
            (vl-position mztzo83_kg-a2dobl-a (list 'INT 'REAL))
            (<= mztzo83_kg-a2dobl-a 0.0)
          )
        )
          (setq mztzo83_kg-a2dobl-a 2.5)
      )
      (prompt
        (strcat
          "\nAktuelle Einstellungen: Layer = " mztco83_kg-a2doal-a
          ", Textstil = " mztco83_kg-a2dobl-a
          ", Texthöhe = " (rtos mztzo83_kg-a2dobl-a)
        )
      )
    )
    (defun snp15 (spn09 / spn32 spn79 spn56 spn57 spn25 spn80)
      (setq spn32 (snp07))
      (setq spn79 0)
        (if (= (vla-get-Lock (setq spn56 (vlax-ename->vla-object (tblobjname "LAYER" (getvar "CLAYER"))))) :vlax-true)
          (progn
            (setq spn57 1)
            (vla-put-Lock spn56 :vlax-false)
          )
        )
        (while spn09
          (setq spn79 (1+ spn79))
          (setq spn25 (car spn09))
          (setq spn80 (vla-AddText spn32 (itoa spn79) (vlax-3D-point spn25) mztzo83_kg-a2dobl-a))
          (vl-catch-all-apply 'vlax-put (list spn80 'Layer mztco83_kg-a2doal-a))
          (vl-catch-all-apply 'vlax-put (list spn80 'StyleName mztco83_kg-a2dobl-a))
          (setq spn09 (cdr spn09))
        )
        (if (= spn57 1)
          (vla-put-Lock spn56 :vlax-true)
        )
    )
    (defun snp16 ( / spn81 spn82 spn83)
      (snp14)
        (if (setq spn81 (snp09))
          (progn
            (setq spn82 (car spn81))
            (setq spn83 (strcase (cadr (cadr spn81))))
              (if (vl-position spn83 (list "ACDB2DPOLYLINE" "ACDBPOLYLINE"))
                (snp13 spn82)
                (snp15 (snp08 spn82))
              )
          )
        )
    )
  (if (snp02)
    (progn
      (vl-load-com)
      (setq spn68 (getvar "CMDECHO"))
      (setvar "CMDECHO" 0)
      (setq spn31 (vla-get-ActiveDocument (vlax-get-acad-object)))
      (setq spn84 *error*)
      (setq *error* snp01)
      (vla-EndUndoMark spn31)
      (vla-StartUndoMark spn31)
      (snp16)
        (if spn84
          (setq *error* spn84)
          (setq *error* nil)
        )
      (setvar "CMDECHO" spn68)
      (vla-EndUndoMark spn31)
    )
  )
  (princ)
)
(terpri)
(princ "\nAutoLISP-Tool ACM-STPNUMMERN (Copyright © 2024 Gerhard Rampf) geladen.")
(princ "\nRufen Sie den Befehl mit ACM-STPNUMMERN auf.")
