Советы по Delphi

         

Сперва для получения дескриптора иконки


Delphi 1

Извлечение из EXE-файла иконки и рисование ее в TImage II Сперва для получения дескриптора иконки используйте вызов API ExtractIcon, затем назначьте (assign) ее TImage.

Далее смотри электронную документацию. [000389]
Одной строкой

Изменение иконки приложения Присвойте свойству Application. Icon другую иконку и вызовите функцию

    InvalidateRect(Application.Handle, NIL, True);

... для немедленной перерисовки. [000392]



Как не допустить запуск второй копии программы II
    program Previns; uses WinTypes, WinProcs, SysUtils, Forms, Uprevins in 'UPREVINS.PAS' {Form1}; {$R *.RES}
type PHWND = ^HWND;
function EnumFunc(Wnd:HWND; TargetWindow:PHWND): bool; export; var ClassName : array[0..30] of char; begin Result := true; if GetWindowWord(Wnd,GWW_HINSTANCE) = hPrevInst then begin GetClassName( Wnd, ClassName, 30 ); if StrIComp( ClassName, 'TApplication' ) = 0 then begin TargetWindow^ := Wnd; Result := false; end; end; end;
procedure GotoPreviousInstance; var PrevInstWnd : HWND; begin PrevInstWnd := 0; EnumWindows( @EnumFunc, Longint( @PrevInstWnd ) ); if PrevInstWnd <> 0 then if IsIconic( PrevInstWnd ) then ShowWindow( PrevInstWnd, SW_RESTORE ) else BringWindowToTop( PrevInstWnd ); end;
begin if hPrevInst <> 0 then GotoPreviousInstance else begin Application.CreateForm(TForm1, Form1); Application.Run; end; end.
[000423]



Delphi 1

Определение окончания работы другого приложения WinExec сразу после запуска приложения возвращает его дескриптор. Для определения завершения программы вы должны вызывать функцию GetModuleUsage(InstanceID), где InstanceID - дескриптор запущенного функцией WinExec приложения. Если возвращаемый результат содержит ноль, приложение завершило свою работу. Сделайте проверку в таймерном цикле и задача решена. [000458]



Одной строкой

Извлечение иконки из EXE/DLL-файла
    var MyIcon: TIcon; begin MyIcon := TIcon. Create; try MyIcon.Handle := ExtractIcon(hInstance, 'MYPROG.EXE', 0) {Здесь можно что-нибудь сделать с иконкой} finally MyIcon.Free; end; end;
Имейте в виду, что средний параметр должен иметь тип PChar. [000479]



Как не допустить запуск второй копии программы III Добрые сутки, Валентин.

Вот решил поделиться советиком по теме "Как не допустить запуск второй копии программы III".
Прочитал версии этого совета "I" и "II". Как говориться, "но есть способ лучше..." Впрочем, он годится только для тех кому нет острой необходимости активировать существующую копию программы, а достаточно сообщить пользователю, что она уже запущена. Проверено, работает корректно в реальном приложении.

    ...
Uses syncobjs;
...
Var
CheckEvent: TEvent; ...
procedure TForm1.FormCreate( Sender: TObject );
begin
CheckEvent:= TEvent.Create( nil, false, true, 'MYPROGRAM_CHECKEXIST' ); If CheckEvent.WaitFor( 10 ) <> wrSignaled then begin // Сюда попадаем если одна копия уже запущена. Можно, например, сообщить об этом пользователю. Self.Close;    // Здесь можно завершить программу или сделать еще что-нибудь. end; end;
С уважением, Владимир Волосенков.

Uno-v@mail.ru [000489]



Одной строкой

Поиск окна с помощью функции FindWindow Вы должны знать имя класса окна или его заголовка. После этого можете написать:

    FindWindow('theclassname', nil)
или

    FindWindow(nil, 'thecaption')
Если один или оба вызова возвращают 0, то вы использовали неверное имя класса, неверный заголовок, или окно не является самым верхним окном. [000518]



Пример EnumWindows
  1. Создайте форму и разместите на ней два компонента ListBox.
  2. Скопируйте код, показанный ниже.
  3. Запустите SysEdit.
  4. Запустите форму Delphi. Первый ListBox должен содержать список всех запущенных приложений. Дважды щелкните на SysEdit и нижний ListBox покажет дочернее MDI-окно программы SysEdit.
Paul Powers (Borland)

    unit Wintask1;
interface
uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls;
type TForm1 = class(TForm) ListBox1: TListBox; ListBox2: TListBox; procedure FormCreate(Sender: TObject); procedure ListBox1DblClick(Sender: TObject); private function enumListOfTasks(hWindow: hWnd): Bool; export; function enumListOfChildTasks(hWindow: hWnd): Bool; export; end;
THoldhWnd = class(TObject) private public hWindow: hWnd; end;
var Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.FormCreate(Sender: TObject); begin enumWindows(@TForm1.EnumListOfTasks, Longint(Self)); if (ListBox1.Items.Count > 0) then ListBox1.ItemIndex := 0; end;
function TForm1.enumListOfTasks(hWindow: hWnd): Bool; var HoldString: PChar; WindowStyle: Longint; IsAChild: Word; HoldhWnd: THoldhWnd;
begin GetMem(HoldString, 256);
HoldhWnd := THoldhWnd.Create; HoldhWnd.hWindow := hWindow;
WindowStyle := GetWindowLong(hWindow, GWL_STYLE); WindowStyle := WindowStyle and Longint(WS_VISIBLE); IsAChild    := GetWindowWord(hWindow, GWW_HWNDPARENT);

{Добавляем строку с текстом задачи или именем класса и дескриптор в ListBox1.Items } if (GetWindowText(hWindow, HoldString, 255) > 0) and (WindowStyle > 0) and (IsAChild = Word(Nil)) then ListBox1.Items.AddObject(StrPas(HoldString), TObject(HoldhWnd)) else if (GetClassName(hWindow, HoldString, 255) > 0) and (WindowStyle > 0) and (IsAChild = Word(Nil)) then ListBox1.Items.AddObject(Concat('<',StrPas(HoldString),'>'),  TObject(HoldhWnd));
FreeMem(HoldString, 256); HoldhWnd := Nil; Result := TRUE; end;
function TForm1.enumListOfChildTasks(hWindow: hWnd): Bool; var HoldString: PChar; WindowStyle: Longint; IsAChild: Word; HoldhWnd: THoldhWnd;
begin GetMem(HoldString, 256);
HoldhWnd := THoldhWnd.Create; HoldhWnd.hWindow := hWindow;
WindowStyle := GetWindowLong(hWindow, GWL_STYLE); WindowStyle := WindowStyle and Longint(WS_VISIBLE); IsAChild    := GetWindowWord(hWindow, GWW_HWNDPARENT);
{Добавляем строку с текстом задачи или именем класса и дескриптор в ListBox1.Items } if (GetWindowText(hWindow, HoldString, 255) > 0) and (WindowStyle > 0)and (IsAChild <> Word(Nil))then ListBox2.Items.AddObject(StrPas(HoldString), TObject(HoldhWnd)) else if (GetClassName(hWindow, HoldString, 255) > 0) and (WindowStyle > 0) and (IsAChild = Word(Nil)) then ListBox2.Items.AddObject(Concat('<',StrPas(HoldString),'>'),  TObject(HoldhWnd));
FreeMem(HoldString, 256); HoldhWnd := Nil; Result := TRUE; end;
procedure TForm1.ListBox1DblClick(Sender: TObject); begin
enumChildWindows(THoldhWnd(ListBox1.Items.Objects[ListBox1.ItemIndex]).hWindow, @TForm1.enumListOfChildTasks, Longint(Self));
ListBox2.RePaint; end;
end.
Дополнение

В Kuliba1000.chm Win32 API/Разное/Пример EnumWindows есть принципиальная ошибка в коде:

ЛЮБАЯ callback ( обратного вызова ) функция в Delphi должна сопровождаться директивой stdcall.

Предоставленный пример просто не работает.

Определение класса формы должно выглядеть как-то так:

    type
TForm1 = class(TForm) ListBox1: TListBox; ListBox2: TListBox; procedure FormCreate(Sender: TObject); procedure ListBox1DblClick(Sender: TObject); private function enumListOfTasks(hWindow: hWnd): Bool; stdcall; function enumListOfChildTasks(hWindow: hWnd): Bool; stdcall; end;
Директивы export (это написано в Help'е) просто не работают (игнорируются) под Win 32 :(

С наилучшими пожеданиями
Андрей Бреслав [000526]



Delphi 1

Управление игрой FreeCell Если вы решили перепробовать ВСЕ номера игры FreeCell, вас можно квалифицировать как законченного маньяка. В этом случае вас, возможно, заинтересует эта маленькая программка. При ее запуске она загружает FreeCell и начинает игру, следующую за той, которую вы не смогли завершить в прошлый раз. А еще она отвечает на глупые вопросы типа "Do you really want to resign the game?". После выигрыша программа изменяет счетчик таким образом, чтобы при очередном запуске номер игры изменялся на следующий автоматически.

Для создания программы расположите на новой форме таймер, установите ее свойство WindowState на wsMinimized и используйте следующий код:

    ... private { Private declarations } InstHandle : Word; WndHandle  : hWnd; NextGame   : Word; function EnumFunc(H : HWnd) : Word; PROCEDURE WMQUERYOPEN(VAR Msg : TWMQueryOpen); message WM_QUERYOPEN; ... interface
USES
ShellApi, IniFiles;
{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
VAR H, SubH    : hMenu;
NewGameID    : Word; FreeCellPath : String; begin
WITH
TIniFile.Create(ChangeFileExt(Application.ExeName, '.INI')) DO try FreeCellPath := ReadString('FreeCell', 'Path', 'C:\WIN32APP\FREECELL\FREECELL.EXE') + #0; NextGame := ReadInteger('FreeCell', 'NextGame', 1); finally Free; end; InstHandle := ShellExecute(Handle, NIL, @FreeCellPath[1], NIL, NIL, SW_SHOW); WndHandle := 0; IF InstHandle >= 32 THEN EnumWindows(@TForm1.EnumFunc, LongInt(Self)); IF WndHandle <> 0 THEN BEGIN {Вычисляем ID пункта меню "Select Game"} H := GetMenu(WndHandle); SubH := GetSubMenu(H, 0); NewGameID := GetMenuItemID(SubH, 1); Winprocs.SetFocus(WndHandle); {вызываем "Select Game"} PostMessage(WndHandle, WM_COMMAND, NewGameID, 0); Timer1.Enabled := True; END ELSE Close; end;

PROCEDURE TForm1.WMQUERYOPEN(VAR Msg : TWMQueryOpen);
BEGIN
Msg.Result := 0; END;

function TForm1.EnumFunc(H : HWnd) : Word;
BEGIN
IF
GetWindowWord(H, GWW_HINSTANCE) = InstHandle THEN BEGIN WndHandle := H; Result := 0; END ELSE Result := 1; END;

procedure TForm1.Timer1Timer(Sender: TObject);
VAR Buffer     : ARRAY[0..10] OF Char;
DlgHandle  : Word; begin
{Если пользователь закрыл FreeCell, выходим!} IF GetModuleUsage(InstHandle) = 0 THEN BEGIN Close; Exit; END; {При необходимости укажите номер игры} DlgHandle := FindWindow('#32770', 'Game Number'); IF DlgHandle <> 0 THEN BEGIN Str(NextGame, Buffer); SendDlgItemMessage(DlgHandle, $CB, WM_SETTEXT, 0, LongInt(@Buffer)); PostMessage(DlgHandle, WM_COMMAND, 1, MakeLong(GetDlgItem(DlgHandle, 1), BN_CLICKED)); END; {Если игра окончена, увеличиваем счетчик} DlgHandle := FindWindow('#32770', 'Game Over'); IF DlgHandle <> 0 THEN BEGIN Inc(NextGame); WITH TIniFile.Create(ChangeFileExt(Application.ExeName, '.INI')) DO try WriteInteger('FreeCell', 'NextGame', NextGame); finally Free; end; PostMessage(DlgHandle, WM_COMMAND, 6, MakeLong(GetDlgItem(DlgHandle, 6), BN_CLICKED)); END; {Если игра спрашивает, хотите ли вы выйти, отвечем соответственно yes или OK} DlgHandle := FindWindow('#32770', 'FreeCell'); IF DlgHandle <> 0 THEN BEGIN IF (NOT (GetDlgItemText(DlgHandle, 6, Buffer, 10) IN [0,10])) AND (StrComp(Buffer, '&Yes') = 0) THEN PostMessage(DlgHandle, WM_COMMAND, 6, MakeLong(GetDlgItem(DlgHandle, 6), BN_CLICKED)) ELSE IF (NOT (GetDlgItemText(DlgHandle, 2, Buffer, 10) IN [0,10])) AND (StrComp(Buffer, 'Cancel') = 0) THEN PostMessage(DlgHandle, WM_COMMAND, 1, MakeLong(GetDlgItem(DlgHandle, 1), BN_CLICKED)) END; end;
[000530]



Извещение об изменениях WIN.INI Функции SendMessage ( Windows API) необходимо несколько параметров. Первым идет дескриптор окна; в нашем случае правильным будет HWND_BROADCAST. Затем идет передаваемое сообщение, WM_WININICHANGE. Последние два параметра - wParam и lParam (word-параметр и long-параметр) сообщения. В нашем случае (для данного конкретного сообщения) wParam должен быть 0, а lParam должен содержать адрес строки с именем измененной секции. Если lParam = NIL (ноль), то система должна проверить на наличие изменений ВСЕ секции, что на деле оказывается ужасно медленным; не посылайте 0, если вы не сделали изменений в нескольких секциях.

Вот пример оповещения об изменениях в секции Desktop:

    VAR S : ARRAY[0..40] OF Char; ... StrCopy(S, 'Desktop'); SendMessage(HWND_BROADCAST, WM_WININICHANGE, 0, LongInt(@S));
- Neil [000568]



Delphi 1

Активизация предыдущего экземпляра вашей программы Если внутренняя переменная hPrevInst не равна нулю, то она содержит дескриптор предыдущего запущенного экземпляра вашей программы. Вы просто находите открытое окно по его дескриптору и, при необходимости, выводите на передний план. Весь код расположен в файле .DPR file, НЕ в модуле. Строки, которые вам необходимо добавить к вашему .DPR-файлу, в приведенном ниже примере помечены {*}.

    program Once;

uses
{*}  WinTypes, WinProcs, SysUtils,
Forms, Onceu in 'ONCEU.PAS' {Form1};
{$R *.RES}
{*}TYPE
{*}  PHWND = ^HWnd;

{*}  FUNCTION EnumWndProc(H : hWnd; P : PHWnd) : Integer; Export;
{*}  VAR ClassName : ARRAY[0..30] OF Char;
{*}  BEGIN
{*}    {Если это окно принадлежит предшествующему экземпляру...}
{*}    IF GetWindowWord(H, GWW_HINSTANCE) = hPrevInst THEN
{*}      BEGIN
{*}        {... проверяем КАКОЕ это окно.}
{*}        GetClassName(H, ClassName, 30);
{*}        {Если это главное окно приложения...}
{*}        IF StrIComp(ClassName, 'TApplication') = 0 THEN
{*}          BEGIN
{*}            {... ищем}
{*}{*}            P^ := H;
{*}            EnumWndProc := 0;
{*}          END;
{*}      END;
{*}  END;

{*}  PROCEDURE CheckPrevInst;
{*}  VAR PrevWnd : hWnd;
{*}  BEGIN
{*}    IF hPrevInst <> 0 THEN
{*}      {Предыдущий экземпляр запущен}
{*}      BEGIN
{*}        PrevWnd := 0;
{*}        EnumWindows(@EnumWndProc, LongInt(@PrevWnd));
{*}        {Ищем дескриптор окна предыдущего}
{*}        {экземпляра и активизируем его}
{*}        IF PrevWnd <> 0 THEN
{*}          IF IsIconic(PrevWnd) THEN
{*}            ShowWindow(PrevWnd, SW_SHOWNORMAL)
{*}          ELSE BringWindowToTop(PrevWnd);
{*}        Halt;
{*}      END;
{*}  END;
begin
{*}  CheckPrevInst;
Application.Title := 'Once'; Application.CreateForm(TForm1, Form1); Application.Run; end.
[000618]



Delphi 1

Завершение всех работающих приложений Как мне завершить все работающие задачи?

Ниже приведен код, который поможет вам завершить ВСЕ задачи без всяких уведомлений о необходимости сохранения данных.

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

    procedure TForm1.ButtonKillAllClick(Sender: TObject);
var
pTask   : PTaskEntry; Task    : Bool; ThisTask: THANDLE; begin
GetMem (pTask, SizeOf (TTaskEntry)); pTask^.dwSize := SizeOf (TTaskEntry);
Task := TaskFirst (pTask); while Task do begin if pTask^.hInst = hInstance then ThisTask := pTask^.hTask else TerminateApp (pTask^.hTask, NO_UAE_BOX); Task := TaskNext (pTask); end; TerminateApp (ThisTask, NO_UAE_BOX); end;
[000622]



Как не допустить запуск второй копии программы IV Пришло от читателя письмо:

Здравствуйте Валентин.

Решил предложить Вам еще один вариант "Как не допустить запуск второй копии программы". Может кому и подойдет...

В этом случае необходимо быть уверенным, что в системе больше нет окон с именем "TForm1" - В.О.

    program Project1;

uses
Forms, Windows, Unit1 in 'Unit1.pas' {Form1};
{$R *.RES}

var
hwnd: THandle;
begin
hwnd := FindWindow('TForm1', 'Form1'); if hwnd = 0 then begin Application.Initialize; Application.CreateForm(TForm1, Form1); Application.Run; end else SetForegroundWindow(hwnd) end.
Васильев Сергей, vs2000@mail.ru [000750]



Как не допустить запуск второй копии программы V Пришло от читателя письмо:

Добрый день!
Хотел бы добавить ещё один метод, с помощью которого можно предотвращать запуск второй копии приложения.

    program pds;

uses
Windows, Forms, Main in 'MAIN.PAS' {MainForm},
const
MemFileSize=127; MemFileName='one_example';
var
MemHnd:HWND;
{$R *.RES}
begin
MemHnd:=CreateFileMapping(HWND($FFFFFFFF),nil, PAGE_READWRITE,0,MemFileSize, MemFileName); if GetLastError<>ERROR_ALREADY_EXISTS then begin Application.Initialize; with TForm1.Create(nil) do try Show; Update; Application.CreateForm(TMainForm, MainForm); finally Free; end; Application.Run; end else Application.MessageBox('Приложение уже запущено (возможно оно свёрнуто на панели задач): Нажмите кнопку ОК для продолжения работы','Производственно-диспетчерская служба',MB_OK); CloseHandle(MemHnd); end.
С уважением,
Васильев Николай.

5 апреля 2000 г., среда
10:15:23 [000780]



Delphi 1

Обработка WM_SysCommand Системное меню в приложениях Delphi ведет двойную жизнь - когда основная форма активна, работает системное меню главной формы, но когда приложение минимизировано, работает системное меню объекта Applictaion. Этот код может оказаться полезным:

    CONST SC_UDF = $EFF0;   {должен быть < $F000 и делиться на 16}
procedure TForm1.FormCreate(Sender: TObject); begin AppendMenu(GetSystemMenu(Handle, False), MF_STRING, SC_UDF, 'Всегда на&верху'); AppendMenu(GetSystemMenu(Application.Handle, False), MF_STRING, SC_UDF, 'Всегда на&верху'); Application.OnMessage := AppOnMessage; end;
procedure TForm1.AppOnMessage(VAR Msg: TMsg; VAR Handled: Boolean); BEGIN IF Msg.Message <> WM_SYSCOMMAND THEN Exit; IF Msg.wParam AND $FFF0 <> SC_UDF THEN Exit; ... здесь вы можете включить код для обработки системного сообщения ... END;
- Neil J. Rubenking [000804]


Содержание раздела