;;; - ------------------------------------------------------------------------------- - ;
;;; -                      A C M - H A T C H G A P                                    - ;
;;; - ------------------------------------------------------------------------------- - ;
;;; - Beschreibung       : Textobjekte innerhalb von Schraffuren freistellen          - ;
;;; - ------------------------------------------------------------------------------- - ;
;;; - Befehle            : HATCHGAP                                                   - ;
;;; - letzte Änderung am : 03.04.2024                                                 - ;
;;; -              durch : Thomas Krüger                                              - ;
;;; - ------------------------------------------------------------------------------- - ;
(vl-load-com)
;;; - ------------------------------------------------------------------------------- - ;
(defun C:HATCHGAP(/ T1LIST T2LIST  AWS ALLHATCHES SCREEN TXTOBJ                    
                    DT:ATTRIB->TEXTOBJ  DT:HATCHGAP DT:HATCHGAPAUTO
                    DT:ZOOMWINDOW DT:EXTSCREEN DT:AWS->OBJLIST
                    DT:HATCH-GETPPROPS DT:HATCH-SETPROPS
                    DT:UNDOEND DT:UNDOSTART DT:ERROR DT:INIT DT:RESET *NOMUTT* *OLDCMD*
                 )
 (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))
    )
    (DT:UNDOEND)
    (DT:RESET)
    (princ)
  )
  (defun DT:INIT()  
    (DT:UNDOSTART)        
    (setq ERRORSAVE *error*  *error* DT:ERROR)
    (setq *NOMUTT* (getvar "NOMUTT"))
    (setvar "NOMUTT"  1)
    (setq *OLDCMD*(getvar "CMDECHO"))
    (setvar "CMDECHO" 0)
  )
  (defun DT:RESET()
    (setq *error* ERRORSAVE)
    (setvar "NOMUTT"  *NOMUTT*)
    (setvar "CMDECHO" *OLDCMD*)
    (if(=(type T2LIST)'LIST)
      (mapcar
        '(lambda(X)
           (if(=(type X)'ENAME)
             (vl-catch-all-apply 'vla-delete (list(vlax-ename->vla-object X)))
           )  
         )
        T2LIST
      )
    )  
    (mapcar '(lambda(X) (set X nil))(list 'ERRORSAVE))
    (DT:UNDOEND)
    (princ)
  )
  (defun DT:ATTRIB->TEXTOBJ(ATTOBJ / DATA TOBJ Y)
    (if(and(setq ATTOBJ(cond 
                         ((=(type ATTOBJ) 'Ename) ATTOBJ)
                         ((=(type ATTOBJ) 'VLA-object) (vlax-vla-object->ename ATTOBJ))    
                       )
           )
           (setq DATA(entget ATTOBJ))
           (=(cdr(assoc 0 DATA))"ATTRIB")
           (setq DATA(if(member '(101 . "Embedded Object") DATA)
                       (progn
                         (setq Y '(001 007 010 011 040 041 050 071 072 073 210))
                         (append '((0 . "MTEXT") (100 . "AcDbEntity") (100 . "AcDbMText"))
                                  (vl-remove-if
                                    '(lambda(Z)
                                       (if(member(car Z)Y)
                                         (progn(setq Y(vl-remove (car Z)Y))'T)
                                       )
                                     )
                                     (vl-remove-if
                                      '(lambda(X)
                                          (member
                                            (car X)
                                           '(000 002 042 043 051 070 074 100 101 102 280 330 360)
                                          )
                                       )
                                       DATA
                                     )
                                   )
                         )
                       )  
                       (append '((0 . "TEXT"))
                                (vl-remove-if
                                 '(lambda(X)(member(car X) '(000 002 070 074 100 280)))
                                  (subst(cons 73(cdr(assoc 74 DATA)))(assoc 74 DATA)DATA)
                                )
                       )                     
                     )  
           )
           (setq TOBJ(entmakex
                       (append
                         (vl-remove-if
                           '(lambda(X)
                              (or(member(car X) '(005 006 008 039 048 062 102 370))
                                 (=(type(cdr X))'ENAME)
                              )
                            )
                           DATA
                         )
                        '((006 . "CONTINUOUS")(008 . "0")(039 . 0.0)(048 . 1.0)(062 . 7)(370 . 0))
                       )
                     )
           )
           
        )
      TOBJ
    )
  )
  (defun DT:HATCHGAP(OBJ HATCH / TMPOBJ)  
    (and(setq OBJ  (cond
                     ((=(type OBJ) 'ENAME)OBJ)
                     ((=(type OBJ)'VLA-OBJECT)(vlax-vla-object->ename OBJ))
                   )
        )      
        (wcmatch (cdr(assoc 0 (entget OBJ))) "*TEXT")
        (setq HATCH(cond
                     ((=(type HATCH) 'ENAME)HATCH)
                     ((=(type HATCH)'VLA-OBJECT)(vlax-vla-object->ename HATCH))
                   )
        )
        (=(cdr(assoc 0 (entget HATCH))) "HATCH")
        (not(vl-catch-all-error-p
              (vl-catch-all-apply'vl-cmdf (list "_.-hatchedit" HATCH "_AD" "_S" OBJ "" ""))
            )
        )
    )    
  )
  (defun DT:ZOOMWINDOW ( PKT1 PKT2 )
    (not(vl-catch-all-error-p
          (vl-catch-all-apply
            'vla-ZoomWindow(list (vlax-get-acad-object)(vlax-3d-point PKT1)(vlax-3d-point PKT2))
          )
        )
    )
  )
  (defun DT:EXTSCREEN ()
    (list
      (list
        (-(car(getvar "viewctr"))
          (*(/(getvar "viewsize")(cadr(getvar "screensize")))(car(getvar "screensize"))0.5)
        )
        (-(cadr(getvar "viewctr"))(/(getvar "viewsize")2.0))
      )
      (list
        (+(car (getvar "viewctr"))
          (*(/(getvar "viewsize")(cadr(getvar "screensize")))(car(getvar "screensize"))0.5)
        )
        (+(cadr (getvar "viewctr"))(/(getvar "viewsize")2.0))
      )
    )
  )
  (defun DT:AWS->OBJLIST(AWS / OBJLIST)
    (if(=(type AWS)'Pickset)
      (setq OBJLIST
        (mapcar'(lambda(X / Y)(if(=(type(setq Y(cadr X)))'ENAME)Y))(ssnamex AWS))
      )
    )  
  )
  (defun DT:HATCH-GETPPROPS(OBJ)
    (if(and(setq OBJ(cond 
                      ((=(type OBJ) 'VLA-object) OBJ)
                      ((=(type OBJ) 'Ename) (vlax-ename->vla-object OBJ))    
                    )
           )
           (=(strcase(vla-get-objectname OBJ))"ACDBHATCH")
           (vlax-property-available-p OBJ "PATTERNNAME")
       )    
      (list (vla-get-patterntype OBJ)
            (cond
              ((=(vla-get-patterntype OBJ)acHatchPatternTypeUserDefined) "_U")
              ('T (vla-get-patternname OBJ))
            )
            (vla-get-patternangle OBJ)
            (vla-get-patternscale OBJ)
      )
    )
  )  
  (defun DT:HATCH-SETPROPS(OBJ PROPS / PTYPE PNAME PANGLE PSCALE)
    (if(and(setq OBJ(cond 
                      ((=(type OBJ) 'VLA-object) OBJ)
                      ((=(type OBJ) 'Ename) (vlax-ename->vla-object OBJ))    
                    )
           )        
           (=(type PROPS)'List)
           (member (setq PTYPE(car PROPS))
                   (list acHatchPatternTypePreDefined
                         acHatchPatternTypeUserDefined
                         acHatchPatternTypeCustomDefined
                   )
           )
           (=(type(setq PNAME(cadr PROPS)))'STR)
           (or(/= PTYPE acHatchPatternTypeUserDefined)(setq PNAME "_U"))
           (or(numberp (setq PANGLE (caddr PROPS)))(setq PANGLE (0.25* PI)))
           (or(numberp (setq PSCALE(cadddr PROPS)))(setq PSCALE       1.0 )) 
       )
      (progn
        (and(not(vl-catch-all-error-p
                  (vl-catch-all-apply'vla-SetPattern(list OBJ PTYPE PNAME))
                )
            )
            (not(vl-catch-all-error-p
                  (vl-catch-all-apply'vla-put-patternangle(list OBJ PANGLE))
                )
            )
            (not(vl-catch-all-error-p
                  (vl-catch-all-apply'vla-put-patternscale(list OBJ PSCALE))
                )
            )
        )    
      )
    )  
  )
  (defun DT:HATCHGAPAUTO(TXTOBJ SINGLECALL? / KOORDS AWS HATCHLIST SCREEN DT:GET-TEXTBOXCOORDS)
    (defun DT:GET-TEXTBOXCOORDS( OBJ OFF
                               / DATA OBJNAME BASEPT WINKEL NORMAL B H APT DX DY P
                               )
      (if(and(or(numberp OFF)0)
             (setq OBJ(cond
                      ((=(type OBJ)'ENAME) OBJ)
                      ((=(type OBJ)'VLA-OBJECT)(vlax-vla-object->ename OBJ))
                    )  
             )
             (setq DATA(entget OBJ))
             (setq OBJNAME(strcase(cdr(assoc  0 DATA))))
             (cond
                ((= OBJNAME "TEXT")
                  (setq BASEPT(cdr(assoc  10 DATA)))
                  (setq WINKEL(cdr(assoc  50 DATA)))
                  (setq P(textbox DATA))
                  (setq P(list
                           (list(-(car(car  P))OFF)(-(cadr(car  P))OFF)0.0)
                           (list(+(car(cadr P))OFF)(-(cadr(car  P))OFF)0.0)
                           (list(+(car(cadr P))OFF)(+(cadr(cadr P))OFF)0.0)
                           (list(-(car(car  P))OFF)(+(cadr(cadr P))OFF)0.0) 
                         )
                  )
                ) 
                ((= OBJNAME "MTEXT")                
                  (setq NORMAL(cdr(assoc 210 DATA)))
                  (setq BASEPT(trans(cdr(assoc  10 DATA)) 0 NORMAL))                
                  (setq WINKEL(angle '(0 0 0)(trans(cdr(assoc 11 DATA)) 0 NORMAL)))                
                  (setq B(cdr(assoc 42 DATA)))
                  (setq H (cdr(assoc 43 DATA)))
                  (setq APT   (cdr(assoc 71 DATA)))
                  (setq DX(cond
                            ((member APT '(2 5 8))(* -0.5 B))
                            ((member APT '(3 6 9))(* -1.0 B))
                            ('T 0.0)
                          )
                  )
                  (setq DY(cond
                            ((member APT '(4 5 6))(* -0.5 H))
                            ((member APT '(1 2 3))(* -1.0 H))
                            ('T 0.0)
                          )
                  )
                  (setq P(list
                           (list (- DX OFF)    (- DY OFF)   0.0)
                           (list (+ DX OFF B)  (- DY OFF)   0.0)
                           (list (+ DX OFF B)  (+ DY OFF H) 0.0)
                           (list (- DX OFF)    (+ DY OFF H) 0.0)
                         )
                  )
                )
             )      
             (setq P(mapcar
                      '(lambda (X)            
                         (mapcar '+ (mapcar'(lambda(Y)(apply '+(mapcar '* Y X)))
                                            (list
                                              (list(cos WINKEL)(sin(- WINKEL))0.0)
                                              (list(sin WINKEL)(cos   WINKEL )0.0)
                                              (list        0.0           0.0  1.0)
                                            ) 
                                    )
                                    BASEPT
                         )
                       )
                       P
                    )
             )
         )
        P
      )
    )
    (if SINGLECALL?(setq SCREEN(DT:EXTSCREEN)))
    (if SINGLECALL?(vla-ZoomExtents (vlax-get-acad-object)))
    (if(and(setq TXTOBJ(cond
                         ((=(type TXTOBJ)'ENAME) TXTOBJ)
                         ((=(type TXTOBJ)'VLA-OBJECT)(vlax-vla-object->ename TXTOBJ))
                       )  
           )
           (wcmatch(cdr(assoc 0 (entget TXTOBJ))) "*TEXT")                
           (setq KOORDS(DT:GET-TEXTBOXCOORDS TXTOBJ 0.5))
           (setq AWS(ssget "_CP" KOORDS (list '(0 . "HATCH")(cons 410(getvar "CTAB")))))
           (>(sslength AWS)0)
           (setq HATCHLIST(DT:AWS->OBJLIST AWS))
       )
      (progn
        (foreach HATCHOBJ HATCHLIST(DT:HATCHGAP TXTOBJ HATCHOBJ))          
      )  
    )
    (if SINGLECALL?(DT:ZOOMWINDOW (car SCREEN)(cadr SCREEN)))
    (princ)
  )
  (DT:INIT)
  (if(or(and(princ (strcat "\nFreizustellende Textobjekte/Attributblöcke wählen: " ))
            (or(vl-catch-all-error-p
                 (setq AWS(vl-catch-all-apply
                            'ssget (list '((-4 . "<or")
                                           (0 . "*TEXT")
                                           (-4 . "<and")(0 . "INSERT")(66 . 1)(-4 . "and>")
                                           (-4 . "or>")
                                          )
                                   )
                          )
                 )
               )
               'T
            )           
            (or(=(type AWS)'PICKSET)(prompt "\nAbbruch durch Anwender..."))
            (>(sslength AWS)0)
            (mapcar
              '(lambda(X / OBJEKTDATEN ATT)
                 (if(and(=(type X)'ENAME)(setq OBJEKTDATEN(entget X)))    
                   (cond
                     ((wcmatch(cdr(assoc 0  OBJEKTDATEN))"*TEXT")(setq T1LIST(cons X T1LIST)))  
                     ((and(=(cdr(assoc 0 OBJEKTDATEN))"INSERT")(assoc 66 OBJEKTDATEN))
                        (while (/= (cdr(assoc 0 OBJEKTDATEN)) "SEQEND")
                          (setq OBJEKTDATEN(entget(entnext(cdr (assoc -1 OBJEKTDATEN)))))
                          (if(and(=(cdr(assoc 0 OBJEKTDATEN))"ATTRIB")
                                 (setq ATT(DT:ATTRIB->TEXTOBJ(cdr(assoc -1 OBJEKTDATEN))))
                             )    
                            (progn
                              (setq T1LIST(cons ATT T1LIST))
                              (setq T2LIST(cons ATT T2LIST))
                            )
                          )
                        )
                     )
                   )
                 )  
               )  
              (DT:AWS->OBJLIST AWS)
            )
            (>(length T1LIST)0)            
        )            
        (prompt "\nKeine TextObjekte gewählt...")
     )
    (progn
      (if(and(setq ALLHATCHES (ssget "_x" (list '(0 . "HATCH")(cons 410(getvar "CTAB")))))
             (setq ALLHATCHES (DT:AWS->OBJLIST ALLHATCHES))
             (setq ALLHATCHES (mapcar
                                '(lambda(X / Y)
                                   (setq Y(list X (DT:HATCH-GETPPROPS X)))
                                   (DT:HATCH-SETPROPS X (list 1 "ANSI37" 0.0 0.5))
                                   Y
                                 )
                                 ALLHATCHES
                              )
            )
         )
        (progn          
          (setq SCREEN(DT:EXTSCREEN))
          (vla-ZoomExtents(vlax-get-acad-object))     
          (foreach TXTOBJ T1LIST(DT:HATCHGAPAUTO TXTOBJ nil))      
          (DT:ZOOMWINDOW (car SCREEN)(cadr SCREEN))
          (mapcar '(lambda(X / Y)(DT:HATCH-SETPROPS(car X)(cadr X))) ALLHATCHES)
        )
      )  
    )
  )
  (DT:RESET)    
  (princ)
)
;;; - ------------------------------------------------------------------------------- - ;
(defun C:ACM-HATCHGAP-INFO()
  (mapcar
    'princ
    (list
      "\n\n"
      "\nACM-HATCHGAP : Freistellung von Textobjekte innerhalb von Schraffuren"  
      "\n============="
      "\n(C) Thomas Krüger 2024 (tk@cad-od.de)"
      "\nBefehlszeilenaufruf : HATCHGAP"
      "\n"    
    )
  )  
  (princ)
)  
;;; - ------------------------------------------------------------------------------- - ;
(C:ACM-HATCHGAP-INFO)
(princ)
;;; - ------------------------------------------------------------------------------- - ;