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

var

 g_hAppCritSecMutex: THandle;

 dw: Longint;

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

 if LongBool(g_hAppMutex)  then begin

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

  CloseHandle(g_hAppMutex);

 end;

end.

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

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

program SelfCheck;

uses

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

const

 AtStr='MyProgram';

function CheckThis : boolean;

var

 Atom: THandle;

begin

 Atom:= GlobalFindAtom(AtStr);

 Result:= Atom <> 0;

 if not result then GlobalAddAtom(AtStr);

end;

begin

 if not CheckThis 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:DELPHI2DEMOSIPCDEMOSipcthrd.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.

 if CreateProcess(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);

  if dwResult <> WAIT_OBJECT_0 then begin

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

   if pi.hProcess <> nil then begin

     TerminateProcess(pi.hProcess, 0);

     CloseHandle(pi.hProcess);

   end;

  end;

 end;

end;

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

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

procedure FNTimeCallBack(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: Почему-то не описан, но руками наковырял…

function NetMessageBufferSend(Zero1, Zero2: Word; WhoTo: PChar; Buffer: PChar; BufSize: Word): Integer; external 'netapi' index 525;

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

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

const WM_ASYNCSELECT = WM_USER+0;

type TNetConnectionsManager = class(tobject)

protected

 FWndHandle : HWND;

procedure WndProc(var MsgRec : TMessage);

 …

end;

constructor TNetConnectionsManager.Create

begin

 inherited Create;

 FWndHandle := AllocateHWnd(WndProc);

 …

end;

destructor TNetConnectionsManager.Destroy;

begin

 …

 if FWndHandle<>0 then DeallocateHWnd(FWndHandle);

 inherited Destroy;

end;

procedure TNetConnectionsManeger.WndProc(var MsgRec : TMessage);

begin

 with MsgRec do

  if Msg = WM_ASYNCSELECT then WMAsyncSelect(MsgRec)

  else DefWindowProc(FWndHandle, Msg, wParam, lParam);

end;

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

WSAEventSelect(FSocket, FEventHandle, FD_READ or fd_close);

WSAWaitForMultipleEvents(…);

WSAEnumNetworkEvents(FSocket, FEventHandle, lpNetWorkEvents);

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

[email protected] пишет:

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

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

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

uses …ToolWin, Windows …

procedure Run(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 предлагает следующий код:

procedure TForm1.Button1Click(Sender: TObject);

VAR

 Wnd : hWnd;

 buff: ARRAY [0..127] OF Char;

begin

 ListBox1.Clear;

 Wnd := GetWindow(Handle, gw_HWndFirst);

 WHILE Wnd <> 0 DO BEGIN {Hе показываем:}

  IF (Wnd <> Application.Handle) AND {-Собственное окно}

   IsWindowVisible(Wnd) AND {-Hевидимые окна}

   (GetWindow(Wnd, gw_Owner) = 0) AND {-Дочернии окна}

   (GetWindowText(Wnd, buff, sizeof(buff)) <> 0)

   THEN BEGIN

   GetWindowText(Wnd, buff, sizeof(buff));

   ListBox1.Items.Add(StrPas(buff));

  END;

  Wnd := GetWindow(Wnd, gw_hWndNext);

 END;

 ListBox1.ItemIndex := 0;

end;

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

A: WinExec() или ShellExecute. У второй больше возможностей.

(SO): CreateProcess() в параметре process info возвращает handle запущенного процесса. Вот и делаешь WaitForSingleObject(pi.hProcess, INFINITE);

(AA): (Win16) Delay можно взять из rxLib.

handle := WinExec(…);