home *** CD-ROM | disk | FTP | other *** search
/ PC World Komputer 1998 April A / Pcwk4a98.iso / PROGRAM / DELPHI16 / Calmira / Src / SRC / RESOURCE.PAS < prev    next >
Pascal/Delphi Source File  |  1997-02-15  |  13KB  |  433 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 Resource;
  24.  
  25. interface
  26.  
  27. uses Graphics, Classes, FileCtrl, ObjList, Strings;
  28.  
  29. type
  30.   { Icons, cursors and some bitmaps are handled by this module.
  31.  
  32.     TIconList manages a large number of icons extracted from
  33.     different files.  By keeping track of where each icon comes from,
  34.     it ensures that a particular icon is only loaded once, thus saving
  35.     memory and disk accesses.  Icons are loaded only when they are
  36.     required.
  37.  
  38.     The icon cache is only maintained for "document" files, because they
  39.     are likely to appear often.  Keeping icons for programs would just
  40.     waste memory because they are only used once or twice.
  41.  
  42.     The icon list is a string list, with each string associated with an
  43.     icon object, which may be nil. For example,
  44.  
  45.     bmp   [an icon ]
  46.     txt   [  nil   ]
  47.     bat   [  nil   ]
  48.  
  49.     ExtensionMap holds a list of file extensions and where the
  50.     representative icon is stored.  For example
  51.  
  52.     bmp=c:\windows\pbrush.exe(0)
  53.     txt=c:\windows\notepad.exe
  54.     bat=c:\windows\notepad.exe
  55.  
  56.     FileMap holds a list of filenames, and the objects array holds
  57.     icon objects, which can also be nil.
  58.  
  59.     c:\windows\pbrush.exe(0)  [ an icon ]
  60.     c:\windows\notepad.exe(0) [   nil   ]
  61.  
  62.  
  63.     When Get() is called, the icon list searches itself for a matching
  64.     key.  If it finds a match plus an icon, the icon is returned, making
  65.     the access fast.  If it finds a match but a nil pointer, the search
  66.     extends to ExtensionMap.
  67.  
  68.     With the data above, Get('bat') will find NIL, so it looks at the
  69.     extensions and finds the reference to Notepad.  Looking through FileMap
  70.     shows that no icon is available for Notepad, so it must be extracted.
  71.     The two nils encountered are overwritten with the TIcon object.
  72.  
  73.     Now consider Get('txt').  The icon list still has no icon but now,
  74.     FileMap has an icon entry for notepad.exe, so the icon object is
  75.     returned and the main list updated.  The next search for 'txt' will
  76.     find an icon immediately.
  77.   }
  78.  
  79.  
  80.   TIconlist = class(TUniqueStrings)
  81.   private
  82.     ExtensionMap, FileMap : TStringList;
  83.     Store : TObjectList;
  84.     function GetDriveIcon(dtype: TDriveType) : TIcon;
  85.   public
  86.     constructor Create;
  87.     destructor Destroy; override;
  88.     procedure AddIcon(const s: string; Icon: TIcon);
  89.     procedure DelayLoad(const key: string; filename: string);
  90.     function Get(const s: string): TIcon;
  91.     property Drive[dtype: TDriveType] : TIcon read GetDriveIcon;
  92.   end;
  93.  
  94.   TResBitmap = class(TBitmap)
  95.   private
  96.     ResID : PChar;
  97.     ExternalFile : PString;
  98.   public
  99.     constructor Load(BitmapName : PChar);
  100.     constructor AlternateLoad(BitmapName : PChar; const Filename: string);
  101.     procedure Reload;
  102.   end;
  103.  
  104. const
  105.   crDropFile      = -20;
  106.   crDropCopy      = -21;
  107.   crDropMulti     = -22;
  108.   crDropMultiCopy = -23;
  109.   crFinger        = -24;
  110.   crFlutter       = -25;
  111.   crBusyPointer   = -26;
  112.  
  113.  
  114. var
  115.   Icons: TIconList;
  116.   FolderIcon  : TIcon;
  117.   FileIcon    : TIcon;
  118.   LetterIcon  : TIcon;
  119.   WindowsIcon : TIcon;
  120.   DOSIcon     : TIcon;
  121.   TinyFile    : TIcon;
  122.   TinyFolder  : TIcon;
  123.   TinyProg    : TIcon;
  124.  
  125.   Sizebox    : TResBitmap;
  126.   ShortArrow : TResBitmap;
  127.   AliasArrow : TResBitmap;
  128.  
  129.  
  130. procedure LoadResources;
  131.  
  132. implementation
  133.  
  134. {$R ICONS.RES}
  135. {$R BITMAPS.RES}
  136. {$R CURSORS.RES}
  137.  
  138. uses SysUtils, WinProcs, ShellAPI, IniFiles, Forms, Controls,
  139.   Files, MiscUtil, Drives, WinTypes, Settings, Environs;
  140.  
  141. { TIconList }
  142.  
  143. constructor TIconList.Create;
  144. begin
  145.   inherited Create;
  146.   Store := TObjectList.Create;
  147.   ExtensionMap := TUniqueStrings.Create;
  148.   FileMap := TUniqueStrings.Create;
  149. end;
  150.  
  151.  
  152. destructor TIconList.Destroy;
  153. begin
  154.   Store.Free;
  155.   ExtensionMap.Free;
  156.   FileMap.Free;
  157.   inherited Destroy;
  158. end;
  159.  
  160.  
  161. procedure TIconList.AddIcon(const s: string; Icon: TIcon);
  162. begin
  163.   AddObject(s, Icon);
  164.   Store.Add(Icon);
  165. end;
  166.  
  167.  
  168. procedure TIconList.DelayLoad(const key: string; filename: string);
  169. begin
  170.   Add(key);
  171.   if ExtensionMap.Values[key] = '' then begin
  172.     filename := EnvironSubst(filename);
  173.     ExtensionMap.Add(Format('%s=%s', [key, filename]));
  174.     FileMap.Add(filename);
  175.   end;
  176. end;
  177.  
  178.  
  179. function TIconList.Get(const s: string): TIcon;
  180. var
  181.   i, j, index: Integer;
  182.   h : HIcon;
  183.   filename : TFilename;
  184. begin
  185.   i := IndexOf(s);
  186.  
  187.   if i <> -1 then begin
  188.     Result := TIcon(Objects[i]);
  189.  
  190.     if Result = nil then begin
  191.       { no icon in main list }
  192.       j := FileMap.IndexOf(ExtensionMap.Values[s]);
  193.  
  194.       if j = -1 then
  195.         { shouldn't really happen! }
  196.         j := FileMap.Add(ExtensionMap.Values[s]);
  197.  
  198.       if FileMap.Objects[j] = nil then begin
  199.         { try to extract icon }
  200.         filename := '';
  201.         index := 0;
  202.         Unformat(FileMap[j], '%s(%d', [@filename, 79, @index]);
  203.         h := ExtractIcon(HInstance, StringAsPChar(filename), index);
  204.  
  205.         if h > 1 then begin
  206.           { a new icon has been found }
  207.           Result := TIcon.Create;
  208.           Result.Handle := h;
  209.           Store.Add(Result);
  210.           FileMap.Objects[j] := Result;
  211.           Objects[i] := Result
  212.         end
  213.         else begin
  214.           { the file doesn't contain an icon so assign default }
  215.           Result := LetterIcon;
  216.           FileMap.Objects[j] := LetterIcon;
  217.           Objects[i] := LetterIcon;
  218.         end;
  219.       end
  220.       else begin
  221.         { Found an icon in FileMap }
  222.         Result := TIcon(FileMap.Objects[j]);
  223.         Objects[i] := Result;
  224.       end;
  225.     end
  226.   end
  227.   else Result := FileIcon;
  228. end;
  229.  
  230.  
  231. function TIconList.GetDriveIcon(dtype : TDriveType) : TIcon;
  232. const
  233.   DriveIdents : array[TDriveType] of string[15] =
  234.    ('HardDrive', 'HardDrive', 'FloppyDrive', 'HardDrive',
  235.     'NetworkDrive', 'CDROMDrive', 'RamDrive');
  236. begin
  237.   Result := Get(DriveIdents[dtype]);
  238. end;
  239.  
  240.  
  241. { TResBitmap }
  242.  
  243. constructor TResBitmap.Load(BitmapName : PChar);
  244. begin
  245.   inherited Create;
  246.   ResID := BitmapName;
  247.   ExternalFile := NullStr;
  248.   Reload;
  249. end;
  250.  
  251. constructor TResBitmap.AlternateLoad(BitmapName : PChar; const Filename: string);
  252. begin
  253.   inherited Create;
  254.   ResID := BitmapName;
  255.   AssignStr(ExternalFile, Filename);
  256.   Reload;
  257. end;
  258.  
  259. procedure TResBitmap.ReLoad;
  260. begin
  261.   if (ExternalFile^ > '') and FileExists(ExternalFile^) then
  262.     LoadFromFile(ExternalFile^)
  263.   else
  264.     Handle := LoadBitmap(HInstance, ResID);
  265. end;
  266.  
  267.  
  268. function LoadSystemIcon(const key, alt: string; ResID: PChar): TIcon;
  269. begin
  270.   Result := TIcon.Create;
  271.  
  272.   if Icons.IndexOf(alt) > -1 then
  273.     Result.Assign(Icons.Get(alt))
  274.   else
  275.     Result.Handle := LoadIcon(HInstance, ResID);
  276.  
  277.   Icons.AddIcon(key, Result);
  278. end;
  279.  
  280.  
  281. function LoadProgmanIcon(const key, alt: string; index: Integer): TIcon;
  282. var buf: array[0..79] of Char;
  283. begin
  284.   Result := TIcon.Create;
  285.  
  286.   if Icons.IndexOf(alt) > -1 then
  287.     Result.Assign(Icons.Get(alt))
  288.   else
  289.     Result.Handle := ExtractIcon(HInstance,
  290.       StrPCopy(buf, WinPath + 'progman.exe'), index);
  291.  
  292.   Icons.AddIcon(key, Result);
  293. end;
  294.  
  295.  
  296. procedure LoadSystemIcons;
  297. begin
  298.   FolderIcon  := LoadSystemIcon('Folder', '_folder', 'FOLDERICON');
  299.   FileIcon    := LoadSystemIcon('File', '_file', 'FILEICON');
  300.   LetterIcon  := LoadSystemIcon('Letter', '_doc', 'LETTERICON');
  301.   TinyFile    := LoadSystemIcon('TinyFile', '_tfile', 'TINYFILEICON');
  302.   TinyProg    := LoadSystemIcon('TinyProg', '_tprog', 'TINYPROGICON');
  303.   TinyFolder  := LoadSystemIcon('TinyFolder', '_tfolder', 'TINYFOLDERICON');
  304.  
  305.   DOSIcon     := LoadProgmanIcon('MSDOS', '_msdos', 1);
  306.   WindowsIcon := LoadProgmanIcon('Windows', '_windows', 8);
  307.  
  308.   LoadSystemIcon('MultiFile', '_multi', 'MULTIFILEICON');
  309.   LoadSystemIcon('HardDrive', '_hard', 'HARDICON');
  310.   LoadSystemIcon('FloppyDrive', '_floppy', 'FLOPPYICON');
  311.   LoadSystemIcon('CDROMDrive', '_cdrom', 'CDROMICON');
  312.   LoadSystemIcon('NetworkDrive', '_network', 'NETWORKICON');
  313.   LoadSystemIcon('RamDrive', '_ramdisk', 'RAMDISKICON');
  314.   LoadSystemIcon('EmptyBin', '_emptbin', 'BINICON');
  315.   LoadSystemIcon('FullBin', '_fullbin', 'FULLBINICON');
  316.   LoadSystemIcon('System', '_system', 'SYSTEMICON');
  317.   LoadSystemIcon('Explorer', '_explore', 'EXPLORERICON');
  318.   LoadSystemIcon('FindDialog', '_finddlg', 'FINDDLGICON');
  319.   LoadSystemIcon('RunDialog', '_rundlg', 'RUNDLGICON');
  320. end;
  321.  
  322.  
  323. procedure LoadUserIcons;
  324. var
  325.   key : string[31];
  326.   temp : TStringList;
  327.   i : Integer;
  328.   path, filename : TFilename;
  329. begin
  330.   temp := TStringList.Create;
  331.   try
  332.     { Find all *.ICO files in the home directory (or directory specified in
  333.       the UserIcons value).  Discard their file extensions and add the
  334.       filenames to the internal lists }
  335.  
  336.     path := ini.ReadString('File System', 'UserIcons', ApplicationPath);
  337.     if path = '' then path := ApplicationPath;
  338.     path := MakePath(path);
  339.  
  340.     FindFiles(path + '*.ico', faArchive or faReadOnly, temp);
  341.  
  342.     for i := 0 to temp.Count-1 do begin
  343.       Unformat(Lowercase(temp[i]), '%s.', [@key, 31]);
  344.       Icons.DelayLoad(key, Format('%s%s(0)', [path, temp[i]]));
  345.     end;
  346.  
  347.     { Add all entries from the [Icons] section }
  348.     temp.Clear;
  349.     ini.ReadSectionValues('Icons', temp);
  350.     for i := 0 to temp.Count-1 do begin
  351.       Unformat(Lowercase(temp[i]), '%s=%s', [@key, 31, @filename, 79]);
  352.       Icons.DelayLoad(key, filename);
  353.     end;
  354.   finally
  355.     temp.Free;
  356.   end;
  357. end;
  358.  
  359.  
  360. procedure LoadRegisteredIcons;
  361. var
  362.   ext : string[15];
  363.   win : TIniFile;
  364.   progname : TFilename;
  365.   i : Integer;
  366.   temp : TStringList;
  367. begin
  368.   { Read [Extensions] section from WIN.INI }
  369.  
  370.   temp := TStringList.Create;
  371.   try
  372.     temp.Clear;
  373.     win := TIniFile.Create('WIN.INI');
  374.     win.ReadSectionValues('Extensions', temp);
  375.     win.Free;
  376.  
  377.     for i := 0 to temp.Count-1 do begin
  378.       Unformat(Lowercase(temp[i]), '%s=%s ', [@ext, 15, @progname, 79]);
  379.       if ExtractFilePath(progname) = '' then progname := WinPath + progname;
  380.       Icons.DelayLoad(ext, progname + '(0)');
  381.     end;
  382.   finally
  383.     temp.Free;
  384.   end;
  385. end;
  386.  
  387.  
  388. procedure LoadCursors;
  389. begin
  390.   with Screen do begin
  391.     Cursors[crDropFile]      := LoadCursor(HInstance, 'DROPFILE');
  392.     Cursors[crDropMulti]     := LoadCursor(HInstance, 'DROPMULTIFILE');
  393.     Cursors[crDropCopy]      := LoadCursor(HInstance, 'DROPFILECOPY');
  394.     Cursors[crDropMultiCopy] := LoadCursor(HInstance, 'DROPMULTIFILECOPY');
  395.     Cursors[crFinger]        := LoadCursor(HInstance, 'FINGERPRESS');
  396.     Cursors[crFlutter]       := LoadCursor(HInstance, 'FILEFLUTTER');
  397.     Cursors[crNoDrop]        := LoadCursor(HInstance, 'DRAGFILE');
  398.     Cursors[crBusyPointer]   := LoadCursor(HInstance, 'BUSYPOINTER');
  399.   end;
  400. end;
  401.  
  402.  
  403. procedure LoadResources;
  404. begin
  405.   LoadUserIcons;
  406.   LoadSystemIcons;
  407.   LoadRegisteredIcons;
  408.   LoadCursors;
  409. end;
  410.  
  411.  
  412. procedure InitResources;
  413. begin
  414.   Icons := TIconList.Create;
  415.   SizeBox := TResBitmap.Load('SIZEBOX');
  416.   ShortArrow := TResBitmap.Load('SHORTARROW');
  417.   AliasArrow := TResBitmap.Load('SHORTARROW');
  418. end;
  419.  
  420. procedure DoneResources; far;
  421. begin
  422.   Icons.Free;
  423.   Sizebox.Free;
  424.   ShortArrow.Free;
  425.   AliasArrow.Free;
  426. end;
  427.  
  428.  
  429. initialization
  430.   InitResources;
  431.   AddExitProc(DoneResources);
  432. end.
  433.