Beefy Boxes and Bandwidth Generously Provided by pair Networks
Don't ask to ask, just ask
 
PerlMonks  

Tk RGBColorDialog

by zentara (Archbishop)
on Jun 22, 2008 at 18:23 UTC ( [id://693397]=sourcecode: print w/replies, xml ) Need Help??
Category: Gui Programming
Author/Contact Info zentara@zentara.net
Description: I got tired of trying to use the cumbersome Tk ColorDialog ( which I could never get to work simply). I wanted a popup dialog, with RGB sliders, that simply returns the RGB color, on the Ok button press. Nothing fancy, but just works in a simple straightforward manner. Presented as a package, but can easily be put into module form.

UPDATE Jun23, 2008 Removed uneeded hex2dec sub, which was intended to be used if you fed the package an initial setting. See comment below if you need an initial color option.

#!/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);

}
Replies are listed 'Best First'.
Re: Tk RGBColorDialog
by zentara (Archbishop) on Jun 23, 2008 at 17:37 UTC
    Well after removing the hex2dec sub above, I figured.."Why not add an initial color option?". So here is an updated version that accepts an initial hex rgb value, and sets the scales. It may be useful as an example of Tk::Derived, and the trick to add extra options.

    I'm not really a human, but I play one on earth CandyGram for Mongo

Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?
Node Status?
node history
Node Type: sourcecode [id://693397]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this?Last hourOther CB clients
Other Users?
Others avoiding work at the Monastery: (4)
As of 2024-03-29 05:02 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found