perl操作word与excel实现办公自动化

有兴趣学习perl数据结构的构造、解析和Moo***::Declare的入门初学者，可参考本文代码。

 

    医院经常得业务查房与行政查房，每次检查都会以科室为单位记录发现的问题，但往往检查发现问题的科室并不一定是都是整改责任科室（有时候会出现一个问题的整改需几个科室共同承担责任），而且检查记录是由几个人共同完成的，加上医院科室很多，所以每次要根据责任科室重新整理改进项目时，都要花大量的时间。为了方便完成此项工作，先是用VBA写了代码，后来又转为Perl代码了。为了学习perl的OO于是将代码用Moo***::Declare进行了改写。终于不会过段时间连自已也看不懂代码了。

一、

    以上问题的描述转化为：将几份word文档内的所有表格每行的内容按责任人进行归类整理。

如下图的第二个表的"我/你们"得归类到"我"与"你们"两类。

二、以下是代码及附件： 附件.rar   

附件包括测试用的word文档、perl代码。要是在博客上不好看就下附件吧，内附POD

#############################################################################

## Name: MD.pl

## Purpose: 因受美女管理员邀请，盛意难却，参加CU的征文大赛。将以前工作

## 用到的代码转为Moo***::Declare的oo形式。^_^

## Author: aef25u

## Created: 3/24/2011

## RCS-ID:

## Copyright: (c) 2011 Maef25u

## Licence: This program is free software; you can redistribute it and/or

## modify it under the same terms as Perl itself

#############################################################################

use Cwd;
use Win32::OLE;
use Moo***::Declare;

#use Data::Dumper;

#############################################################################

class SearchFile {
    has regex =>
      ( is => 'rw', isa => 'Str', required => 1, default => '.*\.doc$' );

    #弹出窗口，以供选择目标文件夹

    method _Path {
        my $shell = Win32::OLE->new("shell.Application");
        my $objFolder = $shell->BrowseForFolder( 0, "Select a folder:", 0 );
        my $Path = $objFolder->Self->{Path};
        $Path =~ s/(\\)/\//g;
        return $Path;
    }

    #遍历搜索文件，支持正则表达式

    method File_Find {
        my $tem = $self->regex;
        my $qr_regex = qr/$tem/;
        my $Path = $self->_Path();
        my @dirs = ( $Path . '/' );
        my ( @retFile, $dir, $file );
        while ( $dir = pop(@dirs) ) {
            local *DH;
            if ( !opendir( DH, $dir ) ) {
                warn "Cannot opendir $dir: $! $^E";
                next;
            }
            foreach ( readdir(DH) ) {
                if ( $_ eq '.' || $_ eq '..' ) {
                    next;
                }
                $file = $dir . $_;
                if ( $file =~ /$qr_regex/ ) {
                    push( @retFile, $file );
                }
                if ( !-l $file && -d _ ) {
                    $file .= '/';
                    push( @dirs, $file );
                }
            }
            closedir(DH);
        }
        return \@retFile;
    }

}
#############################################################################

#my $objFind=SearchFile->new(regex=>'.*\.xls');

#my $objFind=SearchFile->new();

#my $ffn=$objFind->File_Find();

#print join("\n",@{$ffn});

#############################################################################


class WordOLE {
    has Doc => ( is => 'rw', isa => 'Win32::OLE' );

    #提取word文档所有表格某一列单元格字符串，以“/”折分字符串并返回唯一子串

    method Sear_Cell_Uni( Num $Cell_col) {
        my $qr_regex = qr/\//;
          my @reStr;
          my $tCount = $self->Doc->Tables->{'Count'};

          foreach my $i ( 1 .. $tCount ) {
            my $table = $self->Doc->Tables($i);
            my $rNum = $table->Rows->{Count};

            foreach my $j ( 2 .. $rNum ) {
                my $Cell = $table->Cell( $j, $Cell_col )->Range->{Text};
                $Cell =~ s/([(\r\r)(\n\n)(\r\n)])//g;
                chop($Cell);
                if ( $Cell =~ m/$qr_regex/ ) {
                    my @temp = split( "$qr_regex", $Cell );
                    push( @reStr, @temp );
                }
                else {
                    push( @reStr, $Cell );
                }
            }
        }
        return $self->_Unique( \@reStr );

      }

#“关键字”与“指定表格某一列所有单元格”进行匹配，将表格的整行内容按“关键字”进行归类

      method Re_Mat_Row( ArrayRef [Str] $keys, Num $Cell_col) {
        my %reStr;
          my $tCount = $self->Doc->Tables->{'Count'};

          foreach my $key ( @{$keys} ) {
            @{ $reStr{$key} } = ();
            foreach my $i ( 1 .. $tCount ) {
                my $table = $self->Doc->Tables($i);
                my $rNum = $table->Rows->{Count};

                foreach my $j ( 2 .. $rNum ) {
                    my $Cell = $table->Cell( $j, $Cell_col )->Range->{Text};
                    $Cell =~ s/([(\r\r)(\n\n)(\r\n)])//g;
                    chop($Cell);
                    if ( $Cell =~ m/$key/ ) {
                        my @temp;
                        my $c_Count = $table->Rows($j)->Cells->{Count};
                        foreach ( 1 .. $c_Count ) {
                            my $txt = $table->Cell( $j, $_ )->Range->{Text};
                            chop($txt);
                            push( @temp, $txt );
                        }
                        push( @{ $reStr{$key} }, \@temp );

                    }
                }
            }
        }
        return \%reStr;

      }

      #将数组元素过滤为唯一值

      method _Unique( ArrayRef [Str] $tem ) {
        my %hash;
          foreach ( @{$tem} ) {
            $hash{$_}++;
        }
        my @elem_Uni = sort keys %hash;
          return \@elem_Uni;
      }

}
#############################################################################

#my $word = Win32::OLE->new("Word.Application");

#$word->{Visible} = 1;

#my $document = $word->documents->Open('G:/结果/a.doc');

#my $obj = WordOLE->new( Doc => $document );

#my $arr = $obj->Sear_Cell_Uni(4);

#my $brr = $obj->Re_Mat_Row( $arr, 4 );

#print Dumper($brr);

#$document->close;

#$word->quit;

#############################################################################



# Main program

my $dir = getcwd();
my $BookName = $dir . '/整理结果.xls';

#添加Word.Application obj

my $word = Win32::OLE->new("Word.Application");
$word->{Visible} = 1;

#搜索doc文件，new的参数默认为{regexqr=>/.*\.doc$/}

my $objFind = SearchFile->new();
my $ffn = $objFind->File_Find();

#添加Excel.Application obj

my $Excel = Win32::OLE->new("Excel.Application");
$Excel->{Visible} = 1;
$Excel->{SheetsInNewWorkBook} = 1;
my $Book = $Excel->Workbooks->Add;
$Book->SaveAs( { Filename => $BookName } );

#遍历打开文件进行处理

my ( $Sear_key, @Sear_temp, @mat_arr );

foreach my $file ( @{$ffn} ) {
    my $document = $word->documents->Open($file);
    my $obj = WordOLE->new( Doc => $document );
    my $temp = $obj->Sear_Cell_Uni(4);
    push( @Sear_temp, @{$temp} );
    $Sear_key = $obj->_Unique( \@Sear_temp );
    $document->close;
}

#print Dumper($Sear_key);


foreach my $file ( @{$ffn} ) {
    my $document = $word->documents->Open($file);
    my $obj = WordOLE->new( Doc => $document );
    my $temp = $obj->Re_Mat_Row( $Sear_key, 4 );
    push( @mat_arr, $temp );
    $document->close;
}

#print Dumper(\@mat_arr);


#解析数据结构@mat_arr，将数据写进Excel

foreach my $re_match (@mat_arr) {
    foreach my $key ( keys %{$re_match} ) {

        #print Dumper($re_match->{$key});

        my $Row_Count = @{ $re_match->{$key} };

        my $Sheet_Name = $Book->ActiveSheet->{Name};

       #检查是否存在以$key命名的工作表，无则新建并写入内容，有则往后一行增加内空

        if ( !$Book->Sheets($key) ) {
            $Book->Sheets->Add;
            $Book->ActiveSheet->{Name} = $key;
            my $ActSheet = $Book->ActiveSheet;
            $ActSheet->Range('A1:E1')->{'Value'} =
              [ [ '存在问题', '原因分析', '整改要求', '责任人', '关闭时间' ] ];
            my $MaxRows = $ActSheet->UsedRange->Rows->{Count};
            my $RowHight = $MaxRows + $Row_Count;
            $ActSheet->Range( 'A2:E' . $RowHight )->{'Value'} =
              $re_match->{$key};
        }
        else {
            $Book->Sheets($key)->Select;
            my $ActSheet = $Book->ActiveSheet;
            $Book->Sheets($key)->Range('A1:E1')->{'Value'} =
              [ [ '存在问题', '原因分析', '整改要求', '责任人', '关闭时间' ] ];
            my $MaxRows = $ActSheet->UsedRange->Rows->{Count};
            my $RowHight = $MaxRows + $Row_Count;
            my $Star_Row = $MaxRows + 1;
            $ActSheet->Range( 'A' . $Star_Row . ':E' . $RowHight )->{'Value'} =
              $re_match->{$key};
        }
    }
}
$Book->save;
$Book->close;

$word->quit;
$Excel->quit;

三、简单介绍：

作用：弹出窗口，以供选择目标文件夹，按指定的正则模式搜索文件，并返回搜索到的所有文件数组的引用。

设定正则模式：regex=>'Regex'，默认为'.*\.doc$'

支持正则表达式，遍历搜索文件夹匹配的文件，将返回所有文件数组的引用。 调用内置方法_Path()。

my $objFind=SearchFile->new(regex=>'.*\.xls');#更改正则匹配模式

 #my $objFind=SearchFile->new(); #缺省参数时：regex=>'.*\.doc$'

 my $ffn=$objFind->File_Find();
 print join("\n",@{$ffn});

作用：1、Sear_Cell_Uni()方法，提取word文档所有表格某一列单元格字符串，以“/”折分字符串并返回唯一子串Array的引用； 2、Re_Mat_Row()，“关键字”与“指定表格某一列所有单元格”进行匹配，将表格的整行内容按“关键字”进行归类，返回 一个Hash的引用。

Win32::OLE->new("Word.Application")对象的引用。

使用：$obj->Sear_Cell_Uni(查找表格第几列) 调用内置方法_Unique()。

使用：$obj->Re_Mat_Row(关键字,与表格第几列进行匹配)

my $word = Win32::OLE->new("Word.Application");
 $word->{Visible} = 1;
 my $document = $word->documents->Open('G:/结果/a.doc');
 my $obj = WordOLE->new( Doc => $document );
 my $arr = $obj->Sear_Cell_Uni(4);
 my $brr = $obj->Re_Mat_Row( $arr, 4 );
 print Dumper($brr);
 $document->close;
 $word->quit;

四、Main program的工作流程
4.1生成关键字
(1)、my $temp     = $obj->Sear_Cell_Uni(4);
 一份份打开文件生成唯一关键字的Array的引用。
(2)、push( @Sear_temp, @{$temp} );
每打开一份文件，将生成了唯一关键字的数组push进@Sear_temp。
(3)、$Sear_key = $obj->_Unique( \@Sear_temp );
所有文件打开后，调用_Unique()将@Sear_temp过滤为唯一元素数组。
4.2构造数据结构
(1)、my $temp     = $obj->Re_Mat_Row( $Sear_key, 4 );
一份份打开文件，每打开一份文件按$Sear_key将表格的内容行进行归类，生成$temp={$Sear_key=>[[],...]}。
(2)、push( @mat_arr, $temp );
每打开一份文件，将$temp散列引用push进@mat_arr。
4.3解析数据结构，写入数据

获奖了，CU寄来了个无线鼠标，拍了张照片