Beefy Boxes and Bandwidth Generously Provided by pair Networks
Clear questions and runnable code
get the best and fastest answer
 
PerlMonks  

RTF Table function

by ikkon (Monk)
on Aug 29, 2007 at 17:10 UTC ( [id://635868]=perlquestion: print w/replies, xml ) Need Help??

ikkon has asked for the wisdom of the Perl Monks concerning the following question:

I am using RTF::Writer and I am trying to creat a function that will allow me to make a table without using a bunch of extra lines
I don't get any errors but the rtf doesn't have anything in it

here is my code: 
my @tableProp5 = (
                      widths => [inches(3), inches(4)], #--> width of 
+each column
                      align => 'l l',
                     );

my @myText = (
                [\'\fs20\b this', 'that'],
                [\'\fs20\b this', 'that'],
                [\'\fs20\b this', 'that'],
                [\'\fs20\b this', 'that'],
            );


RTFTable(@tableProp5, 9, 7, @myText);

$fh->close();

sub RTFTable{
        my (@tableProps, $headerColor, $bgColor, @Text  ) = @_;
        my $count = 0;
        my $oDecl5;

        foreach (@Text) {
            if($headerColor eq undef || $headerColor eq "" || $headerC
+olor == 0 || $count == 0){
                $oDecl5 = RTF::Writer::TableRowDecl->new(@tableProps);
                $oDecl5->add_bgcolors($headerColor);  # Adds backgroun
+d color using color hash
                $fh->row($oDecl5, $_);
                $count++;
            }else{
                $oDecl5 = RTF::Writer::TableRowDecl->new(@tableProps);
                $oDecl5->add_bgcolors($bgColor);  # Adds background co
+lor using color hash
                $fh->row($oDecl5, $_);
            }
        }
}

[download]
some functions and stuff has been leftout to save space, the above code is the problem

I believe its the Text array i am trying to pass not sure if I am doing that correctly or not
Thanks for any help on this matter

If you would like to see the full script: 
#!/usr/bin/perl

use strict;
use RTF::Writer;

#--> Declare new rtf object either save to disk or save to string
my    $fh = RTF::Writer->new_to_file("newTable.rtf");
    # $fh = RTF::Writer->new_to_string(\$RTF_obj);
    
    #--> MUST write a prolog - font and color table (RGB)
    #--> Font: when calling font use \f0 (or number of the array, to c
+hange font size double the size
    #--> example: for 12 point font do - \fs24 
    $fh->prolog(
                 fonts => ['Arial'],
                 colors => [
                            undef,        # color 0 == black
                            [255,0,0],    # color 1 == red
                            [0,128,0],    # color 2 == green
                            [0,0,255],    # color 3 == blue
                            [255,255,0],  # color 4 == yellow
                            [255,255,255],# color 5 == white
                            [200,200,200],# color 6 == light gray
                            [187,204,224],# color 7 == table blue
                            [144,172,202],# color 8 == table header bl
+ue
                            [102,102,102],# color 9 == gray
                           ],
                );

    #--> Setting up margins (these MUST be here)
    #---------------------------------------------->
    my $iMarginLeftInches = my $iMarginRightInches = 500;
    my $iMarginTop = 500;

    #--> Need bigger bottom margin for footer to fit:
    #------------------------------------------------->
    my $iMarginBottom = 500;
    my $iMarginLeft = $iMarginLeftInches;
    my $iMarginRight = $iMarginRightInches;
    eval "\$fh->Margt$iMarginTop";
    eval "\$fh->Margl$iMarginLeft";
    eval "\$fh->Margr$iMarginRight";
    eval "\$fh->Margb$iMarginBottom";



my @tableProp5 = (
                      widths => [inches(3), inches(4)], #--> width of 
+each column
                      align => 'l l',
                     );

my @myText = (
                ['\fs20\b this', 'that'],
                ['\fs20\b this', 'that'],
                ['\fs20\b this', 'that'],
                ['\fs20\b this', 'that'],
            );


RTFTable(@tableProp5, 9, 7, @myText);

$fh->close();

sub RTFTable{
        my (@tableProps, $headerColor, $bgColor, @Text  ) = @_;
        my $count = 0;
        my $oDecl5;

        foreach my $aref (@Text) {
            if($headerColor eq undef || $headerColor eq "" || $headerC
+olor == 0 || $count == 0){
                $oDecl5 = RTF::Writer::TableRowDecl->new(@tableProps);
                $oDecl5->add_bgcolors($headerColor);  # Adds backgroun
+d color using color hash
                $fh->row($oDecl5, @$aref);
                $count++;
            }else{
                $oDecl5 = RTF::Writer::TableRowDecl->new(@tableProps);
                $oDecl5->add_bgcolors($bgColor);  # Adds background co
+lor using color hash
                $fh->row($oDecl5, $aref);
            }
        }
}


       
       #--> line breaks pass number of lines
       #-------------------------------------->
        sub lineBreak{
            my $line = q'\par';
            $fh->print(\$line);
        }
       
       #--> Creat Table
       #---------------->
        sub newtable(){
            my(@tableProp, $tableColor, @localData) = @_;
            my $decl = RTF::Writer::TableRowDecl->new(@tableProp,);
            $decl->add_bgcolors($tableColor);
                    $fh->row($decl, @$_) for @localData;

         }

       
       #--> Make image
       #--------------->
       sub newImage(){
            $fh->paragraph(
            $fh->image( 'filename' => $_[0], ),
          );

       }

       
       #--> Inches from twips
       #---------------------->
       sub inches{
           my ($inches) = @_;
           my $twips = 1440;
           $inches = ($inches * $twips);
           return $inches;
       }
        
       #--> Write text Function
       #----------------------->
       sub writeText(){
          my($rtfFormat, $writeText) = @_;

           $fh->paragraph(
             \$rtfFormat,  # 12pt, bold, italic
             "$writeText"
           );
       }


#---------------------------------------------------------------------
+---------------------------------------------------------------------
+-------#
#----------------------------------------------- DO NOT EDIT ANYTHING 
+BELOW THIS LINE -----------------------------------------------------
+-------#
#---------------------------------------------------------------------
+---------------------------------------------------------------------
+-------#
BEGIN
  {  
    no warnings 'redefine';

   sub RTF::Writer::close {
   return unless $_[0][2];  # Already closed?!
   $_[0]->print(\$_[0][1]) if length $_[0][1];
   #$_[0][2]->close();   # Call close directly
   undef $_[0][2];   # close any objects
   $_[0][1] = '';
   return;
    }
  # These are updates to RTF::Writer to allow background colors on
  # table cells:
  no warnings 'redefine';
  no warnings;
  # Index 7 was chosen because it is one beyond the last index used by
  # the standard RTF::Writer::TableRowDecl distribution:
  my $INDEX_BG = 7;
  my $INDEX_TS = 8;

  sub RTF::Writer::TableRowDecl::add_bgcolors
    {
    my ($self, @aArg) = @_;
    my @array;
    # Install our new list of RTF commands in the object.
    $self->[$INDEX_BG] = \@array;
    # See if we got _any_ args:
    unless (@aArg and grep defined($_), @aArg)
      {
      # Default is color 0, which is the document default (probably
      # 'white' or 'none' or null):
      @aArg = ('0');
      } # unless
    # Convert arrayref argument to regular array:
    @aArg = @{$aArg[0]} if ((@aArg == 1) && ref($aArg[0]));
    foreach my $spec (@aArg)
      {
      push @array, "\\clcbpat$spec";
      } # foreach
    # No return value.
    } # RTF::Writer::TableRowDecl::add_bgcolors

  sub RTF::Writer::TableRowDecl::add_tabstops
    {
    my $self = shift;
    $self->[$INDEX_TS] = \@_;
    } # RTF::Writer::TableRowDecl::add_tabstops

  sub RTF::Writer::TableRowDecl::add_borders
    {
    my $self = shift;
    $self->make_border_decl(@_);
    } # RTF::Writer::TableRowDecl::add_borders

  sub RTF::Writer::TableRowDecl::cell_content_init
    {
    my $self = shift;
    my $raAlign = $self->[5] || [];
    my $raTabs  = $self->[$INDEX_TS] || [];
    my $iMax = @$raAlign;
    $iMax = @$raTabs if (@$raAlign < @$raTabs);
    my @aRet;
    for (1..$iMax)
      {
      push @aRet, join('', shift(@$raAlign) || '', shift(@$raTabs) || 
+'');
      } # for
    # print STDERR " cell_content_init is ", Dumper(\@aRet);
    return @aRet;
    } # RTF::Writer::TableRowDecl::cell_content_init

  sub RTF::Writer::TableRowDecl::decl_code
    {
    # This function copied from TableRowDecl.pm and 4 lines added (the
    # 4 lines that contain 'bg').
    my $it = shift;
    return $it->[6] if defined $it->[6];
    my $reaches = $it->[0];
    my $cell_count = int($_[0] || 0) || scalar @$reaches;
    if ($cell_count > @$reaches)
      {
      # Uncommon case -- we need to ad-hoc pad this decl.
      $reaches = [@$reaches];   # so we won't mutate the original
      while (@$reaches < $cell_count)
        {
        if (@$reaches == 0)
          {
          push @$reaches, $it->[1] + 1440;
          # sane and noticeable default width, I think: 1 inch, 2.54cm
          }
        elsif (@$reaches == 1)
          {
          push @$reaches, 2 * $reaches->[0] - $it->[1];
          # The left-margin setting
          }
        else
          {
          push @$reaches, 2 * $reaches->[-1] - $reaches->[-2];
          # i.e., last + (last - one_before)
          # DEBUG and printf "Improvised the width %d based on %d,%d\n
+",
          #    $reaches->[-1], $reaches->[-3], $reaches->[-2];
          }
        } # while
      } # if not enough reaches to fulfill cell_count
    my @borders = @{ $it->[3] || [] };
    push @borders, ($borders[-1]) x ($cell_count - @borders)
    if @borders > 0 and @borders < $cell_count;
    my @valign  = @{ $it->[4] || [] };
    push @valign , ($valign[-1] ) x ($cell_count - @valign )
    if @valign  > 0 and @valign < $cell_count;
    # Or should I have it default to a lack of any alignment code?
    my @bgcolors = @{ $it->[$INDEX_BG] || [] };
    push @bgcolors, ($bgcolors[-1]) x ($cell_count - @bgcolors)
    if @bgcolors > 0 and @bgcolors < $cell_count;
    # Cache it for next time (and there usually are many next-times):
    $it->[6] = \join('',
                     sprintf("\\trowd\\trleft%d\\trgaph%d\n",
                             $it->[1], int($it->[2] / 2) ),
                     map (
                          sprintf("%s%s%s\\cellx%d\n",
                                  (shift(@borders ) || ''),
                                  (shift(@valign  ) || ''),
                                  (shift(@bgcolors) || ''),
                                  $_,
                                 ), # sprintf
                          @$reaches
                         ), # map
                    ); # join
    # DEBUG and print "Init code:\n", ${ $it->[6] }, "\n\n";
    return $it->[6];
    } # RTF::Writer::TableRowDecl::decl_code

  } # end of BEGIN block
    

__END__

[download]

Replies are listed 'Best First'.
Re: RTF Table function
by andreas1234567 (Vicar) on Aug 29, 2007 at 18:21 UTC
    I believe it is your use of multiple lists as arguments to the RTFTable function that causes this behavior. You cannot use multiple lists as arguments, since Perl does not know where one list ends and another starts. Use references to lists instead. Reading perlref and perlreftut is an excellent start. 
    #!/usr/bin/perl

use warnings;
use strict;

use Data::Dumper;
use Log::Log4perl qw(:easy);
Log::Log4perl->easy_init($DEBUG);
my $logger = get_logger();

my @tableProp5 = (
                      widths => [3*1440, 4*1400],
                      align => 'l l',
                     );

my @myText = (
                ['\fs20\b this', 'that'],
                ['\fs20\b this', 'that'],
                ['\fs20\b this', 'that'],
                ['\fs20\b this', 'that'],
            );


RTFTable(@tableProp5, 9, 7, @myText);

sub RTFTable{
        my (@tableProps, $headerColor, $bgColor, @Text  ) = @_;
        my $count = 0;
        my $oDecl5;
        $logger->debug("tableProps:". Dumper(@tableProps));
        $logger->debug("headerColor:". Dumper($headerColor));
        $logger->debug("bgColor:". Dumper($bgColor));
        $logger->debug("Text:". Dumper(@Text));
}
__END__
C:\src\perl\perlmonks\635868>perl 635868.pl
2007/08/29 20:15:44 tableProps:$VAR1 = 'widths';
$VAR2 = [
          4320,
          5600
        ];
$VAR3 = 'align';
$VAR4 = 'l l';
$VAR5 = 9;
$VAR6 = 7;
$VAR7 = [
          '\\fs20\\b this',
          'that'
        ];
$VAR8 = [
          '\\fs20\\b this',
          'that'
        ];
$VAR9 = [
          '\\fs20\\b this',
          'that'
        ];
$VAR10 = [
           '\\fs20\\b this',
           'that'
         ];
2007/08/29 20:15:44 headerColor:$VAR1 = undef;
2007/08/29 20:15:44 bgColor:$VAR1 = undef;
2007/08/29 20:15:44 Text:

    [download]
    As you can see, Perl puts all arguments into the first list. The three last variables headerColor, bgColor, Text are all undefined.
    --
    Andreas
[reply]
[d/l]
[select]
Re: RTF Table function
by ikkon (Monk) on Aug 29, 2007 at 18:37 UTC
    that is exactly the problem, thanks with the help of injunjoel we came up with this that worked well 
    my @tableProp5 = (
                      widths => [inches(3), inches(4)], #--> width of 
+each column
                      align => 'l l',
                     );

my @myText = (
                [\'\fs20\b this', 'that'],
                [\'\fs20\b this', 'that'],
                [\'\fs20\b this', 'that'],
                [\'\fs20\b this', 'that'],
            );
RTFTable(\@tableProp5, 9, 7,\@myText);

$fh->close();

sub RTFTable{
        my @tableProps = @{$_[0]};
        my $headerColor = $_[1];
        my $bgColor = $_[2];
        my @Text = @{$_[3]};
        my $count = 0;
        my $oDecl5;

        foreach my $aref (@Text) {
            if($headerColor eq undef || $headerColor eq "" || $headerC
+olor == 0 || $count == 0){
                $oDecl5 = RTF::Writer::TableRowDecl->new(@tableProps);
                $oDecl5->add_bgcolors($headerColor);  # Adds backgroun
+d color using color hash
                $fh->row($oDecl5, @$aref);
                $count++;
            }else{
                $oDecl5 = RTF::Writer::TableRowDecl->new(@tableProps);
                $oDecl5->add_bgcolors($bgColor);  # Adds background co
+lor using color hash
                $fh->row($oDecl5, @$aref);
            }
        }
}

    [download]
    thanks for the help and pointing me in the right direction.
[reply]
[d/l]

Back to Seekers of Perl Wisdom

Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?

www.com | www.net | www.org
Node Status?
node history
Node Type: perlquestion [id://635868]
Approved by injunjoel
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? • Last hour • Other CB clients
Other Users?
Others surveying the Monastery: (2)
As of 2024-04-24 23:04 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found