Форум на Исходниках.RU

unit uSI5.StartUp;

interface

uses

Windows,

Messages,

Classes,

SysUtils,

Graphics,

Forms,

Registry,

ShellApi;

type

TInitializer = class

private

FLink: string;

FMutexHandle, FMMFHandle, FWnd: THandle;

FLinkChange: TNotifyEvent;

protected

procedure ActivatePreviosInstance;

function CheckSLinkHandler: Boolean;

procedure RegisterSLinkHandler(CheckIsAdmin: Boolean = True);

function GetOtherInstanceHandle: THandle;

function CheckOneInstance: Boolean;

function NeedReinstallSLinkHandler: Boolean;

procedure InitFileMapping;

procedure ReleaseFileMapping;

procedure CheckSLink;

procedure WndProc(var Message: TMessage);

procedure ProcessCopyData(Msg: TWMCopyData);

procedure DoLinkChange;

...

public

constructor Create;

destructor Destroy; override;

...

procedure ResetSLink;

property SLink: string read FLink;

property OnLinkChange: TNotifyEvent read FLinkChange write FLinkChange;

end;

var

Initializer: TInitializer;

implementation

const

GInfoMutexName = 'GSI Client';

GInfoMMF = 'GSI Client MMF';

MagicWMCopyID = F4B1BE4;

SLinkKeyName = 'slink';

DefaultIconKey = SLinkKeyName + '\DefaultIcon';

CommandKey = SLinkKeyName + '\shell\open\command';

ReinstallSLinkCommand = 'reinstallslink';

function AllowSetForegroundWindow(dwProcessID: DWORD): BOOL; stdcall; external user32;

{ TInitilizer }

procedure TInitializer.ActivatePreviosInstance;

var

OtherInstanceHandle: THandle;

PID: Cardinal;

CopyDataStruct: TCopyDataStruct;

begin

OtherInstanceHandle := GetOtherInstanceHandle;

if OtherInstanceHandle = INVALID_HANDLE_VALUE then Exit;

GetWindowThreadProcessId(OtherInstanceHandle, PID);

AllowSetForegroundWindow(PID);

CopyDataStruct.dwData := MagicWMCopyID;

CopyDataStruct.cbData := Length(FLink) * SizeOf(Char);

if FLink <> '' then

CopyDataStruct.lpData := @FLink[1];

SendMessage(OtherInstanceHandle, WM_COPYDATA, 0, Integer(@CopyDataStruct));

end;

function TInitializer.NeedReinstallSLinkHandler: Boolean;

begin

Result := FindCmdLineSwitch(ReinstallSLinkCommand, ['-', '/'], True);

end;

function TInitializer.CheckOneInstance: Boolean;

begin

FMutexHandle := CreateMutex(nil, False, PChar(GInfoMutexName));

Result := GetLastError <> ERROR_ALREADY_EXISTS;

if not Result then

CloseHandle(FMutexHandle);

end;

procedure TInitializer.CheckSLink;

var

I, Len: Integer;

begin

Len := Length(SLinkProtocolPrefix);

for I := 1 to ParamCount do

if LowerCase(Copy(ParamStr(I), 1, Len)) = SLinkProtocolPrefix then

begin

FLink := ParamStr(I);

Break;

end;

function TInitializer.CheckSLinkHandler: Boolean;

begin

Result := True;

with TRegistry.Create do

try

RootKey := HKEY_CLASSES_ROOT;

if OpenKeyReadOnly(SLinkKeyName) then

try

if ReadString('') <> 'URL:Grand StroyInfo Protocol' then

begin

Result := False;

Exit;

end;

if not ValueExists('URL Protocol') then

begin

Result := False;

Exit;

end;

if ReadString('URL Protocol') <> '' then

begin

Result := False;

Exit;

end;

finally

CloseKey;

end;

if OpenKeyReadOnly(DefaultIconKey) then

try

if AnsiLowerCase(ReadString('')) <> '"' + AnsiLowerCase(ParamStr(0)) + '", 0' then

begin

Result := False;

Exit;

end;

finally

CloseKey;

end;

if OpenKeyReadOnly(CommandKey) then

try

if AnsiLowerCase(ReadString('')) <> '"' + AnsiLowerCase(ParamStr(0)) + '" "%1"' then

begin

Result := False;

Exit;

end;

finally

CloseKey;

end;

finally

Free;

end;

constructor TInitializer.Create;

begin

if NeedReinstallSLinkHandler then

begin

RegisterSLinkHandler(False);

TerminateProcess(GetCurrentProcess, NO_ERROR);

end;

CheckSLink;

if not CheckOneInstance then

begin

ActivatePreviosInstance;

TerminateProcess(GetCurrentProcess, ERROR_SERVICE_EXISTS);

end;

if SLink = '' then

if not CheckSLinkHandler then

RegisterSLinkHandler;

InitFileMapping;

ShowSplash;

end;

destructor TInitializer.Destroy;

begin

ReleaseFileMapping;

CloseHandle(FMutexHandle);

inherited;

end;

procedure TInitializer.DoLinkChange;

begin

if Assigned(FLinkChange) then

FLinkChange(Self);

end;

...

function TInitializer.GetOtherInstanceHandle: THandle;

function ReadHandle: THandle;

var

MMFHandle: THandle;

Data: Pointer;

begin

Result := INVALID_HANDLE_VALUE;

MMFHandle := OpenFileMapping(FILE_MAP_READ, false, PChar(GInfoMMF));

if MMFHandle = 0 then Exit;

try

Data := MapViewOfFile(MMFHandle, FILE_MAP_READ, 0, 0, 0);

if Data = nil then Exit;

try

Result := PInteger(Data)^;

except

// Другое приложение файл созадло, но еще ничего туда не записало..

on EAccessViolation do ;

end;

finally

CloseHandle(MMFHandle);

end;

var

I: Integer;

begin

for I := 0 to 9 do

begin

Result := ReadHandle;

if Result <> INVALID_HANDLE_VALUE then

Exit;

Sleep(100);

end;

...

procedure TInitializer.InitFileMapping;

var

MMFData: Pointer;

begin

FWnd := Classes.AllocateHWnd(WndProc);

FMMFHandle := CreateFileMapping($FFFFFFFF, nil, PAGE_READWRITE,

0, 4096, PChar(GInfoMMF));

if FMMFHandle <> 0 then

begin

MMFData := MapViewOfFile(FMMFHandle, FILE_MAP_WRITE, 0, 0, 0);

if MMFData <> nil then

begin

PHandle(MMFData)^ := FWnd;

UnmapViewOfFile(MMFData);

end;

procedure TInitializer.ProcessCopyData(Msg: TWMCopyData);

begin

if Msg.CopyDataStruct^.dwData <> MagicWMCopyID then Exit;

SetLength(FLink, Msg.CopyDataStruct.cbData div SizeOf(Char));

CopyMemory(Pointer(FLink), Msg.CopyDataStruct.lpData,

Msg.CopyDataStruct.cbData);

ReplyMessage(0);

SendMessage(Application.Handle, WM_SYSCOMMAND, SC_RESTORE, 0);

SetForegroundWindow(Application.Handle);

DoLinkChange;

end;

procedure TInitializer.RegisterSLinkHandler(CheckIsAdmin: Boolean);

var

SEI: TShellExecuteInfo;

begin

case IsAdmin of

csError:

if CheckIsAdmin then Exit;

csLimitedUser:

begin

if not CheckIsAdmin then Exit;

if MessageBox(0,

'Служебный протокол ГСИ не зарегистрирован, выполнить регистрацию сейчас?',

'ГСИ', MB_ICONQUESTION or MB_YESNO or MB_DEFBUTTON1) = IDNO then Exit;

SEI.cbSize := SizeOf(TShellExecuteInfo);

SEI.lpFile := PChar(ParamStr(0));

SEI.lpDirectory := PChar(ExtractFilePath(ParamStr(0)));

SEI.lpVerb := PChar('runas');

SEI.fMask := SEE_MASK_NOCLOSEPROCESS;

SEI.nShow := SW_HIDE;

SEI.hInstApp := HInstance;

SEI.lpParameters := PChar('-' + ReinstallSLinkCommand);

ShellExecuteEx(@SEI);

Exit;

end;

with TRegistry.Create do

try

RootKey := HKEY_CLASSES_ROOT;

if OpenKey(SLinkKeyName, True) then

try

WriteString('', 'URL:Grand StroyInfo Protocol');

WriteString('URL Protocol', '');

finally

CloseKey;

end;

if OpenKey(DefaultIconKey, True) then

try

WriteString('', '"' + ParamStr(0) + '", 0');

finally

CloseKey;

end;

if OpenKey(CommandKey, True) then

try

WriteString('', '"' + ParamStr(0) + '" "%1"');

finally

CloseKey;

end;

finally

Free;

end;

procedure TInitializer.ReleaseFileMapping;

begin

Classes.DeallocateHWnd(FWnd);

CloseHandle(FMMFHandle);

end;

procedure TInitializer.ResetSLink;

begin

FLink := '';

end;

...

procedure TInitializer.WndProc(var Message: TMessage);

begin

if Message.Msg = WM_COPYDATA then

ProcessCopyData(TWMCopyData(Message));

inherited;

end;

initialization

Initializer := TInitializer.Create;

finalization

Initializer.Free;

end.