np. "Nie pokazuj tego komunikatu ponownie" - wykorzystanie funkcji CreateMessageDialog
procedure TForm1.Button1Click(Sender: TObject);
Var AMsgDialog: TForm; ACheckBox: TCheckBox;
begin
AMsgDialog := CreateMessageDialog('This is a test message.', mtWarning, [mbYes, mbNo]);
ACheckBox := TCheckBox.Create(AMsgDialog);
with AMsgDialog do
try Caption := 'Dialog Title' ; Height := 169;
With ACheckBox do begin
Parent := AMsgDialog; Caption := 'Don''t show me again.'; top := 121; Left := 8;
end;
Case ShowModal of
ID_YES: ;//your code here after dialog closed
ID_NO: ;
end;
If ACheckBox.Checked then begin
//...
end; finally ACheckBox.Free; Free;
end; end;
Można również tym sposobem dostosować typowy MessageDialog.
Typowe okno modalne jeżeli jest aktywne (widoczne) uniemożliwia wykonywanie instrukcji spoza niego.
Często jednak istnieje potrzeba wykonania pewnego procesu spoza okienka modalnego.
Wtedy należy wykonac jak niżej:
procedure TForm1.ShowProgrDlg;
var WindowList: Pointer;
begin {Disables all forms except Form2}
WindowList := DisableTaskWindows(Form2.Handle);
try Form2.Show; {Loop that performs a task}
Form2.ProgressBar1.Position := Form2.ProgressBar1.Position + 1; {end loop}
finally {enable all forms again}
EnableTaskWindows(WindowList); Form2.Close;
end; end;
W systemie Windows robimy to prosto za pomocą zdarzenia OnTypeChange.
procedure TMainForm.SaveDialogTypeChange(Sender: TObject);
var S, S1 : string; EditHandle : THandle; startp, endp : DWORD;
begin
s := ''; if SaveDialog.FilterIndex = 2 then begin
s := 'c:\program files';
end else
if SaveDialog.FilterIndex = 3 then begin
s := 'd:\program files';
end;
if s < > '' then begin
EditHandle := GetDlgItem(GetParent(SaveDialog.Handle), edt1);
if EditHandle < > 0 then begin
SetLength(S1, GetWindowTextLength(EditHandle) + 1);
GetWindowText(EditHandle, PChar(S1), Length(S1));
SetLength(S1, StrLen(PChar(S1)));
SendMessage(EditHandle, EM_GETSEL, Integer(@StartP), Integer(@EndP));
SetWindowText(EditHandle, PChar(S));
SendMessage(GetParent(SaveDialog.Handle), WM_COMMAND, 1,
GetDlgItem(GetParent(SaveDialog.Handle), IDOK));
if Length(S1) > 0 then
if S1[Length(S1)] = #10 then
Delete(S1, Length(S1), 1);
SetWindowText(EditHandle, PChar(S1));
SendMessage(EditHandle, EM_SETSEL, StartP, EndP);
end; end; end;
unit ScreenBrowseForFolder;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, Buttons, ShlObj; // TBrowseInfo, pItemIDList
type TFormFolderBrowse = class(TForm)
ButtonBrowse: TButton; Memo1: TMemo; EditFolderName: TEdit;
SpeedButtonUp: TSpeedButton;
procedure ButtonBrowseClick(Sender: TObject);
procedure SpeedButtonUpClick(Sender: TObject);
procedure EditFolderNameChange(Sender: TObject);
private { Private declarations }
public { Public declarations }
end;
PROCEDURE FreePIDL(PIDL: pItemIDList); StdCall;
var FormFolderBrowse: TFormFolderBrowse;
implementation {$R *.DFM}
USES FileCtrl; // DirectoryExists
// Direct call to undocumented Windows function
PROCEDURE FreePIDL; EXTERNAL 'Shell32.DLL' INDEX 155;
FUNCTION BrowseCallback(Wnd : hWND; MessageID: UINT; Param: LPARAM;
Data: LPARAM): INTEGER STDCALL;
VAR Name: ARRAY[0..MAX_PATH] OF CHAR; pIDL: pItemIDList; s : STRING;
BEGIN
CASE MessageID OF
BFFM_INITIALIZED: BEGIN
FormFolderBrowse.Memo1.Lines.Add('BFFM_INITIALIZED (' + IntToStr(MessageID) + ')');
IF (LENGTH(FormFolderBrowse.EditFolderName.Text) > 0) AND
DirectoryExists(FormFolderBrowse.EditFolderName.Text)
THEN BEGIN
SendMessage(Wnd, BFFM_SETSELECTION, Integer(TRUE),
Integer( pChar(FormFolderBrowse.EditFolderName.Text) ) );
END END;
BFFM_SELCHANGED: BEGIN
FormFolderBrowse.Memo1.Lines.Add('BFFM_SELCHANGED (' + IntToStr(MessageID) + ')');
END;
BFFM_ENABLEOK: BEGIN
FormFolderBrowse.Memo1.Lines.Add('BFFM_ENABLEOK (' + IntToStr(MessageID) + ')');
END;
BFFM_SETSELECTION: BEGIN
FormFolderBrowse.Memo1.Lines.Add('BFFM_ENABLEOK (' + IntToStr(MessageID) + ')');
END; ELSE // ignore
END;
pIDL := Pointer(Param); s := '';
IF Assigned(PIDL) THEN SHGetPathFromIDList(pIDL, Name);
FormFolderBrowse.Memo1.Lines.Add(' ' + IntToStr(MessageID) + ' ' + IntToStr(Data) + ' ' + Name );
RESULT := 0
END {BrowseCallback};
procedure TFormFolderBrowse.ButtonBrowseClick(Sender: TObject);
VAR BrowseInfo : TBrowseInfo; ItemIDList : pItemIDList; // some would use PIDL here
DisplayName: ARRAY[0..MAX_PATH] OF CHAR;
begin
BrowseInfo.hwndOwner := Handle; BrowseInfo.pidlRoot := NIL;
BrowseInfo.pszDisplayName := @DisplayName[0];
BrowseInfo.lpszTitle := 'Select Directory';
BrowseInfo.ulFlags := BIF_RETURNONLYFSDIRS;
BrowseInfo.lpfn := BrowseCallback;
BrowseInfo.lParam := 0; BrowseInfo.iImage := 0;
// Display browse folder set as the return value to itemlist
ItemIDList := SHBrowseForFolder(BrowseInfo);
TRY // Get directory from the ItemIDList
IF Assigned(ItemIDList) THEN
IF SHGetPathFromIDList(ItemIDList, DisplayName) THEN BEGIN
EditFolderName.Text := DisplayName;
Memo1.Lines.Add(' Icon index = ' + IntToStr(BrowseInfo.iImage));
SpeedButtonUp.Enabled := (StrLen(DisplayName) > 0)
END; FINALLY FreePIDL(ItemIDList) END
end;
{$IFNDEF VER130} // If not Delphi 5
FUNCTION ExcludeTrailingBackSlash(CONST s: STRING): STRING;
BEGIN
RESULT := s; IF RESULT[LENGTH(s)] = '\'
THEN SetLength(RESULT, LENGTH(RESULT)-1)
END {ExcludeTrailingBackSlash};
{$ENDIF}
procedure TFormFolderBrowse.SpeedButtonUpClick(Sender: TObject);
begin
IF (LENGTH(EditFolderName.Text) > 0) AND
DirectoryExists(EditFolderName.Text) THEN BEGIN
EditFolderName.Text := ExcludeTrailingBackSlash( ExtractFilePath(EditFolderName.Text) )
END;
// Kludge: Must have X:\ instead of X: to re-start search
IF (LENGTH(EditFolderName.Text) = 2) AND (EditFolderName.Text[2] = ':')
THEN EditFolderName.Text := EditFolderName.Text + '\'
end;
procedure TFormFolderBrowse.EditFolderNameChange(Sender: TObject);
begin
SpeedButtonUp.Enabled := (LENGTH(EditFolderName.Text) > 0)
end;
end.
Jak zmienić tekst "File name:", "File Type" i opis klawiszy standardowego okienka Windowsa?
Jeżeli trzeba to zrobić należy wykorzystać komendy Windowsa (Windows API) bowiem komponenty Delphi
takich możliwości nie dają.
Przykład demonstruje zmianę wszystkich napisów umieszczonych w okienku TOpen Dialog. W pierwszej
kolejności określamy identyfikatory dla elementów okienka:
const
// LB_FOLDERS_ID = 65535;
LB_FILETYPES_ID = 1089; // "File types:" label
LB_FILENAME_ID = 1090; // "File name:" label
LB_DRIVES_ID = 1091; // "Look in:" label
Następnie wysyłamy wiadomość do okienka aby to zmieniło opisy:
procedure TForm1.OpenDialog1Show(Sender: TObject);
const // LB_FOLDERS_ID = 65535;
LB_FILETYPES_ID = 1089; LB_FILENAME_ID = 1090; LB_DRIVES_ID = 1091;
Str1 = 'Four'; Str2 = 'Five'; Str3 = 'One'; Str4 = 'Two'; Str5 = 'Three';
begin
SendMessage( GetParent(OpenDialog1.Handle), CDM_SETCONTROLTEXT, IDOK,LongInt(Pchar(Str1)));
SendMessage( GetParent(OpenDialog1.Handle), CDM_SETCONTROLTEXT, IDCANCEL, LongInt(Pchar(Str2)));
SendMessage( GetParent(OpenDialog1.Handle), CDM_SETCONTROLTEXT, LB_FILETYPES_ID, LongInt(Pchar(Str3)));
SendMessage( GetParent(OpenDialog1.Handle), CDM_SETCONTROLTEXT, LB_FILENAME_ID, LongInt(Pchar(Str4)));
SendMessage( GetParent(OpenDialog1.Handle), CDM_SETCONTROLTEXT, LB_DRIVES_ID, LongInt(Pchar(Str5)));
end;
Delphi nie ma tej funkcji więc należy skorzystać z ShellSPI Windowsa:
uses ShlObj;
function GetFolder(aRoot: integer; aCaption :string): string;
var pPrograms,pBrowse: PItemIDList; hBrowseInfo: TBROWSEINFO; hPChar: PChar;
begin
if (not SUCCEEDED(SHGetSpecialFolderLocation(Getactivewindow, aRoot, pPrograms))) then EXIT;
hPChar := StrAlloc(max_path);
with hBrowseInfo do begin
hwndOwner := Getactivewindow; pidlRoot := pPrograms; pszDisplayName := hPChar;
lpszTitle := pChar(aCaption); ulFlags := BIF_RETURNONLYFSDIRS; lpfn := nil; lParam := 0;
end;
pBrowse := SHBrowseForFolder(hBrowseInfo);
if (pBrowse < > nil) then
if (SHGetPathFromIDList(pBrowse, hPChar)) then Result:= hPChar; StrDispose(hPChar);
end;
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ExtCtrls, ComCtrls;
type TForm1 = class(TForm) PaintBox1: TPaintBox;
procedure FormCreate(Sender: TObject);
procedure PaintBox1Paint(Sender: TObject);
private
protected
procedure CreateParams(var Params: TCreateParams); override;
procedure CreateWnd; override;
public
end;
var Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
Params.Style := WS_CAPTION or WS_SIZEBOX or WS_SYSMENU;
Params.ExStyle := WS_EX_DLGMODALFRAME or WS_EX_WINDOWEDGE;
end;
procedure TForm1.CreateWnd;
begin
inherited CreateWnd; SendMessage(Self.Handle, WM_SETICON, 1, 0);
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
PaintBox1.Align := alRight; PaintBox1.Width := 16;
end;
procedure TForm1.PaintBox1Paint(Sender: TObject);
begin
With PaintBox1 do
DrawFrameControl(Canvas.Handle, Rect(Width - 15, Height - 15, Width, Height), DFC_SCROLL,
DFCS_SCROLLSIZEGRIP );
end;
end.
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;
const inputboxmessage = wm_user + 200;
type
tform1 = class(tform)
button1: tbutton;
procedure button1click(sender: tobject);
private
procedure inputboxsetpasswordchar(var msg: tmessage); message inputboxmessage;
public
end;
var form1: tform1;
implementation
{$r *.dfm}
procedure tform1.inputboxsetpasswordchar(var msg: tmessage);
var hinputform, hedit, hbutton: hwnd;
begin
hinputform := screen.forms[0].handle;
if (hinputform < > 0) then
begin
hedit := findwindowex(hinputform, 0, 'tedit', nil);
{
// zmiana tekstu buttona:
hbutton := findwindowex(hinputform, 0, 'tbutton', nil);
sendmessage(hbutton, wm_settext, 0, integer(pchar('cancel')));
}
sendmessage(hedit, em_setpasswordchar, ord('*'), 0);
end; end;
procedure tform1.button1click(sender: tobject);
var inputstring: string;
begin
postmessage(handle, inputboxmessage, 0, 0);
inputstring := inputbox('input box', 'Proszę wprowadź hasło', '');
end;
W module filectrl są dwie metody wyboru katalogu - oto jedna z nich:
uses shlobj
function browsefolderdialog(title: pchar): string;
var titlename: string; lpitemid: pitemidlist; browseinfo: tbrowseinfo;
displayname: array[0..max_path] of char; temppath: array[0..max_path] of char;
begin
fillchar(browseinfo, sizeof(tbrowseinfo), #0);
browseinfo.hwndowner := getdesktopwindow; browseinfo.pszdisplayname := @displayname;
titlename := title; browseinfo.lpsztitle := pchar(titlename);
browseinfo.ulflags := bif_returnonlyfsdirs; lpitemid := shbrowseforfolder(browseinfo);
if lpitemid < > nil then
begin
shgetpathfromidlist(lpitemid, temppath); result := temppath; globalfreeptr(lpitemid);
end; end;
{$apptype console}
program minimize;
uses windows,messages;
var count : integer;
function enumproc (winhandle: hwnd; param: longint): boolean; stdcall;
begin
if (getparent (winhandle) = 0) and (not isiconic (winhandle)) and (iswindowvisible (winhandle)) then
begin
postmessage (winhandle, wm_syscommand, sc_minimize, 0); inc(count);
end;
enumproc := true;
end;
begin
count:=0; enumwindows (@enumproc, 0); writeln('minimized:',count,' windows');
end.
{W celu korzystania z tego przykładu należy wcisnąć przycisk button1.}
function enumminiproc (wd: hwnd; param: longint): boolean; stdcall; { koniecznie stdcall !!!}
begin
if wd< > form1.handle then // jeżeli jest to nasz program
if iswindowvisible(wd) then // jeżeli okno jest widoczne
if not isiconic(wd) then // jeżeli okno nie jest zminimalizowane
if iswindow(wd) then //i ogólnie - wszystkie okna.
showwindow(wd, sw_minimize);
// zwracamy go.
enumproc := true; // przejdź przez wszystkie okna systemu.
end;
procedure tform1.button1click(sender: : tobject);
// zamykamy za naciśnięciem przycisku
begin
enumwindows (@enumminiproc, 0);
end;
Wersja 1:
type
pfindwindowstruct = ^tfindwindowstruct;
tfindwindowstruct = record
caption : string;
classname : string;
windowhandle : thandle;
end;
function enumwindowsproc(hwindow : hwnd; lparam : longint) : bool; stdcall;
var lpbuffer : pchar; windowcaptionfound : bool; classnamefound : bool;
begin
getmem(lpbuffer, 255); result := true; windowcaptionfound := false;
classnamefound := false;
try
if getwindowtext(hwindow, lpbuffer, 255) > 0 then
if pos(pfindwindowstruct(lparam).caption, strpas(lpbuffer)) > 0 then windowcaptionfound := true;
if pfindwindowstruct(lparam).classname = '' then classnamefound := true
else
if getclassname(hwindow, lpbuffer, 255) > 0 then
if pos(pfindwindowstruct(lparam).classname, strpas(lpbuffer)) > 0 then classnamefound := true;
if (windowcaptionfound and classnamefound) then
begin
pfindwindowstruct(lparam).windowhandle := hwindow; result := false;
end; finally freemem(lpbuffer, sizeof(lpbuffer^));
end; end;
function findawindow(caption : string; classname : string) : thandle;
var windowinfo : tfindwindowstruct;
begin
windowinfo.caption := caption;
windowinfo.classname := classname;
windowinfo.windowhandle := 0;
enumwindows(@enumwindowsproc, longint(@windowinfo));
findawindow := windowinfo.windowhandle;
end;
procedure tform1.button1click(sender: tobject);
var thewindowhandle : thandle;
begin
thewindowhandle := findawindow('opera', '');
if thewindowhandle< > 0 then
begin
showwindow(thewindowhandle, sw_restore); bringwindowtotop(thewindowhandle);
end else
showmessage('okna nie znaleziono!');
end;
Wersja 2:
function tform1.find(s:string):hwnd;
var wnd:hwnd; buff:array [0..127] of char;
begin
find:=0; wnd:=getwindow(handle,gw_hwndfirst);
while wnd< > 0 do
begin
if (wnd< > application.handle) and iswindowvisible(wnd) and
(getwindow(wnd,gw_owner)=0) and (getwindowtext(wnd,buff,sizeof(buff))< > 0) then
begin
getwindowtext(wnd,buff,sizeof(buff));
if pos(s,strpas(buff)) > 0 then
begin
find:=wnd; break; end;
end;
wnd:=getwindow(wnd,gw_hwndnext);
end; end;
Ten przykład wymaga użycia obrazu TImage, 2 buttony (open i save) i 2 komponentów - OpenPicture
Dialog i SavePicture Dialog
procedure TForm1.Button1Click(Sender: TObject);
begin
if OpenPictureDialog1.Execute then { uruchom open picture dialog. }
if FileExists(OpenPictureDialog1.FileName) then { najpierw sprawdź czy plik istnieje. }
{ jeżeli istnieje to załaduj dane do komponentu Image. }
Image1.Picture.LoadFromFile(OpenPictureDialog1.FileName)
else
{ w przeciwnym razie zgłoś wyjątek. }
raise Exception.Create('Wybrany plik nie istnieje!');
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
if SavePictureDialog1.Execute then { uruchom save picture dialog. }
if FileExists(SavePictureDialog1.FileName) then { najpierw sprawdź czy taki plik istnieje. }
{ jeżeli taki plik już istnieje to zgłoś wyjątek. }
raise Exception.Create('Taki plik już istnieje. Czy mam go nadpisać?')
else
{ w przeciwnym razie należy zapisać dane do pliku. }
Image1.Picture.SaveToFile(SavePictureDialog1.FileName);
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
Image1.Canvas.Refresh;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if OpenTextFileDialog1.Execute then { uruchom open textfile dialog. }
if FileExists(OpenTextFileDialog1.FileName) then { najpierw sprawdź czy plik istnieje. }
begin
{ jeżeli istnieje to ładuj jego dane na pole memo. }
Memo1.Lines.LoadFromFile(OpenTextFileDialog1.FileName);
Edit1.Text := OpenTextFileDialog1.Encodings[OpenTextFileDialog1.EncodingIndex];
end else
{ w przeciwnym razie zgłoś wyjątek. }
raise Exception.Create('Wybrany plik nie istnieje.');
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
if SaveTextFileDialog1.Execute then { uruchom textsave file dialog. }
if FileExists(SaveTextFileDialog1.FileName) then { najpierw sprawdź czy plik istnieje. }
{jeżeli istnieje to zgłoś wyjątek. }
raise Exception.Create('Plik już istnieje. Czy mam go nadpisać?')
else
{ w przeciwnym razie zapisz wszystkie linie z memo1 do pliku. }
Memo1.Lines.SaveToFile(SaveTextFileDialog1.FileName);
Edit1.Text := SaveTextFileDialog1.Encodings[SaveTextFileDialog1.EncodingIndex];
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
{Inicjowanie filtrów tych okienek z chwilą uruchomienia programu; filtry to plik z rozszerzeniem txt i
dowolny plik. }
OpenTextFileDialog1.Filter := 'Text files (*.txt)|*.TXT|dowolny plik (*.*)|*.*';
SaveTextFileDialog1.Filter := 'Text files (*.txt)|*.TXT| dowolny plik (*.*)|*.*';
end;
procedure TForm1.ReplaceDialog1Replace(Sender: TObject);
// var FindText, ReplaceText: String; - to fraza szukana i fraza do zastąpienia
begin
with Sender as TReplaceDialog do
begin
if frReplace in Options then
DoReplace(ReplaceDialog1.FindText, ReplaceDialog1.ReplaceText)
else
if frReplaceAll in Options then
DoReplaceAll(ReplaceDialog1.FindText, ReplaceDialog1.ReplaceText);
end; end;
procedure TForm1.Button1Click(Sender: TObject);
begin
ReplaceDialog1.Execute;
end;
procedure TForm1.DoReplace(FindText, ReplaceText: String);
begin
ShowMessage( 'Znaleziony tekst: FindText: ' + ReplaceDialog1.FindText +
' Zastąp tekstem : ' + ReplaceDialog1.ReplaceText);
end;
procedure TForm1.DoReplaceAll(FindText, ReplaceText: String);
begin
ShowMessage('Wszystkie znalezione frazy: FindText: ' + ReplaceDialog1.FindText +
' Zastęp tekstem : ' + ReplaceDialog1.ReplaceText);
end;
procedure TForm1.FormCreate(Sender: TObject);
const Path = 'OverView.RTF';
begin
RichEdit1.PlainText := False;
RichEdit1.Lines.LoadFromFile(Path);
RichEdit1.ScrollBars := ssVertical;
end;
//szukanie i zamiana inna wersja:
procedure TForm1.ReplaceDialog1Replace(Sender: TObject);
var SelPos: Integer;
begin
with TReplaceDialog(Sender) do
begin
{ szukaj w całym memo1 z rozróżnianiem wielkości znaków. }
SelPos := Pos(FindText, Memo1.Lines.Text);
if SelPos > 0 then
begin
Memo1.SelStart := SelPos - 1; Memo1.SelLength := Length(FindText);
{ zamień tekst znaleziony z zadanym do zamiany. }
Memo1.SelText := ReplaceText;
end else
MessageDlg(Concat('Nie znalazłem tekstu "', FindText, '" w polu Memo1.'), mtError, [mbOk], 0);
end; end;
Do utworzenia nowego okna modalnego należy usunąć linię z pliku projektu .DPR
Application.CreateForm (TForm2, Form2); i wykorzystać w swoim programie tą standardową konstrukcję:
with TForm2.Create(nil) do
try
ShowModal;
finally Free;
end;
procedure TForm1.Button1Click(Sender: TObject);
var MyForm: TForm;
begin
MyForm:=CreateMessageDialog('To jest przykład', 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;
Wyślij komendę WM_SYSCOMMAND do wszystkich okien przeglądarki Internet Explorer. Do ich
odszukania wykorzystaj funkcję FindWindow.
procedure TForm1.Button1Click(Sender: TObject);
var IExplorer, Prev: THandle;
begin
Prev:=0; IExplorer:=FindWindow('IEFrame', nil);
while (IExplorer< > 0) and (IExplorer< > Prev) do
begin
SendMessage(IExplorer,WM_SYSCOMMAND,SC_MINIMIZE,0);
Prev:=IExplorer; IExplorer:=FindWindow('IEFrame',nil);
end; end;
procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
ReleaseCapture;
SendMessage(Form1.Handle, WM_SYSCOMMAND, $F012, 0);
end;
Jeżeli chcemy by po najechaniu myszą na przycisk Button 1 wyświetliła się podpowiedź w 2 liniach
(można w wielu) to w procedurze odpowiedzialnej za pokazanie planszy programu piszemy:
procedure TForm1.FormShow(Sender: TObject);
begin
Button1.Hint := 'To będzie linia1' + #13#10 + 'a to bezcenna wskazówka w linii2';
end;
{ #13#10 to kod zmiany wiersza i przejście do nowej linii }
function CreateEllipticRgn(
nLeftRect: Integer, // x-coordinate of the upper-left corner
nTopRect: Integer, // y-coordinate of the upper-left corner
nRightRect: Integer, // x-coordinate of the lower-right
nBottomRect: Integer // y-coordinate of the lower-right corner
): HRGN;
function SetWindowRgn(
hWnd: HWND, // handle to window whose window region is to be set
hRgn: HRGN, // handle to region
bRedraw: Boolean // window redraw flag
);
procedure TForm1.FormCreate(Sender: TObject);
var hRegion: HRGN;
begin
BorderStyle := bsNone;
hRegion := CreateEllipticRgn(1, 1, 200, 200);
SetWindowRgn(Handle, hRegion, True);
end;
//przykład:
type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
private {Private declarations}
public {Public declarations}
procedure MyShowHint(var HintStr: string; var CanShow: Boolean;var HintInfo: THintInfo);
end;
var Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.MyShowHint(var HintStr: string; var CanShow: Boolean; var HintInfo: THintInfo);
var i : integer;
begin
for i := 0 to Application.ComponentCount - 1 do
if Application.Components[i] is THintWindow then
with THintWindow(Application.Components[i]).Canvas do
begin
Font.Name:= 'Arial'; Font.Size:= 18; Font.Style:= [fsBold]; HintInfo.HintColor:= clWhite;
end; end;
procedure TForm1.FormCreate(Sender: TObject);
begin
Application.OnShowHint := MyShowHint;
end;
W przykładzie wykorzystano zdarzenie Application.Hint - podpowiedzi są wyświetlane na pasku Status Bar.
type
TForm1 = class(TForm)
Panel1: TPanel;
MainMenu1: TMainMenu;
MenuItemFile: TMenuItem;
MenuItemOpen: TMenuItem;
MenuItemClose: TMenuItem;
OpenDialog1: TOpenDialog;
procedure FormCreate(Sender: TObject);
procedure MenuItemCloseClick(Sender: TObject);
procedure MenuItemOpenClick(Sender: TObject);
private {Private declarations}
procedure HintHandler(Sender: TObject);
public {Public declarations}
end;
var Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.FormCreate(Sender: TObject);
begin
Panel1.Align := alBottom; MenuItemFile.Hint := 'File Menu';
MenuItemOpen.Hint := 'Opens A File';
MenuItemClose.Hint := 'Closes the Application';
Application.OnHint := HintHandler;
end;
procedure TForm1.HintHandler(Sender: TObject);
begin
Panel1.Caption := Application.Hint;
end;
procedure TForm1.MenuItemCloseClick(Sender: TObject);
begin
Application.Terminate;
end;
procedure TForm1.MenuItemOpenClick(Sender: TObject);
begin
if OpenDialog1.Execute then
Form1.Caption := OpenDialog1.FileName;
end;
private { Private declarations }
FSelPos: integer;
public { Public declarations }
end;
var Form1 : TForm1;
implementation
{$R *.dfm}
procedure TForm1.FindDialog1Find(Sender : TObject);
var S : string; startpos : integer;
begin
with TFindDialog(Sender) do
begin
if FSelPos = 0 then {jeżeli na tej pozycji nie ma to szukaj następne. }
Options := Options - [frFindNext];
{ dowiedz się gdzie rozpocząć wyszukiwanie w tekście Memo. }
if frfindNext in Options then
begin
StartPos := FSelPos + Length(Findtext); { To jest znaleziony tekst i szukaj dalej. }
S := Copy(Memo1.Lines.Text, StartPos, MaxInt);
end else begin
{ obszar szukania to Memo1 jako start. }
S := Memo1.Lines.Text; StartPos := 1;
end;
{ szukaj globalnie z rozróżnianiem wielkości liter w całym Memo }
FSelPos := Pos(FindText, S);
if FSelPos > 0 then
begin
{ znalazłem frazę i korekta miejsca rozpoczecia poszukiwania. }
FSelPos := FSelPos + StartPos - 1;
Memo1.SelStart := FSelPos - 1;
Memo1.SelLength := Length(FindText);
Memo1.SetFocus;
end else begin
if frfindNext in Options then { Pokaz komunikatu przy braku frazy. }
S := Concat('Brak dalszych fraz" ', FindText,' " w Memo1')
else
S := Concat(' Nie znalazłem frazy " ', FindText, ' " w' Memo1.');
MessageDlg(S, mtError, [mbOK], 0);
end; end;
end;
// Wywołanie FindDialog
procedure TForm1.Button1Click(Sender : TObject);
begin
FSelPos := 0; FindDialog1.Execute;
end;
const mbMessage = WM_USER + 1024;
type
private
procedure ChangeMessageBoxPosition(var Msg: TMessage); message mbMessage;
end;
var Form1: TForm1; msgCaption: PChar; // zmienna do przechowania opisu
implementation
{$R *.DFM}
procedure TForm1.ChangeMessageBoxPosition(var Msg: TMessage);
var MbHwnd: longword; MbRect: TRect; x, y, w, h: integer;
begin
MbHwnd := FindWindow(MAKEINTRESOURCE(WC_DIALOG), msgCaption);
if (MbHwnd < > 0) then
begin
GetWindowRect(MBHWnd, MBRect);
with MbRect do
begin
w := Right - Left; h := Bottom - Top;
end;
// centruj w poziomie
x := Form1.Left + ((Form1.Width - w) div 2);
// zachowaj na ekranie
if x < 0 then x := 0
else
if x + w > Screen.Width then x := Screen.Width - w;
//centruj w pionie
y := Form1.Top + ((Form1.Height - h) div 2);
// zachowaj na ekranie
if y < 0 then y := 0
else
if y + h > Screen.Height then y := Screen.Height - h;
// ustaw nową pozycję okna
SetWindowPos(MBHWnd, 0, x, y, 0, 0, SWP_NOACTIVATE or SWP_NOSIZE or SWP_NOZORDER);
end; end;
function SelectColor(C: TColor): TColor;
const BasicColors = [$00, $40, $80, $A0, $C0, $FF];
begin
with TColorDialog.Create(Application) do
begin
Color := C;
if (GetRValue(Color) in BasicColors) and (GetGValue(Color) in BasicColors) and
(GetBValue(Color) in BasicColors) then
begin
Options := Options - [cdFullOpen];
end else begin
Options := Options + [cdFullOpen];
end;
if Execute then
begin
Result := Color
end else begin
Result := clNone;
end; Free; end;
end;
Niżej w procedurze pokazano 3 użyteczne sposoby komunikowania się programów z użytkownikiem.
Okienka InputBox i InputQuery pozwalają na wprowadzanie danych z klawiatury.
Okienko InputBox jest zamykane bez względu na to czy użytkownik nacisnie OK lub Cancel (albo ESC). W okienku InputQuery program wie jaki przycisk został wciśniety i odpowiednio reaguje.
ShowMessage - kolejny prosty sposób wyświetlenia wiadomości do użytkownika.
procedure TForm1.Button1Click(Sender: TObject);
var s, s1: string; b: boolean;
begin
s := Trim(InputBox('Nowe hasło' , 'Hasło', 'To hasełko domyślne'));
b := s < > ''; s1 := s;
if b then
b := InputQuery('Powtórz hasło' , 'Hasło' , s1);
if not b or (s1 < > s) then
ShowMessage(' Złe hasło Aniele');
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;
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.
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;
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;
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.
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.
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;
Przykład pokazuje standardowe okno dialogowe, które posiada dodatkowy znacznik wyboru - "Nie
pokazuj tego komunikatu ponownie". Rozwiązanie przydatne przy pracy z grafiką a jest to możliwe przy wykorzystaniu funkcji createmessagedialog i dodanie składnika przez wywołanie showmodal.
na przykład:
procedure tform1.button1click(sender: tobject);
var amsgdialog: tform; acheckbox: tcheckbox;
begin
amsgdialog := createmessagedialog('to jest test komunikatu.', mtwarning, [mbyes, mbno]);
acheckbox := tcheckbox.create(amsgdialog);
with amsgdialog do
try caption := 'Tytuł okienka' ; height := 169;
with acheckbox do
begin
parent := amsgdialog; caption := 'Nie pokazuj tego ponownie.';
top := 121; left := 8;
end;
case showmodal of
id_yes: ;//tutaj kod gdy okno dialogowe zostanie zamknięte
id_no: ;
end;
if acheckbox.checked then begin
//...
end; finally acheckbox.free; free;
end; end;