BadBoyAlex писал(а):Желательно, в любой момент из самой программы.
Дык это ж мазохизм.
1) Системы Windows разные (я так подозреваю). Например, что замутишь в семерке, на десятке уже может и не пойти. Зачем на будущее оставлять этот головняк?
2) На сколько я понял, приложение туда попадает само после правильной установки ассоциации расширения с приложением
3) Даже правильно проведя ассоциацию, необходимо делать rebuild icon cashe
4) Время лучше потратить на более нужные для пользователей возможности программы
5) и т.д.
Вот мой модуль, тут есть функции и свойства для тестирования, но не забывайте про пункт (3). Но опять же повторю, доделав решение, я удалил его из проекта, т.к. радости и уверенности в завтрашней работоспособности у меня не было.
- Код: Выделить всё
unit UAssociation;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, Registry, Dialogs, Forms, ShlObj;
type
//////////////////// TAssociation /////////////////////
// Методы класса производят ассоциацию (или её удаление)
// моей проги с файлами заданного расширения
// Это нужно чтобы они открывались по двойному щелчку
// Кроме ассоцияции нужно еще передавать имя файла командной
// строкой ParamStr(1) см. UfMain -> TfMain.FormCreate
TAssociation = class // ассоциация расширения файла проекта с программой в Windows
private
fExtension: string; // расширение файла без точки
fExeName: string; // название ехе-шника (путь + название)
fProgName: string; // название программы, будет использовано только в реестре
fIconIndex: integer; // индекс иконки в ехе-шнике, для моих проектов индекс = 1 (0 - иконка приложения)
protected
procedure SetExtension(NewExt: string);
public
function GetExeNameByExtension(sExt: string = ''): string;
property Extension: string read fExtension write SetExtension;
property ExeName: string read fExeName write fExeName;
property ProgName: string read fProgName write fProgName;
property IconIndex: integer read fIconIndex write fIconIndex;
procedure MakeAssociation;
procedure DeleteAssociation;
constructor Create;
end;
implementation
procedure TAssociation.SetExtension(NewExt: string);
begin
if NewExt[1] = '.'
then // убираю точку в начале, если есть
fExtension := Copy(NewExt, 2, MaxInt)
else fExtension := NewExt;
end;
procedure TAssociation.MakeAssociation;
var
Reg: TRegistry;
sKey, sVal: AnsiString;
procedure WriteToReg;
begin
Reg.OpenKey(sKey, True);
Reg.WriteString('', sVal);
Reg.CloseKey;
end;
begin
Reg := TRegistry.Create;
try
Reg.RootKey := HKEY_CLASSES_ROOT;
sKey := UTF8ToAnsi('.' + fExtension);
sVal := UTF8ToAnsi(fProgName);
WriteToReg;
sKey := UTF8ToAnsi(fProgName);
sVal := UTF8ToAnsi('Open .' + fExtension + ' extension');
WriteToReg;
sKey := UTF8ToAnsi(fProgName + '\DefaultIcon');
sVal := UTF8ToAnsi(fExeName + ',' + IntToStr(fIconIndex));
WriteToReg;
sKey := UTF8ToAnsi(fProgName + '\Shell\Open\Command');
sVal := UTF8ToAnsi('"' + fExeName + '"' + ' "%1"');
WriteToReg;
finally
Reg.Free;
end;
SHChangeNotify(SHCNE_ASSOCCHANGED, SHCNF_IDLIST, nil, nil);
end;
procedure TAssociation.DeleteAssociation;
var
sExtAnsi, sExtDescAnsi: AnsiString;
Reg: TRegistry;
begin
Reg := TRegistry.Create;
try
Reg.RootKey := HKEY_CLASSES_ROOT;
sExtAnsi := UTF8ToAnsi('.' + fExtension);
if Reg.OpenKeyReadOnly(sExtAnsi)
then
begin
sExtDescAnsi := Reg.ReadString('');
//ShowMessage(AnsiToUTF8(sExtDescAnsi));
Reg.CloseKey;
Reg.DeleteKey(sExtAnsi);
Reg.DeleteKey(sExtDescAnsi + '\DefaultIcon');
Reg.DeleteKey(sExtDescAnsi + '\Shell\Open\Command');
Reg.DeleteKey(sExtDescAnsi + '\Shell\Open');
Reg.DeleteKey(sExtDescAnsi + '\Shell');
Reg.DeleteKey(sExtDescAnsi);
end;
finally
Reg.Free;
end;
SHChangeNotify(SHCNE_ASSOCCHANGED, SHCNF_IDLIST, nil, nil);
end;
constructor TAssociation.Create;
var
s: string; // название ехе-шника
begin
fExeName := AnsiToUTF8(Application.ExeName);
s := ExtractFileName(fExeName);
// fProgName - название ехе-шника без .ехе
fProgName := StringReplace(s,
'.exe',
'',
[rfReplaceAll, rfIgnoreCase]);
//ShowMessage(AnsiToUTF8(fProgName));
fIconIndex := 0;
end;
function TAssociation.GetExeNameByExtension(sExt: string): string;
var
sExtAnsi, sExtDescAnsi, sAnsi: AnsiString;
i: integer;
begin
if sExt = ''
then sExtAnsi := UTF8ToAnsi(fExtension)
else sExtAnsi := UTF8ToAnsi(sExt);
if sExtAnsi[1] <> '.'
then // добавляю точку в начало, если отсутствует
sExtAnsi := '.' + sExtAnsi;
with TRegistry.Create do
begin
try
RootKey := HKEY_CLASSES_ROOT;
if OpenKeyReadOnly(sExtAnsi)
then
begin
sExtDescAnsi := ReadString('');
//ShowMessage(AnsiToUTF8(sExtDescAnsi));
CloseKey;
end;
if sExtDescAnsi <> ''
then
begin
if OpenKeyReadOnly(sExtDescAnsi + '\Shell\Open\Command')
then
begin
sAnsi:= ReadString('');
//ShowMessage(AnsiToUTF8(sAnsi));
end
end;
finally
Free;
end;
end;
if sAnsi <> ''
then
begin
if sAnsi[1] = '"'
then // нужно убрать кавычки впереди и кавычки (и что за ними) в конце
begin
sAnsi := Copy(sAnsi, 2, MaxInt); // убираю кавычки в начале = копирую часть после них
i := Pos('"', sAnsi); // позиция следующих кавычек
sAnsi := Copy(sAnsi, 1, i - 1); // убираю кавычки в конце = копирую часть до них
//ShowMessage(AnsiToUTF8(sAnsi));
end
end;
Result := AnsiToUTF8(sAnsi);
end;
end.
