Виртуальная библиотека Delphi

{Проверяем есть ли указатель на предыдущую копию приложения}

IF hPrevInst <> 0 THEN BEGIN

{Если есть, то выдаем сообщение и выходим}

MessageDlg('Программа уже запущена!', mtError, [mbOk], 0);

Halt;

END;

{Иначе - ничего не делаем (не мешаем созданию формы)}

end;

P.S. Для выхода необходимо использовать Halt, а не Close, как хотелось бы, так как форма еще не создана и закрывать нечего.

Есть и другой способ — по списку загруженных приложений

procedure TForm1.FormCreate(Sender: TObject);

VAR

Wnd : hWnd;

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

Begin

Wnd := GetWindow(Handle, gw_HWndFirst);

WHILE Wnd <> 0 DO BEGIN

IF (Wnd <> Application.Handle) AND (GetWindow(Wnd, gw_Owner) = 0)

THEN BEGIN

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

IF StrPas (buff) = Application.Title THEN

BEGIN

MessageDlg('Приложение уже загружено', mtWarning, [mbOk], 0);

Halt;

END;

END;

Wnd := GetWindow (Wnd, gw_hWndNext);

END;

End;

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

Пример:

program Project1;

uses

Windows, // Обязательно

Forms,

Unit1 in 'Unit1.pas' {Form1};

{$R *.RES}

Const

MemFileSize = 1024;

MemFileName = 'one_inst_demo_memfile';

Var

MemHnd : HWND;

begin

{ Попытаемся создать файл в памяти }

MemHnd := CreateFileMapping(HWND($FFFFFFFF),

nil,

PAGE_READWRITE,

0,

MemFileSize,

MemFileName);

{ Если файл не существовал запускаем приложение }

if GetLastError<>ERROR_ALREADY_EXISTS then

begin

Application.Initialize;

Application.CreateForm(TForm1, Form1);

Application.Run;

end;

CloseHandle(MemHnd);

end.

Часто при работе у пользователя может быть открыто 5–20 окон и сообщение о том, что программа уже запущено приводит к тому, что он вынужден полчаса искать ранее запущенную копию. Выход из положения — найдя копию программы активировать ее, для чего в последнем примере перед HALT необходимо добавить строку :

SetForegroundWindow(Wnd);

Например так:

uses

Windows, // !!!

Forms,

Unit0 in 'Unit0.pas' {Form1};

var

Handle1 : LongInt;

Handle2 : LongInt;

{$R *.RES}

begin

Application.Initialize;

Handle1 := FindWindow('TForm1',nil);

if handle1 = 0 then

begin

Application.CreateForm(TForm1, Form1);

Application.Run;

end

else

begin

Handle2 := GetWindow(Handle1,GW_OWNER);

//Чтоб заметили :)

ShowWindow(Handle2,SW_HIDE); ShowWindow(Handle2,SW_RESTORE);

SetForegroundWindow(Handle1); // Активизируем

end;

end.

Вывод сообщения: ShowMessage('сообщение');

Ввод текста от пользователя: S:=InputBox('Заголовок', 'Сообщение', S{строка по умолчанию});

unit Unit1;

interface

uses

SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms,

Dialogs, StdCtrls;

type

TForm1 = class(TForm)

Button1: TButton;

Button2: TButton;

Button3: TButton;

procedure Button1Click(Sender: TObject);

procedure Button2Click(Sender: TObject);

procedure Button3Click(Sender: TObject);

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);

begin

ShowMessage('Пример простого сообщения.'+#10+

'Данное сообщение выводится всегда в центре экрана.');

end;

procedure TForm1.Button2Click(Sender: TObject);

begin

ShowMessagePos('Пример сообщения с указанием его положения на экране.',

Form1.Left+Button2.Left, Form1.Top+Button2.Top);

end;

procedure TForm1.Button3Click(Sender: TObject);

begin

Button3.Caption := InputBox('Delphi для всех', 'Введите строку:', Button3.Caption);

end;

end.

procedure TForm1.MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);

const SC_DragMove = $F012; { a magic number }

begin

ReleaseCapture;

perform(WM_SysCommand, SC_DragMove, 0);

end;

I. Эмуляция нажатия клавиши.

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

Код

Memo1.Perform(WM_CHAR, Ord('A'), 0);

или

SendMessage(Memo1.Handle, WM_CHAR, Ord('A'), 0);

приведет к печати символа "A" в объекте Memo1.

II. Перехват нажатий клавиши внутри приложения.

Задача решается очень просто. Можно у формы установить свойство KeyPreview в True и обрабатывать событие OnKeyPress. Второй способ — перехватывать событие OnMessage для объекта Application.

III. Перехват нажатия клавиши в Windows.

Существуют приложения, которым необходимо перехватывать все нажатия клавиш в Windows, даже если в данный момент активно другое приложение. Это может быть, например, программа, переключающая раскладку клавиатуры, резидентный словарь или программа, выполняющая иные действия по нажатию "горячей" комбинации клавиш. Перехват всех событий в Windows (в том числе и событий от клавиатуры) выполняется с помощью вызова функции SetWindowsHook(). Данная функция регистрирует в системе Windows ловушку (hook) для определенного типа событий/сообщений. Ловушка — это пользовательская процедура, которая будет обрабатывать указанное событие. Основное здесь то, что эта процедура должна всегда присутствовать в памяти Windows. Поэтому ловушку помещают в DLL и загружают эту DLL из программы. Пока хоть одна программа использует DLL, та не может быть выгружена из памяти. Приведем пример такой DLL и программы, ее использующей. В примере ловушка перехватывает нажатие клавиш на клавиатуре, проверяет их и, если это клавиши "+" или "-", посылает соответствующее сообщение в конкретное приложение (окно). Окно ищется по имени его класса ("TForm1") и заголовку (caption, "XXX").

{текст библиотеки}

library SendKey;

uses

WinTypes, WinProcs, Messages;

const

{пользовательские сообщения}

wm_NextShow_Event = wm_User + 133;

wm_PrevShow_Event = wm_User + 134;

{handle для ловушки}

HookHandle: hHook = 0;

var

SaveExitProc : Pointer;

{собственно ловушка}

function Key_Hook(Code: integer; wParam: word; lParam: Longint): Longint; export;

var

H: HWND;

begin

{если Code>=0, то ловушка может обработать событие}

if Code >= 0 then

begin

{это те клавиши?}

if ((wParam = VK_ADD)or(wParam = VK_SUBTRACT)) and

(lParam and $40000000 = 0)

then begin

{ищем окно по имени класса и по заголовку}

H := FindWindow('TForm1', 'XXX');

{посылаем сообщение}

if wParam = VK_ADD then

SendMessage(H, wm_NextShow_Event, 0, 0)