end.
Решение 2
Предоставленное разработчиками Delphi 2 Пачекой (Pacheco) и Тайхайрой (Teixeira) и значительно переработанное.
unit multinst;
{Применение:
Необходимый код в исходном проекте
if InitInstance then begin
Application.Initialize;
Application.CreateForm(TFrmSelProject, FrmSelProject);
Application.Run;
end;
Это все понятно (я надеюсь)}
interface
uses Forms, Windows, Dialogs, SysUtils;
const
MI_NO_ERROR = 0;
MI_FAIL_SUBCLASS = 1;
MI_FAIL_CREATE_MUTEX = 2;
{ Проверка правильности запуска приложения с помощью описанных ниже функций. }
{ Количество флагов ошибок MI_* может быть более одного. }
function GetMIError: Integer;
Function InitInstance : Boolean;
implementation
const
UniqueAppStr : PChar; {Различное для каждого приложения}
var
MessageId: Integer;
WProc: TFNWndProc = Nil;
MutHandle: THandle = 0;
MIError: Integer = 0;
function GetMIError: Integer;
begin
Result:= MIError;
end;
function NewWndProc(Handle: HWND; Msg: Integer; wParam, lParam: Longint): Longint; StdCall;
begin
{ Если это – сообщение о регистрации… }
if Msg = MessageID then begin
{ если основная форма минимизирована, восстанавливаем ее }
{ передаем фокус приложению }
if IsIconic(Application.Handle) then begin
Application.MainForm.WindowState:= wsNormal;
ShowWindow(Application.Mainform.Handle, sw_restore);
end;
SetForegroundWindow(Application.MainForm.Handle);
end
{ В противном случае посылаем сообщение предыдущему окну }
else Result:= CallWindowProc(WProc, Handle, Msg, wParam, lParam);
end;
procedure SubClassApplication;
begin
{ Обязательная процедура. Необходима, чтобы обработчик }
{ Application.OnMessage был доступен для использования. }
WProc:= TFNWndProc(SetWindowLong(Application.Handle, GWL_WNDPROC, Longint(@NewWndProc)));
{ Если происходит ошибка, устанавливаем подходящий флаг }
if WProc = Nil then MIError:= MIError or MI_FAIL_SUBCLASS;
end;
procedure DoFirstInstance;
begin
SubClassApplication;
MutHandle:= CreateMutex(Nil, False, UniqueAppStr);
if MutHandle = 0 then
MIError:= MIError or MI_FAIL_CREATE_MUTEX;
end;
procedure BroadcastFocusMessage;
{ Процедура вызывается, если уже имеется запущенная копия Вашей программы. }
var
BSMRecipients: DWORD;
begin
{ Не показываем основную форму }
Application.ShowMainForm:= False;
{ Посылаем другому приложению сообщение и информируем о необходимости }
{ перевести фокус на себя }
BSMRecipients:= BSM_APPLICATIONS;
BroadCastSystemMessage(BSF_IGNORECURRENTTASK or BSF_POSTMESSAGE, @BSMRecipients, MessageID, 0, 0);
end;
Function InitInstance : Boolean;
begin
MutHandle:= OpenMutex(MUTEX_ALL_ACCESS, False, UniqueAppStr);
if MutHandle = 0 then begin
{ Объект Mutex еще не создан, означая, что еще не создано }
{ другое приложение. }
ShowWindow(Application.Handle, SW_ShowNormal);
Application.ShowMainForm:=True;
DoFirstInstance;
result:= True;
end else begin
BroadcastFocusMessage;
result:= False;
end;
end;
initialization
begin
UniqueAppStr:= Application.Exexname;
MessageID:= RegisterWindowMessage(UniqueAppStr);
ShowWindow(Application.Handle, SW_Hide);
Application.ShowMainForm:=FALSE;
end;
finalization
begin
if WProc <> Nil then
{ Приводим приложение в исходное состояние }
SetWindowLong(Application.Handle, GWL_WNDPROC, LongInt(WProc));
end;
end.
Решение 3
VAR MutexHandle:THandle;
Var UniqueKey: string;
FUNCTION IsNextInstance:BOOLEAN;
BEGIN
Result:=FALSE;
MutexHandle:=0;
MutexHandle:=CREATEMUTEX(NIL,true, uniquekey);
IF MutexHandle<>0 THEN BEGIN
IF GetLastError=ERROR_ALREADY_EXISTS THEN BEGIN
Result:=TRUE;
CLOSEHANDLE(MutexHandle);
MutexHandle:=0;
END;
END;
END;
begin
CmdShow:=SW_HIDE;
MessageId:=RegisterWindowMessage(zAppName);
Application.Initialize;
IF IsNextInstance THEN PostMessage(HWND_BROADCAST, MessageId,0,0)
ELSE BEGIN
Application.ShowMainForm:=FALSE;
Application.CreateForm(TMainForm, MainForm);
MainForm.StartTimer.Enabled:=TRUE;
Application.Run;
END;
IF MutexHandle<>0 THEN CLOSEHANDLE(MutexHandle);
end.
В MainForm вам необходимо вставить обработчик внутреннего сообщения
PROCEDURE TMainForm.OnAppMessage(VAR M:TMSG; VAR Ret:BOOLEAN);
BEGIN
IF M.Message=MessageId THEN BEGIN
Ret:=TRUE;
// Поместить окно наверх !!!!!!!!
END;
END;
INITIALIZATION
ShowWindow(Application.Handle, SW_Hide);
END.
Каким образом, программным путем, можно узнать о завершении запущенной программы?
16-битная версия:
uses Wintypes,WinProcs,Toolhelp,Classes,Forms;
Function WinExecAndWait(Path: string; Visibility: word): word;
var
InstanceID: THandle;
PathLen: integer;
begin
{ Преобразуем строку в тип PChar }
PathLen:= Length(Path);
Move(Path[1],Path[0],PathLen);
Path[PathLen]:= #00;
{ Пытаемся запустить приложение }
InstanceID:= WinExec(@Path,Visibility);
if InstanceID < 32 then { значение меньше 32 указывает на ошибку приложения }
WinExecAndWait:= InstanceID
else begin
Repeat
Application.ProcessMessages;
until Application.Terminated or (GetModuleUsage(InstanceID) = 0);
WinExecAndWait:= 32;
end;
end;
32-битная версия:
function WinExecAndWait32(FileName: String; Visibility: integer):integer;
var
zAppName:array[0..512] of char;
zCurDir:array[0..255] of char;
WorkDir:String;
StartupInfo:TStartupInfo;
ProcessInfo:TProcessInformation;
begin
StrPCopy(zAppName,FileName);
GetDir(0,WorkDir);
StrPCopy(zCurDir,WorkDir);
FillChar(StartupInfo,Sizeof(StartupInfo),#0);
StartupInfo.cb:= Sizeof(StartupInfo);
StartupInfo.dwFlags:= STARTF_USESHOWWINDOW;
StartupInfo.wShowWindow:= Visibility;
if not CreateProcess(nil,
zAppName, { указатель командной строки }
nil, { указатель на процесс атрибутов безопасности }
nil, { указатель на поток атрибутов безопасности }
false, { флаг родительского обработчика }
CREATE_NEW_CONSOLE or { флаг создания }
NORMAL_PRIORITY_CLASS,
nil, { указатель на новую среду процесса }
nil, { указатель на имя текущей директории }
StartupInfo, { указатель на STARTUPINFO }
ProcessInfo) then result := –1 { указатель на process_inf }
else begin
WaitforSingleObject(ProcessInfo.hProcess,INFINITE);
GetExitCodeProcess(ProcessInfo.hProcess,Result);
end;
end;
Вот мое решение. Я использовал его во многих программах и смело рекомендую его вам.
procedure TForm1.Button1Click(Sender: TObject);
var
szFileName: array[0..49] of char;
szModuleName: array[0..19] of char;
iSize : integer;
begin
StrPCopy(szModuleName, 'NameOfModule');
iSize:= GetModuleFileName(GetModuleHandle(szModuleName), szFileName, SizeOf(szFileName));
if iSize > 0 then ShowMessage('Имя модуля с полным путем: ' + StrPas(szFileName))
else ShowMessage('Имя модуля не встречено');
end;
Извлечение из EXE-файла иконки и рисование ее в TImage.
Каким образом извлечь иконку из EXE– и DLL-файлов (ExtractAssociatedIcon) и отобразить ее на компоненте Timage или небольшой области на форме?
uses ShellApi;
procedure TForm1.Button1Click(Sender: TObject);
var
IconIndex: word;
h: hIcon;
begin
IconIndex:= 0;
h:= ExtractAssociatedIcon(hInstance, 'C:WINDOWSNOTEPAD.EXE', IconINdex);
DrawIcon(Form1.Canvas.Handle, 10, 10, h);
end;
Очень простой пример…
Const MaxBooleans = (High(Cardinal) – $F) div sizeof(boolean);
Type
TBoolArray = array[1..MaxBooleans] of boolean;
PBoolArray = ^TBoolArray;
Var
B: PBoolArray;
N: integer;
BEGIN
N:= 63579;
