Hi! I have a simple non-editable and non-resizable snip% class that in
its draw function distinguishes whether it's selected or not. It works
fine when I select it in a text% with the mouse.
Now I want to select it in the text% when the user left-clicks on it,
so I've overridden on-event and tried this:
(define/public (select-this-snip)
(define editor (send (get-admin) get-editor))
(define pos (send editor get-snip-position this))
(send editor set-position pos (+ pos 1)))
It *does* select the snip in the sense that a selection background is
drawn (which is visible on the edges, since the snip itself uses a
rounded rectangle), but the snip itself is not drawn as highlighted,
even though I check whether draw-caret is a pair in the draw method. It
is correctly drawn when I select it manually with the mouse, though.
I've tried resize and various other refresh methods in editor and
snip-admin with and without wrapping it into queue-callback, but none of
them worked so far. Should I redraw it manually by calling draw
directly?
Best,
Erich
----
(define attachment-snip%
(class snip%
(inherit set-snipclass set-style get-style set-flags get-admin)
(init-field attachment)
(init-field (click-callback #f))
(define/public (get-display-name)
(string-append " " (send attachment get-name) " "))
(define/override (get-extent dc x y [w #f] [h #f]
[descent #f] [space #f]
[lspace #f] [rspace #f])
(let-values ([(tw th tdist tvspace)
(send dc get-text-extent
(get-display-name)
(send (get-style) get-font)
#t
0)])
(when h (set-box! h (max 22 (+ th 4))))
(when w (set-box! w (+ tw 22)))
(when descent (set-box! descent tdist))
(when space (set-box! space tvspace))
(when lspace (set-box! lspace 5))
(when rspace (set-box! rspace 5))))
(define (get-pict)
(case (send attachment get-type)
(("file") icons:snip-file-pict)
(("image-file") icons:snip-image-pict)
(("link") icons:snip-link-pict)
(("url") icons:snip-url-pict)
(else
(log-warning "attachment-snips:attachment-snip%:get-pict
unknown attachment type ~s" (send attachment get-type))
icons:snip-file-pict)))
(define (get-init-style)
(case (send attachment get-type)
(("file") file-style)
(("image-file") image-style)
(("link") link-style)
(("url") url-style)
(else
(log-warning "attachment-snips:attachment-snip%:get-style
unknown attachment type ~s" (send attachment get-type))
link-style)))
(define/override (draw dc x y left top right bottom dx dy
draw-caret)
(define-values (tw th tdist tvspace)
(send dc get-text-extent (get-display-name)
(send (get-style) get-font) #t 0))
(define w (+ tw 22))
(define h (max 22 (+ th 4)))
(define background-color
(if (pair? draw-caret)
(scale-color 0.8 (send (get-style) get-background))
(send (get-style) get-background)))
(define background
(filled-rounded-rectangle
w h
#:color background-color
#:border-color (scale-color 0.8 background-color)
#:draw-border? #t))
(define c-new (send (get-style) get-background))
(define old-pen (send dc get-pen))
(send dc set-smoothing 'aligned)
(draw-pict background dc x y)
(draw-pict (scale-to-fit (get-pict)
16
16)
dc (+ x 4) (+ y 4))
(send dc set-pen old-pen)
(when (and (pair? draw-caret) (get-highlight-text-color))
(send dc set-text-foreground (get-highlight-text-color)))
(send dc set-text-background background-color)
(send dc draw-text (get-display-name) (+ x 20) (+ y 4) #t))
(define/override (adjust-cursor dc x y editorx editory evt)
attachment-snip-cursor)
(define/public (select-this-snip)
(define editor (send (get-admin) get-editor))
(define pos (send editor get-snip-position this))
(send editor set-position pos (+ pos 1)))
(define/override (on-event dc x y editorx editory evt)
(case (send evt get-event-type)
((left-down) (select-this-snip)(displayln "left"))
((right-down) (displayln "right"))
((middle-down) (displayln "middle"))))
(define/override (copy)
(make-object attachment-snip% attachment))
(define/override (get-text offset num [flattened? #f])
(send attachment get-name))
(define/override (write f)
(send f put (send attachment get-id)))
(super-new)
(set-snipclass attachment-snip-class)
(set-style (get-init-style))
(set-flags '(handles-events handles-all-mouse-events
handles-between-events))))
--
You received this message because you are subscribed to the Google Groups
"Racket Users" group.
To unsubscribe from this group and stop receiving emails from it, send an email
to racket-users+unsubscr...@googlegroups.com.
For more options, visit https://groups.google.com/d/optout.
