Beefy Boxes and Bandwidth Generously Provided by pair Networks Joe
Keep It Simple, Stupid
 
PerlMonks  

Tk Canvas WinPhoto Colors are changed in jpg

by rickrutgers (Novice)
on Sep 24, 2012 at 08:32 UTC ( #995311=perlquestion: print w/ replies, xml ) Need Help??
rickrutgers has asked for the wisdom of the Perl Monks concerning the following question:

Tk Canvas WinPhoto Colors are changed in jpg. Goal is to get an jpg file of an image in a PerlTk Canvas.
I've tried this with:
use Tk::WinPhoto; my $image = $mw->Photo(-format => 'Window', -data => oct($mw->id)); $image->write($path_name, -format => 'JPG');
The jpg file is perfect, but the colors are changed.
For example: Blue looks red / Red looks purple.
Script is performed from an Fedora commandline.
Is there a solution for this problem?
Rick Rutgers (The Netherlands)

Comment on Tk Canvas WinPhoto Colors are changed in jpg
Download Code
Re: Tk Canvas WinPhoto Colors are changed in jpg
by zentara (Archbishop) on Sep 24, 2012 at 10:57 UTC
    WinPhoto works fine here. It sounds like a Fedora bug. Are you using the latest Tk, or the binary one provided by Fedora? This script works fine here.
    #!/usr/bin/perl use warnings; use strict; use Tk; use Tk::WinPhoto; use Tk::JPEG; my $image = shift || 'zen16.jpg'; #test image colors my $mw = tkinit; $mw->geometry("200x400+100+100"); my $canv; my $mainbutton = $mw->Button(-text=>'MainWindow Capture', -command => \&mw_capture, )->pack; my $canvbutton = $mw->Button(-text=>'Canvas Capture', -command => sub{ &canv_capture}, )->pack; $canv = $mw->Scrolled('Canvas', -width=>2400, -height=>3400, -scrollregion=>[0,0,2400,3400], -scrollbars=>'osoe') ->pack(-fill=>'both', -expand=>1); my $img = $mw->Photo(-file => $image ); $canv->createImage( 0, 0, -image => $img, -anchor => 'nw' ); # Create line inside the canvas upper area $canv->create ('line',1, 1, 3000, 3400, -fill=>'red'); $canv->createRectangle(10,20,30,40, -fill=>'blue' ); # Create line inside the lower area $canv->createRectangle(400,400,800,800, -fill=>'blue' ); # Create line inside the lower right area $canv->createRectangle(2000,3000,3000,3400, -fill=>'blue' ); MainLoop; ######################################################### sub mw_capture{ my $image = $mw->Photo(-format => 'Window', -data => oct($mw->id) # # -data => oct('0xa00022') # -data => oct($id) ); my $pathname = $0.'-mainwindow.'.time.'.jpg'; $image->write($pathname, -format => 'JPEG'); } ########################################################## sub canv_capture{ #$canv->configure(-height=>2400, -width =>3400); #$mw->update; my $image = $mw->Photo(-format => 'Window', -data => oct($canv->id) ); my $pathname = $0.'-canvas.'.time.'.jpg'; $image->write($pathname, -format => 'JPEG'); } ##############################################################

    I'm not really a human, but I play one on earth.
    Old Perl Programmer Haiku ................... flash japh

Log In?
Username:
Password:

What's my password?
Create A New User
Node Status?
node history
Node Type: perlquestion [id://995311]
Approved by Corion
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others contemplating the Monastery: (5)
As of 2014-04-16 04:22 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    April first is:







    Results (413 votes), past polls