| Новости | Поиск | FAQ | Статьи | Книги | Новости VCL | | Форумы ЧАТ | Орешник | KOL и MCK |
Форумы -» Основная («Начинающим»)/ Базы / WinAPI / Компоненты / Сети / Media / Игры / Corba и COM / KOL / FreePascal / .Net / Прочее / RSDN.ORG

	« предыдущая ветвь | форум | следующая ветвь »

Запуск одной копии программы и обнаружение ее при повторном запус [D7, Win2k]

Страницы:   < 1 2 >

Fantom ©   (2005-01-21 10:07:00) 

Всем привет!
Тема не самая новая и уже проелась, но вчера просидел 3 часа в поисках примера по етому поводу так ничего толкового не нашел... Помогите пожалуйста.
Есть программа, написанная на Delphi. Мне нужно чтобы пользователь мог запусть ее только один раз, а при повторном запуске, если прога уже запущена, первая копия становилась активной независимо свернутая она на панель или весит в трее...
Спасибо!

---

Digitman   (2005-01-21 11:47:00) [1]

> Igor_thief   (21.01.05 11:37) [20]


> Я просто в шоке. Столько кода!


я предложил частное решение.
адаптированное под свои задачи.
и с легкостью адаптируемое под любую похожую задачу, в т.ч. и эту.
при этом подчеркнув доп.возможности этого решения, которые с легкостью м.б. задействованы при использовании либо гот.кода либо наглядно продемонстрированной в нем технологии.

к.г., "не нравится - не ешь")

---

Leshiy   (2005-01-21 11:45:00) [2]

Fay © (21.01.05 11:10) [14]
я ни на что не претендую ;)

---

Igor_thief   (2005-01-21 11:37:00) [3]

Думкин ©   (21.01.05 11:18) [17]
100% будет Copy/Paste. Ведь для решения этой задачи можно найти горздо менее объемные подходы и я уверен что они не буду намного хуже.
Я просто в шоке. Столько кода!

---

Digitman   (2005-01-21 11:25:00) [4]

> Думкин ©   (21.01.05 11:18) [17]


конечно, можно было бы его (код этот) и в кладовку выложить в кач-ве еще одного примера по NP, да вот беда - не работает она ... и давно уже ...

---

Digitman   (2005-01-21 11:24:00) [5]

> Думкин ©   (21.01.05 11:18) [17]


объем в коде данного решения не будет играть никакой роли, если приложение, потенциально использующее дан.код, внушительное по функциональности, использует как минимум те же классы и в нем планируется довольно интенсивный инф.обмен между двумя его экз-рами .. в противном же случае согласен с тобой .. ну это уж - на вкус и цвет ..

---

Думкин   (2005-01-21 11:18:00) [6]

> [15] Digitman ©   (21.01.05 11:13)

Статью ИШ знаю. Это понятно. Но получилось так - новое решение старой задачи и объемное. Ведь втупую Copy/Paste произойдет и все.

---

MetalFan   (2005-01-21 11:16:00) [7]

Digitman ©   (21.01.05 10:49) [2]
в FAQ однозначно!
> З.Ы.
> Я бы сделал через мьютекс и бродкастовое сообщение

а я именно так и делал ) и намана работало!

---

Digitman   (2005-01-21 11:13:00) [8]

> Думкин ©   (21.01.05 10:56) [7]


статья похожая уже есть, кажется ИШ ее писал ..
а код этот был "заточен" мной когда-по под один из проектов и поэтому имеет определенные ограничения, что, впрочем, не мешает доработать его под свои задачи


> REA   (21.01.05 11:01) [10]


и такое я тоже реализовывал ..
но это не суть как важно .. в дан.случае это просто пример готового работающего транспорта и его простой оболочки

---

Fay   (2005-01-21 11:10:00) [9]

2 Leshiy ©   (21.01.05 11:07) [12]
Это самый плохой способ.

---

Digitman   (2005-01-21 11:08:00) [10]

использование NP дает преимущество перед другими сист.объектами синхронизации - позволяет установившим соединение процессам легко и оч быстро обмениваться значительными по размеру блоками инф-ции

в дан.случае применить указанный код можно так :

1. Сразу после старта приложение первым делом создает экз-р класса TIPCClientThread и тут же в цикле ожидает установление св-ва TIPCClientThread.Connected в True .. цикл должен крутиться, скажем, не более 10..20 мс - этого времени достаточно для установления коммуникации с другим процессом того же приложения(если он существует)

2. Если через 10..20 TIPCClientThread.Connected по-прежнему, то экз-р TIPCClientThread уничтожается, а вместо него создается экз-р экз-р класса TIPCServerThread и приложение продолжает свою дальнейшую работу нужным образом

3. Если в ходе цикла было обнаружено TIPCClientThread.Connected = True, то это означает активность другого экз-ра приложения и активность в его процессе серв.части именованого канала .. с пом.метода CallAction(), приложение-клиент посылает приложению-серверу какие-либо данные, по получению которых приложение-сервер выполняет какие-либо действия (например, активизируется и получает фокус).. дождавшись возврата из CallAction() приложение-клиент немедленно завершает работу.

---

Leshiy   (2005-01-21 11:07:00) [11]

Самый наипростейший способ:

var hMainForm:HWND;
begin
 hMainForm:=FindWindow(nil,'Прога');
 if  hMainForm = 0 then
 begin
   Application.Initialize;
   Application.CreateForm(TForm1, Form1);
   Application.Run;
 end else MessageBox(Application.Handle,'Программа уже запущена','Внимание',MB_APPLMODAL or MB_ICONWARNING);
end.

---

Skyle   (2005-01-21 11:05:00) [12]

> Digitman ©   (21.01.05 10:49) [2] - [6]

А это чё за кампанента такая? Где скачать мона? А она кофя варит?

---

REA   (2005-01-21 11:01:00) [13]

2Digitman: круто! Надо было еще COM-сервер и клиент добавить для объема.

---

Fay   (2005-01-21 10:59:00) [14]

2 Fantom   (21.01.05 10:07)
На всякий случай

CreateNamedPipe

Windows NT/2000/XP: Included in Windows NT 3.1 and later.
Windows 95/98/Me: Unsupported.

З.Ы.
Я бы сделал через мьютекс и бродкастовое сообщение

---

Skyle   (2005-01-21 10:57:00) [15]

Тут две задачи.
1. Определить, что копия не первая
 CreateMutes + ERROR_ALREADY_EXISTS
2. Активировать имеющуюся копию
 SetForegroundWindow например

---

Думкин   (2005-01-21 10:56:00) [16]

Вклинюсь.
> [6] Digitman ©   (21.01.05 10:52)
Такое лучше в статью оформить? Или тут она и будет жить?

---

Digitman   (2005-01-21 10:52:00) [17]

//разрыв трансп.соединения
procedure TIPCThread.DoDisconnect;
begin
 if not FConnected then Exit;
 if FPendingConnect or FPendingRead or FPendingWrite then
   CancelIO(hPipe);
 ClearSendingQueue;
 ClearReceivingQueue;
 ClearPendingQueue;
 FConnected := False;
end;

procedure TIPCThread.DoTerminate;
begin
end;

{ TIPCClientThread }

constructor TIPCClientThread.Create(WndHandle: THandle; ServerName, PipeName: String; ActionHandler: TActionHandler);
begin
 FServerName := Trim(ServerName);
 if FServerName = '' then
   FServerName := '.';
 inherited Create(WndHandle, PipeName, ActionHandler);
end;

procedure TIPCClientThread.DoConnect;
var
 FullPipeName: String;
begin
 FullPipeName := '\\' + FServerName + '\pipe\' + FPipeName;
 if WaitNamedPipe(PChar(FullPipeName), DEFAULT_TIMEOUT) then
   begin
     hPipe := CreateFile(PChar(FullPipeName),
             GENERIC_READ or GENERIC_WRITE, 0, nil,
                     OPEN_EXISTING,
                     FILE_FLAG_NO_BUFFERING
                     or FILE_FLAG_WRITE_THROUGH
                     or FILE_FLAG_OVERLAPPED,
                     0);
     FConnected := hPipe <> 0;
   end;
 if not FConnected and (GetLastError = ERROR_FILE_NOT_FOUND) then
   Sleep(100)
 else
   inherited;
end;

procedure TIPCClientThread.DoDisconnect;
begin
 inherited;
 CloseHandle(hPipe);
 hPipe := 0;
end;

{ TIPCServerThread }

procedure TIPCServerThread.DoConnect;
var
 ovc: TOverlapped;
 WaitResult: DWord;
begin
 if hPipe = 0 then
   begin
     hPipe := CreateNamedPipe(PChar('\\.\pipe\' + FPipeName),
                           PIPE_ACCESS_DUPLEX
                           or FILE_FLAG_WRITE_THROUGH
                           or FILE_FLAG_OVERLAPPED,
                           PIPE_TYPE_MESSAGE or PIPE_READMODE_MESSAGE or PIPE_WAIT,
                           1, MAX_MSG_SIZE, MAX_MSG_SIZE, DEFAULT_TIMEOUT, nil);

     if hPipe = 0 then Exit;
   end;
 FillChar(ovc, SizeOf(ovc), 0);
 ovc.hEvent := CreateEvent(nil, False, False, nil);
 ConnectNamedPipe(hPipe, @ovc);
 FPendingConnect := GetLastError = ERROR_IO_PENDING;
 while not Terminated and FPendingConnect do
   begin
     WaitResult := MsgWaitForMultipleObjects(1, ovc.hEvent, False, INFINITE, QS_ALLINPUT);
     case  WaitResult of
       WAIT_OBJECT_0:
       begin
         FPendingConnect := False;
         FConnected := GetOverlappedResult(hPipe, ovc, FBytesRead, False);
         if FConnected then
          inherited;
       end;
       WAIT_OBJECT_0 + 1: ProcessMessages;
     end;
   end;
 CloseHandle(ovc.hEvent);
end;

procedure TIPCServerThread.DoDisconnect;
begin
 inherited;
 DisconnectNamedPipe(hPipe);
end;

end.

продолжение следует ..

---

Digitman   (2005-01-21 10:51:00) [18]

//обработка входящих результатов исполнения акции
procedure TIPCThread.ProcessIncomingResult;
var
 List: TList;
 DataBlock: PDataBlock;
 BlockSize: DWord;
 idx: Integer;
begin
 BlockSize := DataBlockHdrSize + FInBuf.Header.ParamSize;
 List := FRecvQueue.LockList;
 with List do
 try
   GetMem(DataBlock, BlockSize);
   CopyMemory(DataBlock, FInBuf, BlockSize);
   idx := FPendingQueue.IndexOf(Pointer(DataBlock.Header.WaitEvent));
   if idx >= 0 then
     begin
       FPendingQueue.Delete(idx);
       if SetEvent(DataBlock.Header.WaitEvent) then
         Add(DataBlock)
       else
         FreeMem(DataBlock);
     end
   else
     FreeMem(DataBlock);
 finally
   FRecvQueue.UnLockList;
 end;
end;

//обработка сообщений на постановку инф.блока в очередь на передачу
procedure TIPCThread.MsgSendMsg(var Message: TMessage);
var
 List: TList;
 DataBlock: PDataBlock;
 BlockSize: DWord;
 idx: Integer;
begin
 DataBlock := PDataBlock(Message.wParam);
 if FPendingWrite then
   begin
     List := FSendQueue.LockList;
     try
       List.Add(DataBlock);
     finally
       FSendQueue.UnLockList;
     end;
   end
 else
   begin
     BlockSize := Message.lParam;
     CopyMemory(FOutBuf, DataBlock, BlockSize);
     FreeMem(DataBlock);
     with FOutBuf.Header do
     begin
       if (Signature = CallSig) and (WaitEvent <> 0) then
         idx := FPendingQueue.Add(Pointer(WaitEvent));
     end;
     if WriteFile(hPipe, FOutBuf^, BlockSize, FBytesWritten, @ovw) then
       Exit;
     FPendingWrite := GetLastError = ERROR_IO_PENDING;
     if not FPendingWrite then
       DoDisconnect;
   end;
end;

//команда на завершение трэда
procedure TIPCThread.MsgQuit(var Message: TMessage);
begin
 Terminate;
end;

//вызов акции на исполнение удаленной стороной

//Вх.аргументы :
// Action - код акции
// Params - параметры акции
// ParamSize - число байт параметров акции
//Вых.аргументы:
// ResultData - данные, предст. результаты исполненной акции
// ResultSize - число байт результата

//ф-ция возвращает True, если транзакция успешно завершена, False - иначе
//ф-ция так же возбуждает исключения ETransportError и EActionError

function TIPCThread.CallAction(Action: TAction; Params: Pointer;
 ParamSize: DWord; out ResultData: Pointer; out ResultSize: DWord): Boolean;
var
 DataBlock: PDataBlock;
 BlockSize: DWord;
 hEvent: THandle;
 List: TList;
 i: Integer;
begin
 Result := False;
 if not FConnected then Exit;
 BlockSize := DataBlockHdrSize + ParamSize;
 GetMem(DataBlock, BlockSize);
 hEvent := CreateEvent(nil, False, False, nil);
 with DataBlock^ do
 begin
   Header.Signature := CallSig;
   Header.Action := Action;
   Header.WaitEvent := hEvent;
   Header.ParamSize := ParamSize;
 end;
 CopyMemory(@DataBlock.Params, Params, ParamSize);
 if not PostThreadMessage(ThreadId, TM_SENDMSG, Cardinal(DataBlock), BlockSize) then
   begin
     CloseHandle(hEvent);
     FreeMem(DataBlock);
     raise ETransportError.Create('Соединение разорвано');
   end;
 DataBlock := nil;
 while True do
   case WaitForSingleObject(hEvent, 10) of
     WAIT_OBJECT_0:
     begin
       List := FRecvQueue.LockList;
       with List do
       try
         for i := 0 to Count - 1 do
           if PDataBlock(Items[i]).Header.WaitEvent = hEvent then
             begin
               DataBlock := Items[i];
               CloseHandle(DataBlock.Header.WaitEvent);
               Delete(i);
               Break;
             end;
           Break;
       finally
         FRecvQueue.UnLockList;
       end;
     end;
     WAIT_FAILED:  raise ETransportError.Create('Соединение разорвано');
     WAIT_TIMEOUT: Continue;
   end;

 if Assigned(DataBlock) then
   try
     if not DataBlock.Header.ExceptionFlag then
       begin
         ResultSize := DataBlock.Header.ParamSize;
         GetMem(ResultData, ResultSize);
         CopyMemory(ResultData, @DataBlock.Params, ResultSize);
         Result := True;
       end
     else
       raise EActionError.Create(StrPas(@DataBlock.Params));
   finally
     FreeMem(DataBlock);
   end;
end;

procedure TIPCThread.DoConnect;
begin
 if hWnd <> 0 then
   PostMessage(hWnd, TM_CONNECT, 0, 0);
end;

продолжение следует ..

---

Digitman   (2005-01-21 10:51:00) [19]

//очистка очереди приема
procedure TIPCThread.ClearReceivingQueue;
var
 List: TList;
 i: Integer;
 DataBlock: PDataBlock;
begin
 List := FRecvQueue.LockList;
 with List do
 try
   for i:= 0 to Count - 1 do
     begin
       DataBlock := Items[i];
       if DataBlock.Header.Signature = ResultSig then
         CloseHandle(DataBlock.Header.WaitEvent);
       FreeMem(DataBlock);
     end;
   Clear;
 finally
   FRecvQueue.UnLockList;
 end;
end;

//обработка трансп.событий
procedure TIPCThread.ProcessTransport;
var
 Msg: TMsg;
 DataBlock: PDataBlock;
 Size: DWord;
begin
 if not FPendingRead then
   begin
     FPendingRead := not ReadFile(hPipe, FInBuf^, MAX_MSG_SIZE, FBytesRead, @ovr) and (GetLastError = ERROR_IO_PENDING);
     if not FPendingRead then
       DoDisconnect
   end
 else
   case MsgWaitForMultipleObjects(2, FEvents, False, INFINITE, QS_SENDMESSAGE or QS_POSTMESSAGE) of
     WAIT_OBJECT_0     :  ProcessReadEvent;
     WAIT_OBJECT_0 + 1 :  ProcessWriteEvent;
     WAIT_OBJECT_0 + 2 :  ProcessMessages;
   end;
end;

//событие приема данных
procedure TIPCThread.ProcessReadEvent;
var
 ovl_Result: Boolean;
begin
 FPendingRead := False;
 ovl_Result := GetOverlappedResult(hPipe, ovr, FBytesRead, False);
 if ovl_Result and (FBytesRead = 0) then Exit;
 if not ovl_Result or (FBytesRead <> (DataBlockHdrSize + FInBuf.Header.ParamSize)) then
   DoDisconnect
 else
   case FInBuf.Header.Signature of
     CallSig:    ProcessIncomingCall;
     ResultSig:  ProcessIncomingResult;
   else
     DoDisconnect;
   end;
end;

//событие передачи данных
procedure TIPCThread.ProcessWriteEvent;
var
 DataBlock: PDataBlock;
 BlockSize: DWord;
 List: TList;
 ovl_Result: Boolean;
begin
 FPendingWrite := False;
 ovl_Result := GetOverlappedResult(hPipe, ovw, FBytesWritten, False);
 if ovl_Result and (FBytesWritten = 0) then Exit;
 if not ovl_Result or (FBytesWritten <> (DataBlockHdrSize + FOutBuf.Header.ParamSize)) then
   DoDisconnect
 else
   begin
     List := FSendQueue.LockList;
     with List do
     try
       if Count > 0 then
         begin
           DataBlock := Items[0];
           Delete(0);
         end
       else
         DataBlock := nil;
     finally
       FSendQueue.UnLockList;
     end;
     if Assigned(DataBlock) then
       begin
         BlockSize := DataBlockHdrSize + DataBlock.Header.ParamSize;
         CopyMemory(FOutBuf, DataBlock, BlockSize);
         FreeMem(DataBlock);
         if WriteFile(hPipe, FOutBuf^, BlockSize, FBytesWritten, @ovw) then Exit;
         FPendingWrite := GetLastError = ERROR_IO_PENDING;
         if not FPendingWrite then
           with FOutBuf.Header do
           begin
             if (Signature = CallSig) and (WaitEvent <> 0) then
               CloseHandle(WaitEvent);
             DoDisconnect;
           end;
       end;
   end;
end;

//обработка входящих запросов на исполнение акции
procedure TIPCThread.ProcessIncomingCall;
const
 ActionNotSupported: PChar = 'Акция не поддерживается удаленной стороной';
var
 ResultDataBlock: PDataBlock;
 ResultDataBlockSize: DWord;
 excptmsg: String;
begin
 with FInBuf^ do
 try
   Header.ExceptionFlag := True;
   if not Assigned(FActionHandler)
   or not FActionHandler(Header.Action, @Params, Header.ParamSize, Params, Header.ParamSize) then
     begin
       StrCopy(@Params, ActionNotSupported);
       Header.ParamSize := StrLen(ActionNotSupported) + 1;
     end
   else
     Header.ExceptionFlag := False;
 except
   on e:Exception do
     begin
       excptmsg := 'Исполнение акции вызвало исключительную ситуацию'#10 + e.ClassName + #10 + e.Message;
       StrCopy(@Params, PChar(excptmsg));
       Header.ParamSize := Length(excptmsg) + 1;
     end;
 end;
 ResultDataBlockSize :=  DataBlockHdrSize + FInBuf.Header.ParamSize;
 GetMem(ResultDataBlock, ResultDataBlockSize);
 with ResultDataBlock^ do
   begin
     Header.Action := FInBuf.Header.Action;
     Header.WaitEvent := FInBuf.Header.WaitEvent;
     Header.Signature := ResultSig;
     Header.ExceptionFlag := FInBuf.Header.ExceptionFlag;
     Header.ParamSize := FInBuf.Header.ParamSize;
     if Header.ParamSize > 0 then
       CopyMemory(@Params, @FInBuf.Params, FInBuf.Header.ParamSize);
     PostThreadMessage(ThreadId, TM_SENDMSG, Cardinal(ResultDataBlock), ResultDataBlockSize);
   end;
end;

продолжение следует ..

---

Digitman   (2005-01-21 10:50:00) [20]

implementation

{ TIPCThread }

constructor TIPCThread.Create(WndHandle: THandle; PipeName: String; ActionHandler: TActionHandler);
begin
 hWnd := WndHandle;
 FPipeName := PipeName;
 FActionHandler := ActionHandler;
 FillChar(ovr, sizeof(ovr), 0);
 FillChar(ovw, sizeof(ovw), 0);
 ovr.hEvent := CreateEvent(nil, False, False, nil);
 ovw.hEvent := CreateEvent(nil, False, False, nil);
 FEvents[0] := ovr.hEvent;
 FEvents[1] := ovw.hEvent;
 GetMem(FInBuf, MAX_MSG_SIZE);
 GetMem(FOutBuf, MAX_MSG_SIZE);
 FSendQueue := TThreadList.Create;
 FRecvQueue := TThreadList.Create;
 FPendingQueue := TList.Create;
 inherited Create(False);
end;

destructor TIPCThread.Destroy;
begin
 PostThreadMessage(ThreadId, WM_QUIT, 0, 0);
 inherited;
 if hPipe <> 0 then
   CloseHandle(hPipe);
 FRecvQueue.Free;
 FSendQueue.Free;
 FPendingQueue.Free;
 CloseHandle(ovr.hEvent);
 CloseHandle(ovw.hEvent);
 CloseHandle(hPipe);
 FreeMem(FInBuf);
 FreeMem(FOutBuf);
end;

procedure TIPCThread.Execute;
var
 Msg: TMsg;
begin
 PeekMessage(Msg, 0, 0, 0, PM_NOREMOVE);
 try
//пока трансп.трэд не терминирован
   while not Terminated do
     begin
       DoConnect; //соединение с удаленным партнером
       if Terminated then Exit;
//пока транспорт активен и трэд не терминирован
       while not Terminated and FConnected do
         ProcessTransport; //обработка транспортных событий
     end;
 finally
   DoDisconnect;
 end;
end;

//обработка сообщений трансп.трэду
procedure TIPCThread.ProcessMessages;
var
 Msg: TMsg;
begin
 while PeekMessage(Msg, 0, 0, 0, PM_REMOVE) do
   Dispatch(Msg.Message);
end;

//очистка списка объектов-событий ожидания рез-тов вызванных акций
procedure TIPCThread.ClearPendingQueue;
var
 i: Integer;
begin
 with FPendingQueue do
 begin
   for i := 0 to Count - 1 do
     CloseHandle(THandle(Items[i]));
   Clear;
 end;
end;

//очистка очереди передачи
procedure TIPCThread.ClearSendingQueue;
var
 Msg: TMsg;
 DataBlock: PDataBlock;
 List: TList;
 i: Integer;
begin
 while PeekMessage(Msg, 0, TM_SENDMSG, TM_SENDMSG, PM_REMOVE) do
   begin
     DataBlock := PDataBlock(Msg.wParam);
     with DataBlock.Header do
     if (Signature = CallSig) and  (WaitEvent <> 0) then
       CloseHandle(WaitEvent);
     FreeMem(DataBlock);
   end;
 List := FSendQueue.LockList;
 with List do
 try
   for i:= 0 to Count - 1 do
     begin
       DataBlock := Items[i];
       with DataBlock.Header do
       if (Signature = CallSig) and (WaitEvent <> 0) then
         CloseHandle(WaitEvent);
       FreeMem(DataBlock);
     end;
   Clear;
 finally
   FSendQueue.UnLockList;
 end;
end;

продолжение следует ..

---

Страницы:   < 1 2 >

Наверх