Валентин Озеров - Советы по Delphi. Версия 1.4.3 от 1.1.2001

begin

g_hAppCritSecMutex := CreateMutex( nil, true, PChar(Application.Title + '.OneInstance32.CriticalSection'));

// if GetLastError - лениво писать

g_hAppMutex := CreateMutex( nil, false, PChar(Application.Title + 'OneInstance32.Default'));

dw := WaitForSingleObject(g_hAppMutex, 0);

Result := (dw <> WAIT_TIMEOUT);

ReleaseMutex(g_hAppCritSecMutex); // необязательно вследствие последующего закрытия

CloseHandle(g_hAppCritSecMutex);

end;

initialization

g_hAppMutex := 0;

finalization

ifLongBool(g_hAppMutex) then begin

ReleaseMutex(g_hAppMutex); // необязательно

CloseHandle(g_hAppMutex);

end;

end.

Михаил Чумакрекомендует следующий код:

Есть такая штука Atom (см. Help).

programSelfCheck;

uses

Windows,Forms,Unit1 in'Unit1.pas' {Form1};

const

AtStr='MyProgram';

functionCheckThis : boolean;

var

Atom: THandle;

begin

Atom:= GlobalFindAtom(AtStr);

Result:= Atom <> 0;

if notresult thenGlobalAddAtom(AtStr);

end;

begin

if notCheckThis then begin

// Запуск программмы

Application.Initialize;

Application.CreateForm(TForm1, Form1);

Application.Run;

GlobalDeleteAtom(GlobalFindAtom(AtStr));

// !!!

end

else begin

MessageBox(0,'Нельзя запустить две копии','Моя программа',0);

end;

end.

Элегантно и работает однозначно. Спасибо Славе Шубину.

Nomadicрекомендует следующее:

A: Воспользуйтесь функцией ActivatePrevInstance из библиотеки rxLib. Для завершения второго экземпляра используйте Application.Terminate.

(AS): Другой вариант: X:\DELPHI2\DEMOS\IPCDEMOS\ipcthrd.pas, функция IsMonitorRunning().

Nomadicрекомендует следующий код:

Если не принудительно, то можно послать на его Instance сообщение WM_QUIT. Если же необходимо принудительно терминировать приложение, то смотрите ниже — под Windows NT процесс можно терминировать через специально предназначенный для этого хэндл. Иначе гарантии нет. Предположим, что процесс создаем мы, ожидая его завершения в течение maxworktime. Тогда —

var

dwResult: Longint; // This example was converted from C source.

begin

// Not tested. Some 'nil' assignments must be applied

// as zero assignments in Pascal. Some vars need to

// be declared (maxworktime, si, pi). AA.

ifCreateProcess( nil, CmdStr, nil, nil, FALSE,CREATE_NEW_CONSOLE, nil, nil, si, pi) then begin

CloseHandle(pi.hThread);

dwResult := WaitForSingleObject(pi.hProcess, maxworktime*1000*60);

CloseHandle(pi.hProcess);

ifdwResult <> WAIT_OBJECT_0 then begin

pi.hProcess := OpenProcess(PROCESS_TERMINATE, FALSE, pi.dwProcessId);

ifpi.hProcess <> nil then begin

TerminateProcess(pi.hProcess, 0);

CloseHandle(pi.hProcess);

end;

end;

end;

end;

Nomadicрекомендует следующий код:

Для начала описываешь процедуру, которая будет вызываться по сообщению от таймера :

procedureFNTimeCallBack(uTimerID, uMessage: UINT;dwUser, dw1, dw2: DWORD); stdcall;

begin

//// Тело процедуры.

end;

а дальше в программе (например по нажатию кнопки) создаешь Таймер и вешаешь на него созданную процедуру

uTimerID:=timeSetEvent(10, 500, @FNTimeCallBack, 100, TIME_PERIODIC);

Подробности смотри в Help. Hу и в конце убиваешь таймер

timeKillEvent(uTimerID);

И все. Точность этого способа до 1 мсек. минимальный интервал времени можно задавать 1 мсек.

Обратите внимание на то, что все CALLBACK-функции, вызываемые Windows, должны использовать соглашение о вызовах stdcall.

Nomadicрекомендует следующий код:

Если только послать, то проще всего, пожалуй…

W32: F1 «NetMessageBufferSend»;

Win16: Почему-то не описан, но руками наковырял…

functionNetMessageBufferSend(Zero1, Zero2: Word; WhoTo: PChar; Buffer: PChar; BufSize: Word): Integer; external'netapi' index525;

«Кому» может быть '*' == всем.

Nomadicрекомендует следующий код:

constWM_ASYNCSELECT = WM_USER+0;

typeTNetConnectionsManager = class(tobject)

protected

FWndHandle : HWND;

procedureWndProc( varMsgRec : TMessage);

…

end;

constructorTNetConnectionsManager.Create

begin

inheritedCreate;

FWndHandle := AllocateHWnd(WndProc);

…

end;

destructorTNetConnectionsManager.Destroy;

begin

…

ifFWndHandle<>0 thenDeallocateHWnd(FWndHandle);

inheritedDestroy;

end;

procedureTNetConnectionsManeger.WndProc( varMsgRec : TMessage);

begin

withMsgRec do

ifMsg = WM_ASYNCSELECT thenWMAsyncSelect(MsgRec)

elseDefWindowProc(FWndHandle, Msg, wParam, lParam);

end;

Hо pекомендую посмотpеть WinSock2, в котоpом можно:

WSAEventSelect(FSocket, FEventHandle, FD_READ orfd_close);

WSAWaitForMultipleEvents( …);

WSAEnumNetworkEvents(FSocket, FEventHandle, lpNetWorkEvents);

То есть, обойтись без окон и без очеpеди сообщений windows, а заодно иметь возможность pаботать и с IPX/SPX, и с netbios.

VRSLazy@mail.ruпишет:

Доброго времени суток,

Вот посмотрел Ваше произведение Советы по делфи, мне очень понравилось :-)

Правда в вопросе/решении запустить другую программу просто обалдел :-( Я как то долго мучился с этим самым ShellExecute пока не пришёл к следующему:

uses …ToolWin, Windows …

procedureRun(App: String);

var

ErrStr : String;

PMSI: TStartupInfo;

PMPI: TProcessInformation;

begin

try

CreateProcess( nil, @App[1] , nil, nil, False, NORMAL_PRIORITY_CLASS, nil, nil, PMSI, PMPI);

except

ErrStr := 'Fault run process: '''+App+'''';

Application.MessageBox(@ErrStr[1],'Failure process', MB_OK+MB_ICONERROR);

end;

разумеется это одно из самых корявых решений, но всё же работает, как вариант сойдет?

Igor Nikolaev aKa The Spriteпредлагает следующий код:

procedureTForm1.Button1Click(Sender: TObject);