unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ShellAPI;
type
TForm1 = class(TForm)
Button1: TButton;
Button2: TButton;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
private
public
end;
var
Form1: TForm1;
CurrentSemafor : THandle;
implementation
{$R *.dfm}
procedure RunAsAdmin(const ProgramName: String; const Parameters: String = ''; Handle : HWND = 0);
var
Info : TShellExecuteInfo;
begin
FillChar(Info, SizeOf(Info), 0);
Info.cbSize := SizeOf(Info);
Info.Wnd := Handle;
Info.fMask := SEE_MASK_FLAG_DDEWAIT or SEE_MASK_FLAG_NO_UI;
Info.lpVerb := 'runas'; Info.lpFile := PChar(ProgramName);
Info.lpParameters := PChar(Parameters);
Info.nShow := SW_SHOWNORMAL;
if not ShellExecuteEx(@Info) then
RaiseLastOSError;
end;
function CheckInstance(AppName : String) : Boolean;
var
Semafor : THandle;
begin
Semafor := CreateSemaphore(nil, 0, 1, PChar(AppName));
if (Semafor <> 0) and (GetLastError = ERROR_ALREADY_EXISTS) then
begin
CloseHandle(Semafor);
Result := False;
Exit;
end
else
begin
CurrentSemafor := Semafor;
Result := True;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if CheckInstance('Calc') then
RunAsAdmin('Calc.exe')
else
MessageDlg('La Aplicación ya esta Activa en Memoria',mtInformation,[mbOK],0)
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
CloseHandle(CurrentSemafor);
end;
end.