;;; - ------------------------------------------------------------------------------ - ;
;;; -                T O O L - A C M - P L S E G I N F O 2                           - ;
;;; - ------------------------------------------------------------------------------ - ;
;;; - Beschreibung : Gibt Informationen über angeklicktes Polyliniensegment zurück   - ;
;;; - Befehle      : PLSEGINFO2                                                      - ;
;;; - ------------------------------------------------------------------------------ - ;
;;; - letzte Änderung am : 11.09.2023                                                - ;
;;; -              durch : Thomas Krüger                                             - ;
;;; - ------------------------------------------------------------------------------ - ;
(vl-load-com)
(defun C:PLSEGINFO2 ( / PL-OBJ PKT SEGINFO
                        DT:UNDOEND DT:UNDOSTART DT:ERROR DT:INIT DT:RESET
                        DT:PL-SEGINFO GRTXT TXTLIST
                        DT:CLIPBORD-CLEARDATA DT:CLIPBORD-PUT-TXT
                    ) 
  (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))
    )
    (mapcar'(lambda(X)(vl-catch-all-apply 'entdel (list X)))TXTLIST)
    (DT:UNDOEND)
    (DT:RESET)
    (princ)
  )
  (defun DT:INIT()
    (DT:UNDOEND)
    (DT:UNDOSTART)        
    (setq ERRORSAVE *error*  *error* DT:ERROR OLDDIMZIN (getvar "DIMZIN"))
    (setvar "DIMZIN" 0)
  )
  (defun DT:RESET()
    (setq *error* ERRORSAVE)
    (setvar "DIMZIN" OLDDIMZIN)
    ;(mapcar'(lambda(X)(vl-catch-all-apply 'entdel (list X)))TXTLIST)
    (mapcar '(lambda(X) (set X nil))(list 'ERRORSAVE 'OLDDIMZIN))
    (DT:UNDOEND)
    (princ)
  )

  (defun DT:CLIPBORD-CLEARDATA(/ HTML PW CB OK?)  
    (if(and(not(vl-catch-all-error-p 
                 (setq HTML(vl-catch-all-apply
                             'vlax-create-object (list "htmlfile")
                           )
                 )
               )
           )
           (=(type HTML)'VLA-OBJECT)
       )    
      (progn
        (setq OK?(and(not(vl-catch-all-error-p 
                           (setq PW(vl-catch-all-apply
                                     'vlax-get (list HTML 'ParentWindow)
                                   )
                           ) 
                         )
                     )    
                     (not(vl-catch-all-error-p 
                           (setq CB(vl-catch-all-apply
                                     'vlax-get (list PW 'ClipBoardData)
                                   )
                           )
                         )
                     )
                     (not(vl-catch-all-error-p 
                           (vl-catch-all-apply
                             'vlax-invoke (list CB 'Cleardata "TEXT")
                           )
                         )
                     )
                 )
        )  
        (vlax-release-object HTML)
      )  
    )
    OK?
  )

  (defun DT:CLIPBORD-PUT-TXT(TEXT / HTML PW CB OK?)  
    (if(and(=(type TEXT)'STR)
           (not(vl-catch-all-error-p 
                 (setq HTML(vl-catch-all-apply
                             'vlax-create-object (list "htmlfile")
                           )
                 )
               )
           )
           (=(type HTML)'VLA-OBJECT)
       )    
      (progn
        (setq OK?(and(not(vl-catch-all-error-p 
                           (setq PW(vl-catch-all-apply
                                     'vlax-get (list HTML 'ParentWindow)
                                   )
                           ) 
                         )
                     )    
                     (not(vl-catch-all-error-p 
                           (setq CB(vl-catch-all-apply
                                     'vlax-get (list PW 'ClipBoardData)
                                   )
                           )
                         )
                     )
                     (not(vl-catch-all-error-p 
                           (vl-catch-all-apply
                             'vlax-invoke (list CB 'Cleardata "TEXT")
                           )
                         )
                     )
                     (not(vl-catch-all-error-p 
                           (vl-catch-all-apply
                             'vlax-invoke (list CB 'Setdata "TEXT" TEXT)
                           )
                         )
                     )
                 )            
        )  
        (vlax-release-object HTML)
      )  
    )
    OK?
  )
  (defun GRTXT(SEGINFO / P P0 P1 TXT TH TXTDRAW)
    (defun TXTDRAW (PKT H TXTSTR)
      (if(and(=(type TXTSTR)'STR)
             (or(=(type H)'REAL)
                (setq H(/(getvar "ViewSIZE")40.0))
             )   
             (entmake (list
                       '(0 . "TEXT")
                       '(100 . "AcDbEntity")
                       '(100 . "AcDbText")
                        (cons 10 PKT)
                        (cons 7 (getvar "TextStyle"))
                        (cons 40 H)                        
                        (cons 50 0.0)
                        (cons 1 TXTSTR)
                      )  
             )
         )             
       (entlast)
      )
    )
    (setq P0 (getvar "extmin")   P1 (getvar "extmax"))        
    (if(<(length(cdr(setq P(grread 't 5 0))))3) 
      (setq P (cons 3
                    (list (list (+ (/ (nth 0 p0) 2) (/ (nth 0 p1) 2))
                                (+ (/ (nth 1 p0) 2) (/ (nth 1 p1) 2))
                                (+ (/ (nth 2 p0) 2) (/ (nth 2 p1) 2))
                          )
                    ) 
              ) 
      )
    )
    (setq TH (/(getvar "ViewSIZE")40.0))
    (if (<(setq AB(fix(* TH 1.5)))TH)(setq AB(fix(* TH 2.1))))
    (setq X (car   (cadr P)))
    (setq Y (- (cadr  (cadr P)) AB))
    (setq Z (caddr (cadr P)))
    
    (setq TXTLIST
      (mapcar       
        '(lambda(V)
           (TXTDRAW
             (list X (setq Y(+ Y AB)) Z)
             TH
             (strcat "\n "(car V)(cadr V))
           )
         )
        SEGINFO
      )
    )        
    (while (= 5 (car (setq P (grread 't 5 0))))
      (mapcar'(lambda(X)(vl-catch-all-apply 'entdel (list X)))TXTLIST)  
      (setq X (car   (cadr P)))
      (setq Y (- (cadr  (cadr P)) AB))
      (setq Z (caddr (cadr P)))
      (setq TXTLIST
        (mapcar       
          '(lambda(V)(TXTDRAW (list X (setq Y(+ Y AB)) Z) TH (strcat "\n "(car V)(cadr V))))
          SEGINFO
        )
      )
    )
    (if (= 3 (car P))(setq PKT(cadr P))(setq PKT nil))
    (mapcar'(lambda(X)(vl-catch-all-apply 'entdel (list X)))TXTLIST)        
    PKT        
  )
  
  (defun DT:PL-SEGINFO(PL-OBJ PKT / PARAM PRE SUF BULGE W C S R M WLIST) 
    (if(and(setq PL-OBJ(cond
                         ((=(type PL-OBJ) 'VLA-OBJECT) PL-OBJ)
                         ((=(type PL-OBJ) 'Ename) (vlax-ename->vla-object PL-OBJ))   
                       )
           )
           (or(member(strcase(vla-get-objectname PL-OBJ))
                    '("ACDB3DPOLYLINE" "ACDBPOLYLINE" "ACDB2DPOLYLINE")
              )
              (prompt "\nKeine Polylinie gewählt.Abbruch!")
           )   
           (setq PKT  (vlax-curve-getClosestPointTo PL-OBJ (trans PKT 1 0)))
           (setq PARAM(vlax-curve-getparamAtPoint PL-OBJ PKT))
           (setq PRE(vlax-curve-getpointatparam PL-OBJ (fix PARAM)))
           (setq SUF(vlax-curve-getpointatparam PL-OBJ (1+(fix PARAM))))
           (setq L
             (-(vlax-curve-getDistAtPARAM  PL-OBJ (1+(fix PARAM)))
               (vlax-curve-getDistAtPARAM  PL-OBJ    (fix PARAM) )
             )
           )      
           (setq BULGE(if(not(vl-catch-all-error-p
                               (setq BULGE (vl-catch-all-apply
                                             'vla-GetBulge (list PL-OBJ (fix PARAM))
                                           )
                               )
                             )   
                         ) 
                         BULGE
                         0.0
                      )
           )
           (if (> BULGE 0)
             (progn
               (setq W (* 4.0 (atan (abs BULGE)))) 
               (setq C (distance PRE SUF))           
               (setq S (*(/ C 2.0)(abs BULGE)))
               (setq R  (/ (/ C 2.0) (sin (/ W 2.0))))      
               (setq M (polar
                         PRE
                         (if (>= BULGE 0)
                           (+ (angle PRE SUF) (/ (- pi W) 2.0))
                           (- (angle PRE SUF) (/ (- pi W) 2.0))
                         )
                         R
                       )
               )
             )
             (progn
               (setq R "unendlich")
               (setq M "nicht vorhanden")
             )
           )
           (setq WLIST(if(not(vl-catch-all-error-p
                              (vl-catch-all-apply
                                'vla-GetWidth (list PL-OBJ PRE 'STARTW 'ENDW)
                              )
                             )
                         ) 
                        (list STARTW ENDW)
                       '(0 0)
                      )
           )
           (setq SEGINFO
             (list
               (list "KLICKPUNKT          : " (vl-princ-to-string            PKT  ))
               (list "SEGMENT-NUMMER      : " (vl-princ-to-string  (1+(fix PARAM))))
               (list "SEGMENT-STARTPUNKT  : " (vl-princ-to-string            PRE  ))
               (list "SEGMENT-ENDPUNKT    : " (vl-princ-to-string            SUF  ))
               (list "SEGMENT-LÄNGE       : " (vl-princ-to-string              L  ))
               (list "SEGMENT-STARTBREITE : " (vl-princ-to-string    (car  WLIST )))
               (list "SEGMENT-ENDBREITE   : " (vl-princ-to-string    (cadr WLIST )))
               (list "BULGE-BOGEN-RADIUS  : " (vl-princ-to-string              R  ))
               (list "BOGENMITTELPUNKT    : " (vl-princ-to-string              M  ))
             )
           )
       )
      SEGINFO
    ) 
  )
  ;;; - ----------------------------------------------------------------------------- - ;
  (DT:INIT)
  (if(and(or(setq PL-OBJ(entsel "\nPolyliniensegment wählen : "))
            (prompt "\nNichts gewählt.Abbruch!")
         )   
         (setq PKT(cadr PL-OBJ))
         (setq PL-OBJ (car PL-OBJ))
         (setq SEGINFO(DT:PL-SEGINFO PL-OBJ PKT))
     )
    (progn
      (mapcar
        '(lambda(X)(princ (strcat "\n "(car X)(cadr X))))
        SEGINFO
      )      
      (DT:CLIPBORD-CLEARDATA)
      (DT:CLIPBORD-PUT-TXT
        (apply
          'strcat
          (mapcar
            '(lambda(X)(strcat "\n "(car X)"\t"(cadr X)))
             SEGINFO
          )
        )
      )
      (GRTXT (reverse SEGINFO))               
      (princ)
    )
  )
  (DT:RESET)
)
;;; - ------------------------------------------------------------------------------- - ;
(defun ACM-PLSEGINFO2:INFO() 
  (mapcar
    'princ
    (list
      "\n\n"
      "\nACM-PL-SEGINFO2  : Gibt Informationen über angeklicktes"
      "\n===============    Polyliniensegment aus"
      "\n(C) Thomas Krüger 2023 (tk@cad-od.de)"
      "\nBefehlszeilenaufrufe : PLSEGINFO2\n"
      "\n"    
    )
  )
  (princ)  
)
;;; - ------------------------------------------------------------------------------- - ;
(ACM-PLSEGINFO2:INFO)