Avr 06

Régulièrement, je réutilise les mêmes méthodes parmi divers projets…

J’en ai regroupé certaines d’entre elles dans des unités que j’utilise lorsque j’en ai besoin, tandis que pour d’autres qui me servent moins souvent, je me contente de faire un copier/coller.

Le plus dur, en général, est de retrouver le projet où j’en ai eu précédemment besoin. :$

Alors, tout comme j’avais écrit un article sur les boutons de la barre des tâches sous Windows 7, et qui m’a encore servi pour wText2QR, je rédige un article où je vais recenser certaines des fonctions que j’utilise. Lorsque j’arriverai à retrouver la référence d’une source, je l’ajouterai. Je spécifie néanmoins que la plupart ont été récupérée de pages Web au fil du temps, lorsque j’en ai eu pour la première fois l’utilité, (bow) et que je n’en suis pas l’auteur (j’ai éventuellement fait des modifications pour mes propres exigences).

Source Delphi

Par où commencer… :?

Attention !!! Certains bouts de code sont clairement hardcodés pour mes besoins… relisez bien les scripts si vous en copiez certains !

C’est par exemple le cas de cette unité, que je me suis faite et qui fonctionne aussi bien sous Windows x86, x64 et Max OS X (VCL & FireMonkey) :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
/// <summary>
///   Unit with cross-platforms methods
/// </summary>
/// <remarks>
///   Currently works on Microsoft and Posix (OSX).
/// </remarks>
unit uWxPlatform;

interface

uses
{$IFDEF MSWINDOWS}
  Winapi.ShellAPI, Winapi.Windows, ShlObj,
{$ENDIF MSWINDOWS}
{$IFDEF POSIX}
  Posix.Stdlib,
{$ENDIF POSIX}
{$IFDEF MACOS}
  System.RegularExpressions, MacApi.AppKit, MacApi.Foundation, Macapi.CocoaTypes,
{$ENDIF MACOS}
  System.SysUtils;

{$IFDEF MACOS}
procedure NSBeep; cdecl;  external '/System/Library/Frameworks/AppKit.framework/AppKit' name '_NSBeep';
{$ENDIF MACOS}

type
  TFileVersionInfo = record
    fCompanyName,
    fFileDescription,
    fFileVersion,
    fInternalName,
    fLegalCopyRight,
    fLegalTradeMark,
    fOriginalFileName,
    fProductName,
    fProductVersion,
    fComments         : string;
    fMajor,
    fMinor,
    fRelease,
    fBuild            : Word;
  end;
  /// <summary>
  ///   The class which contains cross-platforms methods.
  /// </summary>
  /// <remarks>
  ///   Procedures and functions are class methods when possible.
  /// </remarks>
  TMisc = class

    /// <summary>
    ///   To open the command.
    /// </summary>
    /// <param name="sCommand">
    ///   Command which is opened in the shell/DOS.
    /// </param>
    /// <remarks>
    ///   <para>
    ///     Example :
    ///   </para>
    ///   <para>
    ///     TMisc.Open('http://www.whiler.com/');<br />It loads the URL in the default browser.
    ///   </para>
    ///   <para>
    ///     TMisc.Open('filename.txt');<br />It opens the file <i>filename.txt</i> with the default text reader.
    ///   </para>
    /// </remarks>
    class procedure Open(sCommand: string);
    class procedure Beep;
    class function  BrowseForFolder(const ATitle: string; var ADir: string): Boolean;
    class procedure GetAppVersionInfo(sAppNamePath: string; var aFileVersionInfo: TFileVersionInfo); static;
    class function  IsCtrlDown: Boolean;
    class function  IsShiftDown: Boolean;
  private
  end;

implementation

var
  lg_StartFolder: String;



{$IFDEF MSWINDOWS}
function BrowseForFolderCallBack(Wnd: HWND; uMsg: UINT; lParam, lpData: LPARAM): Integer stdcall;
begin
  if (uMsg = BFFM_INITIALIZED) then
  begin
    SendMessage(Wnd, BFFM_SETSELECTION, 1, Integer(@lg_StartFolder[1]));
    Sleep(500);
    PostMessage(Wnd, BFFM_SETSELECTION, 1, Integer(@lg_StartFolder[1]));
  end;
  Result := 0;
end;
{$ENDIF MSWINDOWS}

class procedure TMisc.Open(sCommand: string);
begin
{$IFDEF MSWINDOWS}
  ShellExecute(0, 'OPEN', PChar(sCommand), '', '', SW_SHOWNORMAL);
{$ENDIF MSWINDOWS}
{$IFDEF POSIX}
  _system(PAnsiChar('open ' + AnsiString(sCommand)));
{$ENDIF POSIX}
end;

class procedure TMisc.Beep;
begin
{$IFDEF MSWINDOWS}
  Beep;
{$ENDIF MSWINDOWS}
{$IFDEF MACOS}
  NSBeep;
{$ENDIF MACOS}
end;

class function TMisc.BrowseForFolder(const ATitle: string; var ADir: string): Boolean;
{$IFDEF MACOS}
var
  LOpenDir: NSOpenPanel;
  LInitialDir: NSURL;
  LDlgResult: NSInteger;
begin
  Result   := False;
  LOpenDir := TNSOpenPanel.Wrap(TNSOpenPanel.OCClass.openPanel);
  LOpenDir.setAllowsMultipleSelection(False);
  LOpenDir.setCanChooseFiles(False);
  LOpenDir.setCanChooseDirectories(True);
  if (ADir <> '') then
  begin
    LInitialDir := TNSURL.Create;
    LInitialDir.initFileURLWithPath(NSSTR(ADir));
    LOpenDir.setDirectoryURL(LInitialDir);
  end;
  if (ATitle <> '') then
  begin
    LOpenDir.setTitle(NSSTR(ATitle));
  end;
  LOpenDir.retain;
  try
    LDlgResult := LOpenDir.runModal;
    if (LDlgResult = NSOKButton) then
    begin
      ADir   := string(TNSUrl.Wrap(LOpenDir.URLs.objectAtIndex(0)).relativePath.UTF8String);
      Result := True;
    end;
  finally
    LOpenDir.release;
  end;
{$ENDIF MACOS}
{$IFDEF MSWINDOWS}
var
  browse_info : TBrowseInfo;
  folder      : array[0..MAX_PATH] of char;
  find_context: PItemIDList;
begin
  Result := False;
  //--------------------------
  // Initialise the structure.
  //--------------------------
  FillChar(browse_info,SizeOf(browse_info),#0);
  lg_StartFolder             := ADir;
  browse_info.pszDisplayName := @folder[0];
  browse_info.lpszTitle      := PChar(ATitle);
  browse_info.ulFlags        := BIF_RETURNONLYFSDIRS or BIF_NEWDIALOGSTYLE;
//  browse_info.hwndOwner := appHWND;
  if (ADir <> '') then
  begin
    browse_info.lpfn := BrowseForFolderCallBack;
  end;
  find_context := SHBrowseForFolder(browse_info);
  if Assigned(find_context) then
  begin
    if SHGetPathFromIDList(find_context,folder) then
    begin
      ADir   := folder;
      Result := True;
    end
    else
      ADir := '';
    GlobalFreePtr(find_context);
  end
  else
    ADir := '';
{$ENDIF MSWINDOWS}
end;

class procedure TMisc.GetAppVersionInfo(sAppNamePath: string; var aFileVersionInfo: TFileVersionInfo);
var
{$IFDEF MSWINDOWS}
  iVerSize     : Integer;
  pcVerBuf     : PChar;
  pVerBufValue : Pointer;
  iVerHandle   : Cardinal;
  iVerBufLen   : Cardinal;
  sVerKey      : string;

  function GetInfo(ThisKey: string): string;
  begin
    Result  := '';
    sVerKey := '\StringFileInfo\' + IntToHex(loword(integer(pVerBufValue^)), 4) +
                  IntToHex(hiword(integer(pVerBufValue^)), 4) + '\' + ThisKey;

    if VerQueryValue(pcVerBuf, PChar(sVerKey), pVerBufValue, iVerBufLen) then
      Result := StrPas(PChar(pVerBufValue));

  end;

  function QueryValue(ThisValue: string): string;
  begin
    Result := '';

    if GetFileVersionInfo(PChar(sAppNamePath), iVerHandle, iVerSize, pcVerBuf) and
        VerQueryValue(pcVerBuf, '\VarFileInfo\Translation', pVerBufValue, iVerBufLen) then
      Result := GetInfo(ThisValue);

  end;

  function GetFileVersion(const FileName: string): boolean;
  // Returns True on success and False on failure.
  var
    lwSize, lwLen : LongWord;
    hFile         : Cardinal;
    pcBuffer      : PChar;
    pInfo         : ^VS_FIXEDFILEINFO;
  begin
    Result := False;
    lwSize := GetFileVersionInfoSize(PWideChar(FileName), hFile);
    if lwSize > 0 then
    begin
      GetMem(pcBuffer, lwSize);
      if GetFileVersionInfo(Pointer(FileName), 0, lwSize, pcBuffer) then
        if VerQueryValue(pcBuffer, '\', pointer(pInfo), lwLen) then
        begin
          aFileVersionInfo.fMajor   := HiWord(pInfo.dwFileVersionMS);
          aFileVersionInfo.fMinor   := LoWord(pInfo.dwFileVersionMS);
          aFileVersionInfo.fRelease := HiWord(pInfo.dwFileVersionLS);
          aFileVersionInfo.fBuild   := LoWord(pInfo.dwFileVersionLS);
          Result  := True;
        end;
      FreeMem(pcBuffer);
    end;
  end;
{$ENDIF MSWINDOWS}
{$IFDEF MACOS}
  sPlist  : string;
  sContent: string;
  sLine   : string;
  tf      : TextFile;

  function QueryValue(ThisValue: string): string;
  var
    reSearch: TRegEx;
    mFound  : TMatch;
  begin
    Result   := '';
    reSearch := TRegEx.Create('<key>' + ThisValue + '</key>\s*<string>([^<]*)</string>');
    mFound   := reSearch.Match(sContent);
    if mFound.Success then
    begin
      Result := mFound.Groups[1].Value;
    end;
  end;

{$ENDIF MACOS}
begin
  if sAppNamePath = '' then
    sAppNamePath := ParamStr(0);

{$IFDEF MSWINDOWS}
  GetFileVersion(sAppNamePath);
  iVerSize := GetFileVersionInfoSize(PChar(sAppNamePath), iVerHandle);
  pcVerBuf := AllocMem(iVerSize);
  try
    with aFileVersionInfo do
    begin
      fCompanyName      := QueryValue('CompanyName');
      fFileDescription  := QueryValue('FileDescription');
      fFileVersion      := QueryValue('FileVersion');
      fInternalName     := QueryValue('InternalName');
      fLegalCopyRight   := QueryValue('LegalCopyRight');
      fLegalTradeMark   := QueryValue('LegalTradeMark');
      fOriginalFileName := QueryValue('OriginalFileName');
      fProductName      := QueryValue('ProductName');
      fProductVersion   := QueryValue('ProductVersion');
      fComments         := QueryValue('Comments');
    end;
  finally
    FreeMem(pcVerBuf, iVerSize);
  end;
{$ENDIF MSWINDOWS}
{$IFDEF MACOS}
  sContent := '';
  sPlist   := ExpandFileName(ExtractFilePath(sAppNamePath) + '/../Info.plist');
  if FileExists(sPlist) then
  begin
    AssignFile(tf, sPlist);
    Reset(tf);
    while not Eof(tf) do
    begin
      ReadLn(tf, sLine);
      sContent := sContent + sLine;
    end;
    CloseFile(tf);
  end;
  with aFileVersionInfo do
  begin
    fCompanyName      := 'Whiler.com ©';
    fFileDescription  := '';
    fFileVersion      := QueryValue('CFBundleVersion');
    fInternalName     := QueryValue('CFBundleExecutable');
    fLegalCopyRight   := 'Whiler.com ©';
    fLegalTradeMark   := 'Whiler.com ©';
    fOriginalFileName := QueryValue('CFBundleDisplayName');
    fProductName      := QueryValue('CFBundleName');
    fProductVersion   := QueryValue('CFBundleVersion');
    fComments         := '';
  end;
{$ENDIF MACOS}
end;

class function TMisc.IsCtrlDown: Boolean;
{$IFDEF MSWINDOWS}
var
  ksCurrent : TKeyboardState;
begin
  GetKeyboardState(ksCurrent);
  Result := ((ksCurrent[VK_CONTROL] and 128) <> 0);
{$ENDIF MSWINDOWS}
{$IFDEF MACOS}
begin
  Result := NSControlKeyMask and TNSEvent.OCClass.modifierFlags = NSControlKeyMask;
{$ENDIF MACOS}
end;

class function TMisc.IsShiftDown: Boolean;
{$IFDEF MSWINDOWS}
var
  ksCurrent : TKeyboardState;
begin
  GetKeyboardState(ksCurrent);
  Result := ((ksCurrent[VK_SHIFT] and 128) <> 0);
{$ENDIF MSWINDOWS}
{$IFDEF MACOS}
begin
  Result := NSShiftKeyMask and TNSEvent.OCClass.modifierFlags = NSShiftKeyMask;
{$ENDIF MACOS}
end;

end.

J’avais déjà publié une partie de ce code dans cet article.

Retrouvez d’autres bouts de code sur la page suivante

Share

Pages : 1 2

Lien permanent vers Fonctions Delphi Rédigé par Whiler \\ Tags : , , , ,

3 réponses pour “Fonctions Delphi”

  1. Whiler a dit :

    Ajout de la fonction Beep dans l’unité uWxPlatform.

    Répondre

  2. Whiler a dit :

    Ajout de la fonction BrowseForFolder dans l’unité uWxPlatform.

    Répondre

  3. Whiler a dit :

    Ajout des fonctions IsCtrlDown & IsShiftDown dans l’unité uWxPlatform.

    Répondre

Laisser une réponse

(requis)

(requis)

*

Notifiez-moi les commentaires à venir via email. Vous pouvez aussi vous abonner sans commenter.

;) (lol) (y) |-( (hi) 8-) (angel) :s (clap) (bow) (tmi) (:| plus »

Ce site utilise Akismet pour réduire les indésirables. En savoir plus sur comment les données de vos commentaires sont utilisées.