Create New Windows

unit CreateAWindowu;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

{ Register the Window Class }
function RegisterClass: Boolean;
var
  WindowClass: TWndClass;
begin
  {setup our new window class}
  WindowClass.Style := CS_HREDRAW or CS_VREDRAW;           {set the class styles}
  WindowClass.lpfnWndProc := @DefWindowProc;               {point to the default window procedure}
  WindowClass.cbClsExtra := 0;                             {no extra class memory}
  WindowClass.cbWndExtra := 0;                             {no extra window memory}
  WindowClass.hInstance := hInstance;                      {the application instance}
  WindowClass.hIcon := 0;                                  {no icon specified}
  WindowClass.hCursor := 0;                                {no cursor specified}
  WindowClass.hbrBackground := COLOR_WINDOW;               {use a predefined color}
  WindowClass.lpszMenuName := nil;                         {no menu}
  WindowClass.lpszClassName := 'TestClass';                {the registered class name}

  {now that we have our class set up, register it with the system}
  Result := Windows.RegisterClass(WindowClass) <> 0;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  hWindow: HWND;
begin
  {Step 1: Register our new window class}
  if not RegisterClass then
  begin
    ShowMessage('RegisterClass failed');
    Exit;
  end;

  {Step 2: Create a window based on our new class}
  hWindow := CreateWindow('TestClass',           {the registered class name}
                          'New Window',          {the title bar text}
                          WS_OVERLAPPEDWINDOW,   {a normal window style}
                          CW_USEDEFAULT,         {default horizontal position}
                          CW_USEDEFAULT,         {default vertical position}
                          CW_USEDEFAULT,         {default width}
                          CW_USEDEFAULT,         {default height}
                          0,                     {no owner window}
                          0,                     {no menu}
                          hInstance,             {the application instance}
                          nil                    {no additional information}
                          );

  {Step 3: If our window was created successfully, display it}
  if hWindow <> 0 then
  begin
    ShowWindow(hWindow, SW_SHOWNORMAL);
    UpdateWindow(hWindow);
  end
  else
  begin
    ShowMessage('CreateWindow failed');
    Exit;
  end;

end;

end.

Draw Polygon in 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;

Bitmap Radio Button

uses

Themes;

{$ENDIF}

function GetRadioButtonBitmap(Checked, Hot : boolean; BgColor : TColor): TBitmap;

const

CtrlState : array[boolean] of integer = (DFCS_BUTTONRADIO,

DFCS_BUTTONRADIO or DFCS_CHECKED);

var

CBRect : TRect;

{$IFDEF VER150}

Details : TThemedElementDetails;

{$ENDIF}

BgOld : TColor;

ChkBmp : TBitmap;

ThemeOK : boolean;

x, x2, y : integer;

begin

Result := nil;

try

Result := TBitmap.Create;

ChkBmp := TBitmap.Create;

ThemeOK := False;

with Result do

begin

Width := 16;

Height := 16;

with Canvas do

begin

Brush.Color := BgColor;

FillRect(ClipRect);

ChkBmp.Assign(Result);

CBRect := ClipRect;

CBRect.Top := 1;

CBRect.Left := 1;

{$IFDEF VER150}

if ThemeServices.ThemesAvailable then

begin

//ab WinXP

if Checked = True then

begin

if Hot = True then

Details := ThemeServices.GetElementDetails(tbRadioButtonCheckedHot)

else

Details :=

ThemeServices.GetElementDetails(tbRadioButtonCheckedNormal);

end

else

begin

if Hot = True then

Details :=

ThemeServices.GetElementDetails(tbRadioButtonUncheckedHot)

else

Details :=

ThemeServices.GetElementDetails(tbRadioButtonUncheckedNormal);

end;

ThemeServices.DrawElement(Handle, Details, CBRect);

//Prüfen ob es tatsächlich geklappt hat (Win2003 liefert leere Images!)

for x := 15 downto 0 do

for y := 15 downto 0 do

if ChkBmp.Canvas.Pixels[x, y] <> Pixels[x, y] then

begin

ThemeOK := True;

break;

end;

end;

{$ENDIF}

if ThemeOK = False then

begin

//alles vor WinXP

CBRect.Left := ClipRect.Left + 2;

CBRect.Right := ClipRect.Right - 1;

CBRect.Top := ClipRect.Top + 2;

CBRect.Bottom := ClipRect.Bottom - 1;

DrawFrameControl(Handle, CBRect, DFC_BUTTON, CtrlState[Checked]);

end;

end;

end;

finally

end;

end;

Close a MDIChild Form

unit Child;

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.

Make Transfarent Form

procedure TForm1.FormCreate(Sender: TObject);
begin
SetWindowLong(Form1.Handle, GWL_EXSTYLE,
(GetWindowLong(Form1.Handle, GWL_EXSTYLE) or WS_WX_TRANSPARENT));
end;

Zoom Content in StringGrid

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

procedure gridZoom(FFact: Real);

public

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;

procedure TForm1.BitBtn1Click(Sender: TObject);

begin

gridZoom(1.1);

end;

procedure TForm1.BitBtn2Click(Sender: TObject);

begin

gridZoom(0.9);

end;

Hide the main form at startup

program Project1;
uses
Forms,
Unit1 in 'Unit1.pas'; {Form1}
{$R *.RES}
begin
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.ShowMainForm := False;
Application.Run;
end.

Image Background Form

procedure TForm1.FormCreate(Sender: TObject);
var
MyBitmap: TBitmap;
begin
MyBitmap:=TBitmap.Create;
MyBitmap.LoadFromFile('bg.bmp');
Form1.Brush.Bitmap:=MyBitmap;
end;

Hide the caption bar

procedure TForm1.HideTitlebar;
var
Style: Longint;
begin
if BorderStyle = bsNone then Exit;
Style := GetWindowLong(Handle, GWL_STYLE);
if (Style and WS_CAPTION) = WS_CAPTION then
begin
case BorderStyle of
bsSingle,
bsSizeable: SetWindowLong(Handle, GWL_STYLE, Style and
(not (WS_CAPTION)) or WS_BORDER);
bsDialog: SetWindowLong(Handle, GWL_STYLE, Style and
(not (WS_CAPTION)) or DS_MODALFRAME or WS_DLGFRAME);
end;
Height := Height - GetSystemMetrics(SM_CYCAPTION);
Refresh;
end;
end;


procedure TForm1.ShowTitlebar;
var
Style: Longint;
begin
if BorderStyle = bsNone then Exit;
Style := GetWindowLong(Handle, GWL_STYLE);
if (Style and WS_CAPTION) <> WS_CAPTION then
begin
case BorderStyle of
bsSingle,
bsSizeable: SetWindowLong(Handle, GWL_STYLE, Style or WS_CAPTION or
WS_BORDER);
bsDialog: SetWindowLong(Handle, GWL_STYLE,
Style or WS_CAPTION or DS_MODALFRAME or WS_DLGFRAME);
end;
Height := Height + GetSystemMetrics(SM_CYCAPTION);
Refresh;
end;
end;


procedure TForm1.Button1Click(Sender: TObject);
begin
HideTitlebar;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
ShowTitlebar;
end;

Form Transparan

procedure TForm1.FormCreate(Sender: TObject);
begin
SetWindowLong(Form1.Handle, GWL_EXSTYLE,
(GetWindowLong(Form1.Handle, GWL_EXSTYLE) or WS_WX_TRANSPARENT));
end;

Full Screen Form

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;