#!/usr/bin/perl
use warnings;
use strict;
use Tk;
package RGBColorDialog;
use Carp;
use strict;
# basic ideas copied from www.perltk.org/ex/showcolor.pl
# and made to work easily as package/module
# by zentara of Perlmonks, Jun, 22, 2008
# Free to use and modify for your own purposes.
require Tk::Toplevel;
use base qw(Tk::Toplevel);
use Tk::Scale;
Construct Tk::Widget 'RGBColorDialog';
sub Populate {
# SettingsDialog object constructor. Uses `new' method from base
+class
# to create object container then creates the dialog toplevel.
my ($self, $args) = @_;
$self->SUPER::Populate($args);
# Create the Toplevel window
$self->{RESULT} = '';
$self->protocol('WM_DELETE_WINDOW' => sub {});
$self->transient($self->Parent->toplevel);
$self->withdraw;
$self->fontCreate('big',
-family=>'arial',
-weight=>'bold',
-size=>int(-18*18/14));
$self->{value} = "#000000"; #initially black
$self->{sample} = $self->Frame( -height => '2c',
-relief => 'ridge' )->pack( -side => 'bottom', -fill => 'x' );
$self->{left} = $self->Frame->pack( -side => 'left', -fill => 'y')
+;
# Make a scale for each color component.
makeRGBAScales($self);
$self->{OK_BUTTON} = $self->Button(
-text =>'Ok',
-background => 'lightyellow',
-activebackground => 'yellow',
-font => 'big',
-command => sub{
$self->{RESULT} = $self->{value};
} )->pack();
}
sub makeRGBAScales{
my ( $self ) = shift;
# Stick a message at the top.
$self->{left}->Label( -text => "Slide colors:",
-bg => 'black',
-fg => 'hotpink',
-font => 'big',
-relief => "raised", -bd => 2 )->pack( -side => 'top',
-fill => 'x' );
# Display the current value at the bottom.
$self->{left}->Label( -textvariable => \$self->{value},
-bg => 'white',
-font => 'big',
-relief => "ridge", -bd => 2 )->pack( -side => 'bottom',
-fill => 'x' );
# Make a scale for each color component.
$self->{redScale} = makeScale( $self, 'red' );
$self->{greenScale} = makeScale( $self,'green' );
$self->{blueScale} = makeScale( $self, 'blue' );
}
sub makeScale{
my ( $self, $color ) = @_;
my $scale = $self->{left}->Scale(
-label => substr( $color, 0, 1 ),
-from => 0, -to => 255,
-troughcolor => $color,
-showvalue => 'yes',
-orient => 'vertical',
-command => [ \&scaleCommand, $self ] );
$scale->pack( -side => 'left', -fill => 'y' );
$scale->bind( '<1>' => sub { $scale->focus } );
return $scale;
}
sub scaleCommand{
my $self = shift;
# Get each scale's setting and recalculate the rgb value.
$self->{value} = sprintf( "#%02x%02x%02x",
$self->{redScale}->get,
$self->{greenScale}->get,
$self->{blueScale}->get );
# Repaint the sample area.
$self->{sample}->configure( -background => $self->{value} );
}
sub Show {
# public method - display the dialog.
my ($self, $grab_type) = @_;
croak "Tk::RGBColorDialog: `Show' method requires at least 1 argu
+ment"
if scalar @_ < 1 ;
my $old_focus = $self->focusSave;
my $old_grab = $self->grabSave;
# Update all geometry information, center the dialog in the displa
+y
# and deiconify it
$self->Popup();
# set a grab and claim the focus.
if (defined $grab_type && length $grab_type) {
$self->grab($grab_type);
} else {
$self->grab;
}
$self->waitVisibility unless $self->viewable; # this "unless" clau
+se
# is due to a change
+ in Tk800.015
$self->update;
foreach my $w ( $self->Descendants ) {
$w->update;
}
# needs to be visible to set -bg??
$self->{OK_BUTTON}->configure(-background => 'lightyellow');
$self->{OK_BUTTON}->focus;
# Wait for the user to respond, restore the focus and grab, withdr
+aw
# the dialog and return the label of the selected button.
$self->waitVariable(\$self->{RESULT});
$self->grabRelease;
$self->withdraw;
&$old_focus;
&$old_grab;
return $self->{RESULT};
} # end Show method
1;
package main;
my $mw = MainWindow->new(-title => "RGBColorDialog Tester");
$mw->geometry("100x100+500+500");
my $dlg = $mw->RGBColorDialog();
my $button = $mw->Button(-text=>'Test',-command=>\&test)->pack();
Tk::MainLoop;
sub test {
my $result = $dlg->Show;
print "$result\n";
$button->configure(-background => $result);
}
|