home *** CD-ROM | disk | FTP | other *** search
/ PC World Komputer 1998 April A / Pcwk4a98.iso / PROGRAM / DELPHI16 / Calmira / Src / SRC / FILEPROP.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1997-02-17  |  10.0 KB  |  341 lines
  1. {**************************************************************************}
  2. {                                                                          }
  3. {    Calmira shell for Microsoft« Windows(TM) 3.1                          }
  4. {    Source Release 1.0                                                    }
  5. {    Copyright (C) 1997  Li-Hsin Huang                                     }
  6. {                                                                          }
  7. {    This program is free software; you can redistribute it and/or modify  }
  8. {    it under the terms of the GNU General Public License as published by  }
  9. {    the Free Software Foundation; either version 2 of the License, or     }
  10. {    (at your option) any later version.                                   }
  11. {                                                                          }
  12. {    This program is distributed in the hope that it will be useful,       }
  13. {    but WITHOUT ANY WARRANTY; without even the implied warranty of        }
  14. {    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the         }
  15. {    GNU General Public License for more details.                          }
  16. {                                                                          }
  17. {    You should have received a copy of the GNU General Public License     }
  18. {    along with this program; if not, write to the Free Software           }
  19. {    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.             }
  20. {                                                                          }
  21. {**************************************************************************}
  22.  
  23. unit FileProp;
  24.  
  25. { File Properties dialog
  26.  
  27.   Displays details of files (and version information), folders or
  28.   a combination.  The main call is SetItem(), which accepts either
  29.   a TDirItem or a TFileList, and sets up the dialog appropriately.
  30. }
  31.  
  32. interface
  33.  
  34. uses WinTypes, WinProcs, Classes, Graphics, Forms, Controls, Buttons,
  35.   StdCtrls, ExtCtrls, Directry, TabNotBk, VerInfo;
  36.  
  37. type
  38.   TFilePropDlg = class(TForm)
  39.     OKBtn: TBitBtn;
  40.     CancelBtn: TBitBtn;
  41.     Notebook: TTabbedNotebook;
  42.     Notes: TNotebook;
  43.     Label1: TLabel;
  44.     Label2: TLabel;
  45.     Label3: TLabel;
  46.     Label4: TLabel;
  47.     FilenameLab: TLabel;
  48.     LocationLab: TLabel;
  49.     SizeLab: TLabel;
  50.     DateLab: TLabel;
  51.     Label10: TLabel;
  52.     TypeLab: TLabel;
  53.     Label6: TLabel;
  54.     Foldername: TLabel;
  55.     Label8: TLabel;
  56.     FolderLoc: TLabel;
  57.     Label16: TLabel;
  58.     Foldersize: TLabel;
  59.     Label21: TLabel;
  60.     FolderDate: TLabel;
  61.     Label23: TLabel;
  62.     TotalLab: TLabel;
  63.     Label7: TLabel;
  64.     Label9: TLabel;
  65.     Selfiles: TLabel;
  66.     Selsize: TLabel;
  67.     Listbox: TListBox;
  68.     Bevel2: TBevel;
  69.     ReadOnly: TCheckBox;
  70.     Hidden: TCheckBox;
  71.     Archive: TCheckBox;
  72.     System: TCheckBox;
  73.     Label5: TLabel;
  74.     Bevel1: TBevel;
  75.     Header: THeader;
  76.     Panel1: TPanel;
  77.     ItemImage: TImage;
  78.     HelpBtn: TBitBtn;
  79.     procedure OKBtnClick(Sender: TObject);
  80.     procedure ReadOnlyClick(Sender: TObject);
  81.     procedure TotalLabClick(Sender: TObject);
  82.     procedure ListboxDrawItem(Control: TWinControl; Index: Integer;
  83.       Rect: TRect; State: TOwnerDrawState);
  84.     procedure FormCreate(Sender: TObject);
  85.     procedure HeaderSized(Sender: TObject; ASection, AWidth: Integer);
  86.   private
  87.     { Private declarations }
  88.     Item : TObject;
  89.     changed : Boolean;
  90.     procedure SetSingle;
  91.     procedure SetFile;
  92.     procedure SetFolder;
  93.     procedure SetList;
  94.     procedure ExtractVerInfo;
  95.     procedure SetCheckBoxes(attr, gray: Integer);
  96.   public
  97.     { Public declarations }
  98.     procedure SetItem(AItem : TObject);
  99.   end;
  100.  
  101. var
  102.   FilePropDlg: TFilePropDlg;
  103.  
  104. implementation
  105.  
  106. {$R *.DFM}
  107.  
  108. uses SysUtils, Files, Strings, Resource, Settings, MiscUtil,
  109.   Dialogs, Alias, FourDOS, FileCtrl;
  110.  
  111.  
  112. procedure TFilePropDlg.SetCheckboxes(attr, gray: Integer);
  113.  
  114. procedure SetCheckBox(Checkbox: TCheckbox; mask: Integer);
  115. begin
  116.   with Checkbox do begin
  117.     Checked := attr and mask <> 0;
  118.     if gray and mask <> 0 then State := cbGrayed else AllowGrayed := False;
  119.   end;
  120. end;
  121.  
  122. begin
  123.   SetCheckbox(ReadOnly, faReadOnly);
  124.   SetCheckbox(Archive, faArchive);
  125.   SetCheckbox(Hidden, faHidden);
  126.   SetCheckbox(System, faSysFile);
  127. end;
  128.  
  129.  
  130. procedure TFilePropDlg.SetSingle;
  131. begin
  132.   with Item as TDirItem do begin
  133.     ItemImage.Picture.Icon := Icon;
  134.     SetCheckBoxes(Attr, 0);
  135.   end;
  136. end;
  137.  
  138.  
  139.  
  140. procedure TFilePropDlg.SetFile;
  141. var
  142.   ext : TFileExt;
  143. begin
  144.   SetSingle;
  145.   with Item as TFileItem do begin
  146.     Notes.PageIndex := 0;
  147.  
  148.     FilenameLab.Caption := Filename;
  149.     LocationLab.Caption := Dir.Fullname;
  150.  
  151.     DateLab.Caption := FormatDateTime('dddd d mmmm yyyy,  hh:mm am/pm', TimeStamp);
  152.     if Size <= 1024 then
  153.       SizeLab.Caption := FormatByte(Size)
  154.     else
  155.       SizeLab.Caption :=
  156.        Format('%s   (%.0n bytes)', [FormatByte(Size), Size * 1.0]);
  157.  
  158.     ext := Extension;
  159.     with TypeLab do
  160.       if ext = 'exe' then Caption := 'Program'
  161.       else if ext = 'com' then Caption := 'MS-DOS program'
  162.       else if ext = 'dll' then Caption := 'Dynamic link library'
  163.       else if ext = 'bat' then Caption := 'MS-DOS batch file'
  164.       else if ext = 'pif' then Caption := 'Program information file'
  165.       else if Item is TAlias then Caption := 'Alias'
  166.       else begin
  167.         { query the registry }
  168.         Caption := GetRegValue(GetRegValue('.' + ext));
  169.         if Caption = '' then Caption := 'Unknown';
  170.       end;
  171.  
  172.     if FindVersion then ExtractVerInfo;
  173.   end;
  174. end;
  175.  
  176.  
  177. procedure TFilePropDlg.SetFolder;
  178. begin
  179.   SetSingle;
  180.   with Item as TFolder do begin
  181.     Notes.PageIndex := 1;
  182.  
  183.     Foldername.Caption := Filename;
  184.     FolderLoc.Caption := Dir.Fullname;
  185.     FolderDate.Caption := FormatDateTime('dddd d mmmm yyyy,  hh:mm am/pm', TimeStamp);
  186.  
  187.     with DirInfo(Fullname, False) do
  188.     FolderSize.Caption := Format('%s in %d file%s',
  189.       [FormatByte(size), files, OneItem[files = 1]]);
  190.   end;
  191. end;
  192.  
  193.  
  194. procedure TFilePropDlg.SetList;
  195. var
  196.   i, gray, attr : Integer;
  197.   f : TDirItem;
  198. begin
  199.   with Item as TFileList do begin
  200.     Notes.PageIndex := 2;
  201.     ItemImage.Picture.Icon := Icons.Get('MultiFile');
  202.     Selfiles.Caption := Format('%d file%s in %d folder%s',
  203.       [FileCount, OneItem[FileCount = 1], FolderCount, OneItem[FolderCount = 1]]);;
  204.     Selsize.Caption := FormatByte(FileSize);
  205.  
  206.     { Determine which checkboxes should be grayed out }
  207.  
  208.     attr := TDirItem(Items[0]).Attr;
  209.     gray := 0;
  210.     for i := 1 to Count-1 do begin
  211.        f := TDirItem(Items[i]);
  212.        gray := gray or (f.Attr xor attr);
  213.        attr := attr or f.Attr;
  214.     end;
  215.     SetCheckBoxes(attr, gray);
  216.   end;
  217. end;
  218.  
  219.  
  220. procedure TFilePropDlg.SetItem(AItem : TObject);
  221. begin
  222.   Item := AItem;
  223.   if Item is TFileItem then SetFile
  224.   else if Item is TFolder then SetFolder
  225.   else SetList;
  226.   Caption := Notes.ActivePage;
  227.   if Listbox.Items.Count = 0 then NoteBook.Pages.Delete(1);
  228. end;
  229.  
  230.  
  231. procedure TFilePropDlg.OKBtnClick(Sender: TObject);
  232. var i, attrib, gray : Integer;
  233. begin
  234.   if not changed then exit;
  235.  
  236.   attrib := Integer(ReadOnly.Checked) * faReadOnly or
  237.             Integer(Archive.Checked) * faArchive or
  238.             Integer(Hidden.Checked) * faHidden or
  239.             Integer(System.Checked) * faSysFile;
  240.  
  241.   if Item is TDirItem then
  242.     (Item as TDirItem).Attr := attrib
  243.   else
  244.       with Item as TFileList do begin
  245.  
  246.       gray := Integer(ReadOnly.State = cbGrayed) * faReadOnly or
  247.               Integer(Archive.State = cbGrayed) * faArchive or
  248.               Integer(Hidden.State = cbGrayed) * faHidden or
  249.               Integer(System.State = cbGrayed) * faSysFile;
  250.  
  251.       for i := 0 to Count-1 do
  252.         with TDirItem(Items[i]) do Attr := attrib or (gray and Attr);
  253.     end;
  254. end;
  255.  
  256.  
  257. procedure TFilePropDlg.ReadOnlyClick(Sender: TObject);
  258. begin
  259.   changed := True;
  260. end;
  261.  
  262. procedure TFilePropDlg.TotalLabClick(Sender: TObject);
  263. begin
  264.   Screen.Cursor := crHourGlass;
  265.   try
  266.     with DirInfo((Item as TFolder).Fullname, True) do
  267.       TotalLab.Caption := Format('%d file%s, %d folder%s, %s total',
  268.        [files, OneItem[files = 1], dirs, OneItem[dirs = 1], FormatByte(size)]);
  269.   finally
  270.     Screen.Cursor := crDefault;
  271.   end;
  272. end;
  273.  
  274. procedure TFilePropDlg.ExtractVerInfo;
  275. var Res: TVersion;
  276.  
  277. procedure AddField(const field, info: string);
  278. begin
  279.   if info > '' then Listbox.Items.Add(field + info);
  280. end;
  281.  
  282. begin
  283.   try
  284.     Res := TVersion.Create((Item as TFileItem).Filename);
  285.     if not Res.HasData then Exit;
  286.  
  287.     Listbox.Items.BeginUpdate;
  288.     with Res do begin
  289.       AddField('Product name¼', ProductName);
  290.       AddField('Legal copyright¼', LegalCopyright);
  291.       AddField('Description¼', FileDescription);
  292.       AddField('Type¼', FileType);
  293.       AddField('Subtype¼', FileSubType);
  294.       AddField('File OS¼', FileOS);
  295.       AddField('Comments¼', Comments);
  296.       AddField('Product version¼', ProductVersion);
  297.       AddField('File version¼', FileVersion);
  298.       AddField('Company¼', CompanyName);
  299.       AddField('Legal trademarks¼', LegalTrademarks);
  300.       AddField('Internal name¼', InternalName);
  301.       AddField('Private build¼', PrivateBuild);
  302.       AddField('Special build¼', SpecialBuild);
  303.     end;
  304.     Listbox.Canvas.Font := Font;
  305.     Header.SectionWidth[0] := Listbox.Canvas.TextWidth('Original filename ') + 8;
  306.     Listbox.Items.EndUpdate;
  307.   finally
  308.     Res.Free;
  309.   end;
  310. end;
  311.  
  312. procedure TFilePropDlg.ListboxDrawItem(Control: TWinControl; Index: Integer;
  313.   Rect: TRect; State: TOwnerDrawState);
  314. var
  315.   field : string[31];
  316.   value : string;
  317. begin
  318.   with Listbox do begin
  319.     Unformat(Items[Index], '%s¼%s', [@field, 31, @value, 255]);
  320.     with Canvas do begin
  321.       FillRect(Rect);
  322.       TextOut(Rect.Left + 2, Rect.Top + 1, field);
  323.       TextOut(Rect.Left + Header.SectionWidth[0], Rect.Top + 1, value);
  324.     end;
  325.   end;
  326. end;
  327.  
  328. procedure TFilePropDlg.FormCreate(Sender: TObject);
  329. begin
  330.   Notebook.PageIndex := 0;
  331.   Listbox.ItemHeight := LineHeight;
  332. end;
  333.  
  334. procedure TFilePropDlg.HeaderSized(Sender: TObject; ASection,
  335.   AWidth: Integer);
  336. begin
  337.   Listbox.Invalidate;
  338. end;
  339.  
  340. end.
  341.