home *** CD-ROM | disk | FTP | other *** search
/ PC World Komputer 1998 April A / Pcwk4a98.iso / PROGRAM / DELPHI16 / Calmira / Src / SRC / ICONIC.PAS < prev    next >
Pascal/Delphi Source File  |  1997-02-15  |  7KB  |  254 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 Iconic;
  24.  
  25. interface
  26.  
  27. uses WinTypes, SysUtils, Graphics, FileCtrl, Referenc, Shorts;
  28.  
  29. type
  30.  
  31. TSmallStr = string[15];
  32.  
  33. { TIconic is the base class for all objects which are shown as
  34.   icons in a window.  This includes disk drives, files, folders
  35.   and aliases.
  36.  
  37.     FName - a string to hold a short caption or filename
  38.     FIcon - a pointer which descandants should maintain themselves.
  39.  
  40.     Draw - provides a simple way to display the object by drawing
  41.       the icon with the caption underneath.  Descandants override
  42.       this for more complex drawing.
  43.  
  44.     InternalDraw - does the actual drawing (called by Draw).
  45.  
  46.     Open - abstract method that determines what happens when you
  47.       double click on the object
  48.  
  49.     AssignRef - abstract method that fills the fields of a
  50.       TReference object with information about the TIconic object
  51.  
  52.     CreateShortcut - returns a new shortcut to the object.
  53.       This uses AssignRef so it must be called from descandants.
  54.  
  55.     WriteAlias - creates and alias file for the object, and
  56.       if necessary, updates the window which should display the
  57.       alias.
  58. }
  59.  
  60. TIconic = class
  61. protected
  62.   FName : TSmallStr;
  63.   FIcon : TIcon;
  64.   procedure InternalDraw(Canvas: TCanvas; const Rect: TRect; const Text: string);
  65. public
  66.   procedure Draw(Canvas: TCanvas; const Rect: TRect); virtual;
  67.   procedure Open; virtual; abstract;
  68.   procedure AssignRef(ref: TReference); virtual; abstract;
  69.   function CreateShortcut : TShort;
  70.   procedure WriteAlias(const filename : TFilename);
  71.   property Icon: TIcon read FIcon write FIcon;
  72. end;
  73.  
  74. { TDrive represents a disk drive in the system window.
  75.   TProgram represents a Windows program in the system window.
  76.   Their functionality is minimal. }
  77.  
  78. const
  79.   DefaultDriveNames : array[TDriveType] of string[15] =
  80.     ('Unknown (%s:)', 'No drive! (%s:)', 'Floppy (%s:)', 'Fixed (%s:)',
  81.      'Network (%s:)', 'CDROM (%s:)', 'RAMdisk (%s:)');
  82.  
  83. type
  84.  
  85. TDrive = class(TIconic)
  86. private
  87.   FLetter : Char;
  88.   FDriveType : TDriveType;
  89. public
  90.   constructor Create(ADrive : Char);
  91.   procedure Open; override;
  92.   procedure AssignRef(ref: TReference); override;
  93.   function Root : TFilename;
  94.   property Letter: Char read FLetter;
  95.   property Caption: TSmallStr read FName;
  96. end;
  97.  
  98.  
  99. TProgram = class(TIconic)
  100. private
  101.   FFilename : TFilename;
  102. public
  103.   property Filename : TFilename read FFilename;
  104.   property Caption : TSmallStr read FName write FName;
  105.   constructor Create(const progname: TFilename); virtual;
  106.   destructor Destroy; override;
  107.   procedure AssignRef(ref: TReference); override;
  108.   procedure Open; override;
  109. end;
  110.  
  111. function MakeDriveName(DriveType: TDriveType; Letter: Char): string;
  112.  
  113. implementation
  114.  
  115. uses Classes, Drives, Resource, Desk, WinProcs, ShellAPI, Forms, Settings,
  116.   Alias, Strings, Files, Dialogs, Controls, Streamer, IconWin, MiscUtil;
  117.  
  118. procedure TIconic.Draw(Canvas: TCanvas; const Rect: TRect);
  119. begin
  120.   InternalDraw(Canvas, Rect, FName);
  121. end;
  122.  
  123.  
  124. procedure TIconic.InternalDraw(Canvas: TCanvas;
  125.   const Rect: TRect; const Text: string);
  126. var
  127.   w, tw, iconleft: Integer;
  128.   r : TRect;
  129. begin
  130.   with Canvas, Rect do begin
  131.     w := Right - Left;
  132.     Draw(Left + ((w - 32) div 2), Top+1, FIcon);
  133.  
  134.     tw := TextWidth(Text);
  135.  
  136.     if tw > w then begin
  137.       r := Rect;
  138.       Inc(r.Top, 33);
  139.       DrawText(Handle, @Text[1], Ord(Text[0]), r,
  140.         DT_CENTER or DT_WORDBREAK or DT_NOCLIP or DT_NOPREFIX)
  141.     end
  142.     else
  143.       TextOut(Left + ((w - tw) div 2), Top + 33, Text);
  144.   end;
  145. end;
  146.  
  147.  
  148. function TIconic.CreateShortcut : TShort;
  149. begin
  150.   Result := TShort.Create(Application);
  151.   AssignRef(Result.Ref);
  152. end;
  153.  
  154. procedure TIconic.WriteAlias(const filename : TFilename);
  155. var
  156.   Reference : TReference;
  157.   w : TIconWindow;
  158.   rec : TSearchRec;
  159.   i : Integer;
  160. begin
  161.   if FFileExists(filename) and (MsgDialog('Replace existing alias?',
  162.     mtInformation, [mbYes, mbNo], 0) <> mrYes) then Abort;
  163.  
  164.   Reference := TReference.Create;
  165.   try
  166.     AssignRef(Reference);
  167.     TAlias.Store(filename, Reference, Icon);
  168.  
  169.     w := Desktop.WindowOf(ExtractFileDir(filename));
  170.     if w <> nil then with w do begin
  171.       if FindFirst(filename, faAnyFile, rec) = 0 then
  172.       with Dir do begin
  173.         if Find(ExtractFilename(filename), i) then FreeObject(i);
  174.         AddItem(rec);
  175.         Update;
  176.       end;
  177.     end;
  178.   finally
  179.     Reference.Free;
  180.   end;
  181. end;
  182.  
  183.  
  184. function MakeDriveName(DriveType: TDriveType; Letter: Char): string;
  185. begin
  186.   Letter := Upcase(Letter);
  187.   if DriveNames.Values[Letter] > '' then
  188.     Result := Format(DriveNames.Values[Letter], [Letter])
  189.   else
  190.     Result := Format(DefaultDriveNames[DriveType], [Letter]);
  191. end;
  192.  
  193.  
  194. constructor TDrive.Create(ADrive : Char);
  195. begin
  196.   inherited Create;
  197.   FLetter := Lowcase(ADrive);
  198.   FDriveType := GuessDriveType(FLetter);
  199.   FName := MakeDriveName(FDriveType, FLetter);
  200.   Icon := icons.Drive[FDriveType];
  201. end;
  202.  
  203.  
  204. function TDrive.Root: TFilename;
  205. begin
  206.   Result := Letter + ':\';
  207. end;
  208.  
  209. procedure TDrive.Open;
  210. begin
  211.    Desktop.OpenFolder(Root);
  212. end;
  213.  
  214.  
  215. procedure TDrive.AssignRef(ref: TReference);
  216. begin
  217.   with Ref do begin
  218.     Kind := rkDrive;
  219.     Target := Root;
  220.     Caption := FName;
  221.   end;
  222. end;
  223.  
  224.  
  225. constructor TProgram.Create(const progname: TFilename);
  226. begin
  227.   FFilename := progname;
  228.   FName := ExtractFilename(progname);
  229.   Icon := TIcon.Create;
  230.   Icon.Handle := ExtractIcon(HInstance, StringAsPChar(FFilename), 0);
  231. end;
  232.  
  233. destructor TProgram.Destroy;
  234. begin
  235.   Icon.Free;
  236.   inherited Destroy;
  237. end;
  238.  
  239.  
  240. procedure TProgram.Open;
  241. begin
  242.   WinExec(StringAsPChar(FFilename), SW_SHOW);
  243. end;
  244.  
  245.  
  246. procedure TProgram.AssignRef(ref: TReference);
  247. begin
  248.   ref.Kind := rkFile;
  249.   ref.Target := FFilename;
  250.   ref.Caption := Caption;
  251. end;
  252.  
  253. end.
  254.