FAQ DelphiConsultez toutes les FAQ

rundll32.exe shell32.dll, Control_RunDLL MONMODULE.CPL

WinExec(PChar('rundll32.exe shell32.dll,Control_RunDLL TIMEDATE.CPL'), SW_SHOWNORMAL);

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
type 
  TOSVERSIONINFOEX = record 
    dwOSVersionInfoSize: DWORD; 
    dwMajorVersion: DWORD; 
    dwMinorVersion: DWORD; 
    dwBuildNumber: DWORD; 
    dwPlatformId: DWORD; 
    szCSDVersion: array[0..127] of AnsiChar; { Maintenance string for PSS usage } 
    wServicePackMajor: WORD; 
    wServicePackMinor: WORD; 
    wSuiteMask: WORD; 
    wProductType: BYTE; 
    wReserved: BYTE; 
  end; 
  
const 
  VER_SERVER_NT                      = DWORD($80000000); 
  {$EXTERNALSYM VER_SERVER_NT} 
  VER_WORKSTATION_NT                 = $40000000; 
  {$EXTERNALSYM VER_WORKSTATION_NT} 
  VER_SUITE_SMALLBUSINESS            = $00000001; 
  {$EXTERNALSYM VER_SUITE_SMALLBUSINESS} 
  VER_SUITE_ENTERPRISE               = $00000002; 
  {$EXTERNALSYM VER_SUITE_ENTERPRISE} 
  VER_SUITE_BACKOFFICE               = $00000004; 
  {$EXTERNALSYM VER_SUITE_BACKOFFICE} 
  VER_SUITE_COMMUNICATIONS           = $00000008; 
  {$EXTERNALSYM VER_SUITE_COMMUNICATIONS} 
  VER_SUITE_TERMINAL                 = $00000010; 
  {$EXTERNALSYM VER_SUITE_TERMINAL} 
  VER_SUITE_SMALLBUSINESS_RESTRICTED = $00000020; 
  {$EXTERNALSYM VER_SUITE_SMALLBUSINESS_RESTRICTED} 
  VER_SUITE_EMBEDDEDNT               = $00000040; 
  {$EXTERNALSYM VER_SUITE_EMBEDDEDNT} 
  VER_SUITE_DATACENTER               = $00000080; 
  {$EXTERNALSYM VER_SUITE_DATACENTER} 
  VER_SUITE_SINGLEUSERTS             = $00000100; 
  {$EXTERNALSYM VER_SUITE_SINGLEUSERTS} 
  VER_SUITE_PERSONAL                 = $00000200; 
  {$EXTERNALSYM VER_SUITE_PERSONAL} 
  VER_SUITE_BLADE                    = $00000400; 
  {$EXTERNALSYM VER_SUITE_BLADE} 
  
// 
// RtlVerifyVersionInfo() os product type values 
// 
  
  VER_NT_WORKSTATION       = $0000001; 
  {$EXTERNALSYM VER_NT_WORKSTATION} 
  VER_NT_DOMAIN_CONTROLLER = $0000002; 
  {$EXTERNALSYM VER_NT_DOMAIN_CONTROLLER} 
  VER_NT_SERVER            = $0000003; 
  {$EXTERNALSYM VER_NT_SERVER} 
  
procedure AddString(var Dest: string; const Source: string; const LineFeed: boolean = True); 
begin 
  if Dest = '' then 
    Dest:= Source 
  else 
    if LineFeed then 
      Dest:= Dest + #13#10 + Source 
    else Dest:= Dest + Source; 
end; 
  
procedure AddStrings(var Dest: string; const Header: string; 
  const Source: TStrings; const Prefix: string = '  '); 
var 
  i: integer; 
begin 
  if Source.Count = 1 then 
  begin 
    if Header <> '' then 
      AddString(Dest, Header + ' ' + Source[0]) 
    else 
      AddString(Dest, Source[0]); 
  end 
  else 
  begin 
    if Header <> '' then 
      AddString(Dest, Header); 
    for i:=0 to Source.Count-1 do 
      AddString(Dest, Prefix + Source[i]); 
  end; 
end; 
  
function SystemVersionText: string; 
type 
  THKEY = type Longword; 
var 
  osvi: TOSVERSIONINFOEX; 
  bOsVersionInfoEx: boolean; 
  
  Key: HKEY; 
  szProductType : PChar; 
  dwBufLen: DWORD; 
begin 
  result:= ''; 
  
  // Try calling GetVersionEx using the OSVERSIONINFOEX structure. 
  // If that fails, try using the OSVERSIONINFO structure. 
  
  FillChar(osvi, SizeOf(TOSVERSIONINFOEX), 0); 
  osvi.dwOSVersionInfoSize:= SizeOf(TOSVERSIONINFOEX); 
  
  bOsVersionInfoEx:= GetVersionEx(POSVERSIONINFO(@osvi)^); 
  if not bOsVersionInfoEx then 
  begin 
    // If OSVERSIONINFOEX doesn't work, try OSVERSIONINFO. 
    osvi.dwOSVersionInfoSize:= SizeOf(TOSVERSIONINFO); 
    if not GetVersionEx(POSVERSIONINFO(@osvi)^) then 
      exit; 
  end; 
  
  case osvi.dwPlatformId of 
    // Tests for Windows NT product family. 
    VER_PLATFORM_WIN32_NT: 
    begin 
      // Test for the product. 
      if osvi.dwMajorVersion <= 4 then 
AddString(result, 'Microsoft Windows NT'); 
      if (osvi.dwMajorVersion = 5) and (osvi.dwMinorVersion = 0) then 
AddString(result, 'Microsoft Windows 2000'); 
  
      if bOsVersionInfoEx then  // Use information from GetVersionEx. 
      begin 
// Test for the workstation type. 
if osvi.wProductType = VER_NT_WORKSTATION then 
begin 
  if (osvi.dwMajorVersion = 5) and (osvi.dwMinorVersion = 1) then 
  AddString(result, 'Microsoft Windows XP'); 
  
  if (osvi.wSuiteMask and VER_SUITE_PERSONAL) <> 0 then 
    AddString(result, ' Home Edition', False) 
  else 
    AddString(result, ' Professional', False); 
end 
  
// Test for the server type. 
else if osvi.wProductType = VER_NT_SERVER then 
begin 
  if (osvi.dwMajorVersion = 5) and (osvi.dwMinorVersion = 1) then 
    AddString(result, 'Microsoft Windows .NET'); 
  
  if (osvi.wSuiteMask and VER_SUITE_DATACENTER) <> 0 then 
    AddString(result, ' DataCenter Server', False) 
  else if (osvi.wSuiteMask and VER_SUITE_ENTERPRISE) <> 0 then 
    if osvi.dwMajorVersion = 4 then 
      AddString(result, ' Advanced Server', False) 
    else 
      AddString(result, ' Enterprise Server', False) 
  else if osvi.wSuiteMask = VER_SUITE_BLADE then 
    AddString(result, ' Web Server', False) 
  else 
    AddString(result, ' Server', False); 
end 
      end 
      else   // Use the registry on early versions of Windows NT. 
      begin 
RegOpenKeyEx(HKEY_LOCAL_MACHINE, 'SYSTEM\\CurrentControlSet\\Control\\ProductOptions', 
  0, KEY_QUERY_VALUE, Key ); 
szProductType:= StrAlloc(80); 
RegQueryValueEx(Key, 'ProductType', Nil, Nil, 
  PByte(szProductType), @dwBufLen); 
RegCloseKey(Key); 
if szProductType = 'WINNT' then 
  AddString(result, ' Professional', False); 
if szProductType = 'LANMANNT' then 
  AddString(result, ' Server', False); 
if szProductType = 'SERVERNT' then 
  AddString(result, ' Advanced Server', False); 
StrDispose(szProductType); 
      end; 
  
    // Display version, service pack (if any), and build number. 
  
      if osvi.dwMajorVersion <= 4  then 
AddString(result, Format('version %d.%d %s (Build %d)', 
  [osvi.dwMajorVersion, 
  osvi.dwMinorVersion, 
  osvi.szCSDVersion, 
  osvi.dwBuildNumber and $FFFF])) 
      else 
AddString(result, Format('%s (Build %d)', 
  [osvi.szCSDVersion, 
  osvi.dwBuildNumber and $FFFF])); 
    end; 
  
    // Test for the Windows 95 product family. 
    VER_PLATFORM_WIN32_WINDOWS: 
    begin 
      if (osvi.dwMajorVersion = 4) and (osvi.dwMinorVersion = 0) then 
      begin 
AddString(result, 'Microsoft Windows 95'); 
if (osvi.szCSDVersion[1] = 'C') or (osvi.szCSDVersion[1] = 'B') then 
  AddString(result, ' OSR2', False); 
      end; 
  
      if (osvi.dwMajorVersion = 4) and (osvi.dwMinorVersion = 10) then 
      begin 
AddString(result, 'Microsoft Windows 98'); 
if osvi.szCSDVersion[1] = 'A' then 
  AddString(result, ' SE', False); 
      end; 
  
      if (osvi.dwMajorVersion = 4) and (osvi.dwMinorVersion = 90) then 
AddString(result, 'Microsoft Windows Millennium Edition'); 
    end; 
  end; 
end;

1
2
3
4
5
6
7
8
9
10
11
function UserName : string;  
var  
  Utilisateur : Array[0..255] Of Char;  
  Taille      : Cardinal;  
begin  
  Taille := SizeOf(Utilisateur);  
  If GetUserName(@Utilisateur,Taille) then  
    Result := strpas(Utilisateur)  
  else  
    Result :='';  
end;

1
2
3
4
Function TimeBoot : TTime; 
Begin 
  Result := (GetTickCount/1000)/(24*3600); 
End;

1
2
3
4
Function DateBoot : TDateTime; 
Begin 
  Result := Now-(GetTickCount/1000)/(24*3600); 
End;

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
type 
  PFindWindowsStruct = ^TFindWindowsStruct; 
  TFindWindowsStruct = record 
    ProcessID: DWORD; 
    HandleList: TList; 
  end; 
  
function EnumWindowsProc(hwnd: HWND; lParam: LPARAM): boolean; stdcall; 
var 
  dwProcessId: DWORD; 
begin 
  if lParam <> 0 then 
  begin 
    GetWindowThreadProcessId(hwnd, dwProcessId); 
    with PFindWindowsStruct(lParam)^ do 
      if dwProcessID = ProcessID then 
        HandleList.Add(Pointer(hwnd)); 
    result:= true; 
  end 
  else 
    result:= false; 
end; 
  
procedure FindProcessWindows(ProcessID: Integer; Handles: TList); 
var 
  findWindowsStruct: TFindWindowsStruct; 
begin 
  findWindowsStruct.ProcessID:= ProcessID; 
  findWindowsStruct.HandleList:= Handles; 
  EnumWindows(@EnumWindowsProc, Integer(@findWindowsStruct)); 
end;

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
procedure TForm1.FormShow(Sender: TObject); 
var 
  handles: TList; 
  i: Integer; 
begin 
  Caption:= Format('Application : %d , Fenêtre courante : %d', 
    [Application.Handle, Handle]); 
  
  handles:= TList.Create; 
  Try 
    FindProcessWindows(GetCurrentProcessID, handles); 
    memo1.lines.Clear; 
    for i:= 0 to handles.Count - 1 do 
      Memo1.Lines.Add(IntToStr(Integer(Handles[i]))); 
  Finally 
    handles.Free; 
  End; 
end;

Function ExitWindowsEx(uFlags: UINT; dwReserved: DWORD): BOOL; stdcall;

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
Function ArretSystem: Boolean; 
Var 
 Token: THandle; 
 TokenPrivilege: TTokenPrivileges; 
 Outlen : Cardinal; 
 Error:Dword; 
  
Const 
 SE_SHUTDOWN_NAME = 'SeShutdownPrivilege'; 
  
Begin 
   Result:=False; 
   // Récupère les informations de sécurité pour ce process. 
   if not OpenProcessToken(GetCurrentProcess, TOKEN_ADJUST_PRIVILEGES, Token) 
    then Exit; 
  try 
  
   FillChar(TokenPrivilege, SizeOf(TokenPrivilege),0); 
     // Valeur de retour 
   Outlen := 0; 
     // Un seul privilége à positionner 
   TokenPrivilege.PrivilegeCount := 1; 
  
     // Récupère le LUID pour le privilége 'shutdown'. 
     // un Locally Unique IDentifier est une valeur générée unique jusqu'a ce 
     // que le système soit redémarré 
   LookupPrivilegeValue(nil, SE_SHUTDOWN_NAME, TokenPrivilege.Privileges[0].Luid); 
  
     // Positionne le privilége shutdown pour ce process. 
   TokenPrivilege.Privileges[0].Attributes:=SE_PRIVILEGE_ENABLED; 
   AdjustTokenPrivileges(Token, False, TokenPrivilege, SizeOf(TokenPrivilege),nil, OutLen); 
  
   Error:=GetLastError; 
   If Error <> ERROR_SUCCESS 
    then Exit; 
  
     // Arrête le système 
   if ExitWindowsEx(EWX_POWEROFF, 0)=False 
      then Exit; 
   Result:=True; 
  
  finally 
   CloseHandle(Token); 
  end; 
end;

1
2
3
4
procedure ProcedureDeNotification(pInfo: pWLX_NOTIFICATION_INFO);  
begin  
  //Code  
end;

1
2
3
4
5
6
7
8
9
10
11
12
type  
  pWLX_NOTIFICATION_INFO = ^WLX_NOTIFICATION_INFO;  
  WLX_NOTIFICATION_INFO = record  
    Size: Cardinal;  
    Flags: Cardinal;  
    UserName: pWideChar;  
    Domain  : pWideChar;  
    WindowStation: pWideChar;  
    hToken  : THandle;  
    hDesktop: HDESK;  
    pStatusCallback: pointer; //Réservé pour utilisation interne  
  end;

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
library LogonNotification;  
  
uses  
  SysUtils, Windows;  
  
{$R *.res}  
  
type  
  pWLX_NOTIFICATION_INFO = ^WLX_NOTIFICATION_INFO;  
  WLX_NOTIFICATION_INFO = record  
    Size: Cardinal;  
    Flags: Cardinal;  
    UserName: pWideChar;  
    Domain  : pWideChar;  
    WindowStation: pWideChar;  
    hToken  : THandle;  
    hDesktop: HDESK;  
    pStatusCallback: pointer; //Réservé pour utilisation interne  
  end;  
  
procedure WLEventLogon(pInfo: pWLX_NOTIFICATION_INFO); stdcall;  
var  
  F: Text;  
begin  
  if (pInfo = nil) or (pInfo^.UserName = nil) then  
    Exit;  
  
  AssignFile(F, 'events.txt');  
  
  if FileExists('events.txt') then  
    Append(F) //Création du fichier  
  else  
    Rewrite(F); //ou ajout en fin de fichier  
  
  //Ecriture de la date/heure de connexion suivie du login de session  
  Writeln(F, '[' + DateTimeToStr(Now) + ']' + ' Logon: ' + WideCharToString(pInfo^.UserName));  
  
  CloseFile(F);  
end;  
  
exports  
  WLEventLogon  name 'WLEventLogon';  
  
begin  
end.

1
2
// Les valeurs doivent être à zéro. 
 ExitWindows(0,0)

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
function GetUserLanguage: string; 
var 
  sz: Integer; 
begin 
  // Le premier appel nous sert uniquement à déterminer la longueur de la chaîne 
  sz:= GetLocaleInfo(LOCALE_USER_DEFAULT, LOCALE_SNATIVELANGNAME, nil, 0); 
  
  // Nous modifions la chaîne de résultat pour qu'elle puisse 
  // contenir le texte complet. 
  SetLength(result, sz - 1); // - 1 car la longueur contient le zéro terminal 
  
  // Le deuxième appel nous retourne le nom de la langue dans la langue 
  GetLocaleInfo(LOCALE_USER_DEFAULT, LOCALE_SNATIVELANGNAME, 
    Pchar(result), sz); 
end;

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
unit main; 
  
interface 
  
uses 
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, 
  shellapi, StdCtrls ; 
  
type 
  TForm1 = class(TForm) 
    ListBox1: TListBox; 
    procedure FormCreate(Sender: TObject); 
  private 
    { Déclarations privées } 
  protected 
     procedure WMDropFiles(var Msg: TMessage); message WM_DROPFILES; 
  public 
    { Déclarations publiques } 
  end; 
  
var 
  Form1: TForm1; 
  
implementation 
  
{$R *.DFM} 
  
procedure TForm1.FormCreate(Sender: TObject); 
begin 
  //la fenêtre accepte le glissement d'objets 
  DragAcceptFiles(Handle, True); 
end; 
  
procedure TForm1.WMDropFiles(var Msg: TMessage);  
var hDeposer: THandle;  
    countFiles, i: integer;  
    FileName: Array[0..255]Of Char;  
begin  
  
  //Récupérer dans hDeposer le handle envoyé par le message WM_DROPFILES  
  hDeposer := THandle(Msg.wParam);  
  
  //Compter le nombre de fichiers déposés.  
  countFiles := DragQueryFile(hDeposer, UINT(-1), nil, 0);  
  
  for i := 0 to pred(countFiles) do  
  begin  
    //Déterminer le nom du ième fichier déposé  
    DragQueryFile(hDeposer, i, FileName, 255);  
  
    //Ajouter le nom du fichier dans le listbox 
    ListBox1.Items.Add(FileName);  
  end;  
  
  //Indiquer à Windows la fin du déposer  
  DragFinish(hDeposer);  
end;  
  
end.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
var 
  ChangeWindowMessageFilter : function(Msg: uint; dwFlag : dword):BOOL; stdcall; 
const 
  MSGFLT_ADD = 1; 
  WM_COPYGLOBALDATA = $49; 
  
procedure TForm1.Button1Click(Sender: TObject); 
var 
  lbrHandle: THandle; 
begin 
  lbrHandle := SafeLoadLibrary('User32.dll'); 
 if lbrHandle <> 0 then 
 try 
   ChangeWindowMessageFilter := GetProcAddress(lbrHandle, 'ChangeWindowMessageFilter'); 
   if Assigned(ChangeWindowMessageFilter) then begin 
     ChangeWindowMessageFilter(WM_DROPFILES, MSGFLT_ADD); 
     ChangeWindowMessageFilter(WM_COPYGLOBALDATA, MSGFLT_ADD); 
   end; 
 finally 
   FreeLibrary(lbrHandle); 
 end; 
end;

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
function GetCPUSpeed(var CpuSpeed: TFreqInfo): Boolean;  
{$IFDEF LINUX}  
begin  
   Result := False;  
end;  
{$ENDIF LINUX}  
{$IFDEF MSWINDOWS}  
var  
   T0, T1: Int64;  
   CountFreq: Int64;  
   Freq, Freq2, Freq3, Total: Int64;  
   TotalCycles, Cycles: Int64;  
   Stamp0, Stamp1: Int64;  
   TotalTicks, Ticks: Double;  
   Tries, Priority: Integer;  
   Thread: THandle;  
begin  
   Stamp0 := 0;  
   Stamp1 := 0;  
   Freq  := 0;  
   Freq2 := 0;  
   Freq3 := 0;  
   Tries := 0;  
   TotalCycles := 0;  
   TotalTicks := 0;  
   Total := 0;  
  
   Thread := GetCurrentThread();  
   Result := QueryPerformanceFrequency(CountFreq);  
   if Result then  
   begin  
     while ((Tries < 3 ) or ((Tries < 20) and ((Abs(3 * Freq - Total) >  
3) or  
       (Abs(3 * Freq2 - Total) > 3) or (Abs(3 * Freq3 - Total) > 3)))) do  
     begin  
       Inc(Tries);  
       Freq3 := Freq2;  
       Freq2 := Freq;  
       QueryPerformanceCounter(T0);  
       T1 := T0;  
  
       Priority := GetThreadPriority(Thread);  
       if Priority <> THREAD_PRIORITY_ERROR_RETURN then  
         SetThreadPriority(Thread, THREAD_PRIORITY_TIME_CRITICAL);  
       try  
         while T1 - T0 < 50 do  
         begin  
           QueryPerformanceCounter(T1);  
           Stamp0 := ReadTimeStampCounter;  
         end;  
         T0 := T1;  
  
         while T1 - T0 < 1000 do  
         begin  
           QueryPerformanceCounter(T1);  
           Stamp1 := ReadTimeStampCounter;  
         end;  
       finally  
         if Priority <> THREAD_PRIORITY_ERROR_RETURN then  
           SetThreadPriority(Thread, Priority);  
       end;  
  
       Cycles := Stamp1 - Stamp0;  
       Ticks := T1 - T0;  
       Ticks := Ticks * 100000;  
  
       // avoid division by zero  
       if CountFreq = 0 then  
         Ticks := High(Int64)  
       else  
         Ticks := Ticks / (CountFreq / 10);  
  
       TotalTicks := TotalTicks + Ticks;  
       TotalCycles := TotalCycles + Cycles;  
  
       // avoid division by zero  
       if Ticks = 0 then  
         Freq := High(Freq)  
       else  
         Freq := Round(Cycles / Ticks);  
  
       Total := Freq + Freq2 + Freq3;  
     end;  
  
     // avoid division by zero  
     if TotalTicks = 0 then  
     begin  
       Freq3 := High(Freq3);  
       Freq2 := High(Freq2);  
       CpuSpeed.RawFreq := High(CpuSpeed.RawFreq);  
     end  
     else  
     begin  
       Freq3 := Round((TotalCycles *  10) / TotalTicks); // freq. in  
multiples of 10^5 Hz  
       Freq2 := Round((TotalCycles * 100) / TotalTicks); // freq. in  
multiples of 10^4 Hz  
       CpuSpeed.RawFreq := Round(TotalCycles / TotalTicks);  
     end;  
  
     CpuSpeed.NormFreq := CpuSpeed.RawFreq;  
  
     if Freq2 - (Freq3 * 10) >= 6 then  
       Inc(Freq3);  
  
  
     Freq := CpuSpeed.RawFreq * 10;  
     if (Freq3 - Freq) >= 6 then  
       Inc(CpuSpeed.NormFreq);  
  
     CpuSpeed.ExTicks := Round(TotalTicks);  
     CpuSpeed.InCycles := TotalCycles;  
  
     CpuSpeed.NormFreq := RoundFrequency(CpuSpeed.NormFreq);  
     Result := True;  
   end;  
end;  
{$ENDIF MSWINDOWS}

CurrencyString := GetLocaleStr(DefaultLCID, LOCALE_SCURRENCY, '');

ShowMessage('Le symbole monétaire courant est ' + CurrencyString);

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Program Lock; 
  
{$APPTYPE CONSOLE} 
  
uses 
  Windows; 
begin 
  // Windows 2000 et supérieure 
  if Win32MajorVersion >= 5  then //test de la version de Windows 
   if Not LockWorkStation 
    then Writeln('Impossible de verrouiller le poste de travail') 
     // Call GetlastError pour plus d'information sur la cause de l'erreur 
    else 
  else Writeln('Nécessite la version Windows 2000 ou supérieure') 
end.

Function LockWorkStation:Bool; External 'User32.dll';

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
Function SecuredLockWorkStation : Boolean ; 
{ 
Demande un verrouillage de la station. 
Renvoie TRUE si le verrouillage a été déclenché. 
Renvoie FALSE si l'OS ne supporte pas la fonction, ou si le verrouillage est  
impossible. 
} 
Type 
    PLockFunction = Function : Cardinal ; stdcall ; 
Var 
   HDLL : THandle       ; 
   Lock : PLockFunction ; 
Begin 
     Result:=False; 
     If Win32Platform=VER_PLATFORM_WIN32_NT Then 
        Begin 
        HDLL:=LoadLibrary('USER32.DLL'); 
        If (HDLL<>0) Then 
           Begin 
           @Lock:=GetProcAddress(HDLL,'LockWorkStation'); 
           If Assigned(@Lock) Then 
              Result:=(Lock<>0) ; 
           FreeLibrary(HDLL); 
           End; 
        End; 
End ;

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
uses  
  ClipBrd, ShlObj;  
  
procedure CopyFilesToClipboard(Filenames: TStrings);  
var  
  i, len: Integer;  
  hMem: THandle;  
  ptr: PByte;  
  dropfiles: PDropFiles;  
begin  
  // On commence par récupérer la longueur totale de la "liste" de chaînes  
  len:= 0;  
  for i:= 0 to Filenames.Count - 1 do  
    Inc(len, Length(Filenames[i]) + 1);  
  
  if len <> 0 then  
  begin  
    Inc(len); // Ajout d'un octet pour le zéro terminal  
  
    // Allocation d'un buffer pour la structure _DROPFILES + la chaîne complète  
    hMem:= GlobalAlloc(GMEM_MOVEABLE, SizeOf(_DROPFILES) + len);  
    dropFiles:= GlobalLock(hMem);  
  
    dropFiles.pFiles:= SizeOf(_DROPFILES);  
    dropFiles.pt:= Point(0, 0);  
    dropFiles.fNC:= false;  
    dropFiles.fWide:= false;  
  
    // On positionne un pointeur juste après la structure  
    ptr:= Pointer(Integer(dropFiles) + SizeOf(_DROPFILES));  
  
    // Et on copie les chemins en les séparant par des zéros  
    for i:= 0 to Filenames.Count - 1 do  
    begin  
      Move(Filenames[i][1], ptr^, Length(Filenames[i]));  
      Inc(Integer(ptr), Length(Filenames[i]));  
      ptr^:= 0;  
      Inc(Integer(ptr));  
    end;  
    // La "liste" de chaînes doit être terminée par un autre zéro  
    ptr^:= 0;  
    // On a donc : StructureChemin1#0Chemin2#0#0  
  
    // Ne pas oublier de déverrouiller la zone mémoire  
    GlobalUnlock(hMem);  
  
    // Il ne reste plus qu'à injecter ça dans le presse-papier  
    with ClipBoard do  
    begin  
      Open;  
      Clear;  
      SetAsHandle(CF_HDROP, hMem);  
      Close  
    end;  
  end;  
  
  // Remarque : la zone allouée n'est pas libérée car elle est maintenant  
  // gérée par le presse-papier. C'est un des rares cas où il ne faut pas  
  // libérer ce que l'on a créé.  
end;  
  
procedure Test;  
var  
  sl: TStringList;  
begin  
  sl:= TStringList.Create;  
  sl.Add('c:\autoexec.bat');  
  sl.Add(Application.Exename);  
  CopyFilesToClipboard(sl);  
  sl.Free;  
end;

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
procedure ListerProcessus(ListBox: TCustomListBox); 
var 
  SnapShot: Cardinal; 
  ProcessEntry: TProcessEntry32; 
begin 
  //Création de "l'instantané" 
  SnapShot := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0); 
  
  //En cas d'erreur on sort 
  If SnapShot = 0 then Exit; 
  
  ProcessEntry.dwSize := SizeOf(ProcessEntry); 
  
  //Lecture du premier processus de la liste 
  If Process32First(SnapShot, ProcessEntry) then 
  begin 
    ListBox.Items.Add(ProcessEntry.szExeFile); 
  
    //Tant qu'il reste un processus, ajouter son nom à la liste 
    while Process32Next(SnapShot, ProcessEntry) do 
      ListBox.Items.Add(ProcessEntry.szExeFile); 
  end; 
  
  //Libération de l'instantané 
  CloseHandle(SnapShot); 
  
end;

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
procedure ListerModules(ListBox: TCustomListBox); 
var 
  SnapShot: Cardinal; 
  ThreadEntry: TThreadEntry32; 
begin 
  //Création de "l'instantané" 
  SnapShot := CreateToolhelp32Snapshot(TH32CS_SNAPTHREAD, GetCurrentProcessId); 
  
  //En cas d'erreur on sort 
  If SnapShot = 0 then Exit; 
  
  ThreadEntry.dwSize := SizeOf(ThreadEntry); 
  
  //Lecture du premier thread de la liste 
  If Thread32First(SnapShot, ThreadEntry) then 
  begin 
    //On n'ajoute que si le thread appartient à notre process 
    If ThreadEntry.th32OwnerProcessID = GetCurrentProcessID then 
      ListBox.Items.Add('Thread ID : ' + IntToStr(ThreadEntry.th32ThreadID)); 
  
    //Tant qu'il reste un thread, ajouter son nom à la liste 
    While Thread32Next(SnapShot, ThreadEntry) do 
      If ThreadEntry.th32OwnerProcessID = GetCurrentProcessID then 
        ListBox.Items.Add('Thread ID : ' + IntToStr(ThreadEntry.th32ThreadID)); 
  end; 
  
  //Libération de l'instantané 
  CloseHandle(SnapShot); 
  
end;

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
procedure ListerModules(ListBox: TCustomListBox); 
var 
  SnapShot: Cardinal; 
  ModuleEntry: TModuleEntry32; 
begin 
  //Création de "l'instantané" 
  SnapShot := CreateToolhelp32Snapshot(TH32CS_SNAPMODULE, GetCurrentProcessId); 
  
  //En cas d'erreur on sort 
  If SnapShot = 0 then Exit; 
  
  ModuleEntry.dwSize := SizeOf(ModuleEntry); 
  
  //Lecture du premier module de la liste 
  If Module32First(SnapShot, ModuleEntry) then 
  begin 
    ListBox.Items.Add(ModuleEntry.szModule + ' (' + ModuleEntry.szExePath + ')'); 
  
    //Tant qu'il reste un module, ajouter son nom à la liste 
    While Module32Next(SnapShot, ModuleEntry) do 
      ListBox.Items.Add(ModuleEntry.szModule + ' (' + ModuleEntry.szExePath + ')'); 
  end; 
  
  //Libération de l'instantané 
  CloseHandle(SnapShot); 
  
end;

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
//------------------------------------------------------------------------------ 
program DD; 
//------------------------------------------------------------------------------ 
  
uses 
  Forms, 
  DragDrop in 'DragDrop.pas' {Form1}, 
  Unit2 in 'Unit2.pas' {Form2}, 
  Unit3 in 'Unit3.pas' {Form3};  
{$R *.res}      
begin 
  Application.Initialize; 
  Application.CreateForm(TForm1, Form1); 
  Application.CreateForm(TForm2, Form2); 
  Application.CreateForm(TForm3, Form3); 
  Application.Run; 
end. 
  
//------------------------------------------------------------------------------ 
unit DragDrop; 
//------------------------------------------------------------------------------ 
  
interface 
  
uses 
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, 
  Dialogs, StdCtrls, Unit2, Unit3;     
type 
  TForm1 = class(TForm) 
    Button2: TButton; 
    Button3: TButton; 
    procedure Button2Click(Sender: TObject); 
    procedure Button3Click(Sender: TObject); 
  end;    
var 
  Form1: TForm1; 
  
implementation 
  
{$R *.dfm} 
//______________________________________________________________________________ 
// 
//       B U T T O N   2    C L I C K 
// 
procedure TForm1.Button2Click(Sender: TObject); 
begin 
  Form2.Show;    {appeler la fiche 2 en mode non modal} 
end;  // Button2Click 
//______________________________________________________________________________ 
// 
//       B U T T O N   3   C L I C K 
// 
procedure TForm1.Button3Click(Sender: TObject); 
begin 
  Form3.Show ;   {appeler la fiche 3 en mode non modal} 
end; //Button3Click   
end. 
  
//------------------------------------------------------------------------------ 
unit Unit2; 
//------------------------------------------------------------------------------ 
  
interface 
  
uses 
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, 
  Dialogs, StdCtrls;    
type 
  TForm2 = class(TForm) 
    Label1: TLabel; 
    procedure Label1MouseDown(Sender: TObject; Button: TMouseButton; 
      Shift: TShiftState; X, Y: Integer); 
  end;   
var 
  Form2: TForm2; 
  
implementation 
  
{$R *.dfm} 
//______________________________________________________________________________ 
// 
//       L A B E L 1     M O U S E    D O W N 
// 
procedure TForm2.Label1MouseDown(Sender: TObject; Button: TMouseButton; 
  Shift: TShiftState; X, Y: Integer); 
begin 
  if Button = mbLeft then     { ne glisser que si le bouton gauche est enfoncé } 
    with Sender as TLabel do  { traiter Sender comme TLabel } 
       BeginDrag(False);      { si tel est le cas, le faire glisser } 
end; // Label1MouseDown      
end. 
  
//------------------------------------------------------------------------------ 
unit Unit3; 
//------------------------------------------------------------------------------ 
  
interface 
  
uses 
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, 
  Dialogs, StdCtrls; 
type 
  TForm3 = class(TForm) 
    Label1: TLabel; 
    procedure Label1DragOver(Sender, Source: TObject; X, Y: Integer;  
    State: TDragState; var Accept: Boolean); 
    procedure Label1DragDrop(Sender, Source: TObject; X, Y: Integer); 
  end;   
var 
  Form3: TForm3; 
  
implementation 
  
{$R *.dfm}    
//______________________________________________________________________________ 
// 
//       L A B E L 1     D R A G    O V E R 
// 
procedure TForm3.Label1DragOver(Sender, Source: TObject; X, Y: Integer; 
  State: TDragState; var Accept: Boolean); 
begin 
  if Source is TLabel then Accept := True 
  else Accept := False; 
end; // Label1DragOver       
//______________________________________________________________________________ 
// 
//       L A B E L 1     D R A G    D R O P 
// 
procedure TForm3.Label1DragDrop(Sender, Source: TObject; X, Y: Integer); 
begin 
  if (Sender is TLabel) and (Source is TLabel) then begin 
    with (Sender as TLabel) do begin 
      Caption := (Source as TLabel).Caption;  {le Label de la fiche 3 devient } 
      Font    := (Source as TLabel).Font;     {identique à celui de la fiche 2} 
      Color   := (Source as TLabel).Color; 
    end; 
  
    SetFocus;                      {et en plus la fiche 3 prend la focalisation} 
  end; 
end;  // Label1DragDrop      
end.

1
2
3
4
5
6
7
8
9
10
uses Windows 
  
// il y a '\' à la fin (par ex : C:\temp\) 
function RepertoireTemporaireWindows: String; 
var 
  lpBuffer : array[0..255] of char; 
begin 
  GetTempPath(SizeOf (lpBuffer), lpBuffer); 
  result := lpBuffer; 
end;

HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders

%ALLUSERSPROFILE%\Documents

1
2
3
4
5
6
7
8
9
10
11
12
13
function ExpandCurrentProcessEnvVar(const Contenu: string): string;  
// Type d'appel : Writeln(ExpandCurrentProcessEnvVar(MaVariable));  
var  
  nSize: DWord;  
begin  
  Result:= '';  
  nSize:= 0;  
  nSize:=ExpandEnvironmentStrings(PChar(Contenu), Nil, nSize);  
     // Si AnsiString -1 si String Unicode -2  
  SetLength(Result, nSize - 2);  
  if ExpandEnvironmentStrings(PChar(Contenu), PChar(Result), nSize)=0  
     then raise Exception.Create(SysErrorMessage(GetlastError))  
end;

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
function GetCurrentProcessEnvVar(const VariableName: string): string;  
// Type d'appel : Writeln(GetCurrentProcessEnvVar('TEMP'));  
var  
  nSize: DWord;  
begin  
  Result:= '';  
  nSize:= 0;  
  nSize:= GetEnvironmentVariable(PChar(VariableName), Nil, nSize);  
  if nSize > 0 then  
  begin  
    SetLength(Resultat, nSize - 1);  
    if GetEnvironmentVariable(PChar(VariableName), PChar(Result), nSize)=0  
     then raise Exception.Create(SysErrorMessage(GetlastError))  
  end;  
end;

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
TForm1=class(TForm) 
  ... 
public 
  ... 
  procedure WndProc(var Msg: TMessage); override; 
  ... 
end; 
  
... 
  
procedure TForm1.WndProc(var Msg: TMessage); 
begin 
  inherited; 
  if Msg.Msg = WM_THEMECHANGED then 
  begin 
    ShowMessage('Le thème a changé !'); 
  end; 
end; 
end;

1
2
3
4
+-------------------------+-------------------------+ 
|     SubLanguage ID      |   Primary Language ID   | 
+-------------------------+-------------------------+ 
15                    10  9                         0   bit

1
2
3
4
function MakeLangId(LangId, SubLangId: Byte): Word; 
begin 
  Result := (SubLangId shl 10) or LangId; 
end

LangId := MakeLangId(LANG_FRENCH, SUBLANG_FRENCH);

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
 
program KillTask; 
 
uses 
  SysUtils, Windows, TlHelp32; 
 
procedure MyKillTask(ExeFileName: string); 
const 
  PROCESS_TERMINATE = $0001; 
var 
  ContinueLoop: Boolean; 
  FSnapshotHandle: THandle; 
  FProcessEntry32: TProcessEntry32; 
begin 
  FSnapshotHandle := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0); 
  FProcessEntry32.dwSize := SizeOf(FProcessEntry32); 
  ContinueLoop := Process32First(FSnapshotHandle, FProcessEntry32); 
  while ContinueLoop do 
  begin 
    if (UpperCase(ExtractFileName(FProcessEntry32.szExeFile)) = UpperCase(ExeFileName)) 
    or (UpperCase(FProcessEntry32.szExeFile) = UpperCase(ExeFileName)) then 
      TerminateProcess(OpenProcess(PROCESS_TERMINATE, False, FProcessEntry32.th32ProcessID), 0); 
    ContinueLoop := Process32Next(FSnapshotHandle, FProcessEntry32); 
  end; 
  CloseHandle(FSnapshotHandle); 
end; 
 
begin 
  if ParamCount = 1 then 
    MyKillTask(ExtractFileName(ParamStr(1))); 
end.

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
type 
  TSLTShellLink = class(TObject) 
  public 
    class function ExtractTarget(const AShellLinkFileName: TFileName): TFileName; 
  end; 
 
{ TSLTShellLink } 
 
class function TSLTShellLink.ExtractTarget(const AShellLinkFileName: TFileName): TFileName; 
const 
  IID_IPersistFile: TGUID = '{0000010B-0000-0000-C000-000000000046}'; 
var 
  LResult: HRESULT; 
  LSHellLink: IShellLink; 
  LPersistFile: IPersistFile; 
  LFindData: TWin32FindData; 
  FileName: array[0..MAX_PATH - 1] of Char; 
begin 
  Result := ''; 
  LResult := CoCreateInstance(CLSID_ShellLink, nil, CLSCTX_INPROC_SERVER, IID_IShellLinkW, LShellLink); 
  if LResult = S_OK then 
  begin 
    if Supports(LShellLink, IID_IPersistFile, LPersistFile) then 
    begin 
      LResult := LPersistFile.Load(PChar(AShellLinkFileName), STGM_READ); 
      if LResult = S_OK then 
      begin 
        LResult := LSHellLink.GetPath(FileName, MAX_PATH, LFindData, SLGP_UNCPRIORITY); 
        if LResult = S_OK then 
          Result := Trim(FileName); 
      end; 
    end; 
  end; 
end;

  Winapi.Windows, Winapi.ShellApi, Winapi.ShlObj, Winapi.Messages, Winapi.ActiveX,

1
2
3
4
procedure TForm1.FormCreate(Sender: TObject); 
begin 
  Caption := TSLTShellLink.ExtractTarget('C:\Users\xxx\Desktop\Delphi XE2.lnk'); 
end;

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
unit Unit1; 
  
interface 
  
uses 
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, 
  Dialogs, StdCtrls; 
  
type 
  PRec = ^Rec; 
  
  Rec = record 
    A,B : integer; 
  end; 
  
  TObjetInterne = class(TObject) 
  end; 
  
  TObjetPrincipal = class(TObject) 
  public 
    FObjetInterne : TObjetInterne; 
    FRec : PRec ; 
    constructor Create; 
    destructor  Destroy; override; 
  end; 
  
  TForm1 = class(TForm) 
    Button1: TButton; 
    procedure Button1Click(Sender: TObject); 
  private 
    { Déclarations privées } 
  public 
    { Déclarations publiques } 
  end; 
  
var 
  Form1: TForm1; 
  
implementation 
  
{$R *.dfm} 
{ TObjetPrincipal } 
constructor TObjetPrincipal.Create; 
begin 
   inherited; 
   FObjetInterne := TObjetInterne.Create; 
   New(FRec); 
end; 
  
destructor TObjetPrincipal.Destroy; 
begin 
  FObjetInterne.Free; 
  Dispose(FRec); 
  inherited; 
end; 
  
procedure TForm1.Button1Click(Sender: TObject); 
var ObjetPrincipal : TObjetPrincipal; ptr : Pointer; 
begin 
   ReportMemoryLeaksOnShutdown := DebugHook <> 0 ; 
   ObjetPrincipal := TObjetPrincipal.Create; 
   ptr := AllocMem(10000); 
end; 
  
end.

1
2
3
4
5
6
7
8
procedure TPrincipal.ReduireApplication; 
begin 
   // on cache la fenêtre et on la minimise	 
   Self.Hide; 
   WindowState      := wsMinimized; 
   // affichage de l'icône dans la barre des tâches 
   TrayIcon.Visible := True; 
end;

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
procedure TPrincipal.TrayIconMouseDown(Sender: TObject; Button: TMouseButton; 
  Shift: TShiftState; X, Y: Integer); 
begin 
   // lors du clic avec le bouton gauche de la souris 
   // on va revenir sur notre écran principal    
   if Button = mbLeft then 
   begin 
      // on masque la fenêtre ouverte avec le TrayIcon  
      FFormTrayIcon.Hide; 
	  // il faut enlever l'icône de la barre des tâches 
	  TrayIcon.Visible := False; 
	  // et afficher notre fenêtre 
      WindowState      := wsNormal; 
      Self.Show; 
      Self.BringToFront; 
   end 
   // sinon on affiche notre fenêtre qui fait office de menu 
   else 
   begin	 
	  // gestion de la position pour que l'écran s'ouvre 
	  // à côté de la souris de l'utilisateur 
      FFormTrayIcon.Left := X - FFormTrayMenu.Width; 
      FFormTrayIcon.Top  := Y - FFormTrayMenu.Height - 10; // marge de 10px 
	  // affichage en premier plan 
      FFormTrayIcon.Show; 
      FFormTrayIcon.BringToFront; 
   end; 
end;