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

• Название: Советы по Delphi. Версия 1.0.6
• Автор: Валентин Озеров
• Жанр: Программирование

---

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:\WINDOWS\NOTEPAD.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;