Example
: dlg_selectCursor.pl
Screenshot
Generated
code
Project
#!perl.exe
## ctk: description Select cursor.
## ctk: title Select cursor.
## ctk: application '' ''
## ctk: strict
0
## ctk: code 0
## ctk: subroutineName dlg_selectCursor
## ctk: autoExtractVariables 1
## ctk: autoExtract2Local 1
## ctk: modalDialogClassName DialogBox
## ctk: modal 1
## ctk: isolGeom 0
## ctk: version 3.099
## ctk: onDeleteWindow sub{1}
## ctk: Toplevel
1
## ctk: argList
## ctk: 2007 11 13 - 16:04:21
## ctk: uselib start
## ctk: uselib end
use Tk;
use Tk::Button;
use Tk::Listbox;;
$mw=MainWindow->new(-title=>'Select cursor.');
## ctk: Globalvars
## ctk: Globalvars end
&main::init();
my $answer = &main::dlg_selectCursor($mw);
print "\nanswer = '$answer'";
MainLoop;
sub dlg_selectCursor {
my $hwnd = shift;
my %args =();
my $rv;
##
## ctk: Localvars
## ctk: Localvars end
##
my $mw = $hwnd->DialogBox(
-title=>
(exists $args{-title})? $args{-title}:'Select cursor.',
-buttons=> (exists $args{-buttons}) ?
$args{-buttons} : ['OK','Cancel']);
$mw->protocol('WM_DELETE_WINDOW',sub{1});
## ctk: code generated by ctk_w version '3.099'
## ctk: instantiate and display widgets
$wr_001 = $mw -> Scrolled ( 'Listbox' , -background
, '#ffffff' , -selectmode , 'single' , -relief , 'sunken' , -scrollbars ,
'e' ) -> pack(-side=>'top',
-anchor=>'nw', -pady=>5, -fill=>'both', -expand=>1, -padx=>5);
$wr_001; &dlg_selectCursorInit($wr_001);
$wr_002 = $mw -> Button ( -background , '#ff8080' ,
-command , [\&_testCursor , $wr_001 ] , -state , 'normal' , -text , 'Test
cursor' , -relief , 'raised' ) ->
pack(-side=>'top', -anchor=>'nw', -pady=>5, -fill=>'both',
-expand=>1, -padx=>5);
## ctk: end of gened Tk-code
$rv =
$mw->Show();
return $rv;
} ## end of dlg_selectCursor
## ctk: end of dialog code
## ctk: callbacks
sub init { 1 }
sub dlg_selectCursorInit {
my ($lb) = @_;
my @cursors = (qw/X_cursor
arrow
based_arrow_down
based_arrow_up
boat
bogosity
bottom_left_corner
bottom_right_corner
bottom_side
bottom_tee
box_spiral
center_ptr
circle
clock
coffee_mug
cross
cross_reverse
crosshair
diamond_cross
dot
dotbox
double_arrow
draft_large
draft_small
draped_box
exchange
fleur
gobbler
gumby
hand1
hand2
heart
icon
iron_cross
left_ptr
left_side
left_tee
leftbutton
ll_angle
lr_angle
man
middlebutton
mouse
num_glyphs
pencil
pirate
plus
question_arrow
right_ptr
right_side
right_tee
rightbutton
rtl_logo
sailboat
sb_down_arrow
sb_h_double_arrow
sb_left_arrow
sb_right_arrow
sb_up_arrow
sb_v_double_arrow
shuttle
sizing
spider
spraycan
star
target
tcross
top_left_arrow
top_left_corner
top_right_corner
top_side
top_tee
trek
ul_angle
umbrella
ur_angle
watch
xterm/);
map {
$lb->insert('end',$_) } @cursors;
}
sub _testCursor {
my ($lb) =
@_;
my $cursor =
$lb->toplevel->cget(-cursor);
my $x = $lb->curselection();
if ($x) {
my $tl
= $lb->toplevel;
$tl->configure(-cursor,
$lb->get($x));
$tl->update();
$tl->Busy();
sleep
3;
$tl->Unbusy();
$tl->configure(-cursor, $cursor);
$tl->update();
} else {}
}
## ctk: other code
## ctk: eof 2007 11 13 - 16:04:21
1; ## make perl
compiler happy...
Exported
## ctk: description Select cursor.
## ctk: title Select cursor.
## ctk: application '' ''
## ctk: strict
0
## ctk: code 0
## ctk: subroutineName dlg_selectCursor
## ctk: autoExtractVariables 1
## ctk: autoExtract2Local 1
## ctk: modalDialogClassName DialogBox
## ctk: modal 1
## ctk: isolGeom 0
## ctk: version 3.099
## ctk: onDeleteWindow sub{1}
## ctk: Toplevel
1
## ctk: argList
## ctk: 2007 11 13 - 16:10:00
use Tk;
use Tk::Button;
use Tk::Listbox;;
sub dlg_selectCursor {
my $hwnd = shift;
my %args =();
my $rv;
##
## ctk: Localvars
## ctk: Localvars end
##
my $mw = $hwnd->DialogBox(
-title=>
(exists $args{-title})? $args{-title}:'Select cursor.',
-buttons=> (exists $args{-buttons}) ?
$args{-buttons} : ['OK','Cancel']);
$mw->protocol('WM_DELETE_WINDOW',sub{1});
## ctk: code generated by ctk_w version '3.099'
## ctk: instantiate and display widgets
$wr_001 = $mw -> Scrolled ( 'Listbox' , -background
, '#ffffff' , -selectmode , 'single' , -relief , 'sunken' , -scrollbars ,
'e' ) -> pack(-anchor=>'nw',
-side=>'top', -pady=>5, -fill=>'both', -expand=>1, -padx=>5);
$wr_001; &dlg_selectCursorInit($wr_001);
$wr_002 = $mw -> Button ( -background , '#ff8080' ,
-command , [\&_testCursor , $wr_001 ] , -state , 'normal' , -text , 'Test
cursor' , -relief , 'raised' ) ->
pack(-anchor=>'nw', -side=>'top', -pady=>5, -fill=>'both',
-expand=>1, -padx=>5);
## ctk: end of gened Tk-code
$rv =
$mw->Show();
return $rv;
} ## end of dlg_selectCursor
## ctk: end of dialog code
## ctk: callbacks
sub dlg_selectCursorInit {
my ($lb) = @_;
my @cursors = (qw/X_cursor
arrow
based_arrow_down
based_arrow_up
boat
bogosity
bottom_left_corner
bottom_right_corner
bottom_side
bottom_tee
box_spiral
center_ptr
circle
clock
coffee_mug
cross
cross_reverse
crosshair
diamond_cross
dot
dotbox
double_arrow
draft_large
draft_small
draped_box
exchange
fleur
gobbler
gumby
hand1
hand2
heart
icon
iron_cross
left_ptr
left_side
left_tee
leftbutton
ll_angle
lr_angle
man
middlebutton
mouse
num_glyphs
pencil
pirate
plus
question_arrow
right_ptr
right_side
right_tee
rightbutton
rtl_logo
sailboat
sb_down_arrow
sb_h_double_arrow
sb_left_arrow
sb_right_arrow
sb_up_arrow
sb_v_double_arrow
shuttle
sizing
spider
spraycan
star
target
tcross
top_left_arrow
top_left_corner
top_right_corner
top_side
top_tee
trek
ul_angle
umbrella
ur_angle
watch
xterm/);
map {
$lb->insert('end',$_) } @cursors;
}
sub _testCursor {
my ($lb) =
@_;
my $cursor =
$lb->toplevel->cget(-cursor);
my $x =
$lb->curselection();
if ($x) {
my $tl
= $lb->toplevel;
$tl->configure(-cursor,
$lb->get($x));
$tl->update();
$tl->Busy();
sleep
3;
$tl->Unbusy();
$tl->configure(-cursor, $cursor);
$tl->update();
} else {}
}
## ctk: other code
## ctk: eof 2007 11 13 - 16:10:00
1; ## make perl
compiler happy...
Logfile
2007 11 13 - 16:03:41 . , perl.exe
2007 11 13 - 16:03:41 ctk_w.exe starting under
'MSWin32'
2007 11 13 - 16:03:41 Session 'Tkadmin' successfully restored.
2007 11 13 - 16:03:41 Version '3.099'
2007 11 13 - 16:03:42 Widget class Tk::Pane does not
exist yet, discarded
2007 11 13 - 16:03:42 Widget class Tk::TextList does
not exist yet, discarded
2007 11 13 - 16:03:57 Widget 'wr_003' deleted
2007 11 13 - 16:04:21 Doing work_save on
'.\work\selectCursor.pl' ...
2007 11 13 - 16:04:21 Work saved into
'.\work\selectCursor.pl'
answer = 'Cancel'
answer = 'OK'
answer = 'Cancel'
2007 11 13 - 16:05:28 Session 'Tkadmin' successfully
saved.
ctk_w.exe ended