neoturk: ...Move components at runtime ?...
{
This example shows how to move components at runtime, dragging it.
You are able to see the components move as you drag them.
Attach the Control event handlers (ControlMouseDown,...)
to all components you want to move.
Dieses Beispiel zeigt, wie man Komponenten zur Laufzeit
verschieben kann. Während dem Verschieben werden die
Komponenten voll angezeigt.
An alle Komponenten, welche verschoben werden sollen,
die Eregnisse ControlMouseDown,ControlMouseMove und
ControlMouseUp zuweisen.
}
type
TForm1 = class(TForm)
Image1: TImage;
procedure ControlMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure ControlMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
procedure ControlMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
private
{ Private declarations }
FDownX,
FDownY: Integer;
FDragging: Boolean;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
type
TMoveCracker = class(TControl);
procedure TForm1.ControlMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
FDownX := X;
FDownY := Y;
FDragging := True;
TMoveCracker(Sender).MouseCapture := True;
end;
procedure TForm1.ControlMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
begin
if FDragging then
with Sender as TControl do
begin
Left := X - FDownX + Left;
Top := Y - FDownY + Top;
end;
end;
procedure TForm1.ControlMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
if FDragging then
begin
FDragging := False;
TMoveCracker(Sender).MouseCapture := False;
end;
end;
Delphi - .....................................
neoturk: ...Remove items from the system menu ?...
private
procedure WMInitMenuPopup(var Msg: TWMInitMenuPopup); message WM_INITMENUPOPUP;
{...}
implementation
{...}
procedure TForm1.WMInitMenuPopup(var Msg: TWMInitMenuPopup);
begin
inherited;
if Msg.SystemMenu then
begin
DeleteMenu(Msg.MenuPopUp, SC_SIZE, MF_BYCOMMAND);
DeleteMenu(Msg.MenuPopUp, SC_MAXIMIZE, MF_BYCOMMAND);
DeleteMenu(Msg.MenuPopUp, SC_MINIMIZE, MF_BYCOMMAND);
DeleteMenu(Msg.MenuPopUp, SC_RESTORE, MF_BYCOMMAND);
// DeleteMenu(msg.MenuPopUp, SC_MOVE, MF_BYCOMMAND);
// DeleteMenu(msg.MenuPopUp, SC_CLOSE, MF_BYCOMMAND);
DeleteMenu(Msg.MenuPopup, 0, MF_BYCOMMAND);
end;
end;
Delphi - .....................................
neoturk: ...Remove items from the system menu ?...
private
procedure WMInitMenuPopup(var Msg: TWMInitMenuPopup); message WM_INITMENUPOPUP;
{...}
implementation
{...}
procedure TForm1.WMInitMenuPopup(var Msg: TWMInitMenuPopup);
begin
inherited;
if Msg.SystemMenu then
begin
DeleteMenu(Msg.MenuPopUp, SC_SIZE, MF_BYCOMMAND);
DeleteMenu(Msg.MenuPopUp, SC_MAXIMIZE, MF_BYCOMMAND);
DeleteMenu(Msg.MenuPopUp, SC_MINIMIZE, MF_BYCOMMAND);
DeleteMenu(Msg.MenuPopUp, SC_RESTORE, MF_BYCOMMAND);
// DeleteMenu(msg.MenuPopUp, SC_MOVE, MF_BYCOMMAND);
// DeleteMenu(msg.MenuPopUp, SC_CLOSE, MF_BYCOMMAND);
DeleteMenu(Msg.MenuPopup, 0, MF_BYCOMMAND);
end;
end;
Delphi - .....................................
neoturk: ...Add menu items to the system menu ?...
private
procedure WMSysCommand(var Msg: TMessage); message WM_SYSCOMMAND;
{...}
const
ID_ABOUT = WM_USER + 1;
ID_HELP = WM_USER + 2;
ID_NEWLINE = WM_USER + 4;
{...}
implementation
{...}
procedure TForm1.FormCreate(Sender: TObject);
var
SysMenu: THandle;
begin
SysMenu := GetSystemMenu(Handle, False);
InsertMenu(SysMenu, Word(-1), MF_SEPARATOR, ID_NEWLINE, '');
InsertMenu(SysMenu, Word(-1), MF_BYPOSITION, ID_HELP, 'Help');
InsertMenu(SysMenu, Word(-1), MF_BYPOSITION, ID_ABOUT, 'About');
end;
procedure TForm1.WMSysCommand;
begin
case Msg.wParam of
ID_ABOUT : ShowMessage('About-Menu Item Pressed!');
ID_HELP : ShowMessage('Help-Menu Item Pressed!');
end;
inherited;
end;
Delphi - .....................................
neoturk: ...Add menu items to the system menu ?...
private
procedure WMSysCommand(var Msg: TMessage); message WM_SYSCOMMAND;
{...}
const
ID_ABOUT = WM_USER + 1;
ID_HELP = WM_USER + 2;
ID_NEWLINE = WM_USER + 4;
{...}
implementation
{...}
procedure TForm1.FormCreate(Sender: TObject);
var
SysMenu: THandle;
begin
SysMenu := GetSystemMenu(Handle, False);
InsertMenu(SysMenu, Word(-1), MF_SEPARATOR, ID_NEWLINE, '');
InsertMenu(SysMenu, Word(-1), MF_BYPOSITION, ID_HELP, 'Help');
InsertMenu(SysMenu, Word(-1), MF_BYPOSITION, ID_ABOUT, 'About');
end;
procedure TForm1.WMSysCommand;
begin
case Msg.wParam of
ID_ABOUT : ShowMessage('About-Menu Item Pressed!');
ID_HELP : ShowMessage('Help-Menu Item Pressed!');
end;
inherited;
end;
Delphi - .....................................
neoturk: ...Draw a gradient fill on a form ?...
procedure FillGradientRect(Canvas: TCanvas; Recty: TRect; fbcolor, fecolor: TColor; fcolors: Integer);
var
i, j, h, w, fcolor: Integer;
R, G, B: Longword;
beginRGBvalue, RGBdifference: array[0..2] of Longword;
begin
beginRGBvalue[0] := GetRvalue(colortoRGB(FBcolor));
beginRGBvalue[1] := GetGvalue(colortoRGB(FBcolor));
beginRGBvalue[2] := GetBvalue(colortoRGB(FBcolor));
RGBdifference[0] := GetRvalue(colortoRGB(FEcolor)) - beginRGBvalue[0];
RGBdifference[1] := GetGvalue(colortoRGB(FEcolor)) - beginRGBvalue[1];
RGBdifference[2] := GetBvalue(colortoRGB(FEcolor)) - beginRGBvalue[2];
Canvas.pen.Style := pssolid;
Canvas.pen.mode := pmcopy;
j := 0;
h := recty.Bottom - recty.Top;
w := recty.Right - recty.Left;
for i := fcolors downto 0 do
begin
recty.Left := muldiv(i - 1, w, fcolors);
recty.Right := muldiv(i, w, fcolors);
if fcolors1 then
begin
R := beginRGBvalue[0] + muldiv(j, RGBDifference[0], fcolors);
G := beginRGBvalue[1] + muldiv(j, RGBDifference[1], fcolors);
B := beginRGBvalue[2] + muldiv(j, RGBDifference[2], fcolors);
end;
Canvas.Brush.Color := RGB(R, G, B);
patBlt(Canvas.Handle, recty.Left, recty.Top, Recty.Right - recty.Left, h, patcopy);
Inc(j);
end;
end;
// Case 1
procedure TForm1.FormPaint(Sender: TObject);
begin
FillGradientRect(Form1.Canvas, rect(0, 0, Width, Height), $FF0000, $00000, $00FF);
end;
Delphi - .....................................
neoturk: ...Draw a gradient fill on a form ?...
procedure FillGradientRect(Canvas: TCanvas; Recty: TRect; fbcolor, fecolor: TColor; fcolors: Integer);
var
i, j, h, w, fcolor: Integer;
R, G, B: Longword;
beginRGBvalue, RGBdifference: array[0..2] of Longword;
begin
beginRGBvalue[0] := GetRvalue(colortoRGB(FBcolor));
beginRGBvalue[1] := GetGvalue(colortoRGB(FBcolor));
beginRGBvalue[2] := GetBvalue(colortoRGB(FBcolor));
RGBdifference[0] := GetRvalue(colortoRGB(FEcolor)) - beginRGBvalue[0];
RGBdifference[1] := GetGvalue(colortoRGB(FEcolor)) - beginRGBvalue[1];
RGBdifference[2] := GetBvalue(colortoRGB(FEcolor)) - beginRGBvalue[2];
Canvas.pen.Style := pssolid;
Canvas.pen.mode := pmcopy;
j := 0;
h := recty.Bottom - recty.Top;
w := recty.Right - recty.Left;
for i := fcolors downto 0 do
begin
recty.Left := muldiv(i - 1, w, fcolors);
recty.Right := muldiv(i, w, fcolors);
if fcolors1 then
begin
R := beginRGBvalue[0] + muldiv(j, RGBDifference[0], fcolors);
G := beginRGBvalue[1] + muldiv(j, RGBDifference[1], fcolors);
B := beginRGBvalue[2] + muldiv(j, RGBDifference[2], fcolors);
end;
Canvas.Brush.Color := RGB(R, G, B);
patBlt(Canvas.Handle, recty.Left, recty.Top, Recty.Right - recty.Left, h, patcopy);
Inc(j);
end;
end;
// Case 1
procedure TForm1.FormPaint(Sender: TObject);
begin
FillGradientRect(Form1.Canvas, rect(0, 0, Width, Height), $FF0000, $00000, $00FF);
end;
Delphi - .....................................
neoturk: ...Show window contents while dragging ?...
procedure ShowContents(Value: Boolean);
begin
SystemParametersInfo(SPI_SETDRAGFULLWINDOWS, Ord(Value), nil, 0);
end;
// To Show window contents while dragging:
procedure TForm1.Button1Click(Sender: TObject);
begin
ShowContents(True);
end;
// To disable this option call the function:
procedure TForm1.Button1Click(Sender: TObject);
begin
ShowContents(False);
end;
Delphi - .....................................
neoturk: ...Show window contents while dragging ?...
procedure ShowContents(Value: Boolean);
begin
SystemParametersInfo(SPI_SETDRAGFULLWINDOWS, Ord(Value), nil, 0);
end;
// To Show window contents while dragging:
procedure TForm1.Button1Click(Sender: TObject);
begin
ShowContents(True);
end;
// To disable this option call the function:
procedure TForm1.Button1Click(Sender: TObject);
begin
ShowContents(False);
end;
Delphi - .....................................
neoturk: ...Move your form by clicking anywhere ?...
private
procedure WMNCHitTest(var msg: TWMNCHitTest); message WM_NCHITTEST;
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.WMNCHitTest(var msg: TWMNCHitTest);
begin
inherited;
if msg.Result = htClient then
msg.Result := htCaption;
end;
{...}
{ ************************* }
{ Or / Oder: }
procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
const
SC_DRAGMOVE = $F012;
begin
if Button = mbleft then
begin
ReleaseCapture;
Form1.Perform(WM_SYSCOMMAND, SC_DRAGMOVE, 0);
end;
end;
Delphi - .....................................
neoturk: ...Move your form by clicking anywhere ?...
private
procedure WMNCHitTest(var msg: TWMNCHitTest); message WM_NCHITTEST;
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.WMNCHitTest(var msg: TWMNCHitTest);
begin
inherited;
if msg.Result = htClient then
msg.Result := htCaption;
end;
{...}
{ ************************* }
{ Or / Oder: }
procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
const
SC_DRAGMOVE = $F012;
begin
if Button = mbleft then
begin
ReleaseCapture;
Form1.Perform(WM_SYSCOMMAND, SC_DRAGMOVE, 0);
end;
end;
Delphi - .....................................
neoturk: ...Create a splash screen ?...
{1) What is a Splash Screen ?
The ones you see when an application is loading.
(You could use splash screens for other purposes)
These usually display the application's name, author, version, copyright.
2) How do I create a Splash Screen ?
Add a new form to your project.
3) Change the Name Property of the Form to something like SplashScreen.
4) Change these Properties in the Object Inspector:}
BorderStyle := bsNone
Position := poScreenCenter
{5) Customize your Splash Screen by adding various components: images, labels...
6) Change your Project file (the .dpr file) to something like the code below:
}
{*************************************************************}
{1) Was ist ein Splash Screen ?
Es ist ein Fenster, das vor dem Starten eines Programms gezeigt wird. (Siehe z.B. Word)
Diese Fenster zeigen normalerweise den Applikationsnamen, Autor, Version, Copyright,
Bilder und ein Anwendungs-Icon
2) Wie macht man einen Splash-Screen ?
Füge eine neue Form dem Projekt hinzu.
(Datei, Neues Formular)
3) Ändere die "Name"-Eigenschaft der Form z.B. zu SplashScreen.
4) Ändere folgende Eigenschaften der Form im Objekt Inspektor:}
BorderStyle := bsNone
Position := poScreenCenter
{5) Füge dem Splash-Screen diverse Komponenten hinzu: Bilder, Labels...
6) Die Projekt Datei (die .dpr Datei) sieht schlussendlich etwa so aus:}
{*************************************************************}
program Project1;
uses
Forms,
Windows,
Unit1 in 'Unit1.pas' {Form1},
Unit2 in 'Unit2.pas' {SplashScreen};
{$R *.RES}
begin
SplashScreen := TSplashScreen.Create(Application);
try
SplashScreen.Show;
Application.Initialize;
SplashScreen.Update;
Sleep(1000); // Or a delay command.
Application.CreateForm(TForm1, Form1);
SplashScreen.Hide;
finally
SplashScreen.Free;
end;
Application.Run;
end.
Delphi - .....................................
neoturk: ...Create a splash screen ?...
{1) What is a Splash Screen ?
The ones you see when an application is loading.
(You could use splash screens for other purposes)
These usually display the application's name, author, version, copyright.
2) How do I create a Splash Screen ?
Add a new form to your project.
3) Change the Name Property of the Form to something like SplashScreen.
4) Change these Properties in the Object Inspector:}
BorderStyle := bsNone
Position := poScreenCenter
{5) Customize your Splash Screen by adding various components: images, labels...
6) Change your Project file (the .dpr file) to something like the code below:
}
{*************************************************************}
{1) Was ist ein Splash Screen ?
Es ist ein Fenster, das vor dem Starten eines Programms gezeigt wird. (Siehe z.B. Word)
Diese Fenster zeigen normalerweise den Applikationsnamen, Autor, Version, Copyright,
Bilder und ein Anwendungs-Icon
2) Wie macht man einen Splash-Screen ?
Füge eine neue Form dem Projekt hinzu.
(Datei, Neues Formular)
3) Ändere die "Name"-Eigenschaft der Form z.B. zu SplashScreen.
4) Ändere folgende Eigenschaften der Form im Objekt Inspektor:}
BorderStyle := bsNone
Position := poScreenCenter
{5) Füge dem Splash-Screen diverse Komponenten hinzu: Bilder, Labels...
6) Die Projekt Datei (die .dpr Datei) sieht schlussendlich etwa so aus:}
{*************************************************************}
program Project1;
uses
Forms,
Windows,
Unit1 in 'Unit1.pas' {Form1},
Unit2 in 'Unit2.pas' {SplashScreen};
{$R *.RES}
begin
SplashScreen := TSplashScreen.Create(Application);
try
SplashScreen.Show;
Application.Initialize;
SplashScreen.Update;
Sleep(1000); // Or a delay command.
Application.CreateForm(TForm1, Form1);
SplashScreen.Hide;
finally
SplashScreen.Free;
end;
Application.Run;
end.
Delphi - .....................................
neoturk: ...Get a popupmenuitems parent ?...
procedure TForm1.PopupMenu1Popup(Sender: TObject);
begin
Label1.Caption := PopupMenu1.PopupComponent.Name;
end;
Delphi - .....................................
neoturk: ...Get a popupmenuitems parent ?...
procedure TForm1.PopupMenu1Popup(Sender: TObject);
begin
Label1.Caption := PopupMenu1.PopupComponent.Name;
end;
Delphi - .....................................
neoturk: ...Show a tmenuitem right-aligned ?...
{
Shows all Menu items from the MenuIndex on right-aligned.
Alle MenuItem werden ab dem MenuIndex rechts angezeigt.
}
procedure TForm1.FormCreate(Sender: TObject);
const
MenuIndex = 3;
var
MII: TMenuItemInfo;
MainMenu: hMenu;
Buffer: array[0..50] of Char;
begin
MainMenu := GetMenu(Handle);
with MII do
begin
cbSize := SizeOf(MII);
fMask := MIIM_TYPE;
dwTypeData := Buffer;
cch := SizeOf(Buffer);
GetMenuItemInfo(MainMenu, MenuIndex, True, MII);
fType := fType or MFT_RIGHTJUSTIFY;
SetMenuItemInfo(MainMenu, MenuIndex, True, MII);
DrawMenuBar(Handle);
end;
end;
Delphi - .....................................
neoturk: ...Show a tmenuitem right-aligned ?...
{
Shows all Menu items from the MenuIndex on right-aligned.
Alle MenuItem werden ab dem MenuIndex rechts angezeigt.
}
procedure TForm1.FormCreate(Sender: TObject);
const
MenuIndex = 3;
var
MII: TMenuItemInfo;
MainMenu: hMenu;
Buffer: array[0..50] of Char;
begin
MainMenu := GetMenu(Handle);
with MII do
begin
cbSize := SizeOf(MII);
fMask := MIIM_TYPE;
dwTypeData := Buffer;
cch := SizeOf(Buffer);
GetMenuItemInfo(MainMenu, MenuIndex, True, MII);
fType := fType or MFT_RIGHTJUSTIFY;
SetMenuItemInfo(MainMenu, MenuIndex, True, MII);
DrawMenuBar(Handle);
end;
end;
Delphi - .....................................
neoturk: ...Position a messagebox over a form ?...
const
mbMessage = WM_USER + 1024;
type
private
procedure ChangeMessageBoxPosition(var Msg: TMessage); message mbMessage;
end;
var
Form1: TForm1;
msgCaption: PChar; // variable to hold the caption
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;
// center horzontal
x := Form1.Left + ((Form1.Width - w) div 2);
// keep on screen
if x < 0 then
x := 0
else if x + w > Screen.Width then x := Screen.Width - w;
//center vertical
y := Form1.Top + ((Form1.Height - h) div 2);
// keep on screen
if y < 0 then y := 0
else if y + h > Screen.Height then y := Screen.Height - h;
// set new windows position
SetWindowPos(MBHWnd, 0, x, y, 0, 0, SWP_NOACTIVATE or SWP_NOSIZE or SWP_NOZORDER);
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
PostMessage(Handle, WM_USER + 1024, 0, 0);
msgCaption := 'Confirm';
MessageBox(Handle, 'Has our MessageBox moved ?', msgCaption,
MB_ICONQUESTION or MB_YESNO);
end;
Delphi - .....................................
neoturk: ...Position a messagebox over a form ?...
const
mbMessage = WM_USER + 1024;
type
private
procedure ChangeMessageBoxPosition(var Msg: TMessage); message mbMessage;
end;
var
Form1: TForm1;
msgCaption: PChar; // variable to hold the caption
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;
// center horzontal
x := Form1.Left + ((Form1.Width - w) div 2);
// keep on screen
if x < 0 then
x := 0
else if x + w > Screen.Width then x := Screen.Width - w;
//center vertical
y := Form1.Top + ((Form1.Height - h) div 2);
// keep on screen
if y < 0 then y := 0
else if y + h > Screen.Height then y := Screen.Height - h;
// set new windows position
SetWindowPos(MBHWnd, 0, x, y, 0, 0, SWP_NOACTIVATE or SWP_NOSIZE or SWP_NOZORDER);
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
PostMessage(Handle, WM_USER + 1024, 0, 0);
msgCaption := 'Confirm';
MessageBox(Handle, 'Has our MessageBox moved ?', msgCaption,
MB_ICONQUESTION or MB_YESNO);
end;
Delphi - .....................................
neoturk: ...Show forms on a tscrollbox ?...
{
Vor dem anzeigen der Form muss einfach die Parent Eigenschaft gesetzt
werden:
Before you show the Form you must simply set the parent property of
the form:
}
procedure TForm1.Button1Click(Sender: TObject);
begin
Form2.Parent := ScrollBox1;
Form2.Show;
end;
Delphi - .....................................
neoturk: ...Show forms on a tscrollbox ?...
{
Vor dem anzeigen der Form muss einfach die Parent Eigenschaft gesetzt
werden:
Before you show the Form you must simply set the parent property of
the form:
}
procedure TForm1.Button1Click(Sender: TObject);
begin
Form2.Parent := ScrollBox1;
Form2.Show;
end;
Delphi - .....................................
neoturk: ...Close a tcommondialog automatically ?...
{
It is possible to close a common dialog shown by TCommonDialog.Execute
(or its overriddens) method while it is visible and application handles messages.
The solution is:
Es ist möglich einen TCommonDialog der mit TCommonDialog.Execute geöffnet wurde,
automatisch zu schliessen während er sichtbar ist. Die Lösung ist:
}
SendMessage(GetParent(OpenDialog1.Handle), WM_SYSCOMMAND, SC_CLOSE, 0);
Delphi - .....................................
neoturk: ...Close a tcommondialog automatically ?...
{
It is possible to close a common dialog shown by TCommonDialog.Execute
(or its overriddens) method while it is visible and application handles messages.
The solution is:
Es ist möglich einen TCommonDialog der mit TCommonDialog.Execute geöffnet wurde,
automatisch zu schliessen während er sichtbar ist. Die Lösung ist:
}
SendMessage(GetParent(OpenDialog1.Handle), WM_SYSCOMMAND, SC_CLOSE, 0);
Delphi - .....................................
neoturk: ...Create a form with rounded corners ?...
{
Die CreateRoundRectRgn lässt eine Form mit abgerundeten Ecken erscheinen.
The CreateRoundRectRgn function creates a rectangular
region with rounded corners
}
procedure TForm1.FormCreate(Sender: TObject);
var
rgn: HRGN;
begin
Form1.Borderstyle := bsNone;
rgn := CreateRoundRectRgn(0,// x-coordinate of the region's upper-left corner
0, // y-coordinate of the region's upper-left corner
ClientWidth, // x-coordinate of the region's lower-right corner
ClientHeight, // y-coordinate of the region's lower-right corner
40, // height of ellipse for rounded corners
40); // width of ellipse for rounded corners
SetWindowRgn(Handle, rgn, True);
end
{ The CreatePolygonRgn function creates a polygonal region. }
procedure TForm1.FormCreate(Sender: TObject);
const
C = 20;
var
Points: array [0..7] of TPoint;
h, w: Integer;
begin
h := Form1.Height;
w := Form1.Width;
Points[0].X := C; Points[0].Y := 0;
Points[1].X := 0; Points[1].Y := C;
Points[2].X := 0; Points[2].Y := h - c;
Points[3].X := C; Points[3].Y := h;
Points[4].X := w - c; Points[4].Y := h;
Points[5].X := w; Points[5].Y := h - c;
Points[6].X := w; Points[6].Y := C;
Points[7].X := w - C; Points[7].Y := 0;
SetWindowRgn(Form1.Handle, CreatePolygonRgn(Points, 8, WINDING), True);
end;
Delphi - .....................................
neoturk: ...Create a form with rounded corners ?...
{
Die CreateRoundRectRgn lässt eine Form mit abgerundeten Ecken erscheinen.
The CreateRoundRectRgn function creates a rectangular
region with rounded corners
}
procedure TForm1.FormCreate(Sender: TObject);
var
rgn: HRGN;
begin
Form1.Borderstyle := bsNone;
rgn := CreateRoundRectRgn(0,// x-coordinate of the region's upper-left corner
0, // y-coordinate of the region's upper-left corner
ClientWidth, // x-coordinate of the region's lower-right corner
ClientHeight, // y-coordinate of the region's lower-right corner
40, // height of ellipse for rounded corners
40); // width of ellipse for rounded corners
SetWindowRgn(Handle, rgn, True);
end
{ The CreatePolygonRgn function creates a polygonal region. }
procedure TForm1.FormCreate(Sender: TObject);
const
C = 20;
var
Points: array [0..7] of TPoint;
h, w: Integer;
begin
h := Form1.Height;
w := Form1.Width;
Points[0].X := C; Points[0].Y := 0;
Points[1].X := 0; Points[1].Y := C;
Points[2].X := 0; Points[2].Y := h - c;
Points[3].X := C; Points[3].Y := h;
Points[4].X := w - c; Points[4].Y := h;
Points[5].X := w; Points[5].Y := h - c;
Points[6].X := w; Points[6].Y := C;
Points[7].X := w - C; Points[7].Y := 0;
SetWindowRgn(Form1.Handle, CreatePolygonRgn(Points, 8, WINDING), True);
end;
Delphi - .....................................
neoturk: ...Show multiline text in a tcombobox ?...
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;
type
TForm1 = class(TForm)
ComboBox1: TComboBox;
procedure FormCreate(Sender: TObject);
procedure ComboBox1MeasureItem(Control: TWinControl; Index: Integer;
var Height: Integer);
procedure ComboBox1DrawItem(Control: TWinControl; Index: Integer;
Rect: TRect; State: TOwnerDrawState);
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.FormCreate(Sender: TObject);
begin
Combobox1.Style := csOwnerDrawVariable;
// die Combobox mit einigen Beispielen füllen
// fill the combobox with some examples
with Combobox1.Items do
begin
Add('Short, kurzer String');
Add('A long String. / Ein langer String.....');
Add('Another String');
Add('abcd defg hijk lmno');
Add('..-.-.-.-.-.-.-.-.-');
end;
end;
procedure TForm1.ComboBox1MeasureItem(Control: TWinControl; Index: Integer;
var Height: Integer);
// Berechnet die notwendige Höhe für einen mehrzeiligen Text
// Calculates the required height for a multiline text
var
i, PosSp: Integer;
strVal: string;
strTmp: string;
begin
if Index >= 0 then
begin
strVal := Combobox1.Items[Index];
// String auf mehrere Zeilen aufteilen, Zeilen sind mit #$D#$A getrennt
// wrap string to multiple lines, each line separated by #$D#$A
strTmp := WrapText(strVal, 20);
// Anzahl der Zeilentrennungen plus eins = Anzahl Zeilen
// Number of line separators + 1 = number of lines
i := 1;
while Pos(#$D#$A, strTmp) > 0 do
begin
i := i + 1;
strTmp := Copy(strTmp, Pos(#13#10, strTmp) + 2, Length(strTmp));
end;
// Höhe für den Text berechnen
// calcualte the height for the text
Height := i * Combobox1.ItemHeight;
end;
end;
procedure TForm1.ComboBox1DrawItem(Control: TWinControl; Index: Integer;
Rect: TRect; State: TOwnerDrawState);
// Schreibt einen Text auf die Combobox. Wenn der Text zu lange ist, wird er
// auf mehrere Zeilen aufgeteilt
// Writes a text to the combobox. If the text is too long, then it will be
// wrapped
var
strVal: string;
strTmp: string;
intPos: Integer;
i: Integer;
rc: TRect;
begin
// Text auf mehrere Zeilen aufteilen
// wrap the text
strVal := WrapText(Combobox1.Items[Index], 20);
i := 0;
Combobox1.Canvas.FillRect(Rect);
// jede Textzeile einzeln ausgeben
// output each single line
while Pos(#$D#$A, strVal) > 0 do
begin
intPos := Pos(#$D#$A, strVal);
// Aktuelle Zeile aus dem String kopieren
// copy current line from string
if intPos > 0 then
strTmp := Copy(strVal, 1, intPos - 1)
else
strTmp := strVal;
rc := Rect;
rc.Top := Rect.Top + i * Combobox1.ItemHeight;
ComboBox1.Canvas.TextRect(rc, Rect.Left, Rect.Top + i * Combobox1.ItemHeight,
strTmp);
// die ausgegebene Zeile aus dem String löschen
// delete the written line from the string
strVal := Copy(strVal, intPos + 2, Length(strVal));
Inc(i);
end;
rc := Rect;
rc.Top := Rect.Top + i * Combobox1.ItemHeight;
// Letzte Zeile schreiben
// write the last line
ComboBox1.Canvas.TextRect(rc, Rect.Left, Rect.Top + i * Combobox1.ItemHeight, strVal);
Combobox1.Canvas.Brush.Style := bsClear;
// den Text mit einem Rechteck umrunden
// surround the text with a rectangle
Combobox1.Canvas.Rectangle(Rect);
end;
end.
Delphi - .....................................
neoturk: ...Show multiline text in a tcombobox ?...
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;
type
TForm1 = class(TForm)
ComboBox1: TComboBox;
procedure FormCreate(Sender: TObject);
procedure ComboBox1MeasureItem(Control: TWinControl; Index: Integer;
var Height: Integer);
procedure ComboBox1DrawItem(Control: TWinControl; Index: Integer;
Rect: TRect; State: TOwnerDrawState);
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.FormCreate(Sender: TObject);
begin
Combobox1.Style := csOwnerDrawVariable;
// die Combobox mit einigen Beispielen füllen
// fill the combobox with some examples
with Combobox1.Items do
begin
Add('Short, kurzer String');
Add('A long String. / Ein langer String.....');
Add('Another String');
Add('abcd defg hijk lmno');
Add('..-.-.-.-.-.-.-.-.-');
end;
end;
procedure TForm1.ComboBox1MeasureItem(Control: TWinControl; Index: Integer;
var Height: Integer);
// Berechnet die notwendige Höhe für einen mehrzeiligen Text
// Calculates the required height for a multiline text
var
i, PosSp: Integer;
strVal: string;
strTmp: string;
begin
if Index >= 0 then
begin
strVal := Combobox1.Items[Index];
// String auf mehrere Zeilen aufteilen, Zeilen sind mit #$D#$A getrennt
// wrap string to multiple lines, each line separated by #$D#$A
strTmp := WrapText(strVal, 20);
// Anzahl der Zeilentrennungen plus eins = Anzahl Zeilen
// Number of line separators + 1 = number of lines
i := 1;
while Pos(#$D#$A, strTmp) > 0 do
begin
i := i + 1;
strTmp := Copy(strTmp, Pos(#13#10, strTmp) + 2, Length(strTmp));
end;
// Höhe für den Text berechnen
// calcualte the height for the text
Height := i * Combobox1.ItemHeight;
end;
end;
procedure TForm1.ComboBox1DrawItem(Control: TWinControl; Index: Integer;
Rect: TRect; State: TOwnerDrawState);
// Schreibt einen Text auf die Combobox. Wenn der Text zu lange ist, wird er
// auf mehrere Zeilen aufgeteilt
// Writes a text to the combobox. If the text is too long, then it will be
// wrapped
var
strVal: string;
strTmp: string;
intPos: Integer;
i: Integer;
rc: TRect;
begin
// Text auf mehrere Zeilen aufteilen
// wrap the text
strVal := WrapText(Combobox1.Items[Index], 20);
i := 0;
Combobox1.Canvas.FillRect(Rect);
// jede Textzeile einzeln ausgeben
// output each single line
while Pos(#$D#$A, strVal) > 0 do
begin
intPos := Pos(#$D#$A, strVal);
// Aktuelle Zeile aus dem String kopieren
// copy current line from string
if intPos > 0 then
strTmp := Copy(strVal, 1, intPos - 1)
else
strTmp := strVal;
rc := Rect;
rc.Top := Rect.Top + i * Combobox1.ItemHeight;
ComboBox1.Canvas.TextRect(rc, Rect.Left, Rect.Top + i * Combobox1.ItemHeight,
strTmp);
// die ausgegebene Zeile aus dem String löschen
// delete the written line from the string
strVal := Copy(strVal, intPos + 2, Length(strVal));
Inc(i);
end;
rc := Rect;
rc.Top := Rect.Top + i * Combobox1.ItemHeight;
// Letzte Zeile schreiben
// write the last line
ComboBox1.Canvas.TextRect(rc, Rect.Left, Rect.Top + i * Combobox1.ItemHeight, strVal);
Combobox1.Canvas.Brush.Style := bsClear;
// den Text mit einem Rechteck umrunden
// surround the text with a rectangle
Combobox1.Canvas.Rectangle(Rect);
end;
end.
Delphi - .....................................
neoturk: ...Make an animated application icon ?...
var
icon1: Boolean;
{....}
procedure TForm1.Timer1Timer(Sender: TObject);
begin
icon1 := not Icon1;
case Icon1 of
True: Application.icon := Image1.Picture.Icon;
False: Application.icon := Image2.Picture.Icon;
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
icon1 := True;
end;
Delphi - .....................................
neoturk: ...Make an animated application icon ?...
var
icon1: Boolean;
{....}
procedure TForm1.Timer1Timer(Sender: TObject);
begin
icon1 := not Icon1;
case Icon1 of
True: Application.icon := Image1.Picture.Icon;
False: Application.icon := Image2.Picture.Icon;
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
icon1 := True;
end;
