[编程交流] '警报#039；带foc的盒子

; just some lunchtime fun - rlx 11 dec 2017
; uses reactor / grread / entmake (Mtext) to emulate autoscale messenger box
; minor update on 12 dec : added c key in grread-loop to change background color
; minor update on 13 dec : killed bug , dropped font and added F9 functionality to grread loop
;                        : couldn't resist , added transparency
(defun c:rlxmessenger  (/ loop gr_input    ent messenger-entity messenger-insertion-point transparency-list messenger-title
           messenger-text-height messenger-body-text messenger-background-color messenger-alignment-code messenger-transparency)
 (init_messenger)
 (setq loop t)
 (while loop
   (setq gr_input (vl-catch-all-apply 'grread (list nil 8 0)))
   ; oh dear , user pressed panic button
   (if    (vl-catch-all-error-p gr_input)
     (progn (princ "\nFunction cancelled") (setq loop nil) (bye-bye)))
   (cond ((user_pressed_lmouse_button)
      (if (setq ent (nentselp (cadr gr_input)))
        (_show (entget (car ent)))
        (princ "\ryou missed...")))
     ((user_pressed_rmouse_button) (setq loop nil) (bye-bye))
     ((user_pressed_c) (change_messenger_background_color))
     ((user_pressed_e) (command "zoom" "e") (update_messenger))
     ((user_pressed_z) (command "'zoom" "") (update_messenger))
     ((user_pressed_+) (command "zoom" "2x") (update_messenger))
     ((user_pressed_-) (command "zoom" ".5x") (update_messenger))
     ((user_pressed_f9) (toggle_snapmode))
     ((user_pressed_tab) (cycle_transparency_list))
     ((user_pressed_space) (relocate_messenger)))))
(defun init_messenger  ()
 (setq    transparency-list '(33554661 33554636 33554610 33554585 33554559 33554534 33554508)
   messenger-reactor (vlr-command-reactor nil '((:vlr-commandended . endcommand)))
   messenger-insertion-point (getvar "viewctr")
   messenger-text-height (/ (getvar "VIEWSIZE") 100.0)
   messenger-title    "Basic properties "
   messenger-background-color 2
   messenger-alignment-code 5
   messenger-transparency (car transparency-list))
 (defun *error* (m) (redraw) (bye-bye))
 (create_messenger_entity
   messenger-insertion-point
   "Messenger Rlx dec 2017 "
   messenger-text-height
   '("Click on any entity to display its prop's" "During execution use following keys"    "+/-/e/z used for zoom"
     "space to select messenger location" "c to change background color" "Tab for transparency" "Left mouse button to select entity"
     "Right mouse button to exit")
   messenger-background-color
   messenger-alignment-code)
 (redraw)
 (prompt "\nPress any key to begin")
 (grread)
 (if messenger-entity
   (progn (entdel messenger-entity) (setq messenger-entity nil)))
 (princ))
(defun bye-bye    ()
 (if messenger-entity (progn (entdel messenger-entity) (setq messenger-entity nil)))
 (if (and messenger-reactor (vlr-added-p messenger-reactor)) (vlr-remove messenger-reactor))
 (princ "\nbye-bye") (redraw) (princ))
(defun get_screen_corners  (/ vc vs ss dx dy x- x+ y- y+)
 ; dX = height * ratio (/ x-pixels y-pixels)
 (setq    vc (getvar "VIEWCTR") vs (getvar "VIEWSIZE") ss (getvar "SCREENSIZE")
   dx (* vs (/ (car ss) (cadr ss)) 0.5) dy (* vs 0.5))
 ; four corner points display
 (setq    x- (- (car vc) dx) x+ (+ (car vc) dx) y- (- (cadr vc) dy) y+ (+ (cadr vc) dy))
 (list x- x+ y- y+))
; pl = pointlist xmin , xmax , ymin & ymax. Devide screen in 3x3 matrix to find aligment
(defun select_messenger_alignment  (/ pnt pl x y x- x+ y- y+ dx dy va ho alignment)
 (setq pnt (getpoint "\nSelect position for messenger screen :"))
 ; first get corners of autocad screen with (Get_Screen_Corners)
 (setq    x  (car pnt) y (cadr pnt) pl (get_screen_corners)
   x- (car pl) x+ (cadr pl) y- (caddr pl) y+ (last pl)
   dx (/ (- x+ x-) 3) dy (/ (- y+ y-) 3))
 (cond    ((< x (+ x- dx)) (setq ha "Left" x  x-))
   ((< x (+ x- (* dx 2))) (setq ha "Center" x (car (getvar "VIEWCTR"))))
   (t (setq ha "Right" x  x+)))
 (cond    ((< y (+ y- dy)) (setq va "Bottom" y  y-))
   ((< y (+ y- (* dy 2))) (setq va "Middle" y (cadr (getvar "VIEWCTR"))))
   (t (setq va "Top" y  y+)))
 (setq    alignment
    (cond ((equal ha "Left")   (cond ((equal va "Top") 1) ((equal va "Middle") 4) ((equal va "Bottom") 7)))
          ((equal ha "Center") (cond ((equal va "Top") 2) ((equal va "Middle") 5) ((equal va "Bottom") ))
          ((equal ha "Right")  (cond ((equal va "Top") 3) ((equal va "Middle") 6) ((equal va "Bottom") 9)))))
; if you want attachmentpoint as string (e.g. "acAttachmentPointTopLeft" or "acAttachmentPointTopCenter") use this
; (setq atm-point (strcat "acAttachmentPoint" va ha))
; in order to use this i.c.w. vla-put-AttachmentPoint convert it with (eval (read atm-point))
; (list atm-point (list x y))
; 'acAttachmentPointTopLeft etc is a constant (int) , 1-9 , so aligment contains this code
; this is later used in (Create_messenger_entity) when constructing the entity list (elist) , (cons 71 atc) , attachmentpoint code
 (list alignment (list x y 0.0)))
(defun calcumus     (/ pl x y x- y- x+ y+ xc yc)
 ; first get corners of autocad screen with (Get_Screen_Corners)
 (setq    pl (get_screen_corners)
   x- (car pl) x+ (cadr pl) y- (caddr pl) y+ (last pl) xc (car (getvar "viewctr"))    yc (cadr (getvar "viewctr")))
 (cond    ((= messenger-alignment-code 1) (setq x x- y y+)) ; TopLeft
   ((= messenger-alignment-code 2) (setq x xc y y+)) ; TopCenter
   ((= messenger-alignment-code 3) (setq x x+ y y+)) ; TopRight
   ((= messenger-alignment-code 4) (setq x x- y yc)) ; MiddleLeft
   ((= messenger-alignment-code 5) (setq x xc y yc)) ; MiddelCenter
   ((= messenger-alignment-code 6) (setq x x+ y yc)) ; MiddelRight
   ((= messenger-alignment-code 7) (setq x x- y y-)) ; BottomLEft
   ((= messenger-alignment-code  (setq x xc y y-)) ; BottomCenter
   ((= messenger-alignment-code 9) (setq x x+ y y-)) ; BottomRight
   (t (setq x xc y yc messenger-alignment-code 5))
 )
 (setq    messenger-insertion-point (list x y 0.0) messenger-text-height (/ (getvar "VIEWSIZE") 100))
)
(defun endcommand  (calling-reactor endcommandinfo / cmd)
 (setq cmd (nth 0 endcommandinfo))
 (if (member cmd '("PAN" "ZOOM" "RTZOOM")) (calcumus) (update_messenger)) (princ))
; here you add all the props you want to see. The result should be a list of strings the messenger box (mtext)
; will scale to match (of course add 100 lines and this obviously wont work...)
(defun _show  (%e)
 (setq messenger-body-text (list (strcat "Entity type  : " (cdr (assoc 0 %e))) (strcat "Entity layer : " (cdr (assoc 8 %e)))))
 (calcumus) (update_messenger))
; %pnt = point , $tts = title string , #th = text height , %bsl = body string list , #bgc = background colour
; atc = attachement code (alignment)
(defun create_messenger_entity    (%pnt $tts #th %bsl #bgc atc / msg str fnt elist)
 ; you can use a font for messenger box but I'm not sure it looks better
 ; (setq fnt "{\\fArial|b0|i0|c0|p0;" msg (strcat fnt "\\H" (rtos #th) "x;\\L\\C250;" $tts "\\l\\H0.75x;\n"))
 (setq msg (strcat "\\C250;\\L" $tts "\\l\n")) ; black color (250 for text and underline for title
 (foreach str %bsl (setq msg (strcat msg "\n" str)))
 (setq msg (strcat msg "}")) ; the order of the elist seems to matter... change order and you may end up with empty mtext
 (setq    elist (list '(0 . "MTEXT") '(100 . "AcDbEntity") (cons 440 messenger-transparency) '(100 . "AcDbMText")
           (cons 10 %pnt) (cons 1 msg) '(90 . 1)(cons 63 #bgc) (cons 40 (/ (getvar "VIEWSIZE") 30.0))
           (cons 71 atc) '(72 . 5) '(441 . 0)))
 (setq messenger-entity (entmakex elist))
 ; also possible to use vla-put i.c.w. for example "acAttachmentPointTopLeft"
 ; downside of this can be that alignment is changed after mtext is placed, not before
 ; (vla-put-AttachmentPoint (vlax-ename->vla-object messenger-entity) (eval (read atc)))
)
(defun relocate_messenger  (/ aligment-data)
 (if messenger-entity
   (progn (entdel messenger-entity) (setq messenger-entity nil)))
 (setq    aligment-data (select_messenger_alignment) messenger-alignment-code (car aligment-data)
   messenger-insertion-point (last aligment-data))
 (update_messenger))
(defun update_messenger     ()
 (if messenger-entity
   (progn (entdel messenger-entity) (setq messenger-entity nil)))
 (create_messenger_entity
   messenger-insertion-point messenger-title messenger-text-height messenger-body-text    messenger-background-color messenger-alignment-code))
(defun change_messenger_background_color  (/ col)
 (if (setq col (acad_colordlg messenger-background-color))
   (progn (setq messenger-background-color col) (update_messenger))))
(defun toggle_snapmode () (setvar "snapmode" (if (= (getvar "snapmode") 1) 0 1)))
; transparency:
; 10 % = (440 . 33554661) , 20 % = (440 . 33554636) , 30 % = (440 . 33554610) 40 % = (440 . 33554585)
; 50 % = (440 . 33554559) , 60 % = (440 . 33554534) , 70 % = (440 . 33554508) , 80 % = (440 . 33554483) , 90 % = (440 . 33554457)
; difference is 25.5 per 10% so 0 % (solid) would (theoretically) be 33554686 and 100% (invissible) would be 33554432
(defun cycle_transparency_list    ()
 (setq    transparency-list      (append (cdr transparency-list) (list (car transparency-list)))
   messenger-transparency (car transparency-list))
 (update_messenger))
; maybe not efficient to use extra defun's but hey, autodesk uses predefined constants etc all the time so bite me
; just don't go over board and put the entire alphabet here
(defun user_pressed_+ ()(if (equal gr_input '(2 43)) t nil))
(defun user_pressed_- ()(if (equal gr_input '(2 45)) t nil))
(defun user_pressed_c ()(if (member gr_input '((2  99) (2 67))) t nil))
(defun user_pressed_e ()(if (member gr_input '((2 101) (2 69))) t nil))
(defun user_pressed_x ()(if (member gr_input '((2 120) (2 88))) t nil))
(defun user_pressed_z ()(if (member gr_input '((2 122) (2 90))) t nil))
(defun user_pressed_f9    () (if (equal gr_input '(2 2)) t  nil))
(defun user_pressed_tab      () (if (equal gr_input '(2 9)) t nil))
(defun user_pressed_enter () (if (equal gr_input '(2 13)) t nil))
(defun user_pressed_space () (if (equal gr_input '(2 32)) t nil))
(defun user_pressed_lmouse_button  () (if (= (car gr_input) 3) t nil))
(defun user_pressed_rmouse_button  () (if (= (car gr_input) 25) t nil))
;(c:rlxmessenger)