fileextassociate.pas

Delphi VCL Component Pack

//***********************************************************
//                       TFileExtAssociate                  *
//                                                          *
//               For Delphi 5,6, 7 , 2005, 2006             *
//                     Freeware Component                   *
//                            by                            *
//                     Eran Bodankin (bsalsa)               *
//                     [e-mail]                    *
//                                                          *
//           Based on idea by:  Zarko Gajic                 *
//                                                          *
//     Documentation and updated versions:                  *
//               http://www.bsalsa.com                      *
//***********************************************************

{*******************************************************************************}
{LICENSE:
THIS SOFTWARE IS PROVIDED TO YOU "AS IS" WITHOUT WARRANTY OF ANY KIND,
EITHER EXPRESSED OR IMPLIED INCLUDING BUT NOT LIMITED TO THE APPLIED
WARRANTIES OF MERCHANTABILITY AND/OR FITNESS FOR A PARTICULAR PURPOSE.
YOU ASSUME THE ENTIRE RISK AS TO THE ACCURACY AND THE USE OF THE SOFTWARE
AND ALL OTHER RISK ARISING OUT OF THE USE OR PERFORMANCE OF THIS SOFTWARE
AND DOCUMENTATION. [YOUR NAME] DOES NOT WARRANT THAT THE SOFTWARE IS ERROR-FREE
OR WILL OPERATE WITHOUT INTERRUPTION. THE SOFTWARE IS NOT DESIGNED, INTENDED
OR LICENSED FOR USE IN HAZARDOUS ENVIRONMENTS REQUIRING FAIL-SAFE CONTROLS,
INCLUDING WITHOUT LIMITATION, THE DESIGN, CONSTRUCTION, MAINTENANCE OR
OPERATION OF NUCLEAR FACILITIES, AIRCRAFT NAVIGATION OR COMMUNICATION SYSTEMS,
AIR TRAFFIC CONTROL, AND LIFE SUPPORT OR WEAPONS SYSTEMS. VSOFT SPECIFICALLY
DISCLAIMS ANY EXPRESS OR IMPLIED WARRANTY OF FITNESS FOR SUCH PURPOSE.

You may use, change or modify the component under 3 conditions:
1. In your website, add a link to "http://www.bsalsa.com"
2. In your application, add credits to "Embedded Web Browser"
3. Mail me ([e-mail]) any code change in the unit
   for the benefit of the other users.
{*******************************************************************************}

unit FileExtAssociate;

interface

{$I EWB.inc}

uses
   Dialogs, Windows, Classes, Graphics, Forms;

type
   TFileInfo = record
      Icon: hIcon;
      Image: Integer;
      DisplayName: string;
      TypeName: string;
      Size: Integer;
      SizeAsString: string;
      DateTime: TDateTime;
   end;

type
   TOnErrorEvent = procedure(Text: string) of object;
   TOnSuccessEvent = procedure(Text: string) of object;
   TOnCompleteEvent = procedure(Extension, Status: string; HResult: HResult) of object;
   TOnShortcutEvent = procedure(ShortcutItem, Status: string; HResult: HResult) of object;
   TShortcutItems = (SendTo, StartMenu, StartUp, Desktop, OpenWith, Programs,
      QuickLaunch, ProgramsSubDir);
   TShortcutItem = set of TShortcutItems;

   TAppShortcuts = class(TPersistent)
   private
      FCreateShortcuts: Boolean;
      FOptions: TShortcutItem;
      FMenuSubDir: WideString;
      FOnShortcut: TOnShortcutEvent;
   public
   published
      property CreateShortcuts: boolean read FCreateShortcuts write FCreateShortcuts default True;
      property Options: TShortcutItem read FOptions write FOptions default [OpenWith];
      property MenuSubDir: WideString read FMenuSubDir write FMenuSubDir;
      property OnShortcutEvent: TOnShortcutEvent read FOnShortcut write FOnShortcut;
   end;

   TExtensionAssociate = class(TPersistent)
   private
      FCreateAssociation: Boolean;
      FExtensions: TStrings;
   protected
      procedure SetExtensions(Value: TStrings);
   public
   published
      property CreateAssociation: boolean read FCreateAssociation write FCreateAssociation default True;
      property Extensions: TStrings read FExtensions write SetExtensions;
   end;

   TAppDetails = class(TPersistent)
   private
      FAppTitle: string;
      FAppExeName: string;
      FIcon: TIcon;
   published
      property Title: string read FAppTitle write FAppTitle;
      property ExeName: string read FAppExeName write FAppExeName;
      property Icon: TIcon read FIcon write FIcon;
   end;

type
   TFileExtAssociate = class(TComponent)
   private
      FAbout: string;
      FBusy: Boolean;
      FOnBusy: TNotifyEvent;
      FEnabled: Boolean;
      FApplicationDetails: TAppDetails;
      FExtensionAssociate: TExtensionAssociate;
      FOnError: TOnErrorEvent;
      FOnSuccess: TOnSuccessEvent;
      FOnComplete: TOnCompleteEvent;
      FOnShortcut: TOnShortcutEvent;
      FAppShortcuts: TAppShortcuts;
      function RegisterFileType(rExt: string; rTitle: string; rIcon: TIcon): Boolean;
      function UnRegisterFileType(uExt: string; uTitle: string): Boolean;
      function UpdateAppExeName(sExeName: string): string;
      function UpdateIcon(sIcon: TIcon): TIcon;
      function UpdateAppTitle(sTitle: string): string;
      function UpdateExtension(sExt: string): string;
      function CreateShortcut(SourceFileName: string; ShellFolder: TShortcutItems;
         SubFolder, WorkingDir, Parameters, Description: string): string;
      function DoExtension(sExt, sTitle, sExeName: string; sIcon: TIcon): Boolean;
      function DoShortcuts(dExeName, dTitle: string): Boolean;
      procedure BusyChange; dynamic;
   protected
      procedure SetAbout(Value: string);
      function UpdateShortcutItemValue: LongInt;
   public
      constructor Create(AOwner: TComponent); override;
      destructor Destroy; override;
      function Exceute: Boolean; overload;
      function Exceute(Extension, AppTitle, ExeName: string; Icon: TIcon): Boolean; overload;
      function Exceute(Extensions: TStrings; AppTitle, ExeName: string; Icon: TIcon): Boolean; overload;
      function Remove: Boolean; overload;
      function Remove(Ext: string; ExeName: string): Boolean; overload;
      function GetExeByExtension(sExt: string): string;
      function GetIconByExtension(Extension: string; Small: Boolean): HIcon;
      function GetFileDisplayName(const Path: string): string;
      function GetFileSize(const Path: string): string;
      function GetFileTypeName(const Path: string): string;
      function GetFileIcon(const Path: string): HIcon;
      function GetFileImage(const Path: string): integer;
      function GetFileDateTime(const Path: string): TDateTime;
      function CreateShortcutSendTo(cExeName, cSubDir, cWorkDir, cParam,
         cTitle: string; CShellDir: TShortcutItems): HResult;
      function CreateShortcutStartUp(cExeName, cSubDir, cWorkDir, cParam,
         cTitle: string; CShellDir: TShortcutItems): HResult;
      function CreateShortcutStartMenu(cExeName, cSubDir, cWorkDir, cParam,
         cTitle: string; CShellDir: TShortcutItems): HResult;
      function CreateShortcutDesktop(cExeName, cSubDir, cWorkDir, cParam,
         cTitle: string; CShellDir: TShortcutItems): HResult;
      function CreateShortcutPrograms(cExeName, cSubDir, cWorkDir, cParam,
         cTitle: string; CShellDir: TShortcutItems): HResult;
      function CreateShortcutQuickLaunch(cExeName, cSubDir, cWorkDir, cParam,
         cTitle: string; CShellDir: TShortcutItems): HResult;
      function CreateShortcutOtherFolder(cExeName, cSubDir, cWorkDir, cParam,
         cTitle: string; CShellDir: TShortcutItems): HResult;
      function RemoveShortcuts(rmExeName: string): HResult;
      property Busy: Boolean read FBusy write FBusy default False;
   published
      property About: string read FAbout write SetAbout;
      property Enabled: boolean read FEnabled write FEnabled default True;
      property ExtensionAssociate: TExtensionAssociate read FExtensionAssociate write FExtensionAssociate;
      property ApplicationDetails: TAppDetails read FApplicationDetails write FApplicationDetails;
      property ApplicationShortcuts: TAppShortcuts read FAppShortcuts write FAppShortcuts;
      property OnBusyStateChange: TNotifyEvent read FOnBusy write FOnBusy;
      property OnErrorText: TOnErrorEvent read FOnError write FOnError;
      property OnSuccessText: TOnSuccessEvent read FOnSuccess write FOnSuccess;
      property OnComplete: TOnCompleteEvent read FOnComplete write FOnComplete;
      property OnShortcutEvent: TOnShortcutEvent read FOnShortcut write FOnShortcut;
   end;

implementation

uses
   ShellAPI, SysUtils, ActiveX, Registry, ShlObj, ComObj, IEConst;

// ExtensionAssociate===========================================================

procedure TExtensionAssociate.SetExtensions(Value: TStrings);
begin
   FExtensions.Assign(Value)
end;
// FileExtAssociate=============================================================

constructor TFileExtAssociate.Create;
begin
   FAbout := 'File Extension Associate component by bsalsa. ' + WEB_SITE;
   FApplicationDetails := TAppDetails.Create;
   FApplicationDetails.FIcon := Application.Icon;
   FEnabled := True;
   FAppShortcuts := TAppShortcuts.Create;
   FAppShortcuts.FOptions := [OpenWith];
   FAppShortcuts.FCreateShortcuts := True;
   FExtensionAssociate := TExtensionAssociate.Create;
   FExtensionAssociate.FExtensions := TStringList.Create;
   FExtensionAssociate.FCreateAssociation := True;
   inherited;
end;

destructor TFileExtAssociate.Destroy;
begin
   FApplicationDetails.Free;
   FAppShortcuts.Free;
   FExtensionAssociate.FExtensions.Free;
   FExtensionAssociate.Free;
   inherited Destroy;
end;

procedure TFileExtAssociate.SetAbout(Value: string);
begin
   Exit;
end;

procedure TFileExtAssociate.BusyChange;
begin
   if Assigned(FOnBusy) then
      FOnBusy(Self);
end;

function TFileExtAssociate.UpdateAppExeName(sExeName: string): string;
begin
   if sExeName = '' then
      sExeName := Application.ExeName;
   FApplicationDetails.FAppExeName := sExeName;
   Result := sExeName;
   if not FileExists(sExeName) then
      begin
         if Assigned(FOnError) then
            FOnError('Can not locate your Exe name and path');
         Result := '';
      end;
end;

function TFileExtAssociate.UpdateAppTitle(sTitle: string): string;
begin
   if sTitle = '' then
      sTitle := Application.Title;
   FApplicationDetails.FAppTitle := sTitle;
   if sTitle = '' then
      begin
         if Assigned(FOnError) then
            FOnError('Please Enter a valid application title');
         Result := '';
      end
   else
      Result := sTitle;
end;

function TFileExtAssociate.UpdateIcon(sIcon: TIcon): TIcon;
begin
   if (sIcon = nil) then
      sIcon := Application.Icon;
   FApplicationDetails.FIcon := sIcon;
   Result := sIcon;
end;

function TFileExtAssociate.UpdateExtension(sExt: string): string;
begin
   if sExt = '' then
      begin
         if Assigned(FOnError) then
            FOnError('Please Enter a valid extension');
      end;
   Result := sExt;
end;

function TFileExtAssociate.Exceute: Boolean;
var
   i: integer;
   stExt: string;
   bExt, bSc: Boolean;
begin
   FBusy := True;
   BusyChange;
   bExt := False;
   Result := bExt;
   for i := 0 to FExtensionAssociate.FExtensions.Count - 1 do
      begin
         stExt := FExtensionAssociate.FExtensions[i];
         bExt := DoExtension(stExt, FApplicationDetails.FAppTitle,
            FApplicationDetails.FAppExeName, FApplicationDetails.FIcon);
      end;
   bSc := DoShortcuts(FApplicationDetails.FAppExeName, FApplicationDetails.FAppTitle);
   if ((FAppShortcuts.FCreateShortcuts and bSc) or
      (FExtensionAssociate.FCreateAssociation and bExt)) then
      Result := True;
   FBusy := False;
   BusyChange;
end;

function TFileExtAssociate.Exceute(Extension, AppTitle, ExeName: string; Icon:
   TIcon): Boolean;
begin
   FBusy := True;
   BusyChange;
   Result := False;
   if DoExtension(Extension, AppTitle, ExeName, Icon) and
      DoShortcuts(ExeName, AppTitle) then
      Result := True;
   FBusy := False;
   BusyChange;
end;

function TFileExtAssociate.Exceute(Extensions: TStrings; AppTitle, ExeName: string;
   Icon: TIcon): Boolean;
var
   i: integer;
   stExt: string;
   bExt, bSc: Boolean;
begin
   FBusy := True;
   BusyChange;
   bExt := False;
   Result := bExt;
   for i := 0 to Extensions.Count - 1 do
      begin
         stExt := Extensions[i];