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
wingetdesknull252 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
wingetappdatanull522 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
550