fileextassociate.pas

Delphi VCL Component Pack

         bExt := DoExtension(stExt, AppTitle, ExeName, Icon);
      end;
   bSc := DoShortcuts(ExeName, AppTitle);
   if ((FAppShortcuts.FCreateShortcuts and bSc) or
      (FExtensionAssociate.FCreateAssociation and bExt)) then
      Result := True;
   FBusy := False;
   BusyChange;
end;

function TFileExtAssociate.DoExtension(sExt, sTitle, sExeName: string; sIcon: TIcon): Boolean;
begin
   Result := False;
   if FExtensionAssociate.FCreateAssociation then
      begin
         if Assigned(FOnError) then
            FOnError('');
         if Assigned(FOnSuccess) then
            FOnSuccess('');
         sTitle := UpdateAppTitle(sTitle);
         if sTitle = '' then
            Exit;
         sExeName := UpdateAppExeName(sExeName);
         if sExeName = '' then
            Exit;
         sIcon := UpdateIcon(sIcon);
         if sIcon = nil then
            Exit;
         sExt := UpdateExtension(sExt);
         if sExt = '' then
            Exit;
         if RegisterFileType(sExt, sExeName, sIcon) then
            begin
               if Assigned(FOnComplete) then
                  FOnComplete(sExt, 'Registeration successfuly.', S_OK);
               if Assigned(FOnSuccess) then
                  FOnSuccess('Done.');
            end
         else
            if Assigned(FOnError) then
               FOnError('Registration failare');
      end;
end;

function TFileExtAssociate.DoShortcuts(dExeName, dTitle: string): Boolean;
begin
   Result := False;
   if FAppShortcuts.FCreateShortcuts then
      begin
         if Assigned(FOnError) then
            FOnError('');
         if Assigned(FOnSuccess) then
            FOnSuccess('');
         dExeName := UpdateAppExeName(dExeName);
         if dExeName = '' then
            Exit;
         UpdateShortcutItemValue;
         if SendTo in FAppShortcuts.FOptions then
            CreateShortcutSendTo(dExeName, '', '', '', dTitle, SendTo);
         if StartUp in FAppShortcuts.FOptions then
            CreateShortcutStartUp(dExeName, '', '', '', dTitle, StartUp);
         if StartMenu in FAppShortcuts.FOptions then
            CreateShortcutStartMenu(dExeName, '', '', '', dTitle, StartMenu);
         if Desktop in FAppShortcuts.FOptions then
            CreateShortcutDesktop(dExeName, '', '', '', dTitle, Desktop);
         if Programs in FAppShortcuts.FOptions then
            CreateShortcutPrograms(dExeName, '', '', '', dTitle, Programs);
         if QuickLaunch in FAppShortcuts.FOptions then
            CreateShortcutQuickLaunch(dExeName, '', '', '', dTitle, QuickLaunch);
         if ProgramsSubDir in FAppShortcuts.FOptions then
            CreateShortcutOtherFolder(dExeName, FAppShortcuts.FMenuSubDir, '', '',
               dTitle, ProgramsSubDir);
         Result := True;
         if Assigned(FOnSuccess) then
            FOnSuccess('Done.');
      end;
   if (not FAppShortcuts.FCreateShortcuts) and
      (not FExtensionAssociate.FCreateAssociation) then
      if Assigned(FOnComplete) then
         FOnComplete('', 'No action was selected.', S_FALSE);

end;

function TFileExtAssociate.Remove: Boolean;
var
   i: integer;
   stExt: string;
begin
   FBusy := True;
   BusyChange;
   Result := False;
   if Assigned(FOnError) then
      FOnError('');
   if Assigned(FOnSuccess) then
      FOnSuccess('');
   RemoveShortcuts(FApplicationDetails.FAppExeName);
   for i := 0 to FExtensionAssociate.FExtensions.Count - 1 do
      begin
         stExt := FExtensionAssociate.FExtensions[i];
         if UnRegisterFileType(stExt, FApplicationDetails.FAppExeName) then
            begin
               if Assigned(FOnComplete) then
                  FOnComplete(stExt, 'Unregister', S_OK);
               if Assigned(FOnSuccess) then
                  FOnSuccess('Successfuly removed ' + stExt);
               Result := True;
            end
         else
            begin
               if Assigned(FOnComplete) then
                  FOnComplete(stExt, 'Unregister', S_FALSE);
               Result := False;
            end;
      end;
   FBusy := False;
   BusyChange;
end;

function TFileExtAssociate.Remove(Ext: string; ExeName: string): Boolean;
begin
   FBusy := True;
   BusyChange;
   if Assigned(FOnError) then
      FOnError('');
   if Assigned(FOnSuccess) then
      FOnSuccess('');
   RemoveShortcuts(ExeName);
   if UnRegisterFileType(Ext, ExeName) then
      begin
         if Assigned(FOnComplete) then
            FOnComplete(Ext, 'Unregister', S_OK);
         if Assigned(FOnSuccess) then
            FOnSuccess('Successfuly removed ' + Ext);
         Result := True;
      end
   else
      begin
         if Assigned(FOnComplete) then
            FOnComplete(Ext, 'Unregister', S_FALSE);
         Result := False;
      end;
   FBusy := False;
   BusyChange;
end;

function TFileExtAssociate.RegisterFileType(rExt: string; rTitle: string; rIcon: TIcon): Boolean;
begin
   if rExt[1] = '.' then
      rExt := Copy(rExt, 2, MaxInt);
   with TRegistry.Create do
      begin
         try
            RootKey := HKEY_CLASSES_ROOT;
            OpenKey('.' + rExt, True);
            WriteString('', rExt + 'file');
            CloseKey;
            CreateKey(rExt + 'file');
            OpenKey(rExt + 'file\DefaultIcon', True);
            WriteString('', rTitle + ',0');
            CloseKey;
            OpenKey(rExt + 'file\shell\open\command', True);
            WriteString('', rTitle + ' "%1"');
            CloseKey;
            Result := True;
         finally
            Free;
         end;
      end;
   SHChangeNotify(SHCNE_ASSOCCHANGED, SHCNF_IDLIST, nil, nil);
end;

function TFileExtAssociate.UnRegisterFileType(uExt: string; uTitle: string): Boolean;
var
   st: string;
begin
   if uExt = '' then
      begin
         if Assigned(FOnError) then
            FOnError('Can not remove a null extension');
         Result := False;
         exit;
      end;
   with TRegistry.Create do
      begin
         try
            if AnsiPos('.', uExt) = 0 then
               st := '.' + uExt;
            RootKey := HKEY_CLASSES_ROOT;
            if KeyExists(st) then
               DeleteKey(uExt)
            else
               begin
                  if Assigned(FOnError) then
                     FOnError('Error occured while removing ' + st);
                  Result := False;
               end;
            if uExt[1] = '.' then
               uExt := Copy(uExt, 2, MaxInt);
            if KeyExists(uExt + 'file') then
               DeleteKey(uExt + 'file')
            else
               begin
                  if Assigned(FOnError) then
                     FOnError('Error occured while removing ' + uExt + 'file');
                  Result := False;
               end;
            Result := True;
         finally
            Free;
         end;
      end;
   SHChangeNotify(SHCNE_ASSOCCHANGED, SHCNF_IDLIST, nil, nil);
end;

// Shortcuts====================================================================

function TFileExtAssociate.CreateShortcut(SourceFileName: string; ShellFolder: TShortcutItems;
   SubFolder, WorkingDir, Parameters, Description: string): string; //Idea by Smot
var
   MyObject: IUnknown;
   MySLink: IShellLink;
   MyPFile: IPersistFile;
   FolderPath, LinkName: string;
   ShortcutFile: WideString;
   Reg: TRegIniFile;
begin
   MyObject := CreateComObject(CLSID_ShellLink);
   MySLink := MyObject as IShellLink;
   MyPFile := MyObject as IPersistFile;
   MySLink.SetPath(PChar(SourceFileName));
   MySLink.SetArguments(PChar(Parameters));
   MySLink.SetDescription(PChar(Description));
   LinkName := ChangeFileExt(SourceFileName, '.lnk');
   LinkName := ExtractFileName(LinkName);
   if LinkName = '' then
      begin
         if Assigned(FOnError) then
            FOnError('Error occured creating link.');
         Result := '';
         Exit;
      end
   else
      begin
         Reg := TRegIniFile.Create(SHELL_FOLDERS_ROOT);
         try
            case ShellFolder of
               ProgramsSubDir: FolderPath := Reg.ReadString('Shell Folders',
                     'Programs', '') + '\' + SubFolder;
               Desktop: FolderPath := Reg.ReadString('Shell Folders', 'Desktop', '');
               StartUp: FolderPath := Reg.ReadString('Shell Folders', 'Startup', '');
               StartMenu: FolderPath := Reg.ReadString('Shell Folders', 'Start Menu', '');
               SendTo: FolderPath := Reg.ReadString('Shell Folders', 'SendTo', '');
               Programs: FolderPath := Reg.ReadString('Shell Folders', 'Programs', '');
               QuickLaunch: FolderPath := Reg.ReadString('Shell Folders', 'AppData', '') +
                  '\Microsoft\Internet Explorer\Quick Launch';
            end;
         finally
            Reg.Free;
         end;
      end;
   if FolderPath <> '' then
      begin
         if (SubFolder <> '') and (ShellFolder = ProgramsSubDir) then
            begin
               if CreateDir(FolderPath) then
                  ShortcutFile := FolderPath + '\' + LinkName;
            end
         else
            if (SubFolder <> '') and (ShellFolder <> ProgramsSubDir) then
               ShortcutFile := FolderPath + '\' + SubFolder + '\' + LinkName
            else
               ShortcutFile := FolderPath + '\' + LinkName;
         if WorkingDir = '' then
            MySLink.SetWorkingDirectory(PChar(ExtractFilePath(SourceFileName)))
         else
            MySLink.SetWorkingDirectory(PChar(WorkingDir));
         MyPFile.Save(PWChar(ShortcutFile), False);
         Result := ShortcutFile;
      end
   else
      begin
         if Assigned(FOnError) then
            FOnError('Error occured while locating path to the shortcut.');
         Result := '';
         Exit;
      end;
end;

function TFileExtAssociate.CreateShortcutSendTo(cExeName, cSubDir, cWorkDir, cParam, cTitle: string; CShellDir: TShortcutItems): HResult;
begin
   Result := S_OK;
   CreateShortcut(cExeName, CShellDir, '', '', '', cTitle);
   if Assigned(FOnShortcut) then
      FOnShortcut('SendTo', 'Add', Result);
end;

function TFileExtAssociate.CreateShortcutStartUp(cExeName, cSubDir, cWorkDir, cParam, cTitle: string; CShellDir: TShortcutItems): HResult;
begin
   Result := S_OK;
   CreateShortcut(cExeName, CShellDir, '', '', '', cTitle);
   if Assigned(FOnShortcut) then
      FOnShortcut('StartUp', 'Add', Result);
end;

function TFileExtAssociate.CreateShortcutStartMenu(cExeName, cSubDir, cWorkDir, cParam, cTitle: string; CShellDir: TShortcutItems): HResult;
begin
   Result := S_OK;
   CreateShortcut(cExeName, CShellDir, '', '', '', cTitle);
   if Assigned(FOnShortcut) then
      FOnShortcut('StartMenu', 'Add', Result);
end;

function TFileExtAssociate.CreateShortcutPrograms(cExeName, cSubDir, cWorkDir, cParam, cTitle: string; CShellDir: TShortcutItems): HResult;
begin
   Result := S_OK;
   CreateShortcut(cExeName, CShellDir, '', '', '', cTitle);
   if Assigned(FOnShortcut) then
      FOnShortcut('Programs', 'Add', Result);
end;

function TFileExtAssociate.CreateShortcutDesktop(cExeName, cSubDir, cWorkDir, cParam, cTitle: string; CShellDir: TShortcutItems): HResult;
begin