"Fossies" - the Fresh Open Source Software Archive

Member "peazip-8.0.0.src/unit_report.pas" (2 May 2021, 17706 Bytes) of package /linux/misc/peazip-8.0.0.src.zip:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) delphi source code syntax highlighting (style: standard) with prefixed line numbers. Alternatively you can here view or download the uninterpreted source code file. See also the latest Fossies "Diffs" side-by-side code changes report for "unit_report.pas": 7.9.0_vs_8.0.0.

    1 unit Unit_report;
    2 {
    3  DESCRIPTION     :  Unit providing GUI for display reports in two string grids
    4                     and four label
    5 
    6  REQUIREMENTS    :  FPC, Lazarus
    7 
    8  EXTERNAL DATA   :  ---
    9 
   10  MEMORY USAGE    :  ---
   11 
   12  DISPLAY MODE    :  ---
   13 
   14  REFERENCES      :  ---
   15 
   16  REMARK          :  ---
   17 
   18  Version  Date      Author      Modification
   19  -------  --------  -------     ------------------------------------------
   20  0.10     20060908  G.Tani      Initial version
   21  0.11     20060920  G.Tani      removed *_VER; P_RELEASE constant in pea_utils
   22                                 is used to keep track of release level;
   23                                 for porting the application please refer to notes
   24                                 in unit Peach.
   25  0.12     20060927  G.Tani      changed Win32 transparence code to be compatible
   26                                 with all Win32 versions (no longer needed separate
   27                                 builds);
   28  0.12b    20070328  G.Tani      Minor visual updates for better integration with
   29                                 PeaZip 1.6 look and feel
   30  0.13     20070503  G.Tani      Updated look and feel
   31  0.14     20070802  G.Tani      Accepts new PeaZip theming
   32  0.15     20070924  G.Tani      Updated according to PeaZip theming improvements
   33  0.16     20071130  G.Tani      Minor cleanup
   34  0.17     20080314  G.Tani      Transparency made available for Win64
   35  0.18     20080707  G.Tani      Updated to work with utf8 LCL
   36  0.19     20080826  G.Tani      Ask path for saving reports, default is desktop (or current path if desktop is not found)
   37  0.20     20081026  G.Tani      Autosized/customisable GUI's items height; various graphic updates
   38                                 Form_report that can now close the application if it is the only form needing to be shown
   39  0.21     20081118  G.Tani      appdata fixed for Windows users with names containing extended characters
   40                                 filemode set to 0 before all reset file operations to avoid possible lock situations (i.e. concurrent instances)
   41  0.22     20091103  G.Tani      New icons
   42  0.23     20101105  G.Tani      Updated look and feel
   43  0.24     20200414  G.Tani      New function to save crc/hash value(s) to file
   44  0.25     20210502  G.Tani      Batch and hidden *_report modes now save report to output path without requiring user interaction
   45 
   46 (C) Copyright 2006 Giorgio Tani giorgio.tani.software@gmail.com
   47 The program is released under GNU LGPL http://www.gnu.org/licenses/lgpl.txt
   48 
   49     This library is free software; you can redistribute it and/or
   50     modify it under the terms of the GNU Lesser General Public
   51     License as published by the Free Software Foundation; either
   52     version 3 of the License, or (at your option) any later version.
   53 
   54     This library is distributed in the hope that it will be useful,
   55     but WITHOUT ANY WARRANTY; without even the implied warranty of
   56     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
   57     Lesser General Public License for more details.
   58 
   59     You should have received a copy of the GNU Lesser General Public
   60     License along with this library; if not, write to the Free Software
   61     Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA
   62 }
   63 
   64 {$mode objfpc}{$H+}
   65 {$INLINE ON}
   66 
   67 interface
   68 
   69 uses
   70   {$IFDEF MSWINDOWS}
   71   Windows, ActiveX,
   72   {$ENDIF}
   73   Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, Buttons,
   74   Grids, StdCtrls, ExtCtrls, ComCtrls,
   75   ansiutf8_utils, list_utils, pea_utils, img_utils, Menus;
   76 
   77 type
   78 
   79   { TForm_report }
   80 
   81   TForm_report = class(TForm)
   82     Button2: TBitBtn;
   83     Label1: TLabel;
   84     Label2: TLabel;
   85     Label3: TLabel;
   86     Label4: TLabel;
   87     LabelCase: TLabel;
   88     LabelTitleREP1: TLabel;
   89     LabelSave: TLabel;
   90     LabelSaveTxt: TLabel;
   91     LabelSave2: TLabel;
   92     LabelSaveTxt1: TLabel;
   93     LabelTitleREP2: TLabel;
   94     Memo1: TMemo;
   95     MenuItem1: TMenuItem;
   96     MenuItem2: TMenuItem;
   97     Notebook1: TPageControl;
   98     InputT: TTabSheet;
   99     OutputT: TTabSheet;
  100     Panelsp0: TPanel;
  101     PanelTitleREP: TPanel;
  102     PopupMenu1: TPopupMenu;
  103     SaveDialog1: TSaveDialog;
  104     ShapeTitleREPb1: TShape;
  105     ShapeTitleREPb2: TShape;
  106     StringGrid1: TStringGrid;
  107     StringGrid2: TStringGrid;
  108     procedure Button2Click(Sender: TObject);
  109     procedure FormClose(Sender: TObject; var CloseAction: TCloseAction);
  110     procedure FormCreate(Sender: TObject);
  111     procedure LabelCaseClick(Sender: TObject);
  112     procedure LabelSaveTxt1Click(Sender: TObject);
  113     procedure LabelSaveTxtClick(Sender: TObject);
  114     procedure LabelTitleREP1Click(Sender: TObject);
  115     procedure LabelTitleREP1MouseEnter(Sender: TObject);
  116     procedure LabelTitleREP1MouseLeave(Sender: TObject);
  117     procedure LabelTitleREP2Click(Sender: TObject);
  118     procedure LabelTitleREP2MouseEnter(Sender: TObject);
  119     procedure LabelTitleREP2MouseLeave(Sender: TObject);
  120     procedure MenuItem1Click(Sender: TObject);
  121     procedure MenuItem2Click(Sender: TObject);
  122     procedure StringGrid1HeaderClick(Sender: TObject; IsColumn: Boolean;
  123       Index: Integer);
  124     procedure StringGrid1MouseDown(Sender: TObject; Button: TMouseButton;
  125       Shift: TShiftState; X, Y: Integer);
  126     procedure StringGrid2HeaderClick(Sender: TObject; IsColumn: Boolean;
  127       Index: Integer);
  128   private
  129     { private declarations }
  130   public
  131     { public declarations }
  132   end;
  133 
  134 procedure save_report(s,reptype,modparam,out_path:ansistring);
  135   
  136 var
  137   Form_report: TForm_report;
  138    t:text;
  139    //theming
  140    conf:text;
  141    opacity,grid1index,grid2index:integer;
  142    confpath:ansistring;
  143    grid1switch,grid2switch:boolean;
  144    executable_path,dummy,color1,color2,color3,color4,color5:string;
  145    Binfo,Bloadlayout:TBitmap;
  146    activelabel_rep:TLabel;
  147    
  148 implementation
  149 
  150 ///rep
  151 procedure exitlabel_rep(var a: TLabel; var b:TShape);
  152 begin
  153 if activelabel_rep=a then exit;
  154 b.visible:=false;
  155 b.Brush.Color:=pvvlblue;
  156 a.Font.Color:=pgray;
  157 end;
  158 
  159 procedure deselectlabels_rep;
  160 begin
  161 with Form_report do
  162 begin
  163 exitlabel_rep(LabelTitleREP1,ShapeTitleREPb1);
  164 exitlabel_rep(LabelTitleREP2,ShapeTitleREPb2);
  165 end;
  166 end;
  167 
  168 procedure save_report_clip;
  169 var
  170    x,y:dword;
  171 begin
  172 Form_report.Memo1.lines.BeginUpdate;;
  173 Form_report.Memo1.Clear;
  174 if Form_report.Caption<>'Hex preview' then
  175 begin
  176 for x:=1 to Form_report.StringGrid1.RowCount-1 do
  177    begin
  178    for y:=0 to Form_report.StringGrid1.ColCount-1 do
  179       if Form_report.StringGrid1.ColWidths[y]>0 then
  180       if ((Form_report.StringGrid1.Cells[y,0]<>'File header') and (Form_report.StringGrid1.Cells[y,0]<>'End of file')) then
  181       if Form_report.StringGrid1.Cells[y,x]<>'' then
  182          Form_report.Memo1.Append(Form_report.StringGrid1.Cells[y,0]+': '+Form_report.StringGrid1.Cells[y,x])
  183       else
  184          Form_report.Memo1.Append(Form_report.StringGrid1.Cells[y,0]+': -');
  185    Form_report.Memo1.Append('');
  186    end;
  187 if Form_report.StringGrid2.Cells[0,0]<>'' then
  188 for x:=1 to Form_report.StringGrid2.RowCount-1 do
  189    begin
  190    for y:=0 to Form_report.StringGrid2.ColCount-1 do
  191       if Form_report.StringGrid2.ColWidths[y]>0 then
  192       if Form_report.StringGrid2.Cells[y,x]<>'' then
  193          Form_report.Memo1.Append(Form_report.StringGrid2.Cells[y,0]+': '+Form_report.StringGrid2.Cells[y,x])
  194       else
  195          Form_report.Memo1.Append(Form_report.StringGrid2.Cells[y,0]+': - ');
  196    Form_report.Memo1.Append('');
  197    end;
  198 end;
  199 Form_report.Memo1.Append(Form_report.Label1.Caption);
  200 Form_report.Memo1.Append(Form_report.Label2.Caption);
  201 Form_report.Memo1.Append(Form_report.Label3.Caption);
  202 Form_report.Memo1.Append(Form_report.Label4.Caption);
  203 Form_report.Memo1.lines.EndUpdate;
  204 Form_report.Memo1.SelStart:=0;
  205 Form_report.Memo1.SelLength:=0;
  206 end;
  207 
  208 procedure setpanel_rep(i:integer);
  209 begin
  210 case i of
  211    1: begin
  212    Form_report.Notebook1.visible:=true;
  213    Form_report.Memo1.visible:=false;
  214    end;
  215    2: begin
  216    Form_report.Notebook1.visible:=false;
  217    Form_report.Memo1.visible:=true;
  218    save_report_clip;
  219    end;
  220 end;
  221 end;
  222 
  223 procedure setlabelpanel_rep(var a: Tlabel);
  224 begin
  225 with Form_report do
  226 begin
  227 if a = LabelTitleREP1 then setpanel_rep(1);
  228 if a = LabelTitleREP2 then setpanel_rep(2);
  229 end;
  230 end;
  231 
  232 procedure clicklabel_rep(var a: TLabel; var b:TShape);
  233 begin
  234 activelabel_rep:=a;
  235 deselectlabels_rep;
  236 a.Font.Color:=clDefault;
  237 b.visible:=true;
  238 b.Brush.Color:=pvvlblue;
  239 setlabelpanel_rep(a);
  240 end;
  241 
  242 procedure enterlabel_rep(var a: TLabel; var b:TShape);
  243 begin
  244 if activelabel_rep=a then exit;
  245 b.visible:=true;
  246 b.Brush.Color:=pvvvlblue;
  247 a.Font.Color:=clDefault;
  248 end;
  249 
  250 ///
  251 
  252 function wingetdesk(var dp:ansistring):integer;
  253 {$IFDEF MSWINDOWS}
  254 var
  255   pidl: PItemIDList;
  256   Buf: array [0..MAX_PATH] of Char;
  257 {$ENDIF}
  258 begin
  259 wingetdesk:=-1;
  260 {$IFDEF MSWINDOWS}
  261 try
  262    if Succeeded(ShGetSpecialFolderLocation(Form_report.Handle,0,pidl)) then //0 is CSIDL_DESKTOP numerical value
  263       if ShGetPathfromIDList(pidl, Buf ) then
  264          begin
  265          dp:=(Buf);
  266          CoTaskMemFree(pidl);
  267          wingetdesk:=0;
  268          end
  269       else CoTaskMemFree(pidl);
  270 except
  271 end;
  272 {$ENDIF}
  273 end;
  274 
  275 procedure save_report(s,reptype,modparam,out_path:ansistring);
  276 var
  277 x,y:dword;
  278 field_delim:string;
  279 p:ansistring;
  280 begin
  281 if reptype='txt' then field_delim:=chr($09)
  282 else field_delim:=';';
  283 
  284 if upcase(modparam)='INTERACTIVE_REPORT' then //interactive
  285    begin
  286    {$IFDEF MSWINDOWS}wingetdesk(p);{$ELSE}get_desktop_path(p);{$ENDIF}
  287    if p[length(p)]<>directoryseparator then p:=p+directoryseparator;
  288    s:=formatdatetime('yyyymmdd_hh.nn.ss_',now)+s+'.'+reptype;
  289    Form_report.SaveDialog1.FileName:=p+s;
  290    if directoryexists(p) then Form_report.SaveDialog1.InitialDir:=p;
  291    if Form_report.SaveDialog1.Execute then s:=Form_report.SaveDialog1.FileName
  292    else s:='';
  293    end
  294 else //batch or hidden, non interactive
  295    begin
  296    p:=out_path;
  297    if p[length(p)]<>directoryseparator then p:=p+directoryseparator;
  298    s:=formatdatetime('yyyymmdd_hh.nn.ss_',now)+s+'.'+reptype;
  299    end;
  300 
  301 if s<>'' then
  302 begin
  303 assignfile(t,s);
  304 rewrite(t);
  305 write_header(t);
  306 if Form_report.Caption<>'Hex preview' then
  307 begin
  308 for x:=0 to Form_report.StringGrid1.RowCount-1 do
  309    begin
  310    for y:=0 to Form_report.StringGrid1.ColCount-1 do
  311       if Form_report.StringGrid1.ColWidths[y]>0 then
  312       if ((Form_report.StringGrid1.Cells[y,0]<>'File header') and (Form_report.StringGrid1.Cells[y,0]<>'End of file')) then
  313       write(t,Form_report.StringGrid1.Cells[y,x]+field_delim);
  314    writeln(t);
  315    end;
  316 for x:=0 to Form_report.StringGrid2.RowCount-1 do
  317    begin
  318    for y:=0 to Form_report.StringGrid2.ColCount-1 do
  319       if Form_report.StringGrid2.ColWidths[y]>0 then
  320       write(t,Form_report.StringGrid2.Cells[y,x]+field_delim);
  321    writeln(t);
  322    end;
  323 end;
  324 writeln(t,Form_report.Label1.Caption);
  325 writeln(t,Form_report.Label2.Caption);
  326 writeln(t,Form_report.Label3.Caption);
  327 writeln(t,Form_report.Label4.Caption);
  328 closefile(t);
  329 end;
  330 end;
  331 
  332 { TForm_report }
  333 
  334 procedure conditional_stop;
  335 begin
  336 if Form_report.Caption='List' then Application.Terminate;
  337 if Form_report.Caption='Info' then Application.Terminate;
  338 if Form_report.Caption='Compare' then Application.Terminate;
  339 if Form_report.Caption='Checksum and hash' then Application.Terminate;
  340 if Form_report.Caption='Analyze' then Application.Terminate;
  341 if Form_report.Caption='Environment variables' then Application.Terminate;
  342 if Form_report.Caption='Hex preview' then Application.Terminate;
  343 end;
  344 
  345 procedure TForm_report.Button2Click(Sender: TObject);
  346 begin
  347 Form_report.Visible:=false;
  348 conditional_stop;
  349 end;
  350 
  351 procedure TForm_report.FormClose(Sender: TObject; var CloseAction: TCloseAction
  352   );
  353 begin
  354 conditional_stop;
  355 end;
  356 
  357 procedure TForm_report.FormCreate(Sender: TObject);
  358 begin
  359 grid1index:=0;
  360 grid2index:=0;
  361 grid1switch:=true;
  362 grid2switch:=true;
  363 clicklabel_rep(LabelTitleREP1,ShapeTitleREPb1);
  364 end;
  365 
  366 procedure TForm_report.LabelCaseClick(Sender: TObject);
  367 var
  368    irow,icol:integer;
  369    orig_activelabel_rep:TLabel;
  370 begin
  371 orig_activelabel_rep:=activelabel_rep;
  372 if LabelCase.Caption='[CASE]' then
  373    begin
  374    LabelCase.Caption:='[case]';
  375    if Form_report.StringGrid1.RowCount<2 then exit;
  376    if Form_report.StringGrid1.ColCount<24 then exit;
  377    for irow:=1 to Form_report.StringGrid1.RowCount-1 do
  378       for icol:=7 to 24 do Form_report.StringGrid1.Cells[icol,irow]:=lowercase(Form_report.StringGrid1.Cells[icol,irow]);
  379    end
  380 else
  381    begin
  382    LabelCase.Caption:='[CASE]';
  383    if Form_report.StringGrid1.RowCount<2 then exit;
  384    if Form_report.StringGrid1.ColCount<24 then exit;
  385    for irow:=1 to Form_report.StringGrid1.RowCount-1 do
  386       for icol:=7 to 24 do Form_report.StringGrid1.Cells[icol,irow]:=upcase(Form_report.StringGrid1.Cells[icol,irow]);
  387    end;
  388 clicklabel_rep(LabelTitleREP2,ShapeTitleREPb2);
  389 if orig_activelabel_rep=LabelTitleREP1 then clicklabel_rep(LabelTitleREP1,ShapeTitleREPb1);
  390 end;
  391 
  392 procedure TForm_report.LabelSaveTxt1Click(Sender: TObject);
  393 begin
  394 save_report(Form_report.Caption,'csv','INTERACTIVE_REPORT','');
  395 end;
  396 
  397 procedure TForm_report.LabelSaveTxtClick(Sender: TObject);
  398 begin
  399 save_report(Form_report.Caption,'txt','INTERACTIVE_REPORT','');
  400 end;
  401 
  402 procedure TForm_report.LabelTitleREP1Click(Sender: TObject);
  403 begin
  404 clicklabel_rep(LabelTitleREP1,ShapeTitleREPb1);
  405 end;
  406 
  407 procedure TForm_report.LabelTitleREP1MouseEnter(Sender: TObject);
  408 begin
  409 enterlabel_rep(LabelTitleREP1,ShapeTitleREPb1);
  410 end;
  411 
  412 procedure TForm_report.LabelTitleREP1MouseLeave(Sender: TObject);
  413 begin
  414 exitlabel_rep(LabelTitleREP1,ShapeTitleREPb1);
  415 end;
  416 
  417 procedure TForm_report.LabelTitleREP2Click(Sender: TObject);
  418 begin
  419 clicklabel_rep(LabelTitleREP2,ShapeTitleREPb2);
  420 end;
  421 
  422 procedure TForm_report.LabelTitleREP2MouseEnter(Sender: TObject);
  423 begin
  424 enterlabel_rep(LabelTitleREP2,ShapeTitleREPb2);
  425 end;
  426 
  427 procedure TForm_report.LabelTitleREP2MouseLeave(Sender: TObject);
  428 begin
  429 exitlabel_rep(LabelTitleREP2,ShapeTitleREPb2);
  430 end;
  431 
  432 procedure TForm_report.MenuItem1Click(Sender: TObject);
  433 var
  434    s,fname:AnsiString;
  435 begin
  436 if StringGrid1.Row>0 then
  437    if (StringGrid1.Col>7) and (StringGrid1.Col<25) then
  438       begin
  439       s:=StringGrid1.Cells[StringGrid1.Col,StringGrid1.Row];
  440       if StringGrid1.Cells[0,StringGrid1.Row]='* Digest *' then exit;
  441       fname:=StringGrid1.Cells[0,StringGrid1.Row]+'.'+StringGrid1.Cells[StringGrid1.Col,0]+'.txt';
  442       assignfile(t,fname);
  443       rewrite(t);
  444       write(t,s);
  445       closefile(t);
  446       end;
  447 end;
  448 
  449 procedure TForm_report.MenuItem2Click(Sender: TObject);
  450 var
  451    s,fname:AnsiString;
  452    y:integer;
  453 begin
  454 if StringGrid1.Row>0 then
  455    begin
  456    if StringGrid1.Cells[0,StringGrid1.Row]='* Digest *' then exit;
  457    fname:=StringGrid1.Cells[0,StringGrid1.Row]+'.info.txt';
  458    assignfile(t,fname);
  459    rewrite(t);
  460    write_header(t);
  461    writeln(t,'Name: '+StringGrid1.Cells[1,StringGrid1.Row]);
  462    writeln(t,'Size: '+StringGrid1.Cells[3,StringGrid1.Row]+' ('+StringGrid1.Cells[4,StringGrid1.Row]+' Bytes)');
  463    writeln(t,'Modified: '+StringGrid1.Cells[5,StringGrid1.Row]);
  464    writeln(t,'Attributes: '+StringGrid1.Cells[6,StringGrid1.Row]);
  465    for y:=8 to 24 do
  466       if StringGrid1.ColWidths[y]>0 then
  467          writeln(t,StringGrid1.Cells[y,0]+': '+StringGrid1.Cells[y,StringGrid1.Row]);
  468    closefile(t);
  469    end;
  470 end;
  471 
  472 procedure TForm_report.StringGrid1HeaderClick(Sender: TObject;
  473   IsColumn: Boolean; Index: Integer);
  474 var i:integer;
  475 begin
  476 if grid1index=index then grid1switch:=not(grid1switch);
  477 if grid1switch=true then StringGrid1.SortOrder:=soAscending else StringGrid1.SortOrder:=soDescending;
  478 i:=index;
  479 if (Form_report.Caption='Checksum and hash') and ((i=3) or (i=4)) then i:=25;
  480 if (Form_report.Caption='Checksum and hash') and (i=29) then i:=30;
  481 StringGrid1.SortColRow(true,i);
  482 grid1index:=Index;
  483 end;
  484 
  485 procedure crcmenuenable(en:boolean);
  486 begin
  487 Form_report.MenuItem1.Enabled:=en;
  488 Form_report.MenuItem2.Enabled:=en;
  489 end;
  490 
  491 procedure TForm_report.StringGrid1MouseDown(Sender: TObject;
  492   Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
  493 var col,row:integer;
  494 begin
  495 StringGrid1.MouseToCell(X,Y,col,row);
  496 StringGrid1.Col:=col;
  497 if (StringGrid1.Col>7) and (StringGrid1.Col<25) then
  498    begin
  499    crcmenuenable(true);
  500    MenuItem1.Caption:='Save '+StringGrid1.Cells[StringGrid1.Col,0]+' value';
  501    end
  502 else
  503    begin
  504    crcmenuenable(true);
  505    MenuItem1.Caption:='Save selected CRC or hash value';
  506    MenuItem1.Enabled:=false;
  507    end;
  508 if StringGrid1.Cells[0,StringGrid1.Row]='* Digest *' then crcmenuenable(false);
  509 end;
  510 
  511 procedure TForm_report.StringGrid2HeaderClick(Sender: TObject;
  512   IsColumn: Boolean; Index: Integer);
  513 var i:integer;
  514 begin
  515 if grid2index=index then grid2switch:=not(grid2switch);
  516 if grid2switch=true then StringGrid2.SortOrder:=soAscending else StringGrid2.SortOrder:=soDescending;
  517 i:=index;
  518 StringGrid2.SortColRow(true,i);
  519 grid2index:=Index;
  520 end;
  521 
  522 function wingetappdata(var s:ansistring):integer;
  523 {$IFDEF MSWINDOWS}
  524 var
  525   pidl: PItemIDList;
  526   Buf: array [0..MAX_PATH] of Char;
  527 {$ENDIF}
  528 begin
  529 wingetappdata:=-1;
  530 {$IFDEF MSWINDOWS}
  531 try
  532    if Succeeded(ShGetSpecialFolderLocation(Form_report.Handle,26,pidl)) then //26 is CSIDL_APPDATA numerical value
  533       if ShGetPathfromIDList(pidl, Buf ) then
  534          begin
  535          s:=(Buf)+'\PeaZip\';
  536          CoTaskMemFree(pidl);
  537          wingetappdata:=0;
  538          end
  539       else CoTaskMemFree(pidl);
  540 except
  541 end;
  542 {$ENDIF}
  543 end;
  544 
  545 initialization
  546   {$I unit_report.lrs}
  547 
  548 end.
  549