;;; - ------------------------------------------------------------------------------- - ;
;;; -                T O O L - A C M - M L S A S S I G N                              - ;
;;; - ------------------------------------------------------------------------------- - ;
;;; - Beschreibung : Ändert den Multilinienstil bei Multilinien (Dialog)              - ;
;;; - Befehle      : MLSASSIGN                                                        - ;
;;; - ------------------------------------------------------------------------------- - ;
;;; - letzte Änderung am : 19.09.2025                                                 - ;
;;; -              durch : Thomas Krüger                                              - ;
;;; - ------------------------------------------------------------------------------- - ;
(vl-load-com)
;;; - ------------------------------------------------------------------------------ - ;
(defun C:MLSASSIGN(/ DT:ML-GETSTYLES DT:MLSASSIGN MLSASSIGNDLG
                     AUSWAHL RETURN NEWSTYLE OBJ DUMMY
                  )
  (defun DT:ML-GETSTYLES(/ MLS-DICT MLSNAME ML MLSLIST)
    (if(setq MLS-DICT(dictsearch (namedobjdict) "ACAD_MLINESTYLE"))
      (While MLS-DICT
        (if(and(=(type(setq MLSNAME(cdr(assoc 3 MLS-DICT))))'STR)
               (setq MLSNAME(strcase MLSNAME))
               (setq ML(cdr(assoc 350 MLS-DICT)))
           )
          (setq MLSLIST(cons(list MLSNAME ML)MLSLIST))
        )
        (setq MLS-DICT (cddr(member(assoc 3 MLS-DICT)MLS-DICT)))  
      )
    )
    MLSLIST
  )
  ;;; - ---------------------------------------------------------------------------- - ;
  (defun DT:MLSASSIGN( AUSWAHL BLOCKSELEMENTS? BLOCKDUPLICATE? 
                     / OBJEKT PROPS LAYERPROPS
                       DT:ML-PUTSTYLE  DT:WITH-SELECTION-DOIT
                      
                       DT:COLOR-GET-INTERFACE-OBJ DT:COLOR-GET DT:COLOR-SET
                       DT:GET-PROPERTIES DT:PUT-PROPERTY DT:PUT-PROPERTIES
                        DT:DOIT MLOBJLIST
                     )
    
    (defun DT:ML-PUTSTYLE( ML-OBJ STYLENAME
                         / DT:PROPS-TAKEOVER STYLE OLDCMLSTYLE POINTS SPACE MLSCALE NEWML
                         )
      (defun DT:PROPS-TAKEOVER ( MASTER SLAVE PROPS / RETURN)
        (if(and(setq MASTER(cond                                        
                             ((=(type MASTER) 'VLA-object) MASTER)
                             ((=(type MASTER) 'Ename) (vlax-ename->vla-object MASTER))    
                           )
               )
               (setq SLAVE (cond
                             ((=(type SLAVE) 'VLA-object) SLAVE)
                             ((=(type SLAVE) 'Ename) (vlax-ename->vla-object SLAVE))    
                           )
               )
               (=(type PROPS)'LIST)         
               (not(vl-remove-if
                     '(lambda(x) (or(=(type X)'STR)
                                    (=(type X)'SYM)
                                 )
                      )
                      PROPS
                    )
               )
           )
          (progn
            (foreach PROP(vl-remove-if                        
                           '(lambda(X) (= X nil))
                            (mapcar
                             '(lambda (PROP)
                                (if(and(vlax-property-available-p MASTER PROP)
                                       (not(vl-catch-all-error-p
                                             (setq PROPS_VALUE(vl-catch-all-apply
                                                                'vlax-get-property
                                                                 (list MASTER PROP)
                                                              )
                                             )
                                           )  
                                       )
                                    )          
                                   (list (strcase(vl-princ-to-string PROP)) PROPS_VALUE)
                                )
                              )
                              PROPS
                            )
                         )
               (if(vlax-property-available-p SLAVE (car PROP) 'T)
                 (not(vl-catch-all-error-p 
                       (vl-catch-all-apply
                         'vlax-put-property (list SLAVE (car PROP) (cadr PROP))
                       )
                     )
                 )
               )
             )
             
             (if(and(member "OWNERID"
                            (mapcar'(lambda(X)(strcase(vl-princ-to-string X)))PROPS)
                    )        
                    (not(vl-catch-all-error-p 
                          (setq RETURN 
                            (vl-catch-all-apply
                              'vla-CopyObjects
                              (list(vla-get-ActiveDocument(vlax-get-acad-object))
                                   (vlax-make-variant
                                     (vlax-safearray-fill
                                       (vlax-make-safearray vlax-vbObject '(0 . 0)) 
                                       (list SLAVE)
                                     )
                                   )
                                   (vlax-make-variant
                                     (vlax-invoke-method
                                       (vla-get-ActiveDocument(vlax-get-acad-object))
                                       'ObjectIdToObject
                                       (vla-get-ownerid MASTER)
                                     )
                                   )
                              )
                            )  
                          )
                        )  
                    )
                    (not(vl-catch-all-error-p
                          (vl-catch-all-apply
                            'vla-delete
                              (list SLAVE)
                          )
                        ) 
                    )
                )
               (progn
                 (car(vlax-safearray->list(vlax-variant-value RETURN)))
               )
               SLAVE
             )
          )
        )  
      )
      ;;; - -------------------------------------------------------------------------- - ;
      (if(and(setq ML-OBJ (cond
                            ((=(type ML-OBJ) 'VLA-OBJECT)ML-OBJ)                     
                            ((=(type ML-OBJ) 'Ename)(vlax-ename->vla-object ML-OBJ))
                          )
             )
             (=(strcase(vla-get-Objectname ML-OBJ))"ACDBMLINE")
             (=(type STYLENAME)'STR)
             (setq STYLE(assoc(strcase STYLENAME)(DT:ML-GETSTYLES)))
             (setq OLDCMLSTYLE(getvar "CMLSTYLE"))         
             (not(vl-catch-all-error-p
                   (setq POINTS(vl-catch-all-apply
                                 'vlax-get-property (list ML-OBJ 'coordinates)
                               )
                   )
                 )
             )                      
             (setq SPACE(if(=(vla-get-activespace
                                 (vla-get-activedocument(vlax-get-acad-object))
                               )
                               1
                             )
                            (vla-get-modelspace(vla-get-activedocument(vlax-get-acad-object)))
                            (vla-get-paperspace(vla-get-activedocument(vlax-get-acad-object)))
                          )
             )
             (setvar "CMLSTYLE" (car STYLE))
             (not(vl-catch-all-error-p
                   (setq NEWML(vl-catch-all-apply'vla-addmline (list SPACE POINTS)))
                 )
             )
             (setvar "CMLSTYLE" OLDCMLSTYLE)
             (setq NEWML (DT:PROPS-TAKEOVER
                           ML-OBJ
                           NEWML
                           '(Justification Layer Linetype LinetypeScale
                             Lineweight Material  OwnerID
                             PlotStyleName TrueColor Visible
                            )
                         )
             )
             (not(vl-catch-all-error-p
                   (setq MLSCALE(vl-catch-all-apply'vla-get-mlinescale(list ML-OBJ))  )
                 )
             )
             (not(vl-catch-all-error-p
                   (vl-catch-all-apply'vla-put-mlinescale(list NEWML MLSCALE))
                 )
             )
             (not(vl-catch-all-error-p
                   (vl-catch-all-apply'vla-delete (list ML-OBJ))
                 )
             )
         )
        NEWML
      )
    )   
    (defun DT:WITH-SELECTION-DOIT ( AUSWAHL DOIT-FUNC BLOCKELEMENTS? BLOCKDUPLICATE?
                                  / BLOCK ITEM OBJLIST BLOCKLIST ATTRIBUTES DT:BLOCKSCAN
                                  )     
      (defun DT:BLOCKSCAN (INSERT DOIT-FUNC / NAME BLOCK)
        (if(or(and(=(type INSERT)'STR)(setq NAME (strcase INSERT))(tblobjname "BLOCK" NAME))
    	  (and(setq INSERT(cond      
                                ((=(type INSERT) 'VLA-OBJECT)  INSERT)
                                ((=(type INSERT) 'Ename) (vlax-ename->vla-object INSERT))    
                              )
                  )
                  (member(strcase(vla-get-objectname  INSERT))'("ACDBBLOCKREFERENCE" "ACDBMINSERTBLOCK"))
                  (setq NAME (vla-get-name INSERT))
              )	  
           )
          (progn
            (if(not(member(strcase NAME) BLOCKLIST))
              (progn                               
                (if(not(vl-catch-all-error-p       
                         (setq BLOCK(vl-catch-all-apply
                                      'vla-item
                                      (list(vla-get-blocks(vla-get-ActiveDocument(vlax-get-acad-object)))NAME)
                                    )
                         )
                       )
                   )
                 (progn
                   (setq BLOCKLIST (cons (strcase NAME) BLOCKLIST))
                   (vlax-for ITEM BLOCK
    		 (cond
                       ((member(strcase(vla-get-objectname  ITEM))'("ACDBBLOCKREFERENCE" "ACDBMINSERTBLOCK"))
                          (DT:BLOCKSCAN ITEM DOIT-FUNC)
                          ((eval DOIT-FUNC) ITEM)		      
                       )
                       ('T((eval DOIT-FUNC) ITEM))		   
                     )  
                   )	       
                 )
               )
             )  
           )
         )
        )  
      )      
      (if(=(type AUSWAHL)'PICKSET)
        (progn 
          (setq INDEX -1)
          (repeat (sslength AUSWAHL)
            (if(not(vl-catch-all-error-p
                     (setq ITEM(vl-catch-all-apply
                                 'vlax-ename->vla-object
                                 (list(ssname AUSWAHL(setq INDEX (1+ INDEX))))
                               )      
                     )
                   )
               )    
              (setq OBJLIST(cons ITEM OBJLIST))
            )  
          )
          (foreach ITEM OBJLIST        
            (cond
              ((member(strcase(vla-get-objectname  ITEM))
                        '("ACDBBLOCKREFERENCE" "ACDBMINSERTBLOCK")
                      )                          
                 (if BLOCKELEMENTS? (DT:BLOCKSCAN ITEM DOIT-FUNC))
                 ((eval DOIT-FUNC) ITEM) 
               )
               ('T((eval DOIT-FUNC) ITEM))		   
            )  
          )      
        )    
        (progn 
          (vlax-for BLOCK (vla-get-blocks(vla-get-activedocument(vlax-get-acad-object)))        
            (if(and(or BLOCKELEMENTS? (=(vla-get-islayout BLOCK):vlax-true))    
                   (=(vla-get-isXREF BLOCK):vlax-false)
               )    
              (vlax-for ITEM BLOCK ((eval DOIT-FUNC) ITEM))
            )
          )
        )  
      )
      (princ)
    )
    (defun DT:DOIT (OBJEKT)
      (if(setq OBJEKT(cond      
                        ((=(type OBJEKT) 'VLA-OBJECT)  OBJEKT)
                        ((=(type OBJEKT) 'Ename) (vlax-ename->vla-object OBJEKT))    
                      )
         )
        (progn
          (setq MLOBJLIST(cons OBJEKT MLOBJLIST))  
        )
      )  
    )
    (DT:WITH-SELECTION-DOIT AUSWAHL 'DT:DOIT BLOCKSELEMENTS? nil)
    (mapcar'(lambda(X)(DT:ML-PUTSTYLE X NEWSTYLE))MLOBJLIST)  
  )  
  ;;; - ---------------------------------------------------------------------------- - ;
  (defun MLSASSIGNDLG ( AUSWAHL
                      / LISTBOX:CHECK SELECT-INIT  DLG-WRITE DLG-CHECK DLG-RUN
                        AWS OBJFILTER FILTER:TYPES FILTER:TYP SELECT:LIST
                        BLOCKELEMENTS?   
                      )
    (defun WRITE-DCL(/ DIR POS FILE)
      (if(and(and(setq DIR(vl-filename-mktemp (strcat "MLSASSIGNDLG.DCL")))
               (setq FILE (open DIR "w"))
           )
        )
       (progn
         (mapcar
            '(lambda (X)
               (princ (strcat X "\n") FILE)
             )
           '(
              "MLSASSIGNDLG"
              ": dialog"
              "{ key = DLGTITEL;   "
              "   : boxed_row"
              "   { width = 68;"
              "     fixed_width = true;"
              "     : row   "
              "     {"
              "       : column"
              "       {"
              "         : spacer {}"
              "         : text"
              "         { "
              "           key   = \"SELECTTEXT\";"
              "           label = \"Anwenden auf\";"
              "           width = 22;         "
              "           fixed_width = true; "
              "         }"
              "         : spacer {height=1;}"
              "       }         "
              "        "
              "       : popup_list"
              "       {           "
              "         key   = \"SELECTLIST\";"
              "         label = \"\";"
              "         width = 27;           "
              "         fixed_width = true;"
              "         list = \"Gesamte Zeichnung\\nAktuelles Layout\\nAuswahl\";"
              "         alignment=right;"
              "       }"
              "       : button"
              "       { label = \"Auswahl\";"
              "         key   = \"SELECT\";"
              "         fixed_width = true;"
              "         width = 20;"
              "         alignment=right;"
              "       }"
              "       : spacer {}"
              "     }"
              "   }"
              ""
              "   : boxed_row"
              "   { width = 68;"
              "     fixed_width = true;"
              "     : row   "
              "     {"
              "       : column"
              "       {"
              "         : spacer {}"
              "         : text"
              "         { "
              "           key   = \"MLTEXT\";"
              "           label = \"Neuer Multilinienstil\";"
              "           width = 22;         "
              "           fixed_width = true;       "
              "         }"
              "         : spacer {height=1;}"
              "       }         "
              "        "
              "       : popup_list"
              "       {           "
              "         key   = \"MLLIST\";"
              "         label = \"\";"
              "         width = 27;           "
              "         fixed_width = true;"
              "         alignment=right;"
              "       }"
              "       : button"
              "       { label = \"von Multilinie\";"
              "         key   = \"MLSELECT\";"
              "         fixed_width = true;"
              "         width = 20;"
              "         alignment=right;"
              "       }"
              "       : spacer {}"
              "     }"
              "   }"
              "   : row"
              "   {"
              "     : button"
              "     { label = \"OK\";"
              "       key   = \"OK\";"
              "       fixed_width = true;"
              "       width = 21;"
              "       alignment = right;"
              "       mnemonic =\"O\";"
              "     }"
              "     : cancel_button"
              "     { label = \"Abbruch\";"
              "       key = \"CANCEL\";"
              "       fixed_width = true;"
              "       width = 21;"
              "       alignment = right;"
              "       mnemonic =\"A\"; "
              "       is_cancel = true;"
              "     }"
              "     : button"
              "     { label = \"Info\";"
              "       key   = \"INFO\";"
              "       fixed_width = true;"
              "       width = 21;"
              "       alignment = right;"
              "       mnemonic =\"I\";"
              "     }"
              "   }  "
              "}"
              ""
            )
         )
         (close FILE)
         DIR
       )
      )
    )
    (defun LISTBOX:CHECK(SELECTED BASISLIST / INDEXLIST  POS)
      (if(and(=(type SELECTED)'STR)
             (=(type BASISLIST)'LIST)
         )    
        (progn      
          (while (setq POS(vl-string-search " " SELECTED))
            (setq INDEXLIST  (cons (substr SELECTED 1 POS) INDEXLIST)
                  SELECTED (substr SELECTED (+ POS 2))              
            )
          )      
          (if(and(setq INDEXLIST
                   (vl-remove-if-not '(lambda(Z / Y)
                                        (and(setq Y(atoi Z))(= Y (distof Z 2))
                                            (<= 0 Y)(< Y (length BASISLIST))
                                        )
                                      )  
                                      (reverse(cons SELECTED INDEXLIST))
                   )
                 )
                 (setq SELECTED(mapcar '(lambda(Y) (nth Y BASISLIST))(mapcar 'atoi INDEXLIST)))
             )                       
            SELECTED          
          )  
        )
      )    
    )
    (defun SELECT-INIT()
      (if(=(type AUSWAHL)'PICKSET)
        (progn
          (start_list "SELECTLIST" 3)
          (mapcar 'add_list (setq SELECT:LIST'("Gesamte Zeichnung" "Aktuelles Layout" "Auswahl")))
          (end_list)                     
          (if(= FILTER:TYP "AWS")(set_tile  "SELECTLIST" "2"))
        )
        (progn
          (start_list "SELECTLIST" 3)
          (mapcar 'add_list (setq SELECT:LIST'("Gesamte Zeichnung" "Aktuelles Layout")))
          (end_list)
          (if (= FILTER:TYP "LYT")          
            (set_tile  "SELECTLIST" "1")
            (progn  
              (set_tile  "SELECTLIST" "0")
              (setq FILTER:TYP "DOC")
            )
          )  
        )
      )
      (cond
        ((= FILTER:TYP "AWS")(set_tile  "SELECTLIST" "2"))
        ((= FILTER:TYP "LYT")(set_tile  "SELECTLIST" "1"))
        ((= FILTER:TYP "DOC")(set_tile  "SELECTLIST" "0"))
      )  
      (action_tile "SELECTLIST"
                   (strcat
                     "(setq SELECT (nth(atoi $VALUE) SELECT:LIST))"
                     "(cond"                   
                     "  ((= SELECT \"Aktuelles Layout\" )(setq FILTER:TYP \"LYT\"))"
                     "  ((= SELECT \"Auswahl\"          )(setq FILTER:TYP \"AWS\"))"
                     "  ('T                              (setq FILTER:TYP \"DOC\"))"
                     ")"                   
                   )
      )
      (action_tile "SELECT" "(done_dialog 4)")
    )
    (defun DLG-CHECK(/ ABSTAND SELECT) (list FILTER:TYP AUSWAHL NEWSTYLE))        
   
    (defun DT:ML-GETSTYLES(/ MLS-DICT MLSNAME ML MLSLIST)
      (if(setq MLS-DICT(dictsearch (namedobjdict) "ACAD_MLINESTYLE"))
        (While MLS-DICT
          (if(and(=(type(setq MLSNAME(cdr(assoc 3 MLS-DICT))))'STR)
                 (setq MLSNAME(strcase MLSNAME))
                 (setq ML(cdr(assoc 350 MLS-DICT)))
             )
            (setq MLSLIST(cons(list MLSNAME ML)MLSLIST))
          )
          (setq MLS-DICT (cddr(member(assoc 3 MLS-DICT)MLS-DICT)))  
        )
      )
      MLSLIST
    )
    
    (defun DLG-RUN(DIR / DLGINDEX EXIT? NR)    
      (while (not EXIT?)
        (if(and
             (=(type DIR)'STR)(setq DIR(findfile DIR))
             (>(setq DLGINDEX (load_dialog DIR))0)
           )  
          (if(new_dialog "MLSASSIGNDLG" DLGINDEX)
            (progn
              (setq ML:LIST(mapcar 'car(DT:ML-GETSTYLES)))       
              (set_tile    "DLGTITEL" "ACM-MLSASSIGN © Th.Krüger 2025 ")
              (SELECT-INIT)
              (if(>(length ML:LIST)1) (setq ML:LIST(vl-sort ML:LIST '<)))
              (start_list "MLLIST" 3)(mapcar 'add_list ML:LIST)(end_list)
              (or(and(=(type NEWSTYLE)'STR)(member (strcase NEWSTYLE)ML:LIST))
                 (setq NEWSTYLE(getvar "CMLSTYLE"))
              )
              (set_tile "MLLIST"(itoa(vl-position NEWSTYLE ML:LIST)))
              (action_tile "MLLIST"  "(setq NEWSTYLE (car(LISTBOX:CHECK $VALUE ML:LIST)))")
              (action_tile "MLSELECT" "(done_dialog 5)")
              (action_tile "OK"           (strcat
                                            "(setq RETURN(DLG-CHECK))"
                                            "(done_dialog 1)"
                                          )  
              )
              (action_tile "CANCEL"         "(setq RETURN            nil)(done_dialog 0)")
              (action_tile "INFO"           "(alert(strcat \"=======  ACM-MLSASSIGN  =======\n\n\"
                                                           \"\tÄndern des Stiles von Multilinien\n\"
                                                           \"\t© Th.Krüger 2025  (tk@cad-od.de) \n\"
                                                   )
                                             )"      
              )                                    
              (setq EXIT? (start_dialog))
              (cond
                ((= EXIT? 4)
                  (sssetfirst nil nil)
                  (if(not(vl-catch-all-error-p
                           (setq DUMMY(vl-catch-all-apply
                                        'ssget (list OBJFILTER)
                                      )
                           )      
                         )
                     )    
                    (progn
                      (setq AUSWAHL DUMMY)
                      (setq FILTER:TYP "AWS")
                    )  
                    (alert "Keine gültigen Objekte gewählt!")
                  )
                  (setq EXIT? nil)   
                )
                ((= EXIT? 5)
                  (if(and(not(vl-catch-all-error-p
                               (setq DUMMY(vl-catch-all-apply
                                            'nentsel (list "\nMultilinie für Stilübername wählen : ")
                                          )
                               )      
                             )
                         )
                         (setq DUMMY(car DUMMY))
                         (setq DUMMY(vlax-ename->vla-object DUMMY))
                         (=(strcase(vla-get-ObjectName DUMMY))"ACDBMLINE")
                         (not(vl-catch-all-error-p
                               (setq DUMMY(vl-catch-all-apply
                                            'vla-get-stylename (list DUMMY)
                                          )
                               )      
                             )
                         )
                         (=(type DUMMY)'STR)
                     )                      
                    (setq NEWSTYLE DUMMY)               
                    (alert "Keine Multilinie gewählt!")
                  )
                  (setq EXIT? nil)   
                )
                ('T(setq EXIT? 'T))      
              )                    
              (unload_dialog DLGINDEX)
            )
            (progn (alert "Fehler bei der Dialoginitialisierung")(setq EXIT? 'T))
          )
          (progn (alert "Dialog nicht gefunden")(setq EXIT? 'T))
        )  
      )    
      RETURN
    )
    ;;; - -------------------------------------------------------------------------- - ;
    (setq OBJFILTER '((0 . "MLINE")))
    (setq FILTER:TYPES'("DOC" "LYT" "AWS"))
    (if (=(type AUSWAHL)'PICKSET)(setq FILTER:TYP "AWS")(setq FILTER:TYP "DOC"))
    (setq BLOCKELEMENTS? 'T)
    (if(and(setq DCLFILE(WRITE-DCL))(setq DCLFILE(findfile DCLFILE)))       
      (progn
        (setq RETURN(DLG-RUN DCLFILE))       
        (vl-file-delete DCLFILE)
        RETURN
      )
    )         
    RETURN
  )
  ;;; - ---------------------------------------------------------------------------- - ;
  (setq AUSWAHL (ssget "I"'((0 . "MLINE"))))
  (if(setq RETURN (MLSASSIGNDLG AUSWAHL))                  
    (progn                         
      (setq AUSWAHL
        (cond
          ((=(car RETURN)"LYT")(ssget "_x" (list(cons 410 (getvar"CTAB")))))
          ((and(=(car RETURN)"AWS")(=(type(cadr RETURN))'PICKSET))(cadr RETURN))
          ((=(car RETURN)"DOC")nil)
        )
      )
      (setq BLOCKELEMENTS? 'T)
      (setq NEWSTYLE(caddr RETURN))
      (setq OBJ(entlast))
      (vla-endundomark  (vla-get-activedocument(vlax-get-acad-object)))
      (vla-startundomark(vla-get-activedocument(vlax-get-acad-object)))     
      (DT:MLSASSIGN AUSWAHL BLOCKELEMENTS? nil)
      (if(=(car RETURN)"AWS")
        (progn
          (setq DUMMY(ssadd))
          (while (and(setq OBJ(entnext OBJ))
                     (setq DATA(entget OBJ))
                     (=(cdr(assoc 0 DATA))"MLINE")
                 )
            (ssadd OBJ DUMMY)
          )
          (sssetfirst nil nil)
          (if DUMMY(sssetfirst DUMMY DUMMY))
        )
      )
      (vla-endundomark  (vla-get-activedocument(vlax-get-acad-object)))
      (vla-Regen(vla-get-activedocument(vlax-get-acad-object))acAllViewports)  
    )
  )
  (princ)
)
;;; - ------------------------------------------------------------------------------- - ;
(defun ACM-MLSASSIGN:INFO() 
  (mapcar
    'princ
    (list
      "\n\n"
      "\nACM-MLSASSIGN : Ändert den Multilinienstil bei Multilinien" 
      "\n=============== "
      "\n(C) Thomas Krüger 2025" 
      "\nE-Mail: tk@cad-od.de"
      "\nBefehlszeilenaufruf : MLSASSIGN\n"   
    )
  )
  (princ)  
)
;;; - ------------------------------------------------------------------------------- - ;
(ACM-MLSASSIGN:INFO)
(princ)