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

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.

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.

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;

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– и 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;

{= получение памяти под динамический массив.. =}

GetMem(B, N*sizeof(boolean));

{= работа с массивом… =}

B^[3477]:= FALSE;

{= возвращение памяти в кучу =}

{$IFDEF VER80}

FreeMem(B, N*sizeof(boolean));

{$ELSE}

FreeMem(B);

{$ENDIF}

END.

Вот несколько функций для операций с двухмерными массивами. Самый простой путь для создания собственной библиотеки. Процедуры SetV и GetV позволяют читать и сохранять элементы массива VArray (его Вы можете объявить как угодно). Например:

type

VArray : Array[1..1] of double;

var

X: ^VArray;

NR, NC: Longint;

begin

NR:= 10000;

NC:= 100;

if AllocArray(pointer(X), N*Sizeof(VArray)) then exit;

SetV(X^, NC, 2000, 5, 3.27); { X[2000,5] := 3.27 }

end;

function AllocArray(var V: pointer; const N: longint): Boolean;

begin {распределяем память для массива v размера n}

try

GetMem(V, N);

except

ShowMessage('ОШИБКА выделения памяти. Размер:' + IntToStr(N));

Result:= True;

exit;

end;

FillChar(V^, N, 0); {в случае включения длинных строк заполняем их нулями}

Result:= False;

end;

procedure SetV(var X: Varray; const N,ir,ic: LongInt;const value: double);