neoturk: ...Shape a form to a bitmap ?...
unit Unit1;
interface
uses
Windows, Classes, SysUtils, Graphics, Forms;
type
TRGBArray = array[0..32767] of TRGBTriple;
PRGBArray = ^TRGBArray;
type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
{ Private declarations }
FRegion: THandle;
function CreateRegion(Bmp: TBitmap): THandle;
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
function TForm1.CreateRegion(Bmp: TBitmap): THandle;
var
X, Y, StartX: Integer;
Excl: THandle;
Row: PRGBArray;
TransparentColor: TRGBTriple;
begin
Bmp.PixelFormat := pf24Bit;
Result := CreateRectRGN(0, 0, Bmp.Width, Bmp.Height);
for Y := 0 to Bmp.Height - 1 do
begin
Row := Bmp.Scanline[Y];
StartX := -1;
if Y = 0 then
TransparentColor := Row[0];
for X := 0 to Bmp.Width - 1 do
begin
if (Row[X].rgbtRed = TransparentColor.rgbtRed) and
(Row[X].rgbtGreen = TransparentColor.rgbtGreen) and
(Row[X].rgbtBlue = TransparentColor.rgbtBlue) then
begin
if StartX = -1 then StartX := X;
end
else
begin
if StartX > -1 then
begin
Excl := CreateRectRGN(StartX, Y, X + 1, Y + 1);
try
CombineRGN(Result, Result, Excl, RGN_DIFF);
StartX := -1;
finally
DeleteObject(Excl);
end;
end;
end;
end;
if StartX > -1 then
begin
Excl := CreateRectRGN(StartX, Y, Bmp.Width, Y + 1);
try
CombineRGN(Result, Result, Excl, RGN_DIFF);
finally
DeleteObject(Excl);
end;
end;
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
var
Bmp: TBitmap;
begin
Bmp := TBitmap.Create;
try
Bmp.LoadFromFile('C:YourBitmap.bmp');
FRegion := CreateRegion(Bmp);
SetWindowRGN(Handle, FRegion, True);
finally
Bmp.Free;
end;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
DeleteObject(FRegion);
end;
end.
Delphi - .....................................
neoturk: ...Show a form in full-screen mode ?...
{
Make your application like a game. Full Screen.
Disable all of the system keys.
}
procedure TForm1.FormCreate(Sender: TObject);
var
HTaskbar: HWND;
OldVal: LongInt;
begin
try
// Find handle of TASKBAR
HTaskBar := FindWindow('Shell_TrayWnd', nil);
// Turn SYSTEM KEYS off, Only Win 95/98/ME
SystemParametersInfo(97, Word(True), @OldVal, 0);
// Disable the taskbar
EnableWindow(HTaskBar, False);
// Hide the taskbar
ShowWindow(HTaskbar, SW_HIDE);
finally
with Form1 do
begin
BorderStyle := bsNone;
FormStyle := fsStayOnTop;
Left := 0;
Top := 0;
Height := Screen.Height;
Width := Screen.Width;
end;
end
end;
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
var
HTaskbar: HWND;
OldVal: LongInt;
begin
//Find handle of TASKBAR
HTaskBar := FindWindow('Shell_TrayWnd', nil);
//Turn SYSTEM KEYS Back ON, Only Win 95/98/ME
SystemParametersInfo(97, Word(False), @OldVal, 0);
//Enable the taskbar
EnableWindow(HTaskBar, True);
//Show the taskbar
ShowWindow(HTaskbar, SW_SHOW);
end;
{
Hope you like it !
So if you have any problem using these codes
please e-mail me at :
babak_sateli@yahoo.com
Babak Sateli
www.cdcenterco.com
}
Delphi - .....................................
neoturk: ...Show a form in full-screen mode ?...
{
Make your application like a game. Full Screen.
Disable all of the system keys.
}
procedure TForm1.FormCreate(Sender: TObject);
var
HTaskbar: HWND;
OldVal: LongInt;
begin
try
// Find handle of TASKBAR
HTaskBar := FindWindow('Shell_TrayWnd', nil);
// Turn SYSTEM KEYS off, Only Win 95/98/ME
SystemParametersInfo(97, Word(True), @OldVal, 0);
// Disable the taskbar
EnableWindow(HTaskBar, False);
// Hide the taskbar
ShowWindow(HTaskbar, SW_HIDE);
finally
with Form1 do
begin
BorderStyle := bsNone;
FormStyle := fsStayOnTop;
Left := 0;
Top := 0;
Height := Screen.Height;
Width := Screen.Width;
end;
end
end;
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
var
HTaskbar: HWND;
OldVal: LongInt;
begin
//Find handle of TASKBAR
HTaskBar := FindWindow('Shell_TrayWnd', nil);
//Turn SYSTEM KEYS Back ON, Only Win 95/98/ME
SystemParametersInfo(97, Word(False), @OldVal, 0);
//Enable the taskbar
EnableWindow(HTaskBar, True);
//Show the taskbar
ShowWindow(HTaskbar, SW_SHOW);
end;
{
Hope you like it !
So if you have any problem using these codes
please e-mail me at :
babak_sateli@yahoo.com
Babak Sateli
www.cdcenterco.com
}
Delphi - .....................................
neoturk: ...Minimize a secondary-form to the taskbar ?...
type
TForm = class(TForm)
{...}
protected
procedure CreateParams(var Params: TCreateParams); override;
end;
implementation
{...}
procedure TForm2.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
Params.ExStyle := Params.ExStyle or WS_EX_APPWINDOW;
Params.WndParent := GetDesktopWindow;
end;
Delphi - .....................................
neoturk: ...Minimize a secondary-form to the taskbar ?...
type
TForm = class(TForm)
{...}
protected
procedure CreateParams(var Params: TCreateParams); override;
end;
implementation
{...}
procedure TForm2.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
Params.ExStyle := Params.ExStyle or WS_EX_APPWINDOW;
Params.WndParent := GetDesktopWindow;
end;
Delphi - .....................................
neoturk: ...Make a form semi-- transparent ?...
// Make your forms 25%, 50% Transparent...
TMyForm = class (TForm);
TrackBar1: TTrackBar;
//..
private
FColorKey: TCOLOR;
end;
const
// Use crKey as the transparency color.
LWA_COLORKEY = 1;
// Use bAlpha to determine the opacity of the layered window..
LWA_ALPHA = 2;
WS_EX_LAYERED = $80000;
implementation
{$R *.DFM}
// The SetLayeredWindowAttributes function sets the opacity and transparency
// color key of a layered window.
// Note : This function is only available with Windows 2000 and XP!
function SetLayeredWindowAttributes(
// Handle to the layered window.
Wnd: hwnd;
// Pointer to a COLORREF value that specifies the transparency
// color key to be used when composing the layered window
crKey: ColorRef;
// Alpha value used to describe the opacity of the layered window
Alpha: Byte;
// Specifies an action to take
// LWA_COLORKEY or LWA_ALPHA
// This parameter can be one or more of the following values:
dwFlags: DWORD): Boolean;
stdcall; external 'user32.dll';
procedure TMyForm.TrackBar1Change(Sender: TObject);
// Trackbar.Position must run at range 1-255...
begin
SetWindowLong(Handle, GWL_EXSTYLE, GetWindowLong(Handle, GWL_EXSTYLE) or WS_EX_LAYERED);
SetLayeredWindowAttributes(Handle, ColorToRGB(FColorKey), TrackBar1.Position, LWA_ALPHA);
end;
{******************************************************************}
{ To load the SetLayeredWindowAttributes() function dynamically, use this function:}
function MakeWindowTransparent(Wnd: HWND; nAlpha: Integer = 10): Boolean;
type
TSetLayeredWindowAttributes = function(hwnd: HWND; crKey: COLORREF; bAlpha: Byte;
dwFlags: Longint): Longint;
stdcall;
const
// Use crKey as the transparency color.
LWA_COLORKEY = 1;
// Use bAlpha to determine the opacity of the layered window..
LWA_ALPHA = 2;
WS_EX_LAYERED = $80000;
var
hUser32: HMODULE;
SetLayeredWindowAttributes: TSetLayeredWindowAttributes;
i: Integer;
begin
Result := False;
// Here we import the function from USER32.DLL
hUser32 := GetModuleHandle('USER32.DLL');
if hUser32 <> 0 then
begin @SetLayeredWindowAttributes := GetProcAddress(hUser32, 'SetLayeredWindowAttributes');
// If the import did not succeed, make sure your app can handle it!
if @SetLayeredWindowAttributes <> nil then
begin
// Check the current state of the dialog, and then add the WS_EX_LAYERED attribute
SetWindowLong(Wnd, GWL_EXSTYLE, GetWindowLong(Wnd, GWL_EXSTYLE) or WS_EX_LAYERED);
// The SetLayeredWindowAttributes function sets the opacity and
// transparency color key of a layered window
SetLayeredWindowAttributes(Wnd, 0, Trunc((255 / 100) * (100 - nAlpha)), LWA_ALPHA);
Result := True;
end;
end;
end;
Delphi - .....................................
neoturk: ...Make a form semi-- transparent ?...
// Make your forms 25%, 50% Transparent...
TMyForm = class (TForm);
TrackBar1: TTrackBar;
//..
private
FColorKey: TCOLOR;
end;
const
// Use crKey as the transparency color.
LWA_COLORKEY = 1;
// Use bAlpha to determine the opacity of the layered window..
LWA_ALPHA = 2;
WS_EX_LAYERED = $80000;
implementation
{$R *.DFM}
// The SetLayeredWindowAttributes function sets the opacity and transparency
// color key of a layered window.
// Note : This function is only available with Windows 2000 and XP!
function SetLayeredWindowAttributes(
// Handle to the layered window.
Wnd: hwnd;
// Pointer to a COLORREF value that specifies the transparency
// color key to be used when composing the layered window
crKey: ColorRef;
// Alpha value used to describe the opacity of the layered window
Alpha: Byte;
// Specifies an action to take
// LWA_COLORKEY or LWA_ALPHA
// This parameter can be one or more of the following values:
dwFlags: DWORD): Boolean;
stdcall; external 'user32.dll';
procedure TMyForm.TrackBar1Change(Sender: TObject);
// Trackbar.Position must run at range 1-255...
begin
SetWindowLong(Handle, GWL_EXSTYLE, GetWindowLong(Handle, GWL_EXSTYLE) or WS_EX_LAYERED);
SetLayeredWindowAttributes(Handle, ColorToRGB(FColorKey), TrackBar1.Position, LWA_ALPHA);
end;
{******************************************************************}
{ To load the SetLayeredWindowAttributes() function dynamically, use this function:}
function MakeWindowTransparent(Wnd: HWND; nAlpha: Integer = 10): Boolean;
type
TSetLayeredWindowAttributes = function(hwnd: HWND; crKey: COLORREF; bAlpha: Byte;
dwFlags: Longint): Longint;
stdcall;
const
// Use crKey as the transparency color.
LWA_COLORKEY = 1;
// Use bAlpha to determine the opacity of the layered window..
LWA_ALPHA = 2;
WS_EX_LAYERED = $80000;
var
hUser32: HMODULE;
SetLayeredWindowAttributes: TSetLayeredWindowAttributes;
i: Integer;
begin
Result := False;
// Here we import the function from USER32.DLL
hUser32 := GetModuleHandle('USER32.DLL');
if hUser32 <> 0 then
begin @SetLayeredWindowAttributes := GetProcAddress(hUser32, 'SetLayeredWindowAttributes');
// If the import did not succeed, make sure your app can handle it!
if @SetLayeredWindowAttributes <> nil then
begin
// Check the current state of the dialog, and then add the WS_EX_LAYERED attribute
SetWindowLong(Wnd, GWL_EXSTYLE, GetWindowLong(Wnd, GWL_EXSTYLE) or WS_EX_LAYERED);
// The SetLayeredWindowAttributes function sets the opacity and
// transparency color key of a layered window
SetLayeredWindowAttributes(Wnd, 0, Trunc((255 / 100) * (100 - nAlpha)), LWA_ALPHA);
Result := True;
end;
end;
end;
Delphi - .....................................
neoturk: ...Show hints in the statusbar ?...
private
procedure MyHint(Sender: TObject);
end;
implementation
{....}
procedure TForm1.FormCreate(Sender: TObject);
begin
Application.OnHint := MyHint;
ShowHint := True;
Button1.Hint := 'normal yellow hint|Text in Statusbar';
Button2.Hint := 'only yellow hint|';
Button3.Hint := '|text only in statusbar';
Edit1.Hint := 'same text';
end;
procedure TForm1.MyHint(Sender: TObject);
begin
StatusBar1.SimpleText := Application.Hint;
end;
Delphi - .....................................
neoturk: ...Show hints in the statusbar ?...
private
procedure MyHint(Sender: TObject);
end;
implementation
{....}
procedure TForm1.FormCreate(Sender: TObject);
begin
Application.OnHint := MyHint;
ShowHint := True;
Button1.Hint := 'normal yellow hint|Text in Statusbar';
Button2.Hint := 'only yellow hint|';
Button3.Hint := '|text only in statusbar';
Edit1.Hint := 'same text';
end;
procedure TForm1.MyHint(Sender: TObject);
begin
StatusBar1.SimpleText := Application.Hint;
end;
Delphi - .....................................
neoturk: ...Draw a color outline around tform ?...
{
Erstelle ein Message Handler für die Windows Message WM_NCPAINT Message. Das
folgende Beispiel zeichnet ein 1 Pixel breiter roter Rahmen um
das Formular.
Create a message handler for the Windows Message WM_NCPAINT
message. The following example paints a 1 pixel red border around the
frame of the form.
}
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs;
type
TForm1 = class(TForm)
private
{ Private-Deklarationen }
procedure WMNCPaint(var Msg: TWMNCPaint); message WM_NCPAINT;
public
{ Public-Deklarationen }
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;
//Change the RGB value to change the color
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;
end.
Delphi - .....................................
neoturk: ...Draw a color outline around tform ?...
{
Erstelle ein Message Handler für die Windows Message WM_NCPAINT Message. Das
folgende Beispiel zeichnet ein 1 Pixel breiter roter Rahmen um
das Formular.
Create a message handler for the Windows Message WM_NCPAINT
message. The following example paints a 1 pixel red border around the
frame of the form.
}
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs;
type
TForm1 = class(TForm)
private
{ Private-Deklarationen }
procedure WMNCPaint(var Msg: TWMNCPaint); message WM_NCPAINT;
public
{ Public-Deklarationen }
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;
//Change the RGB value to change the color
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;
end.
Delphi - .....................................
neoturk: ...Shade components ?...
procedure ShadeIt(f: TForm; c: TControl; Width: Integer; Color: TColor);
var
rect: TRect;
old: TColor;
begin
if (c.Visible) then
begin
rect := c.BoundsRect;
rect.Left := rect.Left + Width;
rect.Top := rect.Top + Width;
rect.Right := rect.Right + Width;
rect.Bottom := rect.Bottom + Width;
old := f.Canvas.Brush.Color;
f.Canvas.Brush.Color := Color;
f.Canvas.fillrect(rect);
f.Canvas.Brush.Color := old;
end;
end;
procedure TForm1.FormPaint(Sender: TObject);
var
i: Integer;
begin
for i := 0 to Self.ControlCount - 1 do
ShadeIt(Self, Self.Controls[i], 3, clBlack);
end;
Delphi - .....................................
neoturk: ...Shade components ?...
procedure ShadeIt(f: TForm; c: TControl; Width: Integer; Color: TColor);
var
rect: TRect;
old: TColor;
begin
if (c.Visible) then
begin
rect := c.BoundsRect;
rect.Left := rect.Left + Width;
rect.Top := rect.Top + Width;
rect.Right := rect.Right + Width;
rect.Bottom := rect.Bottom + Width;
old := f.Canvas.Brush.Color;
f.Canvas.Brush.Color := Color;
f.Canvas.fillrect(rect);
f.Canvas.Brush.Color := old;
end;
end;
procedure TForm1.FormPaint(Sender: TObject);
var
i: Integer;
begin
for i := 0 to Self.ControlCount - 1 do
ShadeIt(Self, Self.Controls[i], 3, clBlack);
end;
Delphi - .....................................
neoturk: ...Make a form not resizable but moveable ?...
private
procedure WMGetMinMaxInfo(var Msg: TWMGetMinMaxInfo); message WM_GETMINMAXINFO;
end;
{...}
implementation
procedure TForm1.WMGetMinMaxInfo(var Msg: TWMGetMinMaxInfo);
begin
inherited;
with Msg.MinMaxInfo^ do
begin
ptMinTrackSize.x := Form1.Width;
ptMaxTrackSize.x := Form1.Width;
ptMinTrackSize.y := Form1.Height;
ptMaxTrackSize.y := Form1.Height;
end;
end;
Delphi - .....................................
neoturk: ...Make a form not resizable but moveable ?...
private
procedure WMGetMinMaxInfo(var Msg: TWMGetMinMaxInfo); message WM_GETMINMAXINFO;
end;
{...}
implementation
procedure TForm1.WMGetMinMaxInfo(var Msg: TWMGetMinMaxInfo);
begin
inherited;
with Msg.MinMaxInfo^ do
begin
ptMinTrackSize.x := Form1.Width;
ptMaxTrackSize.x := Form1.Width;
ptMinTrackSize.y := Form1.Height;
ptMaxTrackSize.y := Form1.Height;
end;
end;
Delphi - .....................................
neoturk: ...Scale a form manually ?...
{
Der erste Parameter von ScaleBy ist der Multiplikator, der zweite
der Divisor. Folgendes Beispiel skaliert die Form auf 150%
The first parameter of ScaleBy is the multiplier, the second
the divisor. The example scale the form to 150%
}
procedure TForm1.Button1Click(Sender: TObject);
begin
ScaleBy(150, 100);
end;
Delphi - .....................................
neoturk: ...Scale a form manually ?...
{
Der erste Parameter von ScaleBy ist der Multiplikator, der zweite
der Divisor. Folgendes Beispiel skaliert die Form auf 150%
The first parameter of ScaleBy is the multiplier, the second
the divisor. The example scale the form to 150%
}
procedure TForm1.Button1Click(Sender: TObject);
begin
ScaleBy(150, 100);
end;
Delphi - .....................................
neoturk: ...Close a mdichild form ?...
unit Child;
// Have you noticed that when you try to close a MDIChild form
// the form minimizes but doesn't disappear from your Main form
// client area?
//
// With this tip you can learn how to really close the MDI child
// form and free the memory occupied by the form
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;
type
TMDIChildForm = class(TForm)
procedure FormClose(Sender: TObject; var Action: TCloseAction);
private
{ Private declarations }
public
{ Public declarations }
end;
var
MDIChildForm: TMDIChildForm;
implementation
{$R *.DFM}
procedure TMDIChildForm.FormClose(Sender: TObject;
var Action: TCloseAction);
begin
// This line of code frees memory and closes the form
Action := caFree;
end;
end.
Delphi - .....................................
neoturk: ...Close a mdichild form ?...
unit Child;
// Have you noticed that when you try to close a MDIChild form
// the form minimizes but doesn't disappear from your Main form
// client area?
//
// With this tip you can learn how to really close the MDI child
// form and free the memory occupied by the form
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;
type
TMDIChildForm = class(TForm)
procedure FormClose(Sender: TObject; var Action: TCloseAction);
private
{ Private declarations }
public
{ Public declarations }
end;
var
MDIChildForm: TMDIChildForm;
implementation
{$R *.DFM}
procedure TMDIChildForm.FormClose(Sender: TObject;
var Action: TCloseAction);
begin
// This line of code frees memory and closes the form
Action := caFree;
end;
end.
