formx := tformx.create(appliaction);
formx.showmodal;
formx.free;
Jeżeli forma nie pokazuje się to należy użyc kodu poniżej:
Application.CreateForm(TFormX, FormX);
FormX.ShowModal;
FormX.Free;
Jeżeli ta forma już istnieje to aplikacja zgłosi błąd. Ta forma uprzednio powinna zostać skasowana (Destroy).
procedure TForm1.AppDeactivate(Sender: TObject);
begin
close;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
Application.OnDeactivate := AppDeactivate;
end;
with Sender as TForm do
Label1.Caption := copy(ClassName,2,length(ClassName)-1);
To zapewnia efekt bez dodatkowego kodu w procedurze OnCreate.
Wariant II:
If Sender is TForm then
Label1.Caption := (Sender as TForm).Name ;
W praktyce wygląda to tak:
procedure TForm1.Create( Sender : TObject ) ;
begin
Form1.Name := 'Form1' ;
end ;
procedure TForm1.Button1Click( Sender : TObject ) ;
begin
Label1.Caption := Form1.Name ;
end ;
Forma główna (Form1) stanowi pustą formatkę, na której tworzymy formę kolejną; ma ona styl TDialogBox
chociaż nie jest to MDI.
procedure Form1.Button1Click(Sender: TObject);
begin
Form2 := TForm2.Create(self); { z formy Form1 }
with Form2 do begin
Top := Form1.Top + somevalue;
Left := Form1.Left + someothervalue;
ShowModal;
Free;
end; end;
a oto przykład:
interface
uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, Dialogs, StdCtrls;
type TNewForm = class(TForm)
NewEdit: TEdit; NewButton: TButton;
procedure NewButtonClick(Sender: TObject);
end;
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
private { Private declarations }
public { Public declarations }
end;
var Form1: TForm1;
implementation
{$R *.DFM}
{ OnClick handler for generated forms }
procedure TNewForm.NewButtonClick(Sender: TObject);
begin
NewEdit.Text := 'Hej!';
end;
{ Generates and shows form from scratch }
procedure TForm1.Button1Click(Sender: TObject);
var NewForm: TNewForm;
begin { Create new form }
NewForm := TNewForm.CreateNew(Application); { Set its properties }
with NewForm do begin
Top := 140; Left := 220; Width := 435; Height := 300; Caption := 'Runtime!';
{ Create new edit component }
NewEdit := TEdit.Create(NewForm); { Set its properties }
with NewEdit do begin
Parent := NewForm; Left := 153; Top := 40; Width := 121; Height := 29;
TabOrder := 1; Text := 'Edit1';
end;
{ Create new button component }
NewButton := TButton.Create(NewForm); { Set its properties }
with NewButton do begin
Parent := NewForm; Left := 153; Top := 176; Width := 121; Height := 33; TabOrder := 0;
Caption := 'Change Edit';
{ Wire the component to OnClick handler }
OnClick := NewButtonClick;
end; Show; end;
end;
end.
Procedure MainForm.BtnOpenFormClick(Sender: TObject);
Begin
1) NameOnForm:=TNameOnForm.Create(APPLICATION);
2) NameOnForm:=TNameOnForm.Create(NAMEONFORM);
3) NameOnForm:=TNameOnForm.Create(SELF);
4) NameOnForm:=TNameOnForm.Create(???????????);
NameOnForm.ShowModal;
NameOnForm.Free;
end;
Warianty 1 i 3 są równoważne dla showmodal. W wariancie 1 forma uprzednio musi zostać zamknieta i pamięć zwolniona.
Wariant 2 może być użyty gdy forma jest tworzona po raz pierwszy.
IF frmNewForm = NIL THEN
frmNewForm := TNewForm.Create( owner );
frmNewForm.Show;
Ważne! Aby w/w procedura działała bezbłędnie ta forma uprzednio powinna zostać zniszczona za pomocą kodu:
frmNewForm.Release; frmNewForm := nil;
Użycie metody Release - nie Free.
unit Unit1;
interface
uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, Dialogs, StdCtrls;
type TForm1 = class(TForm)
Button1: TButton; Button2: TButton;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
private { Private declarations }
public { Public declarations }
Form2: TForm;
end;
var Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.Button1Click(Sender: TObject);
begin
if Form2 < > nil then begin
Form2.Release; Form2:= nil;
end; end;
procedure TForm1.Button2Click(Sender: TObject);
begin
if Form2 = nil then begin
Form2 := TForm.Create(Application); Form2.Show;
end; end;
end.
a w pliku DPR:
begin
Application.Create(myForm); Application.Run;
end.
Pamiętaj - wyrzuć z pamięci (free) wszystke formy przed zamknieciem aplikacji!
procedure TForm1.AppDeactivate(Sender: TObject);
var hw: HWnd; CurTask: THandle; WndStyle:Longint;
begin
CurTask:=GetWindowTask(handle);
hw:=GetWindow(GetDesktopWindow, GW_CHILD);
while GetWindowTask(hw) < > CurTask do
hw:=GetWindow(hw, GW_HWNDNEXT);
while (hw < > handle) and (GetWindowTask(hw)=CurTask) do begin
PostMessage(hw, WM_Close, 0, 0);
hw:=GetWindow(hw, GW_HWNDNEXT);
end; end;
Należy do zamykanej formy przesłąc wiadomość jej utworzenia a tam w procedurze OnActivate ująć wiadomość dla Windowsza - WM_CLOSE o zamknięciu tej formy według wzoru poniżej:
Unit Form1;
........................
implementation
uses About;
procedure TForm1.Button1Click(Sender: TObject);
begin
AboutBox.ShowModal;
end;
Unit About;
.......
implementation
uses Messages;
procedure TAboutBox.FormActivate(Sender: TObject);
begin
PostMessage( Handle, WM_CLOSE, 0, 0 );
end;
Umieścić poniższą procedurę w strefie protected
Procedure WMMove(Var Message : TWMMove); message WM_Move;
Procedure TForm1.WMMove(Var Message : TWMMove);
begin
Label1.Caption := 'X = '+IntToStr(Message.XPos)+', Y = '+IntTOStr(Message.YPos);
end;
I. procedure TScrnFrm.GrabScreen;
var DeskTopDC: HDc; DeskTopCanvas: TCanvas; DeskTopRect: TRect;
begin
DeskTopDC := GetWindowDC(GetDeskTopWindow);
DeskTopCanvas := TCanvas.Create;
DeskTopCanvas.Handle := DeskTopDC;
DeskTopRect := Rect(0,0,Screen.Width,Screen.Height);
ScrnForm.Canvas.CopyRect(DeskTopRect,DeskTopCanvas,DeskTopRect);
ReleaseDC(GetDeskTopWindow,DeskTopDC);
end;
II. z wykorzystaniem na formie TImage
var Image3: TImage;
procedure TSaverForm.CopyScreen;
var DeskTopDC: HDc; DeskTopCanvas: TCanvas; DeskTopRect: TRect;
begin
Image3 := TImage.Create(SaverForm); //Image3 tworzone dynamicznie ma rozmiar ekranu
With Image3 do begin
Height := Screen.Height; Width := Screen.Width;
end;
Image3.Canvas.copymode := cmSrcCopy;
DeskTopDC := GetWindowDC(GetDeskTopWindow);
DeskTopCanvas := TCanvas.Create;
DeskTopCanvas.Handle := DeskTopDC;
Image3.Canvas.CopyRect(Image3.Canvas.ClipRect, DeskTopCanvas, DeskTopCanvas.ClipRect);
Image2.Picture.Assign(Image3.Picture);
//Image2 na formie przejmuje ten obraz - jeżeli Stretch = true i Align = alClient to w rozmiary image (formy) wciśnie cały ekran
end;
procedure TSaverForm.FormClose(Sender: TObject; var Action: TCloseAction);
begin
Image3.Free;
end;
III. Warianty uniwersalne Borlanda
unit Scrncap;
interface
uses WinTypes, WinProcs, Forms, Classes, Graphics;
function CaptureScreenRect( ARect: TRect ): TBitmap;
function CaptureScreen: TBitmap;
function CaptureClientImage( Control: TControl ): TBitmap;
function CaptureControlImage( Control: TControl ): TBitmap;
implementation
function CaptureScreenRect( ARect: TRect ): TBitmap; // zrzut rejonu ekranu
var ScreenDC: HDC;
begin
Result := TBitmap.Create;
with Result, ARect do begin
Width := Right - Left; Height := Bottom - Top;
ScreenDC := GetDC( 0 );
try BitBlt( Canvas.Handle, 0, 0, Width, Height, ScreenDC, Left, Top, SRCCOPY);
finally ReleaseDC( 0, ScreenDC );
end; end;end;
function CaptureScreen: TBitmap; //funkcja do zrzutu całego ekranu
begin
with Screen do
Result := CaptureScreenRect( Rect( 0, 0, Width, Height ));
end;
function CaptureClientImage( Control: TControl ): TBitmap;// ta funkcja do zrzutu ClientArea formy
begin
with Control, Control.ClientOrigin do
Result := CaptureScreenRect( Bounds( X, Y, ClientWidth, ClientHeight ));
end;
{ use this to capture an entire form or control }
function CaptureControlImage( Control: TControl ): TBitmap;
begin
with Control do if Parent = nil then
Result := CaptureScreenRect( Bounds( Left, Top, Width, Height ))
else with Parent.ClientToScreen( Point( Left, Top )) do
Result := CaptureScreenRect( Bounds( X, Y, Width, Height ));
end;
end.
W Delphi zrzut formy można realizować najprościej poprzez funkcję GetFormlmage.
Do postaci bitmapy zapisany zostaje obszar ClientArea formy.
Delphi do tego posiada 2 zasadnicze procedury:
procedure WriteComponentResFile(const FileName: string; Instance: TComponent);
Po zapisie tej zawartości pod dowolną nazwą można ją zawsze odtworzyć za pomocą:
function ReadComponentResFile(const FileName: string; Instance: TComponent):
TComponent;
Uwaga: Caption formy musi być pusty, disable= all a BorderStyle = bsNone.
unit Dragmain;
interface
uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, Dialogs, StdCtrls;
type TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
procedure WMNCHitTest(var M: TWMNCHitTest); message wm_NCHitTest;
end;
var Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.WMNCHitTest(var M: TWMNCHitTest);
begin
iinherited; { call the inherited message handler }
if M.Result = htClient then { is the click in the client area? }
M.Result := htCaption; { if so, make Windows think it's }
{ on the caption bar. }
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
Close;
end;
end.
procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
const PageDelta = 10;
begin
With VertScrollbar do if Key = VK_NEXT then
Position := Position + PageDelta
else if Key = VK_PRIOR then Position := Position - PageDelta;
end;
Na formie ustawic - KeyPreview := true;
procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
if (ssCtrl in Shift) and (chr(Key) in ['A', 'a']) then ShowMessage('Ctrl-A');
end;
musi być użyty moduł Winprocs i WinTypes
Procedure TYourFormName.HideTitlebar;
Var Save : LongInt;
Begin
If BorderStyle=bsNone then Exit;
Save:=GetWindowLong(Handle,gwl_Style);
If (Save and ws_Caption)=ws_Caption then Begin
Case BorderStyle of
bsSingle, bsSizeable : SetWindowLong(Handle,gwl_Style,Save and
(Not(ws_Caption)) or ws_border);
bsDialog : SetWindowLong(Handle,gwl_Style,Save and
(Not(ws_Caption)) or ds_modalframe or ws_dlgframe);
End;
Height:=Height-getSystemMetrics(sm_cyCaption); Refresh;
End; end;
Procedure TYourFormName.ShowTitlebar;
Var Save : LongInt;
begin
If BorderStyle=bsNone then Exit;
Save:=GetWindowLong(Handle,gwl_Style);
If (Save and ws_Caption) < > ws_Caption then Begin
Case BorderStyle of
bsSingle, bsSizeable : SetWindowLong(Handle,gwl_Style,Save or ws_Caption or
ws_border);
bsDialog : SetWindowLong(Handle,gwl_Style,Save or ws_Caption or
ds_modalframe or ws_dlgframe);
End;
Height:=Height+getSystemMetrics(sm_cyCaption); Refresh;
End; end;
procedure TForm1.PrintForm;
var DC: HDC; isDcPalDevice: Bool; MemDC: HDC;
MemBitmap: HBITMAP; OldMemBitmap: HBITMAP;
hDibHeader: THandle; pDibHeader: Pointer;
hBits: THandle; pBits: Pointer; ScaleX: Double; ScaleY: Double;
pPal: PLOGPALETTE; pal: HPALETTE; OldPal: HPALETTE; i: Integer;
begin
{Get the screen dc}
DC := GetDC(0);
{Create a compatible dc}
MemDC := CreateCompatibleDC(DC);
{create a bitmap}
MemBitmap := CreateCompatibleBitmap(DC, Self.Width, Self.Height);
{select the bitmap into the dc}
OldMemBitmap := SelectObject(MemDC, MemBitmap);
{Lets prepare to try a fixup for broken video drivers}
isDcPalDevice := False;
if GetDeviceCaps(DC, RASTERCAPS) and RC_PALETTE=RC_PALETTE then begin
GetMem(pPal, SizeOf(TLOGPALETTE)+(255*SizeOf(TPALETTEENTRY)));
FillChar(pPal^, SizeOf(TLOGPALETTE)+(255*SizeOf(TPALETTEENTRY)), #0);
pPal^.palVersion := $300;
pPal^.palNumEntries := GetSystemPaletteEntries(DC, 0, 256, pPal^.palPalEntry);
if pPal^.palNumEntries < > 0 then begin
pal := CreatePalette(pPal^);
OldPal := SelectPalette(MemDC, pal, False);
isDcPalDevice := True
end else
FreeMem(pPal, SizeOf(TLOGPALETTE)+(255*SizeOf(TPALETTEENTRY)));
end;
{copy from the screen to the memdc/bitmap}
BitBlt(MemDC, 0, 0, Self.Width, Self.Height, DC, Self.Left, Self.Top, SRCCOPY);
if isDcPalDevice=True then begin
SelectPalette(MemDC, OldPal, False); DeleteObject(pal);
end; {unselect the bitmap}
SelectObject(MemDC, OldMemBitmap); {delete the memory dc}
DeleteDC(MemDC); {Allocate memory for a DIB structure}
hDibHeader := GlobalAlloc(GHND, SizeOf(TBITMAPINFO)+(SizeOf(TRGBQUAD)* 256));
{get a pointer to the alloced memory}
pDibHeader := GlobalLock(hDibHeader);
{fill in the dib structure with info on the way we want the DIB}
FillChar(pDibHeader^, SizeOf(TBITMAPINFO)+(SizeOf(TRGBQUAD)* 256), #0);
PBITMAPINFOHEADER(pDibHeader)^.biSize := SizeOf(TBITMAPINFOHEADER);
PBITMAPINFOHEADER(pDibHeader)^.biPlanes := 1;
PBITMAPINFOHEADER(pDibHeader)^.biBitCount := 8;
PBITMAPINFOHEADER(pDibHeader)^.biWidth := Self.Width;
PBITMAPINFOHEADER(pDibHeader)^.biHeight := Self.Height;
PBITMAPINFOHEADER(pDibHeader)^.biCompression := BI_RGB;
{find out how much memory for the bits}
GetDIBits(DC, MemBitmap, 0, Self.Height, nil, TBITMAPINFO(pDibHeader^), DIB_RGB_COLORS);
{Alloc memory for the bits}
hBits := GlobalAlloc(GHND, PBITMAPINFOHEADER(pDibHeader)^.BiSizeImage);
{Get a pointer to the bits}
pBits := GlobalLock(hBits); {Call fn again, but this time give us the bits!}
GetDIBits(DC, MemBitmap, 0, Self.Height, pBits, PBitmapInfo(pDibHeader)^, DIB_RGB_COLORS);
{Lets try a fixup for broken video drivers}
if isDcPalDevice=True then begin
for i := 0 to (pPal^.palNumEntries-1) do begin
PBitmapInfo(pDibHeader)^.bmiColors[i].rgbRed := pPal^.palPalEntry[i].peRed;
PBitmapInfo(pDibHeader)^.bmiColors[i].rgbGreen := pPal^.palPalEntry[i].peGreen;
PBitmapInfo(pDibHeader)^.bmiColors[i].rgbBlue := pPal^.palPalEntry[i].peBlue;
end;
FreeMem(pPal, SizeOf(TLOGPALETTE)+(255*SizeOf(TPALETTEENTRY)));
end; {Release the screen dc}
ReleaseDC(0, DC); {Delete the bitmap}
DeleteObject(MemBitmap); {Start print job}
Printer.BeginDoc; {Scale print size }
ScaleX := Self.Width*3; ScaleY := Self.Height*3;
{Just incase the printer drver is a palette device}
isDcPalDevice := False;
if GetDeviceCaps(Printer.Canvas.Handle, RASTERCAPS) and RC_PALETTE=RC_PALETTE
then begin
{Create palette from dib}
GetMem(pPal, SizeOf(TLOGPALETTE)+(255*SizeOf(TPALETTEENTRY)));
FillChar(pPal^, SizeOf(TLOGPALETTE)+(255*SizeOf(TPALETTEENTRY)), #0);
pPal^.palVersion := $300; pPal^.palNumEntries := 256;
for i := 0 to (pPal^.palNumEntries-1) do begin
pPal^.palPalEntry[i].peRed := PBitmapInfo(pDibHeader)^.bmiColors[i].rgbRed;
pPal^.palPalEntry[i].peGreen := PBitmapInfo(pDibHeader)^.bmiColors[i].rgbGreen;
pPal^.palPalEntry[i].peBlue := PBitmapInfo(pDibHeader)^.bmiColors[i].rgbBlue;
end;
pal := CreatePalette(pPal^);
FreeMem(pPal, SizeOf(TLOGPALETTE)+(255*SizeOf(TPALETTEENTRY)));
OldPal := SelectPalette(Printer.Canvas.Handle, pal, False);
isDcPalDevice := True
end;
{send the bits to the printer}
StretchDiBits(Printer.Canvas.Handle, 0, 0, Round(ScaleX), Round(ScaleY),
0, 0, Self.Width, Self.Height, pBits, PBitmapInfo(pDibHeader)^,
DIB_RGB_COLORS, SRCCOPY);
{Just incase you printer drver is a palette device}
if isDcPalDevice=True then begin
SelectPalette(Printer.Canvas.Handle, OldPal, False);
DeleteObject(pal);
end;
{Clean up allocated memory}
GlobalUnlock(hBits); GlobalFree(hBits);
GlobalUnlock(hDibHeader); GlobalFree(hDibHeader); {end the print job}
Printer.EndDoc;
end;
Należy skorzystać z komunikatu wm_DropFiles.
uses ShellAPI; {obsługa DxD}
procedure TForm1.FormCreate(Sender: TObject);
begin
Application.OnMessage := AppMessage; DragAcceptFiles (Handle, True);
end; {mówimy systemowi że chcemy obsłużyć DxD}
procedure TForm1.WMDropFiles (hDrop : THandle; hWindow : HWnd);
var TotalNumberOfFiles, nFileLength: integer; pszFileName: PChar; i: integer;
begin //liczba zrzuconych plików
TotalNumberOfFiles := DragQueryFile (hDrop , $FFFFFFFF, nil, 0);
for i := 0 to TotalNumberOfFiles - 1 do begin
nFileLength := DragQueryFile (hDrop, i , Nil, 0) + 1;
GetMem (pszFileName, nFileLength);
DragQueryFile (hDrop , i, pszFileName, nFileLength);
//pszFileName - nazwa upuszczonego pliku tutaj robimy coś z nazwą pliku
FreeMem (pszFileName, nFileLength);
end;
DragFinish (hDrop);
end; //sprawdzamy co zostało przeciągnięte i obsługujemy to
procedure TForm1.AppMessage(var Msg: TMsg; var Handled: Boolean);
begin
case Msg.Message of WM_DROPFILES : WMDropFiles (Msg.wParam, Msg.hWnd);
end; end; //obsługujemy komunikat WM_DROPFILES
procedure TForm1.FormClose (Sender: TObject; var Action: TCloseAction);
begin
DragAcceptFiles (Handle, False);
end; //dziękujemy
procedure TForm1.FormCloseQuery(Sender: Tobject;
var CanClose: Bolean);
begin
if MessageDlg ( 'Czy na pewno chcesz zamknąć?',
mtConfirmation, [mbYes, mbNo], 0) = idNo then
Canclose:=False;
end;
tform.components - stanowi tablicę komponentów danej formatki. Poniżej w przykładach szukany jest Button1.Przykłady pokazują jak znaleźc komponent Button1 i przywołać go metodą setfocus.
procedure tform1.doodah;
var cnt: integer;
begin
while (cnt <= componentcount) and (components[cnt - 1] < > 'button1' do
inc(cnt); tbutton(components[cnt - 1]).setfocus;
end;
lub jeszcze prościej:
procedure tform1.doodah;
var target: tcomponent;
begin
target := findcomponent('button1'); tbutton(target).setfocus;
end;
Użyj standardowej metody elementu formularza (Brush method). Ta metoda pobiera Bitmapę i wypełnia nią tło całej formatki.
procedure TForm1.FormCreate(Sender: TObject);
var MyBitmap: TBitmap;
begin
MyBitmap:=TBitmap.Create; MyBitmap.LoadFromFile('factory.bmp');
Form1.Brush.Bitmap:=MyBitmap;
end;
//widoczny/ ukryty kursor na formie
procedure TForm1.Button1Click(Sender: TObject);
begin
ShowCursor(False); // ukryty kursor
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
ShowCursor(True); // widoczny kursor
end;
Pokaz tekstu formy z użyciem procedury ObjectBinaryToText, która przekształca dwójkową reprezentację obiektu w tekst.
procedure TForm1.Button1Click(Sender: TObject);
var Source: TResourceStream; Dest: TMemoryStream;
begin
Source:=TResourceStream.Create(hInstance, 'TFORM1', RT_RCDATA);
Dest:=TMemoryStream.Create; Source.Position := 0;
ObjectBinaryToText(Source, Dest); Dest.Position := 0;
Memo1.Lines.LoadFromStream(Dest);
end;
Pokaz logo programu podczas startu - Logo jest zwykłą formą. Umieść Image1 i Timer1 na Form1 -- to będzie logo. W pliku .DPR projektu usuń linie: Application.CreateForm (TForm2, Form2);
(* to dla Form1 *)
procedure TForm1.FormActivate(Sender: TObject);
begin
Image1.Picture.LoadFromFile(' c:\...\factory.bmp');
end;
procedure TForm1.Timer1Timer(Sender: TObject);
begin
Form1.Hide; Form2:=TForm2.Create(nil);
with TForm2.Create(nil) do Show;
end;
(*to dla Form2 *)
procedure TForm2.FormClose(Sender: TObject; var Action: TCloseAction);
begin
Form1.Close;
end;
Dynamiczne tworzenie formy z ustawieniem jej na (ClientOrigin to współrzędne ekranu w pikselach) określonej pozycji.
procedure TForm1.Button1Click(Sender: TObject);
var NewForm: TForm2;
begin
NewForm:=TForm2.Create(nil);
try NewForm.Left:=ActiveControl.Width+ ActiveControl.Left+ ClientOrigin.X;
NewForm.Top:=ActiveControl.Top+ClientOrigin.Y;
NewForm.ShowModal;
finally NewForm.Release;
end; end;
Przywracanie okna do jego ostatniego stanu - poprzez zapis jego parametrów w Rejestrze po zamknięciu formy. Przywołany ponownie program odtworzy te parametry na ekranie.
uses Registry;
procedure TForm1.FormDestroy(Sender: TObject);
begin
with TRegistry.Create do
begin
RootKey:=HKEY_LOCAL_MACHINE;
if OpenKey('Greatis Software\Example\Form', True) then
begin
WriteInteger('Left', Form1.Left); WriteInteger('Top', Form1.Top);
WriteInteger('Width', Form1.Width); WriteInteger('Height', Form1.Height);
case WindowState of
wsMaximized: WriteInteger('State', 1); wsMinimized: WriteInteger('State', 2);
wsNormal : WriteInteger('State', 3);
end; end else
MessageDlg('Błąd odczytu rejestru', mtError, [mbOk], 0);
CloseKey;
end; end;
procedure TForm1.FormCreate(Sender: TObject);
begin
with TRegistry.Create do
begin
RootKey:=HKEY_LOCAL_MACHINE;
if OpenKey('Greatis Software\Example\Form', False) then
try
Form1.Left:=ReadInteger('Left'); Form1.Top:=ReadInteger('Top');
Form1.Width:=ReadInteger('Width'); Form1.Height:=ReadInteger('Height');
case ReadInteger('State') of
1: Form1.WindowState:=wsMaximized; 2: Form1.WindowState:=wsMinimized;
3: Form1.WindowState:=wsNormal;
end; except
MessageDlg('Nie można go odczytać', mtError, [mbOk], 0);
end else
MessageDlg('Błąd odczytu rejestru', mtError, [mbOk], 0);
CloseKey;
end; end;
Forma nieruchoma - niemożliwe jej przenoszenie poprzez zdarzenie - WM_NCHITTEST.
type TForm1 = class(TForm)
private { Private declarations }
procedure WMNCHITTEST(var Msg: TWMNCHitTest);
message WM_NCHITTEST;
public { Public declarations }
end;
...
procedure TForm1.WMNCHitTest(var Msg: TWMNCHitTest);
begin
DefaultHandler(Msg); if Msg.Result=HTCAPTION then Msg.Result:=0;
end;
Ukrycie tekstu na pasku formy
procedure TForm1.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
with Params do Style:=(Style or WS_POPUP) and (not WS_DLGFRAME);
end;
Ukrycie tekstu na pasku opisu formularza MDIChild (forma potomna).
type TForm2 = class(TForm)
private { Private declarations }
procedure CreateParams(var Params: TCreateParams); override;
public { Public declarations }
end;
...
procedure TForm2.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params) ;
Params.Style:=Params.Style and (not WS_CAPTION) ;
end;
Ukrycie formularza potomnego MDIChild. w pliku projektu nie zapomnij usunąć linię Application.CreateForm (TForm2, Form2) .
var ChildForm: TForm;
...
procedure TForm1.New1Click(Sender: TObject);
begin
if not Assigned(ChildForm) then
begin
ChildForm:=TForm2.Create(Application);
ChildForm.Caption:='ChildForm';
end; end;
procedure TForm1.Hide1Click(Sender: TObject);
begin
if Assigned(ChildForm) then
ShowWindow(ChildForm.Handle, SW_HIDE);
end;
procedure TForm1.Show1Click(Sender: TObject);
begin
if Assigned(ChildForm) then
SetWindowPos(ChildForm.Handle, HWND_TOP, 0, 0, 0, 0,
SWP_NOSIZE or SWP_NOMOVE or SWP_SHOWWINDOW);
end;
Tworzenie formy przeźroczystej (z przezroczystym tłem), to należy zmienić metodę Create i Resize tej formy i wykorzystać funkcję CombineRgn.
constructor TForm1.Create(AOwner: TComponent);
begin
inherited;
HorzScrollBar.Visible:=False; VertScrollBar.Visible:=False;
NewWindowRgn;
end;
procedure TForm1.NewWindowRgn;
var i, CoordX, CoordY: Integer; FormRgn, NewRgn: THandle;
begin
CoordX:=(Width-ClientWidth) div 2; CoordY:=Height-ClientHeight-4;
FormRgn:=CreateRectRgn(0, 0, Width, Height);
NewRgn:= CreateRectRgn( CoordX, CoordY, CoordX+ClientWidth, CoordY+ClientHeight);
CombineRgn(FormRgn, FormRgn, NewRgn, RGN_DIFF);
for i:= 0 to ControlCount -1 do
with Controls[i] do
begin
NewRgn:= CreateRectRgn(CoordX + Left, CoordY + Top, CoordX + Left + Width,
CoordY + Top + Height);
CombineRgn(FormRgn, FormRgn, NewRgn, RGN_OR);
end;
SetWindowRgn(Handle, FormRgn, True);
end;
procedure TForm1.Resize;
begin
inherited; NewWindowRgn;
end;
Pokaz okna MessageDlg w wyznaczonym rejonie formy - tu centralnie na formie.
procedure TForm1.Button1Click(Sender: TObject);
var MyForm: TForm;
begin
MyForm:=CreateMessageDialog('This is example', mtInformation, [mbOk]);
with MyForm do
begin
Height:=130; Width:=150;
Left:=Trunc((Form1.Width-Width)/2)+Form1.Left;
Top:=Trunc((Form1.Height-Height)/2)+Form1.Top;
ShowModal;
end; end;
Utworzenie dziury w aplikacji uruchomionej
var
Wnd: HWnd; Region1, Region2: HRgn; Rect: TRect;
begin
Wnd:=Application.MainForm.Handle; GetWindowRect(Wnd,Rect);
Region1:=CreateRectRgn(0,0,Rect.Right-Rect.Left,Rect.Bottom-Rect.Top);
Region2:=CreateEllipticRgn(10,30,150,120);
CombineRgn(Region1,Region1,Region2,RGN_DIFF);
SetWindowRgn(Wnd,Region1,True);
end;
procedure TForm1.FormCreate(Sender: TObject);
var Style: Longint;
begin
Style := GetWindowLong(Handle, GWL_STYLE);
SetWindowLong(Handle, GWL_STYLE, Style And Not WS_SYSMENU);
end;
procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
if (Key = VK_F4) and (ssAlt in Shift) then begin
MessageBeep(0); Key := 0;
end; end;
procedure TForm1.Button1Click(Sender: TObject);
procedure SetReadOnly(Obj:TComponent;Value :boolean);
var PropInfo: PPropInfo; valueInteger : integer;
begin
if Value then valueInteger:=1 else valueInteger:=0;
if not (Obj.ClassInfo=nil) then
begin
PropInfo:= GetPropInfo(Obj.ClassInfo, 'ReadOnly');
if PropInfo < > nil then
begin
case PropInfo^.PropType^.Kind of
tkEnumeration : SetOrdProp(obj,PropInfo,valueInteger);
end; // case
end; end;
end;
var i : integer; f : boolean;
begin
f := CheckBox1.Checked; // poleć po wszystkich komponentach formy
for i:= 0 to ComponentCount-1 do
begin
SetReadOnly(Components[i],f);
end; end;
To obsługa zdarzenia WM_NCPAINT. W przykładzie ramka otoczona czerwoną linią grubości 1 piksela.
type TForm1 = class(TForm)
private {Private declarations}
procedure WMNCPaint(var Msg : TWMNCPaint); message WM_NCPAINT;
public {Public declarations}
end;
var Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.WMNCPaint(var Msg: TWMNCPaint);
var dc : hDc; Pen : hPen; OldPen : hPen; OldBrush : hBrush;
begin
inherited;
dc := GetWindowDC(Handle); msg.Result := 1;
Pen := CreatePen(PS_SOLID, 1, RGB(255, 0, 0));
OldPen := SelectObject(dc, Pen);
OldBrush := SelectObject(dc, GetStockObject(NULL_BRUSH));
Rectangle(dc, 0,0, Form1.Width, Form1.Height);
SelectObject(dc, OldBrush); SelectObject(dc, OldPen);
DeleteObject(Pen); ReleaseDC(Handle, Canvas.Handle);
end;
unit Unit2;
interface
uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;
type TForm2 = class(TForm)
private {Private declarations}
public {Public declarations}
constructor CreateWithCaption(aOwner: TComponent; aCaption: string);
end;
var Form2: TForm2;
implementation
{$R *.DFM}
constructor TForm2.CreateWithCaption(aOwner: TComponent; aCaption: string);
begin
Create(aOwner); Caption := aCaption;
end;
uses Unit2;
procedure TForm1.Button1Click(Sender: TObject);
begin
Unit2.Form2 :=Unit2.TForm2.CreateWithCaption(Application, 'My Caption');
Unit2.Form2.Show;
end;
Użycie GetCapture () z Windows API.
procedure TForm1.FormDeactivate(Sender: TObject);
begin
ReleaseCapture;
end;
procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
begin
If GetCapture = 0 then SetCapture(Form1.Handle);
if PtInRect(Rect(Form1.Left,Form1.Top,Form1.Left + Form1.Width,
Form1.Top + Form1.Height), ClientToScreen(Point(x, y))) then
Form1.Caption := 'Mysz nad formą!'
else
Form1.Caption := 'Forma bez myszy...';
end;
type TMyForm=class(TForm)
procedure wmSysCommand(var Message:TMessage); message WM_SYSCOMMAND;
end;
const
ID_ABOUT = WM_USER+1;
ID_CALENDAR=WM_USER+2;
ID_EDIT = WM_USER+3;
ID_ANALIS = WM_USER+4;
implementation
procedure TMyForm.wmSysCommand;
begin
case Message.wParam of
ID_CALENDAR:DatBitBtnClick(Self) ;
ID_EDIT :EditBitBtnClick(Self);
ID_ANALIS:AnalisButtonClick(Self);
end;
inherited;
end;
procedure TMyForm.FormCreate(Sender: TObject);
var SysMenu:THandle;
begin
SysMenu:=GetSystemMenu(Handle,False);
InsertMenu(SysMenu,Word(-1),MF_SEPARATOR,ID_ABOUT,'');
InsertMenu(SysMenu,Word(-1),MF_BYPOSITION,ID_Calendar, 'Kalendarz');
InsertMenu(SysMenu,Word(-1),MF_BYPOSITION,ID_Analis, 'Analiza');
InsertMenu(SysMenu,Word(-1),MF_BYPOSITION,ID_Edit, 'Edycja');
end;
Wszystko czego potrzebujemy to HRGN i uchwyt (handle) do sterowania. SetWindowRgn ma trzy parametry: uchwyt okna, które zmienią, region i parametr Boolean, który pokazuje rysować lub nie. Kiedy już mamy uchwyt i region to można wywołać SetWindowRgn (Handle, Region, True)!
Pamiętaj, że nie koniecznym jest zwolnienie rejonu przy pomocy DeleteObject, bo po wywołaniu regionu za pomoca SetWindowRgn włąścicielem jego staje się system operacyjny.
function BitmapToRgn(Image: TBitmap): HRGN;
var TmpRgn: HRGN; x, y: integer; ConsecutivePixels: integer; CurrentPixel: TColor;
CreatedRgns: integer; CurrentColor: TColor;
begin
CreatedRgns := 0;
Result := CreateRectRgn(0, 0, Image.Width, Image.Height); inc(CreatedRgns);
if (Image.Width = 0) or (Image.Height = 0) then exit;
for y := 0 to Image.Height - 1 do
begin
CurrentColor := Image.Canvas.Pixels[0,y]; ConsecutivePixels := 1;
for x := 0 to Image.Width - 1 do
begin
CurrentPixel := Image.Canvas.Pixels[x, y];
if CurrentColor = CurrentPixel then inc(ConsecutivePixels)
else begin
//wchodzimy w nowy rejon
if CurrentColor = clWhite then
begin
TmpRgn := CreateRectRgn(x - ConsecutivePixels, y, x, y + 1);
CombineRgn(Result, Result, TmpRgn, RGN_DIFF); inc(CreatedRgns);
DeleteObject(TmpRgn);
end;
CurrentColor := CurrentPixel; ConsecutivePixels := 1;
end; end;
if (CurrentColor = clWhite) and (ConsecutivePixels > 0) then
begin
TmpRgn := CreateRectRgn(x-ConsecutivePixels, y, x, y+1);
CombineRgn(Result, Result, TmpRgn, RGN_DIFF); inc(CreatedRgns);
DeleteObject(TmpRgn);
end; end; end;
procedure TForm1.FormCreate(Sender: TObject);
var MaskBmp: TBitmap;
begin
MaskBmp := TBitmap.Create;
try //będzie forma w kształcie n/w obrazka
MaskBmp.LoadFromFile('c:\moja_buzia.bmp');
Height := MaskBmp.Height; Width := MaskBmp.Width;
//on zarządza rejonem po wywołaniu SetWindowRgn
SetWindowRgn(Self.Handle, BitmapToRgn(MaskBmp), True);
finally MaskBmp.Free; end;
end;
TStretchHandle = class(TCustomControl)
private
procedure WMEraseBkgnd(var message: TWMEraseBkgnd); message WM_ERASEBKGND;
procedure WMGetDLGCode(var message: TMessage); message WM_GETDLGCODE;
protected
procedure Paint; override;
property Canvas;
public
procedure CreateParams(var Params: TCreateParams); override;
end;
procedure TStretchHandle.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params); { ustawia domyślne parametry }
{ następnie dodaje przejrzystości }
Params.ExStyle := Params.ExStyle + WS_EX_TRANSPARENT;
end;
procedure TStretchHandle.WMGetDLGCode(var message: TMessage);
begin
message.Result := DLGC_WANTARROWS;
end;
procedure TStretchHandle.WMEraseBkgnd(var message: TWMEraseBkgnd);
begin
message.Result := 1;
end;
procedure TStretchHandle.Paint;
begin
inherited Paint; with Canvas do
begin
// rysuj sobie co Ci się tylko podoba - gdzie nie bedzie narysowane tam forma będzie przeźroczysta
end;
end;
Wiedząc, jak tworzyć elipsę teraz trzeba stworzyć nie jeden ale dwa rejony i połączyć je za pomocą CombineRgn:
procedure TForm1.FormCreate(Sender: TObject);
var hsWindowRegion, hsWindowRegion2: Integer;
begin
hsWindowRegion := CreateEllipticRgn(50, 50, 350, 200);
hsWindowRegion2:=CreateEllipticRgn(80, 80, 200, 150);
CombineRgn(hsWindowRegion, hsWindowRegion, hsWindowRegion2, RGN_DIFF);
SetWindowRgn(Handle, hsWindowRegion, true);
end;
Wiemy już, jaką funkcję użyć do połączenia rejonów, ale jak to działa i co ona należy określić?
Wprowadzamy następujące parametry:
Uchwyt do regionu przeznaczenia,
Uchwyt do pierwszego obszaru źródła,
Uchwyt do drugiego obszaru, źródła,
Tryb współdziałania rejonów. Dla stałej RGN_DIFF możemy stosować:
RGN_AND - Tworzy formę z dwóch zmieszanych rejonów
RGN_COPY - Forma jest kopią pierwszego obszaru
RGN_DIFF - Wyświetla pierwszą część obszaru źródłowego, który nie przecina się z drugim,
RGN_OR - tworzy związek dwóch obszary mieszane
RGN_XOR - Forma to związek dwóch regionów, z wyjątkiem stref, które zachodzą na siebie.
unit Unit1;
interface
uses Windows, Messages, SysUtils, Classes, Graphics, Controls,
Forms, Dialogs, StdCtrls, ExtCtrls, jpeg;
type TForm1 = class(TForm)
Label1: TLabel; //wyświetla czas
Timer1: TTimer; //ten robi ten czas
Image1: TImage; //wyświetla obraz na formie
procedure FormCreate(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
private
{przenosi formę na zewnątrz nagłówka deklarowanej procedury}
procedure WMNCHitTest(var M:TWMNCHitTest);message wm_NCHitTest;
public { Public declarations }
end;
var Form1: TForm1;
implementation
{$R *.DFM}
{ {przenosi formę na zewnątrz nagłówka deklarowanej procedury}
procedure TForm1.WMNCHitTest(var M: TWMNCHitTest);
begin
inherited; if M.Result = htClient then M.Result := htCaption;
end;
procedure TForm1.FormCreate(Sender: TObject);
var hsWindowRegion, hsWindowRegion2: integer; p: array [0..11] of TPoint;
begin
p[0].x:=30; p[0].y:=40; p[1].x:=80; p[1].y:=70; p[2].x:=95; p[2].y:=20; p[3].x:=110; p[3].y:=70;
p[4].x:=160; p[4].y:=40; p[5].x:=130; p[5].y:=85; p[6].x:=260; p[6].y:=230; p[7].x:=110; p[7].y:=100;
p[8].x:=95; p[8].y:=200; p[9].x:=80; p[9].y:=100; p[10].x:=30; p[10].y:=130; p[11].x:=60; p[11].y:=85;
hsWindowRegion:=CreatePolygonRgn(P,12,Alternate);
hsWindowRegion2:=CreateEllipticRgn(50,50,140,120);
CombineRgn(hsWindowRegion, hsWindowRegion, hsWindowRegion2, rgn_or);
SetWindowRgn(Handle, hsWindowRegion, true);
end;
procedure TForm1.Timer1Timer(Sender: TObject);
begin
Label1.Caption:=TimeToStr(Time);
end;
end.
Wszystko, co trzeba zrobić to napisać kilka linijek kodu do zdarzenia OnPaint. W ramach przebiegu po powierzchni (canvas) formy każdy piksel otrzymuje losowo żądany odcień. Kolor określony kodem 16-szesnastkowym - mozna go zmienić.
procedure TForm1.FormPaint(Sender: TObject);
var i, j: Integer;
begin
with Form1.Canvas do
for j := 0 to Form1.Height do for i := 0 to Form1.Width do
Pixels[i, j] := Trunc(Random($00000095));
end;
Druga metoda (szybciej):
procedure TForm1.FormPaint(Sender: TObject);
var h, w, i, j: Integer; Rect1, Rect2: TRect;
begin
h := Form1.Height div 10; w := Form1.Width div 10;
with Form1.Canvas do
begin
for j := 0 to h do for i := 0 to w do
Pixels[i,j]:=Trunc(Random($00000095)); Rect1 := Rect(0, 0, w, h);
for j := 0 to 9 do begin
for i := 0 to 9 do begin
Rect2 := Rect(w*j, h*i, w*(j+1), h*(i+1)); CopyRect(Rect2, Form1.Canvas, Rect1);
end; end; end; end;
Okno ma stałe rozmiary niezależnie od rozdzielczości ekranu. Oto krótki przykład jak to zrobić:
implementation
const {w takiej rozdzielczości jest tworzona forma 800x600.}
ScreenWidth: LongInt = 800; ScreenHeight: LongInt = 600;
{$R *.DFM}
procedure TForm1.FormCreate(Sender: TObject);
begin
scaled := true;
if (screen.width < > ScreenWidth) then
begin
height := longint(height) * longint(screen.height) div ScreenHeight;
width := longint(width) * longint(screen.width) div ScreenWidth;
scaleBy(screen.width, ScreenWidth);
end; end;
Jeżeli będziesz chciał sprawdzać rozmiar czcionki to jak niżej. Przed zmianą rozmiaru czcionki, musisz upewnić się, że obiekt posiada właściwość zwaną 'font':
uses typinfo;
var i: integer;
begin
for i := componentCount - 1 downtto 0 do
with components[i] do
begin
if GetPropInfo(ClassInfo, 'font') < > nil then
font.size := (NewFormWidth DIV OldFormWidth) * font.size;
end; end;
procedure TForm1.FormCreate(Sender: TObject);
begin
Form1.Brush.Style := bsClear; Form1.BorderStyle := bsNone
end;
Podczas programowania MDI-aplikacji nie ma potrzeby aby kolejny plik był obsługiwany przez kopię tej aplikacji; lepiej zrobic to tak:
// w pliku projektu:
var i: integer; hMainForm: hwnd; copyDataStruct: TCopyDataStruct;
ParamString: string; WParam, LParam: integer;
begin
/ / Szuka okno główne aplikacji zamiast Caption - NIL,
/ / Ponieważ nagłówek MDIChild można dodać do głównego okna
/ / Trzeba unikać nazwy klasy formy głównej
hMainForm := FindWindow('TMainForm', nil);
if hMainForm = 0 then
begin
Application.Initialize; Application.CreateForm(TFrmMain, frmMain);
for i := 1 to ParamCount do
TMainForm(Application.MainForm).OpenFile(ParamStr(i)); Application.Run;
end else begin
ParamString := ''; for i := 1 to ParamCount do
begin
// wszystkie parametry zapisane w jeden ciąg znaków ograniczony #13
ParamString := ParamString + ParamStr(i) + #13;
end;
// tworzy typ rekordu TCopyDataStruct
CopyDataStruct.lpData := PChar(ParamString);
CopyDataStruct.cbData := Length(ParamString);
CopyDataStruct.dwData := 0;
WParam := Application.Handle; LParam := Integer(@CopyDataStruct);
// wysyła komunikat WM_COPYDATA do głównego okna aplikacji
SendMessage(hMainForm, WM_CopyData, WParam, LParam);
Application.Terminate;
end;
end.
//obsługa wiadomości WM_COPYDATA
procedure TMainForm.CopyData(var Msg: TWMCopyData);
var ParamStr: string; CopyDataStructure: TCopyDataStruct; i: integer; len: integer;
begin
CopyDataStructure := Msg.CopyDataStruct^; ParamStr := '';
len := CopyDataStructure.cbData; for i := 0 to len - 1 do
begin
ParamStr := ParamStr + (PChar(CopyDataStructure.lpData) + i)^;
end;
i := 0;
while not (Length(ParamStr) = 0) do
begin
if isDelimiter(#13, ParamStr, i) then
begin
OpenFile(Copy(ParamStr, 0, i - 1)); ParamStr := Copy(ParamStr, i + 1, Length(ParamStr) - i - 1);
end; inc(i); end; inherited;
end;
var ProjectWindow: TWndProject;
begin
If ProjectActive=false then
begin
LockWindowUpdate(ClientHandle); ProjectWindow:=TWndProject.Create(self);
ProjectWindow.Left:=10; ProjectWindow.Top:=10;
ProjectWindow.Width:=373; ProjecTwindow.Height:=222;
ProjectWindow.Show; LockWindowUpdate(0);
end; end;
Ważne: Użyj LockWindowUpdate przed utworzeniem okna MDI.
constructor TMainForm.Create(AOwner: TComponent);
begin
Inherited Create(AOwner);
SetWindowLong(ClientHandle, GWL_EXSTYLE, GetWindowLong(ClientHandle,
GWL_EXSTYLE) or WS_EX_CLIENTEDGE);
SetWindowPos(ClientHandle, 0, 0, 0, 0, 0, swp_DrawFrame or swp_NoMove or swp_NoSize
or swp_NoZOrder);
end;
Aby utworzyć okno bez tytułu z dowolnym stylem wykonaj:
procedure CreateParams(var Params: TCreateParams); override;
i jej realizacja:
procedure TForm1.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
with Params do Style := (Style OR WS_POPUP) AND NOT WS_DLGFRAME;
end;
Wariant1:
program Project1;
uses Forms, Windows, // koniecznie dopisać
Unit1 in 'Unit1.pas' {Form1};
{$R *.RES}
var HM: THandle;
function Check: boolean;
begin
HM := OpenMutex(MUTEX_ALL_ACCESS, false, 'MyOwnMutex');
Result := (HM < > 0);
if HM = 0 then
HM := CreateMutex(nil, false, 'MyOwnMutex');
end;
begin
if Check then Exit;
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.Run;
end.
Wariant 2:
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.
Wariant 3:
...
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
// tutaj możemy dać komunikat jeżeli kopia jest uruchomiona.
Self.Close; // i zakończyć program albo zrobić coś innego.
end; end;
Wariant 4:
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.
Wariant5:
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('Aplikacja jest już uruchomiona. Kliknij OK aby kontynuować', MB_OK);
CloseHandle(MemHnd);
end.