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.

Set Cursor Position

procedure TForm1.Button1Click(Sender: TObject);

var

MausPos: TPoint;

begin

GetCursorPos(MausPos);

label1.Caption := IntToStr(MausPos.x);

label2.Caption := IntToStr(MausPos.y);

end;

// Set mouse position to (x,y)

procedure TForm1.Button2Click(Sender: TObject);

begin

SetCursorPos(600, 600);

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;

Read Acces Using Ado

unit uMain;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
Db, DBTables, ADODB, Grids, DBGrids, ExtCtrls, DBCtrls, StdCtrls, Buttons;

type
TfrmMain = class(TForm)
DSUsers: TDataSource;
DBGridUsers: TDBGrid;
BitBtn1: TBitBtn;
OpenDialog1: TOpenDialog;
TUsers: TADOTable;
procedure FormCreate(Sender: TObject);
procedure ValidateAccessDB;
function CheckIfAccessDB(lDBPathName: string): boolean;
private
{ Private declarations }
public
{ Public declarations }
end;

var
frmMain: TfrmMain;
const
DBNAME = 'ADODemo.MDB';
DBPASSWORD = '123'; // Access DB Password Protected

implementation

{$R *.DFM}

procedure TfrmMain.FormCreate(Sender: TObject);
begin
validateAccessDB;
end;

procedure TfrmMain.ValidateAccessDB;
var
lDBpathName : String;
lDBcheck : boolean;
begin
if FileExists(ExtractFileDir(Application.ExeName) + '\' + DBNAME) then
lDBPathName := ExtractFileDir(Application.ExeName) + '\' + DBNAME
else if OpenDialog1.Execute then
// Set the OpenDialog Filter for ADOdemo.mdb only
lDBPathName := OpenDialog1.FileName;

lDBCheck := False;
if Trim(lDBPathName) <> '' then
lDBCheck := CheckIfAccessDB(lDBPathName);

if lDBCheck = True then
begin
// ADO Connection String to the MS-ACCESS DB
TUsers.ConnectionString :=
'Provider=Microsoft.Jet.OLEDB.4.0;' +
'Data Source=' + lDBPathName + ';' +
'Persist Security Info=False;' +
'Jet OLEDB:Database Password=' + DBPASSWORD;
TUsers.TableName := 'Users';
TUsers.Active := True;
end
else
frmMain.Free;
end;

// Check if it is a valid ACCESS DB File Before opening it.

function TfrmMain.CheckIfAccessDB(lDBPathName: string): Boolean;
var
UnTypedFile: file of byte;
Buffer: array[0..19] of byte;
NumRecsRead: Integer;
i: Integer;
MyString: string;
begin
AssignFile(UnTypedFile, lDBPathName);
reset(UnTypedFile);
BlockRead(UnTypedFile, Buffer, High(Buffer), NumRecsRead);
CloseFile(UnTypedFile);
for i := 1 to High(Buffer) do
MyString := MyString + Trim(Chr(Ord(Buffer[i])));
Result := False;
if Mystring = 'StandardJetDB' then
Result := True;
if Result = False then
MessageDlg('Invalid Access Database', mtInformation, [mbOK], 0);
end;

end.

Compare Image by Pixel

procedure TForm1.Button1Click(Sender: TObject);
var
b1, b2: TBitmap;
c1, c2: PByte;
x, y, i,
different: Integer; // Counter for different pixels
begin
b1 := Image1.Picture.Bitmap;
b2 := Image2.Picture.Bitmap;
Assert(b1.PixelFormat = b2.PixelFormat); // they have to be equal
different := 0;
for y := 0 to b1.Height - 1 do
begin
c1 := b1.Scanline[y];
c2 := b2.Scanline[y];
for x := 0 to b1.Width - 1 do
for i := 0 to BytesPerPixel - 1 do // 1, to 4, dep. on pixelformat
begin
Inc(different, Integer(c1^ <> c2^));
Inc(c1);
Inc(c2);
end;
end;
end;