Sign in Join
Wiki copytemporary

FileAssociation/fr: what changed

Revision 0 to 1. Removed lines have a minus sign; added lines have a plus sign.

Title: FileAssociation/fr

OldNewLine
1+## TFileAssociation
2+
3+Auteur: (lainz-007-) Licence: LGPL modifiée Version: 2.0
4+
5+Cette unité enregistre l'association dans Windows.
6+
7+## Notes
8+
9+Vous devez compiler l'exécutable à la fois en 32 et 64 bit dans Windows pour enregistrer les programmes par défaut.
10+
11+## Emploi
12+
13+Sauver l'unité en ufileassociation.pas sur votre disque dur, ensuite essayer cela:
14+
15+``` pascal
16+...
17+uses
18+ ...
19+ ufileassociation;//<-- add fileassociation unit here
20+
21+type
22+
23+...
24+ { private declarations }
25+ assoc: TFileAssociation;
26+...
27+
28+procedure TfrmMain.FormCreate(Sender: TObject);
29+begin
30+ assoc := TFileAssociation.Create(Self);//<-- create like a regular component
31+end;
32+
33+procedure TfrmMain.Button1Click(Sender: TObject);
34+begin
35+ assoc.ApplicationName := 'Lazarus IDE';
36+ assoc.ApplicationDescription := 'RAD for Free Pascal';
37+
38+ // you can change Extension and Action part for each extension you have
39+
40+ assoc.Extension := '.lpr';
41+ assoc.ExtensionName := 'Lazarus Project';
42+ assoc.ExtensionIcon := '"C:\lazarus\images\lprfile.ico"';
43+
44+ assoc.Action := '"C:\lazarus\lazarus.exe" "%1"';
45+ assoc.ActionName := 'Open';
46+ assoc.ActionIcon := '"C:\lazarus\images\mainicon.ico"';
47+
48+ assoc.RegisterForAllUsers:=True; //<-- you can change it to False and register for current user only
49+ if assoc.Execute then
50+ begin
51+ ShowMessage('OK');
52+ assoc.ClearIconCache; //<<-- rebuild icons
53+ end;
54+end;
55+
56+end.
57+```
58+
59+## Unité
60+
61+Version 2.0: Tout ce qui vient de la v1.0 mais en consommant moins de mémoire et a été réécrite.\
62+Version 1.0: Initiale.
63+
64+(NdT : ne pas traduire les chaînes de caractères dans le code, elles dépendent du système)
65+
66+``` pascal
67+unit ufileassociation;
68+
69+{$mode objfpc}{$H+}
70+
71+interface
72+
73+uses
74+ Classes, SysUtils, Registry, ShlObj;
75+
76+type
77+
78+ { TFileAssociation }
79+
80+ TFileAssociation = class(TComponent)
81+ private
82+ { Options }
83+ FRegistry: TRegistry;
84+ FRegisterForAllUsers: boolean;
85+ FRegisterFileAssociation: boolean;
86+ FAddApplicationToDefaultPrograms: boolean;
87+ FAddExtensionToDefaultPrograms: boolean;
88+ FUnReg: boolean;
89+ { Data }
90+ FApplicationName: string;
91+ FApplicationDescription: string;
92+ FExtension: string;
93+ FExtensionName: string;
94+ FExtensionIcon: string;
95+ FAction: string;
96+ FActionName: string;
97+ FActionText: string;
98+ FActionIcon: string;
99+ procedure SetRoot;
100+ procedure SetFAction(AValue: string);
101+ procedure SetFActionIcon(AValue: string);
102+ procedure SetFActionName(AValue: string);
103+ procedure SetFActionText(AValue: string);
104+ procedure SetFApplicationDescription(AValue: string);
105+ procedure SetFApplicationName(AValue: string);
106+ procedure SetFExtension(AValue: string);
107+ procedure SetFExtensionIcon(AValue: string);
108+ procedure SetFExtensionName(AValue: string);
109+ procedure SetFRegisterForAllUsers(AValue: boolean);
110+ procedure SetFUnReg(AValue: boolean);
111+ procedure SetFAddApplicationToDefaultPrograms(AValue: boolean);
112+ procedure SetFAddExtensionToDefaultPrograms(AValue: boolean);
113+ procedure SetFRegisterFileAssociation(AValue: boolean);
114+ public
115+ constructor Create(AOwner: TComponent); override;
116+ destructor Destroy; override;
117+ public
118+ { String remove spaces }
119+ function StrNoSpaces(const s: string): string;
120+ { Add Root\SubKey\ ValueName=ValueData }
121+ function WriteStringValue(SubKey: string; ValueName: string;
122+ ValueData: string): boolean;
123+ { Delete Root\SuyKey\ ValueName=ValueData }
124+ function DeleteValue(SubKey: string; ValueName: string): boolean;
125+ { Add-Delete (UnReg option) Root\SubKey\ ValueName=ValueData }
126+ function WriteString(SubKey: string; ValueName: string; ValueData: string): boolean;
127+ public
128+ { Registry 'Class' containing the icon }
129+ function WriteFileAssociationClass: boolean;
130+ { Add a command like 'Open', 'Edit', 'Print' or other }
131+ function WriteFileAssociationClassCommand: boolean;
132+ { Associate the 'Class' with the file extension }
133+ function WriteFileAssociation: boolean;
134+ { Add application to Default Programs (Vista+) }
135+ function WriteDefaultPrograms: boolean;
136+ { Add extension to application Default Programs page }
137+ function WriteDefaultProgramsAddExt: boolean;
138+ { Run all }
139+ function Execute: boolean;
140+ { Rebuild Icons }
141+ procedure ClearIconCache;
142+ published
143+ { Data }
144+ { 'Lazarus IDE' }
145+ property ApplicationName: string read FApplicationName write SetFApplicationName;
146+ { 'RAD for Free Pascal' }
147+ property ApplicationDescription: string
148+ read FApplicationDescription write SetFApplicationDescription;
149+ { '.lpr' }
150+ property Extension: string read FExtension write SetFExtension;
151+ { 'Lazarus Project' }
152+ property ExtensionName: string read FExtensionName write SetFExtensionName;
153+ { 'C:\lazarus\images\lprfile.ico' }
154+ property ExtensionIcon: string read FExtensionIcon write SetFExtensionIcon;
155+ { '"C:\lazarus\lazarus.exe" "%1"' }
156+ property Action: string read FAction write SetFAction;
157+ { 'Open' }
158+ property ActionName: string read FActionName write SetFActionName;
159+ { 'Open With Lazarus' or empty '' to use default MUI translation for 'Open', 'Print' and 'Edit' }
160+ property ActionText: string read FActionText write SetFActionText;
161+ { 'C:\lazarus\lazarus.exe,0' }
162+ property ActionIcon: string read FActionIcon write SetFActionIcon;
163+ published
164+ { Options }
165+ { True uses HKML, false HKCU }
166+ property RegisterForAllUsers: boolean read FRegisterForAllUsers
167+ write SetFRegisterForAllUsers default True;
168+ { Do '.lpr' association with 'Lazarus IDE' }
169+ property RegisterFileAssociation: boolean
170+ read FRegisterFileAssociation write SetFRegisterFileAssociation default True;
171+ { Add 'Lazarus IDE' to 'Default Programs' requires RegisterForAllUsers:True }
172+ property AddApplicationToDefaultPrograms: boolean
173+ read FAddApplicationToDefaultPrograms write SetFAddApplicationToDefaultPrograms default
174+ True;
175+ { Add '.lpr' to 'Lazarus IDE' in 'Default Programs' requires RegisterForAllUsers:True }
176+ property AddExtensionToDefaultPrograms: boolean
177+ read FAddExtensionToDefaultPrograms write SetFAddExtensionToDefaultPrograms default True;
178+ { Remove from registry the current data }
179+ property UnReg: boolean read FUnReg write SetFUnReg default False;
180+ end;
181+
182+procedure Register;
183+
184+implementation
185+
186+procedure Register;
187+begin
188+ { $I fileassociation_icon.lrs}
189+ RegisterComponents('System', [TFileAssociation]);
190+end;
191+
192+{ TFileAssociation }
193+
194+procedure TFileAssociation.SetRoot;
195+begin
196+ if RegisterForAllUsers then
197+ FRegistry.RootKey := HKEY_LOCAL_MACHINE
198+ else
199+ FRegistry.RootKey := HKEY_CURRENT_USER;
200+end;
201+
202+procedure TFileAssociation.SetFAction(AValue: string);
203+begin
204+ if FAction = AValue then
205+ Exit;
206+ FAction := AValue;
207+end;
208+
209+procedure TFileAssociation.SetFActionIcon(AValue: string);
210+begin
211+ if FActionIcon = AValue then
212+ Exit;
213+ FActionIcon := AValue;
214+end;
215+
216+procedure TFileAssociation.SetFActionName(AValue: string);
217+begin
218+ if FActionName = AValue then
219+ Exit;
220+ FActionName := AValue;
221+end;
222+
223+procedure TFileAssociation.SetFApplicationDescription(AValue: string);
224+begin
225+ if FApplicationDescription = AValue then
226+ Exit;
227+ FApplicationDescription := AValue;
228+end;
229+
230+procedure TFileAssociation.SetFApplicationName(AValue: string);
231+begin
232+ if FApplicationName = AValue then
233+ Exit;
234+ FApplicationName := AValue;
235+end;
236+
237+procedure TFileAssociation.SetFExtension(AValue: string);
238+begin
239+ if FExtension = AValue then
240+ Exit;
241+ FExtension := AValue;
242+end;
243+
244+procedure TFileAssociation.SetFExtensionIcon(AValue: string);
245+begin
246+ if FExtensionIcon = AValue then
247+ Exit;
248+ FExtensionIcon := AValue;
249+end;
250+
251+procedure TFileAssociation.SetFExtensionName(AValue: string);
252+begin
253+ if FExtensionName = AValue then
254+ Exit;
255+ FExtensionName := AValue;
256+end;
257+
258+procedure TFileAssociation.SetFRegisterForAllUsers(AValue: boolean);
259+begin
260+ FRegisterForAllUsers := AValue;
261+ SetRoot;
262+end;
263+
264+procedure TFileAssociation.SetFUnReg(AValue: boolean);
265+begin
266+ if FUnReg = AValue then
267+ Exit;
268+ FUnReg := AValue;
269+end;
270+
271+procedure TFileAssociation.SetFAddApplicationToDefaultPrograms(AValue: boolean);
272+begin
273+ if FAddApplicationToDefaultPrograms = AValue then
274+ Exit;
275+ FAddApplicationToDefaultPrograms := AValue;
276+end;
277+
278+procedure TFileAssociation.SetFAddExtensionToDefaultPrograms(AValue: boolean);
279+begin
280+ if FAddExtensionToDefaultPrograms = AValue then
281+ Exit;
282+ FAddExtensionToDefaultPrograms := AValue;
283+end;
284+
285+procedure TFileAssociation.SetFRegisterFileAssociation(AValue: boolean);
286+begin
287+ if FRegisterFileAssociation = AValue then
288+ Exit;
289+ FRegisterFileAssociation := AValue;
290+end;
291+
292+constructor TFileAssociation.Create(AOwner: TComponent);
293+begin
294+ inherited Create(AOwner);
295+ FRegistry := TRegistry.Create;
296+ AddApplicationToDefaultPrograms := True;
297+ AddExtensionToDefaultPrograms := True;
298+ RegisterFileAssociation := True;
299+ UnReg := False;
300+ RegisterForAllUsers := True;
301+end;
302+
303+destructor TFileAssociation.Destroy;
304+begin
305+ FRegistry.Free;
306+ inherited Destroy;
307+end;
308+
309+function TFileAssociation.Execute: boolean;
310+var
311+ b1, b2, b3, b4, b5: boolean;
312+begin
313+ b1 := WriteFileAssociationClass;
314+ b2 := WriteFileAssociationClassCommand;
315+
316+ if RegisterFileAssociation then
317+ b3 := WriteFileAssociation;
318+
319+ if RegisterForAllUsers then
320+ begin
321+ if AddApplicationToDefaultPrograms then
322+ b4 := WriteDefaultPrograms;
323+ if AddExtensionToDefaultPrograms then
324+ b5 := WriteDefaultProgramsAddExt;
325+ end;
326+
327+ Result := False;
328+ if b1 and b2 and b3 and b4 and b5 then
329+ Result := True;
330+end;
331+
332+function TFileAssociation.WriteStringValue(SubKey: string; ValueName: string;
333+ ValueData: string): boolean;
334+begin
335+ Result := FRegistry.OpenKey(SubKey, True);
336+
337+ if Result then
338+ begin
339+ FRegistry.WriteString(ValueName, ValueData);
340+ FRegistry.CloseKey;
341+ end;
342+end;
343+
344+function TFileAssociation.DeleteValue(SubKey: string; ValueName: string): boolean;
345+begin
346+ Result := FRegistry.OpenKey(SubKey, True);
347+ if Result then
348+ begin
349+ FRegistry.DeleteValue(ValueName);
350+ FRegistry.DeleteKey(ValueName);
351+ FRegistry.CloseKey;
352+ end;
353+end;
354+
355+procedure TFileAssociation.SetFActionText(AValue: string);
356+begin
357+ if FActionText = AValue then
358+ Exit;
359+ FActionText := AValue;
360+end;
361+
362+procedure TFileAssociation.ClearIconCache;
363+begin
364+ SHChangeNotify(SHCNE_ASSOCCHANGED, SHCNF_IDLIST, nil, nil);
365+end;
366+
367+function TFileAssociation.StrNoSpaces(const s: string): string;
368+begin
369+ Result := StringReplace(s, ' ', '', [rfReplaceAll]);
370+end;
371+
372+function TFileAssociation.WriteString(SubKey: string; ValueName: string;
373+ ValueData: string): boolean;
374+begin
375+ if not UnReg then
376+ Result := WriteStringValue(SubKey, ValueName, ValueData)
377+ else
378+ Result := DeleteValue(SubKey, ValueName);
379+end;
380+
381+function TFileAssociation.WriteFileAssociationClass: boolean;
382+var
383+ b1, b2: boolean;
384+ sub: string;
385+begin
386+ sub := 'Software\Classes\' + StrNoSpaces(ApplicationName) +
387+ '.AssocFile.' + StrNoSpaces(ExtensionName);
388+
389+ b1 := WriteString(sub, '', ExtensionName);
390+ b2 := WriteString(sub + '\DefaultIcon', '', ExtensionIcon);
391+
392+ Result := False;
393+ if b1 and b2 then
394+ Result := True;
395+end;
396+
397+function TFileAssociation.WriteFileAssociationClassCommand: boolean;
398+var
399+ b1, b2, b3: boolean;
400+ sub: string;
401+begin
402+ sub := 'Software\Classes\' + StrNoSpaces(ApplicationName) +
403+ '.AssocFile.' + StrNoSpaces(ExtensionName) + '\Shell\' + StrNoSpaces(ActionName);
404+
405+ b1 := WriteString(sub, '', ActionText);
406+ b2 := WriteString(sub, 'Icon', ActionIcon);
407+ b3 := WriteString(sub + '\Command', '', Action);
408+
409+ Result := False;
410+ if b1 and b2 and b3 then
411+ Result := True;
412+end;
413+
414+function TFileAssociation.WriteFileAssociation: boolean;
415+begin
416+ Result := WriteString('Software\Classes\' + Extension, '',
417+ StrNoSpaces(ApplicationName) + '.AssocFile.' + StrNoSpaces(ExtensionName));
418+end;
419+
420+function TFileAssociation.WriteDefaultPrograms: boolean;
421+var
422+ b1, b2, b3, b4: boolean;
423+ sub: string;
424+begin
425+ sub := 'Software\' + StrNoSpaces(ApplicationName) + '\Capabilities';
426+
427+ b1 := WriteString(sub, '', '');
428+ b2 := WriteString(sub, 'ApplicationName', ApplicationName);
429+ b3 := WriteString(sub, 'ApplicationDescription', ApplicationDescription);
430+ b4 := WriteString('Software\RegisteredApplications',
431+ StrNoSpaces(ApplicationName), sub);
432+
433+ Result := False;
434+ if b1 and b2 and b3 and b4 then
435+ Result := True;
436+end;
437+
438+function TFileAssociation.WriteDefaultProgramsAddExt: boolean;
439+begin
440+ Result := WriteString('Software\' + StrNoSpaces(ApplicationName) +
441+ '\Capabilities\FileAssociations', Extension, StrNoSpaces(ApplicationName) +
442+ '.AssocFile.' + StrNoSpaces(ExtensionName));
443+end;
444+
445+end.
446+```
447+
448+---
449+*From the Free Pascal wiki, page "FileAssociation/fr", as it stood on 2020-02-15 after a change by Trev, out of the wiki's dump of 2024-05-26. Copyright stays with the author who wrote it, according to the old wiki's [[Licensing]] page. If you have concerns about this material, [message the admin](/wiki-contact).*

Back to history