REBOL [ title: "Tooltip style example" file: %simple-tooltip-style.r author: "Marco Antoniazzi" email: [luce80 AT libero DOT it] date: 20-12-2013 version: 0.9.6 Purpose: {A quick way to add a simple tooltip to VID GUIs} comment: {You are strongly encouraged to post an enhanced version of this script} History: [ 0.0.1 [03-12-2010 "First version"] 0.8.0 [08-01-2011 "Enhanced"] 0.9.0 [16-01-2011 "Enhanced with function by Shadwolf, Boss, DideC, Volker and the tipped flag"] 0.9.1 [08-02-2011 "Minor bug fixes and source retouches"] 0.9.2 [19-02-2011 "Minor bug fix of offset/x"] 0.9.3 [04-06-2011 "Minor source retouches"] 0.9.4 [12-08-2011 "Changed *-super to (:*)"] 0.9.5 [09-09-2012 "Allow tip in multiple windows and added function to add tooltip to given faces"] 0.9.6 [20-12-2013 "Fixed for vid1r3.r"] ] Category: [util vid view] library: [ level: 'intermediate platform: 'all type: 'how-to domain: [gui vid] tested-under: [View 2.7.8.3.1] support: none license: 'BSD see-also: %toolt4vid.r ] ] ;**** set correct path to vid1r3.r3 and sdk sources (or use empty string to use default path to sdk) **** if all [system/version > 2.7.8.100 not value? 'mimic-do-event] [do/args %../../../r3/local/vid1r3.r3 %../../sdk-2706031/rebol-sdk-276/source] tip: make face [ style: 'tool-tip color: yello + 30 font: make font [size: 11] para: make para [wrap?: false] edge: make edge [size: 1x1 color: gray] ticks: 0 window-pane: none start_tip: func [face] [ if ticks <> 0 [exit] if not text: get in face 'help [exit] size: 4x6 + size-text self rate: 0:0:0.500 offset: 0x0 - size ; hide it unless none? window-pane [remove find window-pane self show window-pane] window-pane: get in find-window face 'pane append window-pane self ; put on top show find-window face ] open_tip: func [woffset /local wsize] [ offset: woffset + 0x15 wsize: get in find-window self 'size ; keep inside window if offset/y > (wsize/y - size/y) [offset/y: offset/y - size/y - 16] offset/y: min max 0 offset/y wsize/y - size/y offset/x: min max 0 offset/x wsize/x - size/x show self/parent-face ] close_tip: func [] [ if size = 100x100 [exit] ; entering here before start_tip rate: none offset: 0x0 - size ticks: 0 show self/parent-face ] feel: make feel [ engage: func [face action event][ if action = 'time [ if ticks = 1 [open_tip event/offset] if ticks = 6 [close_tip] ticks: ticks + 1 ] if action = 'down [close_tip] ] ] over: func [face over? offset] [either all [over? not flag-face? face tipped] [start_tip face] [deflag-face face tipped close_tip]] engage: func [face action event] [if not flag-face? face tipped [flag-face face tipped close_tip]] ] flag-face: func [ "Sets a flag in a VID face." face [object!] 'flag ][ if none? in face 'flags [exit] ; patched if none? face/flags [face/flags: copy [flags]] if not find face/flags 'flags [face/flags: copy face/flags insert face/flags 'flags] append face/flags flag ] deflag-face: func [ "Clears a flag in a VID face." face [object!] 'flag ][ if all [in face 'flags face/flags] [ ; patched if not find face/flags 'flags [face/flags: copy face/flags insert face/flags 'flags] remove find face/flags flag ] ] flag-face?: func [ "Checks a flag in a VID face." face [object!] 'flag ] [all [in face 'flags face/flags find face/flags flag]] ; patched ; this function is taken from %toolt4vid.r (only a little modified) Add-tooltip-2-style: func [ { Allow to add the tooltip support to all widgets passed in parameter} style-lst [block! ] "Contains the listing of Vid widgets to patch" style-root "Countain the path of the root-styles to patch" ][ foreach style style-lst [ if find style-root style [ ; Teste si le style existe pour la compatibilité avec les versions antérieures de view style-root/:style/feel: make style-root/:style/feel [ over: func [face action offset] compose [ tip/over face action offset (:over) face action offset ; call original ] engage: func [face action event] compose [ (:engage) face action event tip/engage face action event ] ] ] ] ] ; here is the list of widget affected by the tooltip ability (does it make sense to patch also text?) vid-styles: [image btn backtile box sensor key base-text vtext text body txt banner vh1 vh2 vh3 vh4 title h1 h2 h3 h4 h5 tt code button check radio check-line radio-line led arrow toggle rotary choice drop-down icon field info area slider scroller progress anim btn-enter btn-cancel btn-help logo-bar tog] Add-tooltip-2-faces: func [ { Allow to add the tooltip support to all widgets passed in parameter} style-lst [block! object! function!] "Contains the listing of Vid widgets to patch" ][ if function? :style-lst [exit] if object? style-lst [style-lst: reduce [style-lst]] foreach style style-lst [ if get in style 'pane [Add-tooltip-2-faces get in style 'pane] style/feel: make style/feel [ over: func [face action offset] compose [ tip/over face action offset (:over) face action offset ; call original ] engage: func [face action event] compose [ (:engage) face action event tip/engage face action event ] ] ] ] ;comment [ do [ ;use this to patch ALL styles Add-tooltip-2-style vid-styles system/view/vid/vid-styles win: layout [ area "another face" help "an area" panel [across button "test" help "the first button" button "test2" help "the second button" btn "test3" help "the third button" [probe face/feel] button 120 "test4 without help" ] ] ;use this to patch only faces of given face ;Add-tooltip-2-faces win view center-face win ]