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

}

[download]

In reply to Tk RGBColorDialog by zentara

Title:
Use:  <p> text here (a paragraph) </p>
and:  <code> code here </code>
to format your post, it's "PerlMonks-approved HTML":


  • Posts are HTML formatted. Put <p> </p> tags around your paragraphs. Put <code> </code> tags around your code and data!
  • Titles consisting of a single word are discouraged, and in most cases are disallowed outright.
  • Read Where should I post X? if you're not absolutely sure you're posting in the right place.
  • Please read these before you post! —
  • Posts may use any of the Perl Monks Approved HTML tags:
    a, abbr, b, big, blockquote, br, caption, center, col, colgroup, dd, del, details, div, dl, dt, em, font, h1, h2, h3, h4, h5, h6, hr, i, ins, li, ol, p, pre, readmore, small, span, spoiler, strike, strong, sub, summary, sup, table, tbody, td, tfoot, th, thead, tr, tt, u, ul, wbr
  • You may need to use entities for some characters, as follows. (Exception: Within code tags, you can put the characters literally.)
            For:     Use:
    & &amp;
    < &lt;
    > &gt;
    [ &#91;
    ] &#93;
  • Link using PerlMonks shortcuts! What shortcuts can I use for linking?
  • See Writeup Formatting Tips and other pages linked from there for more info.