;;; - ------------------------------------------------------------------------------- - ;
;;; -                T O O L - A C M - L T C H A N G E                                - ;
;;; - ------------------------------------------------------------------------------- - ;
;;; - Beschreibung : Gibt Informationen über angeklicktes Polyliniensegment zurück    - ;
;;; - Befehle      : LTCHANGE                                                         - ;
;;; - ------------------------------------------------------------------------------- - ;
;;; - letzte Änderung am : 30.12.2023                                                 - ;
;;; -              durch : Thomas Krüger                                              - ;
;;; - ------------------------------------------------------------------------------- - ;
(vl-load-com)
(defun C:LTCHANGE(/ DLGRETURN
                    DT:UNDOEND DT:UNDOSTART DT:ERROR DT:INIT DT:RESET
                    DT:LINETYPE:GETLIST DT:OBJ:SETLINETYPE DT:SETLINETYPE
                    DT:LINETYPE:SELECTDLG
                 ) 
  ;;; - ----------------------------------------------------------------------------- - ;
  (defun DT:UNDOEND()
    (while(= 8(logand 8 (getvar "undoctl")))
      (vla-endundomark (vla-get-activedocument(vlax-get-acad-object)))
    )      
  )
  (defun DT:UNDOSTART()
    (DT:UNDOEND)
    (vla-startundomark(vla-get-activedocument(vlax-get-acad-object)))
  )
  (defun DT:ERROR (MSG)    
    (if(not(wcmatch(strcase MSG t) "*break,*cancel*,*exit*"))      
      (princ (strcat "\nFEHLER: " MSG))
    )
    ;_falls noch was anderes zum aufräumen ist : dann hier!
    (DT:UNDOEND)
    (DT:RESET)
    (princ)
  )
  (defun DT:INIT()  
    (DT:UNDOSTART)        
    (setq ERRORSAVE *error*  *error* DT:ERROR)    
  )
  (defun DT:RESET()
    (setq *error* ERRORSAVE)    
    (mapcar '(lambda(X) (set X nil))(list 'ERRORSAVE))
    (DT:UNDOEND)
    (princ)
  )
  ;;; - ----------------------------------------------------------------------------- - ;
  (defun DT:LINETYPE:GETLIST(DOC / LT LTLIST)
    (if(setq DOC
         (cond
           ((and(=(type DOC)'VLA-OBJECT)(vlax-property-available-p DOC 'LINETYPES))DOC)
           ((not DOC)(vla-get-activedocument(vlax-get-acad-object)))
         )  
       )
      (progn
        (vlax-for LT (vla-get-linetypes DOC) 
          (setq LTLIST(cons(list(strcase(vla-get-name LT)) LT) LTLIST))
        )
        LTLIST
      )
    )
  )
  ;;; - ----------------------------------------------------------------------------- - ;
  (defun DT:OBJ:SETLINETYPE(OBJ OLD:LT NEW:LT IGNORELAYLOCK? / DOC) 
    (if(and(setq OBJ(cond
                      ((=(type OBJ) 'VLA-OBJECT) OBJ)
                      ((=(type OBJ) 'Ename) (vlax-ename->vla-object OBJ))   
                    )
           )
           (setq DOC(vla-get-document OBJ))
           (or(=(strcase(vla-get-objectname OBJ))"ACDBLAYERTABLERECORD")
              IGNORELAYLOCK?
              (=(vla-get-Lock(vla-item(vla-get-Layers DOC)(vla-get-Layer OBJ))):vlax-false)
              (not(setq ERRMSG "\nÄnderungen an Objekten auf gesperrten Layern werden nicht ausgeführt"))
           )	                
       )
     (progn
       (if(member(strcase(vla-get-Linetype OBJ))OLD:LT)
         (vl-catch-all-apply'vla-put-Linetype(list OBJ NEW:LT))         
       )
       (if(and(member(strcase(vla-get-objectname OBJ))
                    '("ACDBBLOCKREFERENCE" "ACDBMINSERTBLOCK")
              )
              (=(vla-get-hasattributes OBJ) :vlax-true)
              (setq ATTRIBUTES (vlax-variant-value(vla-getattributes OBJ)))
              (=(vlax-safearray-get-dim ATTRIBUTES)1)
              (<=(vlax-safearray-get-l-bound ATTRIBUTES 1)
                 (vlax-safearray-get-u-bound ATTRIBUTES 1)
              )
              (setq ATTRIBUTES (vlax-safearray->list ATTRIBUTES))
          )    
        (foreach ATTRIBUT ATTRIBUTES
          (if(member(strcase(vla-get-Linetype ATTRIBUT))OLD:LT)
            (vl-catch-all-apply'vla-put-Linetype(list ATTRIBUT NEW:LT))         
          )                            
        )
       )  
     )
    )
  )
  ;;; - ----------------------------------------------------------------------------- - ;
  (defun DT:SETLINETYPE(OLD:LT NEW:LT / BLOCK ITEM LAYER LT:LIST)
    (if(and(setq LT:LIST(mapcar 'car(DT:LINETYPE:GETLIST(vla-get-activedocument(vlax-get-acad-object)))))
           (setq OLD:LT(cond
                          ((and(=(type OLD:LT)'STR)(member(strcase OLD:LT)LT:LIST))
                            (list (strcase OLD:LT))
                          )     
                          ((=(type OLD:LT)'LIST)
                            (vl-remove-if
                              'null
                              (mapcar
                                '(lambda(X)
                                  (if(and(=(type X)'STR)(member(strcase X)LT:LIST))(strcase X))
                                 )
                                 OLD:LT
                              ) 
                            )
                          )
                          ('T (setq ERRMSG "Fehlerhafter Linientypfilter") nil)
                       )
           )
           (setq NEW:LT(cond
                         ((and(=(type NEW:LT)'STR)(member(strcase NEW:LT)LT:LIST))NEW:LT)
                         ('T (setq ERRMSG "Fehlerhafter Ziel-Linientyp") nil)
                       )
           )
       )
      (progn
        (vlax-for BLOCK (vla-get-blocks(vla-get-activedocument(vlax-get-acad-object)))
          (vlax-for ITEM BLOCK
            (DT:OBJ:SETLINETYPE ITEM OLD:LT NEW:LT nil)
          )  
        )
        (vlax-for LAYER (vla-get-layers(vla-get-activedocument(vlax-get-acad-object)))
          (DT:OBJ:SETLINETYPE LAYER OLD:LT NEW:LT 'T)
        )
        (vla-Regen(vla-get-activedocument(vlax-get-acad-object))acAllViewports)
        (if(member(strcase(getvar "CELTYPE"))OLD:LT)
          (vl-catch-all-apply'setvar(list "CELTYPE" NEW:LT))         
        )
      )  
    )
  )
  ;;; - ----------------------------------------------------------------------------- - ;
  (defun DT:LINETYPE:SELECTDLG( NOTSELECTABLE
			      / DT:LINETYPE:GETLIST
			        WRITE-DCL DT:LISTBOX:CHECK DLG-CHECK DLG-RUN
                                DLG FLAGS LT:LIST
                              )
    (defun DT:LINETYPE:GETLIST(DOC / LT LTLIST)
      (if(setq DOC
           (cond
             ((and(=(type DOC)'VLA-OBJECT)(vlax-property-available-p DOC 'LINETYPES))DOC)
             ((not DOC)(vla-get-activedocument(vlax-get-acad-object)))
           )  
         )
        (progn
          (vlax-for LT (vla-get-linetypes DOC) 
            (setq LTLIST(cons(list(strcase(vla-get-name LT)) LT) LTLIST))
          )
          LTLIST
        )
      )
    )    
    (defun WRITE-DCL(/ DIR FILE)
      (if(and(setq DIR(vl-filename-mktemp "LTSELECT.DCL"))
             (setq FILE (open DIR "w"))
         )    
        (progn
          (mapcar
           '(lambda (X)(princ (strcat X "\n") FILE))
           '(             
             "LTSELECT"
             ": dialog"
             "   { key = DLGTITEL;"
             "       : row"
             "       {"
             "       : boxed_column"
             "       {"
             "       : text"
             "         { label       = \"Ursprungs-Linientypen:\";"
             "           key         = \"LT-LISTTXT1\";"
             "           width       = 30;"
             "           fixed_width = true;"                        
             "           alignment = left;"
             "         }"
             "         : list_box"
             "         { key         = \"LT-LIST1\";"
             "           width       = 30;"
             "           fixed_width = true;"
             "           height      = 20;"
             "           fixed_height= true;"
             "           multiple_select = true;"
             "           alignment = left;"
             "         }"
             "         : button"
             "         { label = \"von Objekt..\";"
             "           key = \"SELECT1\";"
             "           fixed_width = true;"
             "           width = 30;"
             "           alignment = centered;"
             "         }"   
             "         : spacer {}"                                 
             "       }"
             "       : boxed_column"
             "       {"
             "       : text"
             "         { label       = \"Ziel-Linientyp:\";"
             "           key         = \"LT-LISTTXT2\";"
             "           width       = 30;"
             "           fixed_width = true;"                        
             "           alignment = left;"
             "         }"
             "         : list_box"
             "         { key         = \"LT-LIST2\";"
             "           width       = 30;"
             "           fixed_width = true;"
             "           height      = 20;"
             "           fixed_height= true;"
             "           multiple_select = false;"
             "           alignment = left;"
             "         }"
             "         : button"
             "         { label = \"von Objekt..\";"
             "           key = \"SELECT2\";"
             "           fixed_width = true;"
             "           width = 30;"
             "           alignment = centered;"
             "         }"   
             "         : spacer {}"                                 
             "       }"
             "     }"
             "       : row"
             "       {"        
             "         : button"
             "         { label=\"OK\";"
             "           key=\"OK\";"
             "           fixed_width=true;"
             "           width=19;"
             "           alignment=centered;"
             "           mnemonic =\"O\";"
             "           is_default = true;"
             "         }"
             "         : cancel_button"
             "         { label = \"Abbruch\";"
             "           key = \"CANCEL\";"
             "           fixed_width = true;"
             "           width = 19;"
             "           alignment = centered;"
             "           mnemonic =\"A\";"
             "           is_cancel = true;"
             "         }"
             "         : button"
             "         { label = \"Info\";"
             "           key = \"INFO\";"
             "           fixed_width = true;"
             "           width = 19;"
             "           alignment = centered;"
             "           mnemonic =\"I\";"
             "         }"
             "       }"
             "     }"
             
            )
          )
          (close FILE)
          DIR
        )
      )
    )
    (defun DT: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 DLG-CHECK( / FLAGS )
      (list
        (DT:LISTBOX:CHECK (get_tile "LT-LIST1") LT:LIST)
        (DT:LISTBOX:CHECK (get_tile "LT-LIST2") LT:LIST)
      )
    )
    (defun DLG-RUN(DIR / DLGINDEX FLAGS NAME ITEM EXIT? LT:AWS1 LT:AWS2 LT:NAME SELECTED1 SELECTED2)
      (or(=(type NOTSELECTABLE)'LIST)(not(setq NOTSELECTABLE nil)))
      (setq LT:LIST
        (vl-remove-if
          '(lambda(X)(member X NOTSELECTABLE))
           (mapcar 'car (DT:LINETYPE:GETLIST nil))
        )   
      )      
      (if(>(length LT:LIST)1) (setq LT:LIST(vl-sort LT:LIST '<)))      
      (while (not EXIT?)          
        (if(and(setq DIR(findfile DIR))(>(setq DLGINDEX (load_dialog DIR))0))
          (if(new_dialog "LTSELECT" DLGINDEX)
            (progn                        
              (set_tile    "DLGTITEL" "ACM-LTCHANGE")          
              (start_list  "LT-LIST1" 3)(mapcar 'add_list  LT:LIST)(end_list)
              (start_list  "LT-LIST2" 3)(mapcar 'add_list  LT:LIST)(end_list)
              (if(and(setq SELECTED1(vl-remove-if 'null(mapcar'(lambda(x)(vl-position X LT:LIST))LT:AWS1)))
                     (setq SELECTED1(apply 'strcat (mapcar'(lambda(X)(strcat (itoa X) " "))SELECTED1)))
                 )    
                (set_tile "LT-LIST1" SELECTED1)                  
              )
              (if(and(setq SELECTED2(vl-remove-if 'null(mapcar'(lambda(x)(vl-position X LT:LIST))LT:AWS2)))
                     (setq SELECTED2(apply 'strcat (mapcar'(lambda(X)(strcat (itoa X) " "))SELECTED2)))
                 )    
                (set_tile "LT-LIST2" SELECTED2)                  
              )
              (action_tile "LT-LIST1"   "(setq LT:AWS1 (DT:LISTBOX:CHECK $VALUE LT:LIST))")
              (action_tile "LT-LIST2"   "(setq LT:AWS2 (DT:LISTBOX:CHECK $VALUE LT:LIST))")
              (action_tile "SELECT1"    (strcat"(setq LT:AWS1 (DT:LISTBOX:CHECK (get_tile \"LT-LIST1\") LT:LIST))"
                                               "(setq LNR 1)" 
                                               "(done_dialog 3)"
                                       )
              )
              (action_tile "SELECT2"    (strcat"(setq LT:AWS2 (DT:LISTBOX:CHECK (get_tile \"LT-LIST2\") LT:LIST))"
                                               "(setq LNR 2)"
                                               "(done_dialog 3)"
                                       )
              )
              (action_tile "OK"        "(if(setq FLAGS (DLG-CHECK))(done_dialog 1))")
              (action_tile "CANCEL"    "(setq FLAGS            nil)(done_dialog 0)")
              (action_tile "INFO"      "(alert(strcat \"=======  ACM-LTCHANGE ========\n\n\"
                                                      \"    Ändern von Linientypen\n\"
                                                      \"  ©Th.Krüger 2023 (tk@cad-od.de)\n\"
                                              )
                                        )"      
              )
              (if(not(setq EXIT?(/=(start_dialog)3)))   
                (if(and(setq ITEM(car(nentsel "\nObjekt mit Linientyp wählen:")))                     
                       (setq ITEM(vlax-ename->vla-object ITEM))
                       (setq LT:NAME (vla-get-linetype ITEM))		
                   )
                  (cond
                    ((= LNR 1) 
  		      (if(not(member(strcase LT:NAME)LT:AWS1)) (setq LT:AWS1(append (list(strcase LT:NAME)) LT:AWS1)))
                    )
                    ((= LNR 2) 
  		      (if(not(member(strcase LT:NAME)LT:AWS2)) (setq LT:AWS2(append (list(strcase LT:NAME)) LT:AWS2)))
                    )
                  )  
                  (alert "== Kein Objekt gewählt. ==")
                )  
              )
              (unload_dialog DLGINDEX)            
            )
            (progn(alert "Dialog nicht gefunden") (setq Exit? 'T))
          )
          (progn(alert "Dialog nicht gefunden") (setq Exit? 'T))
        )
      )  
      FLAGS
    )    
    (if(setq DLG(WRITE-DCL))
      (progn
        (setq FLAGS(DLG-RUN DLG))          
        (vl-file-delete DLG)
        FLAGS
      )  
    )          
  )
  ;;; - ----------------------------------------------------------------------------- - ;
  (DT:INIT)
  (if(setq DLGRETURN(DT:LINETYPE:SELECTDLG nil))
    (progn
      (DT:SETLINETYPE(car DLGRETURN)(car(cadr DLGRETURN)))
    )  
  )
  (DT:RESET)
)
;;; - ------------------------------------------------------------------------------- - ;
(defun ACM-LTCHANGE:INFO() 
  (mapcar
    'princ
    (list
      "\n\n"
      "\nACM-LTCHANGE  : Linientypänderungen in der gesamten Zeichnung"
      "\n============== "
      "\n(C) Thomas Krüger 2023 (tk@cad-od.de)"
      "\nBefehlszeilenaufrufe : LTCHANGE\n"
      "\n"    
    )
  )
  (princ)  
)
;;; - ------------------------------------------------------------------------------- - ;
(ACM-LTCHANGE:INFO)
(princ)