neoturk: ...Format a messagedlg ?...
procedure TForm1.Button1Click(Sender: TObject);
var
f: TForm;
begin
// Create the MessageDialog
// Den MessageDialog erstellen
f := Dialogs.CreateMessageDialog('HELLOWORLD', dialogs.mtInformation, dialogs.mbOKCancel);
// Set the backcolor to blue.
// färbt die Form blau.
f.Color := clBlue;
// Set textcolor to lime
// Färbt die Schrift lime
f.Font.Color := clLime;
// Zeigt die Form an und wartet auf den ModalResult.
// Shows the dialog and wait for the modalresult
if f.ShowModal = mrOk then
ShowMessage('OK Pressed, OK wurde gedrückt')
else
ShowMessage('Cancel pressed. Abbrechen wurde gedrückt');
end;
Delphi - .....................................
neoturk: ...Make a polygon hole on a form ?...
type
PtsType = array [0..15, 0..1] of Integer;
const
Pts: PtsType = ((0, 0), (800, 0), (800, 600),
(200, 600), (200, 220), (300, 280),
(265, 205), (350, 117), (205, 170),
(120, 90), (130, 200), (60, 350), (200, 220),
(200, 600), (0, 600), (0, 0));
procedure TForm1.Button1Click(Sender: TObject);
var
HRegion1: THandle;
begin
HRegion1 := CreatePolygonRgn(Pts, SizeOf(Pts) div 8, alternate);
SetWindowRgn(Handle, HRegion1, True);
end;
Delphi - .....................................
neoturk: ...Make a polygon hole on a form ?...
type
PtsType = array [0..15, 0..1] of Integer;
const
Pts: PtsType = ((0, 0), (800, 0), (800, 600),
(200, 600), (200, 220), (300, 280),
(265, 205), (350, 117), (205, 170),
(120, 90), (130, 200), (60, 350), (200, 220),
(200, 600), (0, 600), (0, 0));
procedure TForm1.Button1Click(Sender: TObject);
var
HRegion1: THandle;
begin
HRegion1 := CreatePolygonRgn(Pts, SizeOf(Pts) div 8, alternate);
SetWindowRgn(Handle, HRegion1, True);
end;
Delphi - .....................................
neoturk: ...Implement an animated gradient ?...
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
I have taken two tipps from this site to work together:
1. to draw a gradient from David Johannes Rieger
2. the unit anithread form P. Below
what's coming out is a animated gradient. You know it maybe from
programms like VCDEasy.
There is nothing from me - all from this site!
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Ich habe zwei Tipps von dieser Seite zusammengefügt:
1. to draw a gradient from David Johannes Rieger
2. the unit anithread form P. Below
Dadurch erhält man einen animierten Gradienten wie Bsp. in VCDEasy zu sehen.
Der Quelltext ist nicht von mir, alles ist von dieser Seite!
+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
unit anithread;
interface
uses
Classes, Windows, Controls, Graphics;
type
TAnimationThread = class(TThread)
private
{ Private declarations }
FWnd: HWND;
FPaintRect: TRect;
FbkColor, FfgColor: TColor;
FInterval: Integer;
procedure DrawGradient(ACanvas: TCanvas; Rect: TRect; Horicontal: Boolean;
Colors: array of TColor);
protected
procedure Execute; override;
public
constructor Create(paintsurface: TWinControl; {Control to paint on }
paintrect: TRect; {area for animation bar }
bkColor, barcolor: TColor; {colors to use }
interval: Integer); {wait in msecs between
paints}
end;
implementation
constructor TAnimationThread.Create(paintsurface: TWinControl;
paintrect: TRect; bkColor, barcolor: TColor; interval: Integer);
begin
inherited Create(True);
FWnd := paintsurface.Handle;
FPaintRect := paintrect;
FbkColor := bkColor;
FfgColor := barColor;
FInterval := interval;
FreeOnterminate := True;
Resume;
end; { TAnimationThread.Create }
procedure TAnimationThread.Execute;
var
image: TBitmap;
DC: HDC;
Left, Right: Integer;
increment: Integer;
imagerect: TRect;
state: (incRight, decRight);
begin
Image := TBitmap.Create;
try
with Image do
begin
Width := FPaintRect.Right - FPaintRect.Left;
Height := FPaintRect.Bottom - FPaintRect.Top;
imagerect := Rect(0, 0, Width, Height);
end; { with }
Left := 0;
Right := 0;
increment := imagerect.Right div 50;
state := Low(State);
while not Terminated do
begin
with Image.Canvas do
begin
Brush.Color := FbkColor;
//FillRect(imagerect); original!
DrawGradient(Image.Canvas, imagerect, True, [clBtnShadow, clBtnFace]);
case state of
incRight:
begin
Inc(Right, increment);
if Right > imagerect.Right then
begin
Right := imagerect.Right;
Inc(state);
end; // if
end; // Case incRight }
decRight:
begin
Dec(Right, increment);
if Right <= 0 then
begin
Right := 0;
state := incRight;
end; // if
end; // Case decLeft
end; { Case }
Brush.Color := FfgColor;
//FillRect(Rect(left, imagerect.top, right, imagerect.bottom)); original!
DrawGradient(Image.Canvas, Rect(Left, imagerect.Top, Right, imagerect.Bottom),
True, [clBtnFace, clBtnShadow]);
end; { with }
DC := GetDC(FWnd);
if DC <> 0 then
try
BitBlt(DC,
FPaintRect.Left,
FPaintRect.Top,
imagerect.Right,
imagerect.Bottom,
Image.Canvas.Handle,
0, 0,
SRCCOPY);
finally
ReleaseDC(FWnd, DC);
end;
Sleep(FInterval);
end; { While }
finally
Image.Free;
end;
InvalidateRect(FWnd, nil, True);
end; { TAnimationThread.Execute }
procedure TAnimationThread.DrawGradient(ACanvas: TCanvas; Rect: TRect;
Horicontal: Boolean; Colors: array of TColor);
type
RGBArray = array[0..2] of Byte;
var
x, y, z, stelle, mx, bis, faColorsh, mass: Integer;
Faktor: Double;
A: RGBArray;
B: array of RGBArray;
merkw: Integer;
merks: TPenStyle;
merkp: TColor;
begin
mx := High(Colors);
if mx > 0 then
begin
if Horicontal then
mass := Rect.Right - Rect.Left
else
mass := Rect.Bottom - Rect.Top;
SetLength(b, mx + 1);
for x := 0 to mx do
begin
Colors[x] := ColorToRGB(Colors[x]);
b[x][0] := GetRValue(Colors[x]);
b[x][1] := GetGValue(Colors[x]);
b[x][2] := GetBValue(Colors[x]);
end;
merkw := ACanvas.Pen.Width;
merks := ACanvas.Pen.Style;
merkp := ACanvas.Pen.Color;
ACanvas.Pen.Width := 1;
ACanvas.Pen.Style := psSolid;
faColorsh := Round(mass / mx);
for y := 0 to mx - 1 do
begin
if y = mx - 1 then
bis := mass - y * faColorsh - 1
else
bis := faColorsh;
for x := 0 to bis do
begin
Stelle := x + y * faColorsh;
faktor := x / bis;
for z := 0 to 2 do
a[z] := Trunc(b[y][z] + ((b[y + 1][z] - b[y][z]) * Faktor));
ACanvas.Pen.Color := RGB(a[0], a[1], a[2]);
if Horicontal then
begin
ACanvas.MoveTo(Rect.Left + Stelle, Rect.Top);
ACanvas.LineTo(Rect.Left + Stelle, Rect.Bottom);
end
else
begin
ACanvas.MoveTo(Rect.Left, Rect.Top + Stelle);
ACanvas.LineTo(Rect.Right, Rect.Top + Stelle);
end;
end;
end;
b := nil;
ACanvas.Pen.Width := merkw;
ACanvas.Pen.Style := merks;
ACanvas.Pen.Color := merkp;
end;
{else
// Please specify at least two colors
raise EMathError.Create('Es müssen mindestens zwei Farben angegeben werden.');
In diesem Fallnicht mehr als zwei Farben!
Here not more than two colors!
}
end;
end.
{Usage:
Place a TPanel on a form, size it as appropriate.Create an instance of the
TanimationThread call like this: procedure TForm1.Button1Click(Sender : TObject);
}
procedure TForm1.Button1Click(Sender: TObject);
var
ani: TAnimationThread;
r: TRect;
begin r := panel1.ClientRect;
InflateRect(r, - panel1.bevelwidth, - panel1.bevelwidth);
ani := TanimationThread.Create(panel1, r, panel1.Color, clBlue, 25);
Button1.Enabled := False;
Application.ProcessMessages;
Sleep(30000); // replace with query.Open or such
Button1.Enabled := True;
ani.Terminate;
ShowMessage('Done');
end;
Delphi - .....................................
neoturk: ...Implement an animated gradient ?...
{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
I have taken two tipps from this site to work together:
1. to draw a gradient from David Johannes Rieger
2. the unit anithread form P. Below
what's coming out is a animated gradient. You know it maybe from
programms like VCDEasy.
There is nothing from me - all from this site!
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Ich habe zwei Tipps von dieser Seite zusammengefügt:
1. to draw a gradient from David Johannes Rieger
2. the unit anithread form P. Below
Dadurch erhält man einen animierten Gradienten wie Bsp. in VCDEasy zu sehen.
Der Quelltext ist nicht von mir, alles ist von dieser Seite!
+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
unit anithread;
interface
uses
Classes, Windows, Controls, Graphics;
type
TAnimationThread = class(TThread)
private
{ Private declarations }
FWnd: HWND;
FPaintRect: TRect;
FbkColor, FfgColor: TColor;
FInterval: Integer;
procedure DrawGradient(ACanvas: TCanvas; Rect: TRect; Horicontal: Boolean;
Colors: array of TColor);
protected
procedure Execute; override;
public
constructor Create(paintsurface: TWinControl; {Control to paint on }
paintrect: TRect; {area for animation bar }
bkColor, barcolor: TColor; {colors to use }
interval: Integer); {wait in msecs between
paints}
end;
implementation
constructor TAnimationThread.Create(paintsurface: TWinControl;
paintrect: TRect; bkColor, barcolor: TColor; interval: Integer);
begin
inherited Create(True);
FWnd := paintsurface.Handle;
FPaintRect := paintrect;
FbkColor := bkColor;
FfgColor := barColor;
FInterval := interval;
FreeOnterminate := True;
Resume;
end; { TAnimationThread.Create }
procedure TAnimationThread.Execute;
var
image: TBitmap;
DC: HDC;
Left, Right: Integer;
increment: Integer;
imagerect: TRect;
state: (incRight, decRight);
begin
Image := TBitmap.Create;
try
with Image do
begin
Width := FPaintRect.Right - FPaintRect.Left;
Height := FPaintRect.Bottom - FPaintRect.Top;
imagerect := Rect(0, 0, Width, Height);
end; { with }
Left := 0;
Right := 0;
increment := imagerect.Right div 50;
state := Low(State);
while not Terminated do
begin
with Image.Canvas do
begin
Brush.Color := FbkColor;
//FillRect(imagerect); original!
DrawGradient(Image.Canvas, imagerect, True, [clBtnShadow, clBtnFace]);
case state of
incRight:
begin
Inc(Right, increment);
if Right > imagerect.Right then
begin
Right := imagerect.Right;
Inc(state);
end; // if
end; // Case incRight }
decRight:
begin
Dec(Right, increment);
if Right <= 0 then
begin
Right := 0;
state := incRight;
end; // if
end; // Case decLeft
end; { Case }
Brush.Color := FfgColor;
//FillRect(Rect(left, imagerect.top, right, imagerect.bottom)); original!
DrawGradient(Image.Canvas, Rect(Left, imagerect.Top, Right, imagerect.Bottom),
True, [clBtnFace, clBtnShadow]);
end; { with }
DC := GetDC(FWnd);
if DC <> 0 then
try
BitBlt(DC,
FPaintRect.Left,
FPaintRect.Top,
imagerect.Right,
imagerect.Bottom,
Image.Canvas.Handle,
0, 0,
SRCCOPY);
finally
ReleaseDC(FWnd, DC);
end;
Sleep(FInterval);
end; { While }
finally
Image.Free;
end;
InvalidateRect(FWnd, nil, True);
end; { TAnimationThread.Execute }
procedure TAnimationThread.DrawGradient(ACanvas: TCanvas; Rect: TRect;
Horicontal: Boolean; Colors: array of TColor);
type
RGBArray = array[0..2] of Byte;
var
x, y, z, stelle, mx, bis, faColorsh, mass: Integer;
Faktor: Double;
A: RGBArray;
B: array of RGBArray;
merkw: Integer;
merks: TPenStyle;
merkp: TColor;
begin
mx := High(Colors);
if mx > 0 then
begin
if Horicontal then
mass := Rect.Right - Rect.Left
else
mass := Rect.Bottom - Rect.Top;
SetLength(b, mx + 1);
for x := 0 to mx do
begin
Colors[x] := ColorToRGB(Colors[x]);
b[x][0] := GetRValue(Colors[x]);
b[x][1] := GetGValue(Colors[x]);
b[x][2] := GetBValue(Colors[x]);
end;
merkw := ACanvas.Pen.Width;
merks := ACanvas.Pen.Style;
merkp := ACanvas.Pen.Color;
ACanvas.Pen.Width := 1;
ACanvas.Pen.Style := psSolid;
faColorsh := Round(mass / mx);
for y := 0 to mx - 1 do
begin
if y = mx - 1 then
bis := mass - y * faColorsh - 1
else
bis := faColorsh;
for x := 0 to bis do
begin
Stelle := x + y * faColorsh;
faktor := x / bis;
for z := 0 to 2 do
a[z] := Trunc(b[y][z] + ((b[y + 1][z] - b[y][z]) * Faktor));
ACanvas.Pen.Color := RGB(a[0], a[1], a[2]);
if Horicontal then
begin
ACanvas.MoveTo(Rect.Left + Stelle, Rect.Top);
ACanvas.LineTo(Rect.Left + Stelle, Rect.Bottom);
end
else
begin
ACanvas.MoveTo(Rect.Left, Rect.Top + Stelle);
ACanvas.LineTo(Rect.Right, Rect.Top + Stelle);
end;
end;
end;
b := nil;
ACanvas.Pen.Width := merkw;
ACanvas.Pen.Style := merks;
ACanvas.Pen.Color := merkp;
end;
{else
// Please specify at least two colors
raise EMathError.Create('Es müssen mindestens zwei Farben angegeben werden.');
In diesem Fallnicht mehr als zwei Farben!
Here not more than two colors!
}
end;
end.
{Usage:
Place a TPanel on a form, size it as appropriate.Create an instance of the
TanimationThread call like this: procedure TForm1.Button1Click(Sender : TObject);
}
procedure TForm1.Button1Click(Sender: TObject);
var
ani: TAnimationThread;
r: TRect;
begin r := panel1.ClientRect;
InflateRect(r, - panel1.bevelwidth, - panel1.bevelwidth);
ani := TanimationThread.Create(panel1, r, panel1.Color, clBlue, 25);
Button1.Enabled := False;
Application.ProcessMessages;
Sleep(30000); // replace with query.Open or such
Button1.Enabled := True;
ani.Terminate;
ShowMessage('Done');
end;
Delphi - .....................................
neoturk: ...Zoom the content of a stringgrid ?...
{
Stringgrid zoomen:
benötigt wird ein Formular mit einem Stringgrid namens grid und zwei TBitBtn.
der Funktion gridZoom(Fact) wird ein Realzahlenfaktor übergeben, der den Zoomgrad angibt:
1.0 - keine Veränderung
0.9 - Kleiner
1.1 - Größer
Diese Funktion multipliziert nun zu Breite und Höhe der jeweiligen Spalten / Zeilen
den angegebenen Faktor.
Die Schriftgröße wird anhand der Zeilenhöhe der Zeile 0 bestimmt (*0.8).
Zu empfehlen ist hier eine TrueType-Schriftart (z.Bsp. Arial), da sonnst die Schrift
sehr eckig wirkt.
}
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
Grids, StdCtrls, Buttons;
type
TForm1 = class(TForm)
grid: TStringGrid;
BitBtn1: TBitBtn;
BitBtn2: TBitBtn;
procedure BitBtn1Click(Sender: TObject);
procedure BitBtn2Click(Sender: TObject);
private
{ Private-Deklarationen }
procedure gridZoom(FFact: Real);
public
{ Public-Deklarationen }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.gridZoom(FFact: Real);
var
x: Integer;
begin
for x := 0 to grid.colcount - 1 do
grid.colwidths[x] := round(grid.colwidths[x] * FFact);
for x := 0 to grid.RowCount - 1 do
grid.rowheights[x] := round(grid.rowheights[x] * FFact);
grid.Font.Size := round(grid.rowheights[0] * 0.65);
end;
//Grösser:
procedure TForm1.BitBtn1Click(Sender: TObject);
begin
gridZoom(1.1);
end;
//Kleiner:
procedure TForm1.BitBtn2Click(Sender: TObject);
begin
gridZoom(0.9);
end;
end.
Delphi - .....................................
neoturk: ...Zoom the content of a stringgrid ?...
{
Stringgrid zoomen:
benötigt wird ein Formular mit einem Stringgrid namens grid und zwei TBitBtn.
der Funktion gridZoom(Fact) wird ein Realzahlenfaktor übergeben, der den Zoomgrad angibt:
1.0 - keine Veränderung
0.9 - Kleiner
1.1 - Größer
Diese Funktion multipliziert nun zu Breite und Höhe der jeweiligen Spalten / Zeilen
den angegebenen Faktor.
Die Schriftgröße wird anhand der Zeilenhöhe der Zeile 0 bestimmt (*0.8).
Zu empfehlen ist hier eine TrueType-Schriftart (z.Bsp. Arial), da sonnst die Schrift
sehr eckig wirkt.
}
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
Grids, StdCtrls, Buttons;
type
TForm1 = class(TForm)
grid: TStringGrid;
BitBtn1: TBitBtn;
BitBtn2: TBitBtn;
procedure BitBtn1Click(Sender: TObject);
procedure BitBtn2Click(Sender: TObject);
private
{ Private-Deklarationen }
procedure gridZoom(FFact: Real);
public
{ Public-Deklarationen }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.gridZoom(FFact: Real);
var
x: Integer;
begin
for x := 0 to grid.colcount - 1 do
grid.colwidths[x] := round(grid.colwidths[x] * FFact);
for x := 0 to grid.RowCount - 1 do
grid.rowheights[x] := round(grid.rowheights[x] * FFact);
grid.Font.Size := round(grid.rowheights[0] * 0.65);
end;
//Grösser:
procedure TForm1.BitBtn1Click(Sender: TObject);
begin
gridZoom(1.1);
end;
//Kleiner:
procedure TForm1.BitBtn2Click(Sender: TObject);
begin
gridZoom(0.9);
end;
end.
Delphi - .....................................
neoturk: ...Early trap then close window procedure ?...
Procedure TForm1.HandleMessage(var Msg:TMessage);
begin
if msg.msg = WM_CLOSE //You can insert there other message constans from windows unit.
then
begin
{Your code when user clicked close button}
showmessage('You can not close this window!');
end
else form1.wndproc(msg); //if not closed system handle the message default
end;
procedure TForm1.Create(Sender:Tobject);
begin
form1.Windowproc:=form1.handlemessage; //run handling
end;
