Delphi programming tips and tricks

How Detect If an Application Has Stopped Responding

2009-05-21T14:55:00.002+03:00

In many situations you might like to detect if an application is blocked. For example while automating Internet Explorer, you'd like to know if Internet Explorer has stopped responding. There is no clear definition of an application hanging. Typically the application is "busy" with some processing. However from a user's perspective, the application has stopped responding. The idea is to periodically detect if the application is still responding in a timer and depending on application logic, the target application can be killed or other necessary action can be taken. Next example describes how to detect if an automated instance of Internet Explorer is hung or not.

unit Unit1;

interface

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

type
TForm1 = class(TForm)
 btnLaunch: TButton;
 btnCheck: TButton;
 btnKill: TButton;
 procedure btnLaunchClick(Sender: TObject);
 procedure btnCheckClick(Sender: TObject);
 procedure btnKillClick(Sender: TObject);
private
 { Private declarations }
public
 { Public declarations }
 modObjIE : OLEVariant;
 modlngWndIE : THandle;
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.btnLaunchClick(Sender: TObject);
begin
modObjIE := CreateOleObject('InternetExplorer.Application');
modObjIE.Visible := true;
modObjIE.Navigate2('http://www.borland.com');
modlngWndIE := modObjIE.hwnd;
end;

procedure TForm1.btnCheckClick(Sender: TObject);
var
dwResult : DWORD;
lngReturnValue : longint;
begin
lngReturnValue := SendMessageTimeout(modlngWndIE, WM_NULL, 0,
   0, SMTO_ABORTIFHUNG OR SMTO_BLOCK, 1000, dwResult);
 If lngReturnValue > 0 then
     ShowMessage('Responding')
 Else
     ShowMessage('Not Responding');
end;



procedure TForm1.btnKillClick(Sender: TObject);
var
ProcessID : DWORD;
Process : THandle;
begin
GetWindowThreadProcessId(modlngWndIE, @ProcessID);
Process := OpenProcess(PROCESS_ALL_ACCESS, false, ProcessID);
TerminateProcess(Process, 0);
end;

end.

Although the code is written for Internet Explorer, the idea can be used for other applications as well.

unit Unit1;

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}

procedure TForm1.Button1Click(Sender: TObject);
var
H : THandle;
lngReturnValue : longint;
DWResult : DWORD;
begin
H := FindWindow('Notepad', nil);
if H > 0 then
begin
 lngReturnValue := SendMessageTimeout(H, WM_NULL, 0,
   0, SMTO_ABORTIFHUNG And SMTO_BLOCK, 1000, DWResult);
 if lngReturnValue > 0 then
  ShowMessage('Responding')
   else
    ShowMessage('Not responding');
end
else
  ShowMessage('Application not found');
end;

end.

How to validate an IBAN

2007-09-02T21:47:00.000+03:00

IBAN stands for International Bank Account Number
Example : CH10002300A1023502601

Here is a method how to check if an IBAN is valid:

function ChangeAlpha(input: string): string;
// A -> 10, B -> 11, C -> 12 ...
var
a: Char;
begin
Result := input;
for a := 'A' to 'Z' do
begin
Result := StringReplace(Result, a, IntToStr(Ord(a) - 55), [rfReplaceAll]);
end;
end;

function CalculateDigits(iban: string): Integer;
var
v, l: Integer;
alpha: string;
number: Longint;
rest: Integer;
begin
iban := UpperCase(iban);
if Pos('IBAN', iban) > 0 then
Delete(iban, Pos('IBAN', iban), 4);
iban := iban + Copy(iban, 1, 4);
Delete(iban, 1, 4);
iban := ChangeAlpha(iban);
v := 1;
l := 9;
rest := 0;
alpha := '';
try
while v <= Length(iban) do
begin
if l > Length(iban) then
l := Length(iban);
alpha := alpha + Copy(iban, v, l);
number := StrToInt(alpha);
rest := number mod 97;
v := v + l;
alpha := IntToStr(rest);
l := 9 - Length(alpha);
end;
except
rest := 0;
end;
Result := rest;
end;

function CheckIBAN(iban: string): Boolean;
begin
iban := StringReplace(iban, ' ', '', [rfReplaceAll]);
if CalculateDigits(iban) = 1 then
Result := True
else
Result := False;
end;

Implementing Floyd-Warshall algorithm in Delphi

2007-09-02T13:21:00.000+03:00

// +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
// Floyd-Warshall algorithm - shortest path problem - Graph Theory
//
// http://de.wikipedia.org/wiki/Algorithmus_von_Floyd_und_Warshall
// +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

unit Unit1;

interface

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

type
typ = array [1..50,1..50] of Integer;
TForm1 = class(TForm)
Edit1: TEdit;
Button1: TButton;
sg1: TStringGrid;
Button2: TButton;
Edit2: TEdit;
Edit3: TEdit;
Label1: TLabel;
Label2: TLabel;
Label3: TLabel;
Label4: TLabel;
Button3: TButton;
i1: TImage;
sg2: TStringGrid;
Edit4: TEdit;
sg3: TStringGrid;
Label5: TLabel;
Label6: TLabel;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure Button3Click(Sender: TObject);
procedure Button4Click(Sender: TObject);
private

public
procedure floyd2(n: Integer; w: typ; var d: typ; var p: typ);
procedure path(q: Integer; r: Integer);
procedure laa(teta: Integer; r: Integer; x: Integer; y: Integer; i1: TImage);
end;

var
Form1: TForm1;
w: typ;
d: typ;
p: typ;
n, cont: Integer;
v: array of Integer;
X, y: array of Integer;

implementation

procedure tform1.path(q: Integer; r: Integer);
begin
if not (p[q, r] = 0) then
begin
path(q, p[q, r]);
label4.Caption := label4.Caption + IntToStr(p[q, r]) + ',';
path(p[q, r], r);
end;
end;

procedure tform1.floyd2(n: Integer; w: typ; var d: typ; var p: typ);
var
i, j, k: Integer;
begin
for i := 1 to n do
for j := 1 to n do
p[i, j] := 0;
d := w;
for k := 1 to n do
for i := 1 to n do
for j := 1 to n do
begin
if (d[i, k] + d[k, j] <>then
begin
p[i, j] := k;
d[i, j] := d[i][k] + d[k][j];
end;
end;
end;

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);
var
i, j: Integer;
s: string;
e: TEdit;
begin
Button3Click(Sender);
n := StrToInt(edit1.Text);
setlength(v, n);
for i := 1 to n do
for j := 1 to n do
w[i, j] := StrToInt(sg1.Cells[i, j]);
floyd2(n, w, d, p);
label4.Caption := edit2.Text + ',';
path(StrToInt(edit2.Text), StrToInt(edit3.Text));
Button3Click(Sender);
label4.Caption := label4.Caption + edit3.Text + '.';
s := label4.Caption;
i := 1;
label3.Caption := '';
cont := 0;
while not (s[i] = '.') do
begin
label3.Caption := s[i] + label3.Caption;
if s[i] = ',' then i := i + 1
else
begin
if cont <> 0 then
begin
i1.Canvas.MoveTo(x[cont], y[cont]);
i1.Canvas.LineTo(x[StrToInt(s[i])], y[StrToInt(s[i])]);
end;
cont := StrToInt(s[i]);
i := i + 1;
end;
end;

for i := 1 to n do
for j := 1 to n do
sg2.Cells[i, j] := IntToStr(p[i, j]);
for i := 1 to n do
for j := 1 to n do
sg3.Cells[i, j] := IntToStr(d[i, j]);
end;

procedure TForm1.Button2Click(Sender: TObject);
var
i, j: Integer;
begin
Button3Click(Sender);
sg1.Visible := True;
sg1.Cells[0,0] := 'W matris:';
sg1.RowCount := StrToInt(edit1.Text) + 1;
sg1.ColCount := StrToInt(edit1.Text) + 1;
sg2.Visible := True;
sg2.Cells[0,0] := 'Paths:';
sg2.RowCount := StrToInt(edit1.Text) + 1;
sg2.ColCount := StrToInt(edit1.Text) + 1;
sg3.Visible := True;
sg3.Cells[0,0] := 'D Matris:';
sg3.RowCount := StrToInt(edit1.Text) + 1;
sg3.ColCount := StrToInt(edit1.Text) + 1;
for i := 1 to StrToInt(edit1.Text) + 1 do
begin
sg1.Cells[0,i] := IntToStr(i);
sg1.Cells[i, 0] := IntToStr(i);
sg2.Cells[0,i] := IntToStr(i);
sg2.Cells[i, 0] := IntToStr(i);
sg3.Cells[0,i] := IntToStr(i);
sg3.Cells[i, 0] := IntToStr(i);
end;
for i := 1 to StrToInt(edit1.Text) + 1 do
begin
for j := 1 to StrToInt(edit1.Text) + 1 do
begin
sg1.Cells[i, j] := IntToStr(Random(19) + 1);
if i = j then sg1.Cells[i, j] := '0';
end;
end;
//sg1.Width:=(strtoint(edit1.Text)+3)*sg1.ColWidths[0];
//sg1.Height:=(strtoint(edit1.Text)+3)*sg1.RowHeights[0];
end;

procedure TForm1.Button3Click(Sender: TObject);
var
i, j, k, l, r, rt: Integer;
centerx, centery: Integer;
rad, teta, alfax: Integer;
alfa: Extended;
a, b: TPoint;
begin
i1.Canvas.Brush.Style := bsSolid;
n := StrToInt(edit1.Text);
setlength(x, n + 1);
setlength(y, n + 1);
centery := i1.Width div 2;
centerx := i1.Height div 2;
rad := centerx - 20;
teta := 360 div n;
rt := 10;//pointer
i1.Canvas.Rectangle(0,0,i1.Width, i1.Height);
i1.Canvas.Pen.Color := clgreen;
i1.Canvas.Pen.Width := 3;
for i := 1 to n do
begin
Y[i] := centerx + trunc(rad * sin(teta * i * ((2 * 3.14) / 360)));
X[i] := centery + trunc(rad * cos(teta * i * ((2 * 3.14) / 360)));
l := y[i];
k := x[i];
r := 3;
i1.Canvas.Pie(k - r, l - r, k + r, l + r, 1,1,1,1);
end;
i1.Canvas.Pen.Width := 1;

for i := 1 to n do
for j := 1 to n do
begin
if not (w[i, j] = 0) then
begin
if i = j then
begin
i1.Canvas.Pen.Color := clred;
i1.Canvas.Brush.Style := bsClear;
l := y[i];
k := x[i];
i1.Canvas.Pie(k, l, k + 6 * r, l + 6 * r, 1,1,1,1);
//loop
end;

if (i <> j) and (w[i, j] <> StrToInt(edit4.Text)) then
begin
i1.Canvas.Pen.Color := clblue;
i1.Canvas.Pen.Width := 1;
i1.Canvas.MoveTo(x[i], y[i]);
i1.Canvas.LineTo(x[j], y[j]);
// i1.Canvas.Chord();
end;
i1.Canvas.Pen.Width := 2;

{ if i if (y[i]-y[j])<>0 then alfa:=ArcTan((X[i]-x[j])/(y[j]-y[i])) else alfa:=pi/2;
if x[i]>x[j] then alfax:=round((180/Pi)*alfa+90);
if (x[i] if (x[i]y[j]) then alfax:=270+round((180/Pi)*alfa);
l:=x[j];k:=y[j];
laa(alfax,10,l,k,i1);
end;
if i>j then begin
if (y[i]-y[j])<>0 then alfa:=ArcTan((X[i]-x[j])/(y[j]-y[i])) else alfa:=pi/2;
if x[i]>x[j] then alfax:=round((180/Pi)*alfa+90);
if (x[i] if (x[i]y[j]) then alfax:=270+round((180/Pi)*alfa);
l:=x[i];k:=y[i];
laa(alfax,10,l,k,i1);
end;}
end;
end;
end;

procedure tform1.laa(teta: Integer; r: Integer; x: Integer; y: Integer; i1: TImage);
var
tetap: Extended;
begin
teta := teta mod 360;
tetap := (pi / 180) * (teta);
tetap := (pi / 180) * (teta - 30);
i1.Canvas.MoveTo(x - round(r * sin(tetap)), y - round(r * cos(tetap)));
i1.Canvas.LineTo(x, y);
tetap := (pi / 180) * (teta + 30);
i1.Canvas.MoveTo(x - round(r * sin(tetap)), y - round(r * cos(tetap)));
i1.Canvas.LineTo(x, y);
{end;
if (teta<=180) and (teta>=90) then begin
tetap:=(pi/180)*(teta-30);
i1.Canvas.MoveTo(x-round(r*cos(tetap)),y-round(r*sin(tetap)));
i1.Canvas.LineTo(x,y);
tetap:=(pi/180)*(teta+30);
i1.Canvas.MoveTo(x-round(r*cos(tetap)),y-round(r*sin(tetap)));
i1.Canvas.LineTo(x,y);
end;
if (teta<=270) and (teta>=180) then begin
tetap:=(pi/180)*(teta-30);
i1.Canvas.MoveTo(x+round(r*sin(tetap)),y+round(r*cos(tetap)));
i1.Canvas.LineTo(x,y);
tetap:=(pi/180)*(teta+30);
i1.Canvas.MoveTo(x+round(r*sin(tetap)),y+round(r*cos(tetap)));
i1.Canvas.LineTo(x,y);
end;
if (teta<=360) and (teta>=270) then begin
tetap:=(pi/180)*(teta-30);
i1.Canvas.MoveTo(x+round(r*cos(tetap)),y+round(r*sin(tetap)));
i1.Canvas.LineTo(x,y);
tetap:=(pi/180)*(teta+30);
i1.Canvas.MoveTo(x+round(r*cos(tetap)),y+round(r*sin(tetap)));
i1.Canvas.LineTo(x,y);
end;
}
end;

procedure TForm1.Button4Click(Sender: TObject);
var
i: Integer;
begin
for i := 1 to 360 do
begin
laa(i, 10,100,100,i1);
ShowMessage(IntToStr(i));
end;
end;

end.

How To Use MySQL With Delphi

2007-09-01T15:19:00.000+03:00

For using this tutorial you need some stuff that you can get them all from respective vendor. (Almost all of them are free). you should install them all before you start working by this tutorial

First you need Delphi 6 (I did this pages by Enterprise edition but probably you can use professional or personal edition) for more information about Delphi refer to www.Borland.com

Then you need My SQL that you can get from www.MySQL.com

And also Myodbc which is available at WWW.MySQL.com

And finally you need to have Mycc which is available at www.MySQL.com

For this tutorial you need to make tutorial database which contain 4 different table

I did this one by means of Mycc.

At first you should register a server, to register a server follow the instruction mentioned below

1-Run Mycc

2-By default register server button is the first button on the left side of toolbar.

3-click on register server button and fill the form as I did. (figure Mycc1).

Note:

if you r using a network joined computer you should fill the host name field by your computer name or IP

Now push the test button if you did all jobs without mistake you will get no message else

You will get an error message which means you didn’t fill it right

Warning: Database name is mini_employee which defined as a normal database.

I set admin as user and password is 123.

So if you get error message check for following items

1-check if MySQL server is running (By default after you install MySQL it will run automatically)

2-check if you fill host name as mentioned?

3-check if you fill server name as you should do?

After you make testing sequence error free you can click add button to add the server to your server list.

After you register the server as mentioned you will see ‘Test server for my tutorial ‘ in the MySQL servers tree view

There is a nice icon for servers in this application, isn’t it?

To connect to the server double click on the Test server for my tutorial or click on connect button from toolbar

Now you are connected to a fresh MySQL server.

figure:Mycc1

To create database :

1-right clicks on databases and choose new database

2-fill database name by mini_employee and then choose okay.

Congratulation you made your database for this tutorial.

Okay now we assume you register your server and create your database its now I’ll teach you how to make table.

There is some differences between MySQL and Interbase you can learn the MySQL scripting in the MySQL manual wich is downloadable from http://www.MySQL.com

To make tables

1-double click on databases to make it open

2-double click on the mini_employee database.[you can click on connect button from tool bar instead]

Now you can see the tables item below of mini_employee

Creating tables is too easy by using Mycc

Just right click on the tables and select create new table

Now fill the field names and field type for each table as I mentioned in the tables

After you fill all field of each table click the save button and type table name for that as I write under each table.

For example I’ll fill one field of employee

1-type “emp_no” (without double quote) for field name.

2-select smallint from the combo box at the end of cell.

3-fill the length edit box by 6.

4-fill the default value by 0.

Note

Allow null means that if the field can left empty in data entry ?

If you don’t check allow null check box and put the field empty in data entry time you will get

a database level exception

Now create tables as u see in the tables below.

(My best wishes are with you to create tables successfully J )

Tables are:

1- Employee:

DDL for employee is

CREATE TABLE `employee` (

`emp_no` smallint(6) NOT NULL default '0',

`first_name` varchar(15) default NULL,

`last_name` varchar(20) default NULL,

`phone` varchar(15) default NULL,

`dept_no` smallint(6) default NULL,

`jobe_code` tinyint(4) default NULL,

`job_grade` tinyint(4) default NULL,

`salary` int(11) default NULL,

`hire_date` date default NULL,

`Full_name` tinyint(4) default NULL

) TYPE=MyISAM

You should fill the create table form like this:

Field name	Field kind
emp_no	smallint(6) NOT NULL default '0'
first_name	varchar(15) default NULL
last_name	varchar(20) default NULL
Phone	varchar(15) default NULL
dept_no	smallint(6) default NULL
jobe_code	tinyint(4) default NULL
job_grade	tinyint(4) default NULL
salary	int(11) default NULL
hire_date	date default NULL
Full_name	tinyint(4) default NULL

2- department:

DDL for department is

CREATE TABLE `department` (

`dep_no` smallint(4) default NULL,

`department` varchar(30) default NULL,

`manager_no` smallint(6) default NULL,

`location` varchar(30) default NULL,

`phone` varchar(10) default NULL

) TYPE=MyISAM

You should fill the create table form like this:

Field name	Field kind
Dep_no	smallint(4) default NULL
Department	varchar(30) default NULL
Manager_no	smallint(6) default NULL
Location	varchar(30) default NULL
phone	varchar(10) default NULL

3-jobs:

DDL for job is

CREATE TABLE `jobs` (

`jobe_id` smallint(6) default NULL,

`job_grade` smallint(6) default NULL,

`job_title` varchar(10) default NULL

) TYPE=MyISAM

You should fill the create table form like this:

Field name		Field kind
	jobe_id	smallint(6) default NULL
	job_grade	smallint(6) default NULL
	job_title	varchar(10) default NULL

4-projects:

DDL for projects is

CREATE TABLE `projects` (

`emp_no` smallint(4) default NULL,

`proj_name` varchar(15) default NULL,

`team_leader` smallint(6) default NULL,

`product` set('software','hardware','n/a','other') default 'software'

) TYPE=MyISAM

You should fill the create table form like this:

Field name	Field kind
Emp_no	smallint(4) default NULL
Proj_name	varchar(15) default NULL
Team_leader	smallint(6) default NULL
Product	set('software','hardware','n/a','other') default 'software'

After you make database and tables you need to make an odbc connection to your database

For this item you need to install Myodbc which is downloadable from www.MySQL.com

Its know we assume you install the driver now I’ll tell you how to make odbc connection for your database

1-Goto control panel

Note:

if you are in win2k or winxp goto Administrative Tools then select

2-open data sources (odbc)

Now you will see a window like this

now you should make a new connection by clicking on add button

its now select MySQL odbc 3.51 driver from the listbox (its probably at the end of list)

after you select the item and click on the finish button you need to fill some field of data to make your connection:

do it as I did

Warning:

Beware that the password field is 123 .

Now push the Test Data Source button if you did all job as yu should you will face with a successfully connected to … MessageJ.

Congratulation you did the first phase of learning MySQL J

If you get any fail message test if MySQL service is running?

if you fill database name correctly?

If you fill password and user name correctly?

Okay we assume you connected to database successfully

Now you should copy some files from MySQL dir\ lib\opt to your windows directory\system\

Note:

If you r using any NT edition of Microsoft windows you should copy the files into

Windows directory\system32 \

It’s now our programming by Delphi started

1-Start Delphi

The data access component which we use are BDE component tab which contain several component (listed below) but we will not use them all in this part of my tutorial probably you will learn more

About them in next part tutorial, we will just use

1-Table 2- Query 3- Database

2-Open a new project

3-add a datamodule to the new project and change name property to employee_DtMdl.

4-add a form to your project and change the name to details_frm.

5-add employee_DtMdl to use cluse of the form and frame ;)

6-rename the form1 to master_frm

7-save the (u can choose your desire name for the project and units ;))

Drop the component which listed below on the datamodule which you add to new project

Component

Name

Related properties

Database

Mini_emp_dtb

AliasName = mini_employee

DatabaseName= mini_employee

Name=mini_employee_db

Donot change the driver name property

Left it blank

Params:

USERNAME	Admin
PASSWORD	Sysdba

Query

Employee_qry

Database=mini_emp_dtb

Table

projects _tlb

Databasename= Mini_emp_dtb

TableName =projects

Mastersource= Employee_dtsr

Masterfield=emp_no

Indexfieldname= employee_no

Table

Jobs_tlb

Databasename= Mini_emp_dtb

TableName =jobs

Mastersource= Employee_dtsr

Masterfield=jobe_code

Indexfieldname=jobe_id

Table

department_tlb

Databasename= Mini_emp_dtb

TableName =employee_proj

Mastersource= Employee_dtsr

Masterfield=dept_no

Indexfieldname=dep_no

Datasource

projects _dtsr

Dataset= projects _tlb

Datasource

Jobs_dtsr

Dataset= Jobs_tlb

Datasource

department_dtsr

Dataset= department_tlb

Datasource

Employee_dtsr

Dataset=employee_qry

Now we did anything require for our data access part.
Lets do some data control job and finish our first MySQL learning paper
Drop the components listed below on the form and make changes with their properties as listed in the Table

Component	Name	Properties
DbGride	Employee_grd	Datasource= employee_DtMdl. employee_qry
Dbgride	Projects_grd	Datasource= employee_DtMdl. projects _tlb
Statusbar	Main_stbar	Add 1 new panel and make it a text panel
Button	Exit_btn	Caption= cancel
button	Clear_btn	Caption=Clear
Bottom	Execute_btn	Caption = Execute
Memo	SQL_mem	Lines:select * from employee where emp_no = 2
Label	No matter	Caption=Enter your SQL command here
Label	No matter	Caption=Result of your SQL command
Label	No matter	Caption=Related project for selected employee

We need frame to show some other details about our database so we need another frame or form (we add frame because it dosnt need as resources as form need)

Component	Name	Properties
Dbgrid	Jobs_grd	Datasource= employee_DtMdl. Jobs_dtsr
Dbgrid	Dep_grid	Datasource= employee_DtMdl.department_drst
Label	No matter	Caption= Selected employee job details
Label	Nomatter	Caption=selected employee department details
Button	Close_btn	Cancel=true

Now we can start coding in delph to make our test application for MySQL accessing J

We will made a master details application to show some preadvanced topic of database programming

And a SQL input box will help us to execute our query by typing and clicking on execute button.J

So design form and frame as you can see below on figures: detail_frm and main_frm
After you designed the interface you need to write some code to make application working
So we will write code for the execute button to make our query execute what we will write
In the SQL_mem .

Note:

MySQL language has some difference with ISQL (Interbase SQL) PL SQL (Oracle SQL) and T-SQL

(Ms SQL server SQL). So you need to have a look at MySQL manual which is available in www.MySQL.com

We will write one SQL sample of them together.

Figure:details_frm

Figure:master_frm

Now make following changes in the components events

For details_frm:

procedure Tdetails_frm.Button1Click(Sender: TObject);

begin

self.Close;

end;

for master_frm:

procedure Tmaster_frm.Button3Click(Sender: TObject);

begin

application.Terminate;

end;

procedure Tmaster_frm.Button1Click(Sender: TObject);

begin

SQL_mem.Lines.Clear;

end;

procedure Tmaster_frm.Button2Click(Sender: TObject);

begin

employee_dtmdl.employee_qry.close;

employee_dtmdl.employee_qry.SQL:=SQL_mem.Lines;

try

employee_dtmdl.employee_qry.Open;

details_frm.Show;

except

application.MessageBox ('There is an error in your type SQL command',' Error');

end;

Now save the project and run it J.

Amazing hum? You did your first MySQL database application using odbc driver J

Congratulation.

Undocumented MessageBoxTimeOut function

2007-08-17T11:46:00.000+03:00

There are lots of neat little things that are in many of the DLLs that Microsoft has installed in Windows. Most of them are documented in the Win32 API. However, there are a lot of them that are undocumented. This article shows how to use one of the undocumented functions available in user32.dll, MessageBoxTimeOut.

This type of functionality for a MessageBox has been requested on the Delphi newsgroups many times and there have been several solutions written. After being introduced in XP, this functionality is now available to developers using this undocumented API.

Since this function is not documented, it is not found in Windows.pas, so it has to be defined. It is identical to the MessageBox API definition except it has two more parameters, wLanguageID and dmMilliseconds.

function MessageBoxTimeOut(
hWnd: HWND; lpText: PChar; lpCaption: PChar;
uType: UINT; wLanguageId: WORD; dwMilliseconds: DWORD): Integer; stdcall;

function MessageBoxTimeOutA(
hWnd: HWND; lpText: PChar; lpCaption: PChar;
uType: UINT; wLanguageId: WORD; dwMilliseconds: DWORD): Integer; stdcall;

function MessageBoxTimeOutW(
hWnd: HWND; lpText: PWideChar; lpCaption: PWideChar;
uType: UINT; wLanguageId: WORD; dwMilliseconds: DWORD): Integer; stdcall;

implementation

// this const is not defined in Windows.pas
const
MB_TIMEDOUT = 32000;

function MessageBoxTimeOut; externaluser32 name 'MessageBoxTimeoutA';
function MessageBoxTimeOutA; external user32 name 'MessageBoxTimeoutA';
function MessageBoxTimeOutW; external user32 name 'MessageBoxTimeoutW';

Now, to call the function, it is as easy as setting the flags and making the call. There may be other results returned that I am not aware of besides the standard IDxxx return values and the MB_TIMEDOUT result defined above.

var
iResult: Integer;
iFlags: Integer;

begin
// Define a MessagBox with an OK button and a timeout of 2 seconds
iFlags := MB_OK or MB_SETFOREGROUND or MB_SYSTEMMODAL or MB_ICONINFORMATION;
iResult := MessageBoxTimeout(
Application.Handle,
'Test a timeout of 2 seconds.',
'MessageBoxTimeout Test', iFlags, 0, 2000);

// iResult will = 1 (IDOK)

ShowMessage(IntToStr(iRet));

// Define a MessageBox with a Yes and No button and a timeout of 5 seconds

iFlags := MB_YESNO or MB_SETFOREGROUND or MB_SYSTEMMODAL or MB_ICONINFORMATION;

iResult := MessageBoxTimeout(
Application.Handle,
'Test a timeout of 5 seconds.',
'MessageBoxTimeout Test', iFlags, 0, 5000);

// iResult = MB_TIMEDOUT if no buttons clicked, otherwise
// iResult will return the value of the button clicked

case iResult of
IDYES: // Pressed Yes button
ShowMessage('Yes');
IDNO: // Pressed the No button
ShowMessage('No');
MB_TIMEDOUT: // MessageBox timed out
ShowMessage('TimedOut');
end;
end;

I presume Borland will not put this into Windows.pas until Microsoft documents it but developers can get a head start on them by using the code above. It is unlikely that Microsoft will depricate this function for quite some time because all of the standard MessageBox API calls actually call MessageBoxTimeOutA or MessageBoxTimeoutW and pass $FFFFFFFF as the timeout period meaning the dialog will wait a very long time, approx 49 days!

How to check a file name against a list of masks ?

2007-08-17T11:39:00.000+03:00

{
This code can be used to test if the given filename matches with a
list of wildcards search.

examples of use :
isFileFromDefinition('c:\pictures\vanessa.jpg','*.gif;*.jpg;*.tga;*.bmp');
ifFileFromDefinition('c:\pictures\vanessa.jpg','v*.jp?');
}

uses
SysUtils, Masks; // works only from Delphi 5 and above

function isFileFromDefinition(aFilename, aMaskList: string): Boolean;
var
Definition: string;
begin
aFilename := ExtractFileName(aFilename);
Definition := '';
repeat
if Pos(';', aMaskList) > 0 then
Definition := Copy(aMaskList, 1,Pos(';', aMaskList) - 1)
else
Definition := aMaskList;
Delete(aMaskList, 1,Length(Definition) + 1);
if MatchesMask(aFileName, Definition) then
begin
Result := True;
Exit;
end;
until Length(aMaskList) = 0;
Result := False;
end;

How to detect memory leaks ?

2007-08-17T11:34:00.000+03:00

In computer science, a memory leak is a particular kind of unintentional memory consumption by a computer program where the program fails to release memory when no longer needed. This condition is normally the result of a bug in a program that prevents it from freeing up memory that it no longer needs.
A memory leak can diminish the performance of the computer by reducing the amount of available memory. Eventually, in the worst case, too much of the available memory may become allocated and all or part of the system or device stops working correctly or the application fails.
Here it is how to check for memory leaks in Delphi:

procedure TForm.DebugProcessStatus(s: string);
var
pmc: PPROCESS_MEMORY_COUNTERS;
cb: Integer;
MemStat: tMemoryStatus;
begin
MemStat.dwLength := SizeOf(MemStat);
GlobalMemoryStatus(MemStat);

// Get the total and available system memory
TotalMemoryLabel.Caption := 'Total system memory: ' +
FormatFloat('###,###', MemStat.dwTotalPhys / 1024) + ' KByte';
FreeMemoryLabel.Caption := 'Free physical memory: ' +
FormatFloat('###,###', MemStat.dwAvailPhys / 1024) + ' KByte';

// Get the used memory for the current process
cb := SizeOf(TProcessMemoryCounters);
GetMem(pmc, cb);
pmc^.cb := cb;
if GetProcessMemoryInfo(GetCurrentProcess(), pmc, cb) then
begin
NewWorkingMemory := Longint(pmc^.WorkingSetSize);
ProcessMemoryLabel.Caption := 'Process-Memory: ' +
FormatFloat('###,###', NewWorkingMemory / 1024) + ' KByte';
MemoryLeakLabel.Caption := 'Memory Loss: ' +
FormatFloat('###,###', (NewWorkingMemory - OldWorkingMemory) / 1024) + ' KByte';
OldWorkingMemory := NewWorkingMemory;
end;
FreeMem(pmc);

DebugStatusLabel.Caption := 'Status: ' + s;
end;

How to monitor a harddrive with S.M.A.R.T.

2007-08-17T11:28:00.000+03:00

{ .... }

type

TSmartData = array[0..527] of Byte;

{ .... }

procedure GetSmartData(var Data: TSmartData);

var

hdrive: Cardinal;

dwBytesReturned: DWORD;

ipar: array[0..31] of Byte;

opar: TSmartData;

begin

ipar[0] := 0;
ipar[1] := $02;
ipar[2] := 0;
ipar[3] := 0;
ipar[4] := $d0;
ipar[5] := $01;
ipar[6] := $01;
ipar[7] := $4f;
ipar[8] := $c2;
ipar[9] := $a0;
ipar[10] := $b0;
ipar[11] := 0;
ipar[12] := 0;
ipar[13] := 0;
ipar[14] := 0;
ipar[15] := 0;
ipar[16] := $8c;
ipar[17] := $fd;
ipar[18] := $14;
ipar[19] := 0;
ipar[20] := 0;
ipar[21] := $02;
ipar[22] := 0;
ipar[23] := 0;
ipar[24] := $03;
ipar[25] := 0;
ipar[26] := 0;
ipar[27] := 0;
ipar[28] := $03;
ipar[29] := 0;
ipar[30] := 0;
ipar[31] := 0;

// Get first harddrive

hdrive := CreateFile(PChar('\\.\PhysicalDrive0'), 3221225472, 3, nil, 3, 0, 0);
DeviceIoControl(hdrive, $0007C088, @ipar, 32, @opar, 528, dwBytesReturned, nil);
CloseHandle(hdrive);
Data := opar;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
StringGrid1.Cells[0, 0] := 'Description';
StringGrid1.Cells[1, 0] := 'Value';
StringGrid1.Cells[0, 1] := 'Spin Up Time';
StringGrid1.Cells[0, 2] := 'Start/Stop Count';
StringGrid1.Cells[0, 3] := 'Reallocated Sectors Count';
StringGrid1.Cells[0, 4] := 'Read Channel Margin';
StringGrid1.Cells[0, 5] := 'Seek Error Rate';
StringGrid1.Cells[0, 6] := 'Seek Time Performance';
StringGrid1.Cells[0, 7] := 'Power-On Minutes';
StringGrid1.Cells[0, 8] := 'Spin Retry Count';
StringGrid1.Cells[0, 9] := 'Recalibration Retries';
StringGrid1.Cells[0, 10] := 'Device Power Cycle Count';
StringGrid1.Cells[0, 11] := 'Load/Unload Cycle Count';
StringGrid1.Cells[0, 12] := 'Temperature';
StringGrid1.Cells[0, 13] := 'Reallocation Event Count';
StringGrid1.Cells[0, 14] := 'Current Pending Sector Count';
StringGrid1.Cells[0, 15] := 'Uncorrectable Sector Count';
StringGrid1.Cells[0, 16] := 'UDMA CRC Error Count';
StringGrid1.Cells[0, 17] := 'Write Error Rate';

Timer1.Interval := 700;
Timer1.Enabled := True;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
var
smartdatavar: TSmartData;
begin
getsmartdata(smartdatavar);
StringGrid1.Cells[1, 1] := IntToStr(smartdatavar[24] * 256 + smartdatavar[23]);
StringGrid1.Cells[1, 2] := IntToStr(smartdatavar[36] * 256 + smartdatavar[35]);
StringGrid1.Cells[1, 3] := IntToStr(smartdatavar[48] * 256 + smartdatavar[47]);
StringGrid1.Cells[1, 4] := IntToStr(smartdatavar[60] * 256 + smartdatavar[59]);
StringGrid1.Cells[1, 5] := IntToStr(smartdatavar[72] * 256 + smartdatavar[71]);
StringGrid1.Cells[1, 6] := IntToStr(smartdatavar[84] * 256 + smartdatavar[83]);
StringGrid1.Cells[1, 7] := IntToStr(smartdatavar[96] * 256 + smartdatavar[95]);
StringGrid1.Cells[1, 8] := IntToStr(smartdatavar[108] * 256 + smartdatavar[107]);
StringGrid1.Cells[1, 9] := IntToStr(smartdatavar[120] * 256 + smartdatavar[119]);
StringGrid1.Cells[1, 10] := IntToStr(smartdatavar[132] * 256 + smartdatavar[131]);
StringGrid1.Cells[1, 11] := IntToStr(smartdatavar[156] * 256 + smartdatavar[155]);
StringGrid1.Cells[1, 12] := IntToStr(smartdatavar[168] * 256 + smartdatavar[167]);
StringGrid1.Cells[1, 13] := IntToStr(smartdatavar[192] * 256 + smartdatavar[191]);
StringGrid1.Cells[1, 14] := IntToStr(smartdatavar[204] * 256 + smartdatavar[203]);
StringGrid1.Cells[1, 15] := IntToStr(smartdatavar[216] * 256 + smartdatavar[215]);
StringGrid1.Cells[1, 16] := IntToStr(smartdatavar[228] * 256 + smartdatavar[227]);
StringGrid1.Cells[1, 17] := IntToStr(smartdatavar[240] * 256 + smartdatavar[239]);
end;

How to convert from HTML color to delphi color

2007-08-14T11:57:00.000+03:00

Here is a sample of code how to convert from HTML color representation to Delphi colors:

function HtmlToColor(Color: string): TColor;
begin
 Result := StringToColor('$' + Copy(Color, 6, 2) + Copy(Color, 4, 2) + Copy(Color, 2, 2));
end;

I write a small example program:

unit Unit1;

interface

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

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

var
 Form1: TForm1;

implementation

{$R *.dfm}
function HtmlToColor(Color: string): TColor;
begin
 Result := StringToColor('$' + Copy(Color, 6, 2) + Copy(Color, 4, 2) + Copy(Color, 2, 2));
end;


procedure TForm1.Button1Click(Sender: TObject);
begin
Shape1.Brush.Color:=HtmlToColor(Edit1.Text);
Shape1.Invalidate;
end;

end.

Variants and COM

2007-07-13T21:07:00.000+03:00

Empty and Null

Variants can handle several datatypes and some special states as EMPTY and NULL. Before you
assign a value to a variant, it has the state EMPTY. There are a lot of functions to check the
state or type of a variant and there are predefined variants you can use.

uses Variants;

procedure VariantDemo;
var
  vDemo: Variant;
  bTest: Boolean;
begin
  // EMPTY
  vDemo := Unassigned;          // assign EMPTY to variant
  bTest := VarIsEmpty(vDemo);   // check if variant is EMPTY
  // NULL
  vDemo := NULL;                // assign NULL to variant
  bTest := VarIsNull(vDemo);    // check if variant is NULL
  // numeric
  vDemo := 8.8;                 // assign a float to variant
  bTest := VarIsNumeric(vDemo); // check if variant is numeric
  // text
  vDemo := 'demo';              // assign a string to variant
  bTest := VarIsStr(vDemo);     // check if variant contains text
  // COM methods can define obtional parameters. if you are
  // working with typelibraries you have to pass a parameter
  // nevertheless, then you can pass "EmptyParam"
  vDemo := EmptyParam;
  bTest := VarIsEmptyParam(vDemo);
end;

How to register a COM server

Before you can use and test your new created COM server, you have to register it. You can do
this with the Delphi menu Start\Register ActiveX-Server or you can register it by
yourself. It depends on the kind of server you have (in-process *.dll or out-of-process *.exe)
how to register the server.

	Register	Unregister
in-process (MyServer.dll)	`regsvr32 MyServer.dll`	`regsvr32 /u MyServer.dll`
out-of-process (MyServer.exe)	`MyServer.exe /regserver`	`MyServer.exe /unregserver`

If you often have to do with COM servers, it is very useful to be able to (un)register them
in the explorer. It's not difficult to extend the explorer's context menu, you can use this
small reg file to add a "Register" and an "UnRegister" entry.

Download regfile	StoComRegister.zip

User actions while (un)registering a COM server

With an in-process server (DLL), you have the possiblility to run additional code at the
time of (un)registering. Creating a COM library, the delphi IDE will produce a projectfile like
this:

library Project1;

uses
  ComServ;

exports
  DllGetClassObject,
  DllCanUnloadNow,
  DllRegisterServer,
  DllUnregisterServer;

{$R *.RES}

begin
end.

The functions "DllRegisterServer" and "DllUnregisterServer" are exported, and will be called
when the user or the setup registers the server. You can detour this call to take your own
actions, but make sure no errors can occur in this place.

library Project1;

uses
  ComServ;

  function CustomDllRegisterServer: HResult; stdcall;
  begin
    // call the standard function
    Result := DllRegisterServer;
    // execute your own code
    // ...
  end;

  function CustomDllUnregisterServer: HResult; stdcall;
  begin
    // call the standard function
    Result := DllUnregisterServer;
    // execute your own code
    // ...
  end;

exports
  DllGetClassObject,
  DllCanUnloadNow,
  CustomDllRegisterServer name 'DllRegisterServer',
  CustomDllUnregisterServer name 'DllUnregisterServer';

{$R *.RES}

begin
end.

Modal forms in COM

When you are using modal forms in a COM server, you will miss the support of the menu
shortcuts and the automatic navigation between the controls with the TAB key. this is because
the "Application" object doesn't handle the windows messages, it is the window of the client
application.

// if you display a form from inside a COM server, you will miss the
// automatic navigation between the controls with the "TAB" key.
// the "KeyPreview" property of the form has to be set to "True".
procedure TForm1.FormKeyPress(Sender: TObject; var Key: Char);
var
  bShift: Boolean;
begin
  // check for tab key and switch focus to next or previous control.
  // handle this in the KeyPress event, to avoid a messagebeep.
  if (Ord(Key) = VK_TAB) then
  begin
    bShift := Hi(GetKeyState(VK_SHIFT)) <> 0;
    SelectNext(ActiveControl, not(bShift), True);
    Key := #0; // mark as handled
  end;
end;

// if you display a form from inside a COM server, you will miss the
// support of the menu- and action- shortcuts like "<Ctrl><S>".
// the "KeyPreview" property of the form has to be set to "True".
procedure TForm1.FormKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);
const
  AltMask = $20000000;
var
  myMessage: TWMKey;
begin
  // recreate the original "KeyUp" message
  FillChar(myMessage, SizeOf(TWMKey), 0);
  myMessage.Msg := WM_KEYUP;
  myMessage.CharCode := Key;
  if (ssAlt in Shift) then
    myMessage.KeyData := AltMask;
  // find and execute matching shortcut
  if IsShortCut(myMessage) then
    Key := 0; // mark as handled
end;

Using interfaces without COM

Normally you will use interfaces in combination with COM objects. In contrast to
conventional objects, a COM object supports reference counting and will free itself when the
last reference is released.

You can use interfaces for your conventional objects too, without supporting reference
counting and automatically freeing. Doing this, you have to pay attention to some special
facts.

ITest = interface(IInterface)
  // press <ctrl><shift><g> to create your own GUID for each interface.
  // this is necessary to implement the "QueryInterface" method.
  ['{CA51B752-0DF5-40D2-945C-A5CF2EAA3B31}']
  procedure ShowText;
end;

TTest = class(TObject, ITest)
protected
  FText: String;
  // IInterface
  function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
  function _AddRef: Integer; stdcall;
  function _Release: Integer; stdcall;
  // ITest
  procedure ShowText;
end;

Because every interface inherites from the parent interface "IInterface" (same as windows
specific "IUnknown"), you have to support at least the three methods of "IInterface". This
example shows a standard implementation.

function TTest._AddRef: Integer;
begin
  Result := -1; // no reference counting supported
end;

function TTest._Release: Integer;
begin
  Result := -1; // no reference counting supported
end;

function TTest.QueryInterface(const IID: TGUID; out Obj): HResult;
begin
  if GetInterface(IID, Obj) then
    Result := S_OK
  else
    Result := E_NOINTERFACE;
end;

procedure TTest.ShowText;
begin
  ShowMessage(FText);
end;

When you later use the object, you have to be careful, that at the moment of destruction, no
reference to the interface remains.

procedure WellUsed;
var
  myTestObject: TTest;
  pTestInterface: ITest;
begin
  // creating the object
  myTestObject := TTest.Create;
  // get a reference to the interface of the object, this will implicitly call "_AddRef"
  pTestInterface := myTestObject;
  // ...
  // release the reference to the interface, this will implicitly call "_Release"
  pTestInterface := nil;
  // freeing the object itself
  myTestObject.Free;
end;

If you free the object, before the last reference to the interface is released, then the
implicitly call to "_Release" will call to a not existing object (Delphi will release the
interface automatically, if you don't do it yourself).

procedure WrongUsed;
var
  myTestObject: TTest;
  pTestInterface: ITest;
begin
  myTestObject := TTest.Create;
  pTestInterface := myTestObject;
  // ...
  // freeing the object with an existing reference
  myTestObject.Free;
  // this releasing of the interface will implicitly call "_Release", but there
  // is no living object anymore.
  pTestInterface := nil;
end;

Normally, calling a method of a not existing object will cause a runtime error, not in our
example. That's because no member of the object is used inside "_Release", as soon as you
access a member, you will get the expected error. So, first make sure you don't call a
"_Release" on a not existing object, then don't access members inside of "_Release".

function TTest._Release: Integer;
begin
  // this will cause an error, if the reference is released after the object was freed.
  FText := '';
  Result := -1; // no reference counting supported
end;

Global mouse hook

2007-06-16T09:47:00.000+03:00

Here is a global mouse hook on Delphi which will intercept middle (scroll) button click (WM_NCMBUTTONDOWN and WM_MBUTTONDOWN messages), check if any top level window is under the cursor and if yes then minimize that window.

The code is pretty simple.

We need two projects: one - which runs the hook and then kills it; the other - the hook itself (it is supposed to be a DLL because it is a global hook). Nothing difficult (at least if you what is DLL and how to use them)!

Here is the mouse hook (WH_MOUSE) implementation:

library MiddleButton;

uses
Windows,
Messages;

const
MemMapFile = 'temp_thief';
type
PDLLGlobal = ^TDLLGlobal;
TDLLGlobal = packed record
HookHandle: HHOOK;
end;

var
GlobalData: PDLLGlobal;
MMF: THandle;

{$R *.res}

function HookProc(Code: integer; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall;
var
CurrWND: THandle;
begin
if Code < wparam =" WM_NCMBUTTONDOWN)" wparam =" WM_MBUTTONDOWN)" mmf =" 0" globaldata =" nil">nil then
UnmapViewOfFile(GlobalData);

if MMF<> INVALID_HANDLE_VALUE then
CloseHandle(MMF);
end;

procedure RunHook; stdcall;
begin
GlobalData^.HookHandle:= SetWindowsHookEx(WH_MOUSE, @HookProc, HInstance, 0);
if GlobalData^.HookHandle = INVALID_HANDLE_VALUE then
begin
MessageBox(0, 'Error :)' , '' , MB_OK);
Exit;
end;
end;

procedure KillHook; stdcall;
begin
if (GlobalData<>nil) and (GlobalData^.HookHandle<>INVALID_HANDLE_VALUE) then
UnhookWindowsHookEx(GlobalData^.HookHandle);
end;

procedure DLLEntry(dwReason: DWORD);
begin
case dwReason of
DLL_PROCESS_ATTACH: CreateGlobalHeap;
DLL_PROCESS_DETACH: DeleteGlobalHeap;
end;
end;

exports
KillHook,
RunHook;

begin
DLLProc:= @DLLEntry;
DLLEntry(DLL_PROCESS_ATTACH);
end.And here is an implementation of the hook launcher:
unit RunMiddleButton;

interface

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

type
TfrmMain = class(TForm)
btnRunHook: TButton;
btnKillHook: TButton;
procedure btnRunHookClick(Sender: TObject);
procedure btnKillHookClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

procedure RunHook; stdcall; external 'MiddleButton.dll' name 'RunHook';
procedure KillHook; stdcall; external 'MiddleButton.dll' name 'KillHook';

var
frmMain: TfrmMain;

implementation

{$R *.dfm}

procedure TfrmMain.btnRunHookClick(Sender: TObject);
begin
RunHook;
end;

procedure TfrmMain.btnKillHookClick(Sender: TObject);
begin
KillHook;
end;

end.

Rounded buttons with bitmaps for the up/down state

2007-06-15T01:22:00.000+03:00

unit Bibutton;

interface

uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, ExtCtrls;

type
TBiButton = class(TCustomControl)
private
FTPicture : TPicture;
FPPicture : TPicture;
FOnPaint : TNotifyEvent;
FRegion : THandle;
FBRegion : THandle;
FBorder : Boolean;
FOffset : Integer;
FCaption : String;

FXRad,
FYRad : Integer;

Down,
Pressed : Boolean;

procedure SetTPicture (Value : TPicture);
procedure SetPPicture (Value : TPicture);
procedure SetXRadius (Value : Integer);
procedure SetYRadius (Value : Integer);
procedure SetBorder (Value : Boolean);
procedure PictureChanged(Sender : TObject);
procedure WM_LButtonDown (var Msg : TWMLButtonDown); message wm_LButtonDown;
procedure WM_LButtonUp (var Msg : TWMLButtonUp); message wm_LButtonUp;
procedure WM_MouseMove (var Msg : TWMMouseMove); message wm_MouseMove;
procedure WM_Size (var Msg : TWMSize); message wm_Size;
procedure SetRegion;
procedure SetOffest(const Value: Integer);
procedure SetCaption(const Value: String);

public
constructor Create (AOwner : TComponent); override;
destructor Destroy; override;
property Canvas;

protected
function GetPalette : HPalette; override;
procedure Paint; override;

published
// The "not-pressed-picture"
property TopPicture : TPicture read FTPicture write SetTPicture;
// The "pressed-picture" - if none, TopPicture will be used
property PressedPicture : TPicture read FPPicture write SetPPicture;
// for round buttons
property XRadius : Integer read FXRad write SetXRadius;
property YRadius : Integer read FYRad write SetYRadius;
// showing a border or not
property Border : Boolean read FBorder write SetBorder;
// offset of the "pressed-picture"
property Offset : Integer read FOffset write SetOffest;
property Caption : String read FCaption write SetCaption;

property Color;
property Font;
property Align;
property Visible;
property ShowHint;
property Enabled;
property ParentColor;
property ParentFont;
property ParentShowHint;
property TabOrder;
property OnClick;
property OnDblClick;
property OnDragDrop;
property OnDragOver;
property OnEnter;
property OnExit;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
end;

procedure Register;

implementation

procedure Register;
begin
RegisterComponents('GBit', [TBiButton]);
end;

constructor TBiButton.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FRegion := 0;
FBRegion := 0;
ControlStyle := [csCaptureMouse, csClickEvents];
FTPicture := TPicture.Create;
FTPicture.OnChange := PictureChanged;
FPPicture := TPicture.Create;
FPPicture.OnChange := PictureChanged;
FBorder := True;
Height := 100;
Width := 100;
XRadius := Width;
YRadius := Height;
Offset := 2;
Pressed := False;
end;

destructor TBiButton.Destroy;
begin
FTPicture.Free;
FPPicture.Free;
DeleteObject (FRegion);
DeleteObject (FBRegion);
inherited Destroy;
end;

function TBiButton.GetPalette: HPalette;
begin
Result := 0;
if FTPicture.Graphic is TBitmap then
Result := TBitmap(FTPicture.Graphic).Palette;
end;

procedure TBiButton.SetTPicture(Value: TPicture);
begin
FTPicture.Assign(Value);
end;

procedure TBiButton.SetPPicture(Value: TPicture);
begin
FPPicture.Assign(Value);
end;

procedure TBiButton.Paint;
var
Rect : TRect;
Ha : HDC;
ps : TPaintStruct;
x, y : Integer;
R, rx,
G, gx,
B, bx : Word;
AColor,
LightC,
DarkC : TColor;
begin
Rect := GetClientRect;
InvalidateRgn (Handle, FRegion, False);
try
SetWindowRgn (Self.Handle, FBRegion, True);
except
end;

if Color < width =" Width)" height =" Height)" width =" Width)" height =" Height)"> Down then begin
Down := D;
Invalidate;
end;
end;
inherited;
end;

procedure TBiButton.SetYRadius (Value : Integer);
begin
if Value > Height then
Value := Height;
if Value <> YRadius then begin
FYRad := Value;
SetRegion;
Invalidate;
end;
end;

procedure TBiButton.SetXRadius (Value : Integer);
begin
if Value > Width then
Value := Width;
if Value <> XRadius then begin
FXRad := Value;
SetRegion;
Invalidate;
end;
end;

procedure TBiButton.SetRegion;
begin
DeleteObject (FRegion);
DeleteObject (FBRegion);
if XRadius > Width then
FXRad := Width;
if YRadius > Height then
FYRad := Height;
FRegion := CreateRoundRectRgn (0, 0, Width+1, Height+1, XRadius, YRadius);
FBRegion := CreateRoundRectRgn (0, 0, Width+1, Height+1, XRadius, YRadius);
end;

procedure TBiButton.WM_Size (var Msg : TWMSize);
begin
SetRegion;
Invalidate;
end;

procedure TBiButton.SetBorder (Value : Boolean);
begin
if Value <> FBorder then begin
FBorder := Value;
Invalidate;
end;
end;

procedure TBiButton.SetOffest(const Value: Integer);
begin
FOffset := Value;
Invalidate;
end;

procedure TBiButton.SetCaption(const Value: String);
begin
FCaption := Value;
Invalidate;
end;

end.

Drawing a form by the shape of a bitmap

2007-06-10T14:38:00.000+03:00

Question:

How do i shape a form by the outlines of a TBitmap image?

Answer:

How to make this work for your application :
-------------------------------------------------

(I rewrote this part since some people didn't
manage to run the application)

1. Create new application.
2. Insert a TBitmap object called 'image1'
and place it in the most top-left location
by setting the top and left properties of
the TImage object to zero.
(selecting a bmp for it will be cool too-
do that by clicking the 'Picture' property
of the TImage object)
3. Paste my code into you project.
4. Assign the FormCreate proc of your form.
(by double clicking the 'OnCreate' event
in the object inspector)
5. Set the form's border style to bsNone.
6. Press F9 :)
(in order to close the application
press Alt+F4)

Some comments
-------------------------------------------------

1. The image must be saved as 24bit format.
(However , you CAN make it work in other
formats too, but that'll require some
changes in the code)

2. This code will assume that the [0,0]
pixel is background color and should
not be visable.(you can change that
by assigning something else to the
'transp' variable located at the
beggining of the FormCreate proc)
All pixels in your image, that has
the same color as [0,0] will become
transparent.

3. I wrote this one after I read the an
article in the GUI category and decided
that there must be a shorter way of
doing this.

The code
---------------------------------------------

unit Unit1;

interface

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

type

//structure of the bitmap
bit24=record
r,g,b:byte;
end;
bit24array=array[0..0] of bit24;
pbit24array=^bit24array;

TForm1 = class(TForm)
Image1: TImage;
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
var
x,y,rc:integer;
tmprgn,tmprgn2,tmprgn3: HRGN;
NewRgn : HRGN;
b:tbitmap;
p:pbit24Array;
transp:bit24;
begin
NewRgn := CreateRectRgn(0,0,0,0);
b:=image1.Picture.Bitmap;
p:= b.scanline[0];

//change this in order to set other color as bg
transp:=p[0];

//loop for lines
for y := 0 to b.height-1 do
begin
p:= b.scanline[y];
x:=0;

//loop for rows :
//this loop looks very stupid...
//but it didn't work any other way:
while x<(b.width) do if (p[x].r<>transp.r)or(p[x].g<>transp.g)
or(p[x].b<>transp.b) then
begin
rc:=1;
while (p[x+rc].r<>transp.r)and(p[x+rc].g<>transp.g)
and(p[x+rc].b<>transp.b) do inc(rc);
tmprgn:=CreateRectRgn(x,y,x+rc,y+1);
tmpRgn2:=CreateRectRgn(0,0,0,0);
CombineRgn(tmpRgn2,newRgn,tmpRgn,RGN_OR);
DeleteObject(newrgn);
newrgn := tmprgn2;
inc(x,rc);
end else inc(x);
end;
//set to the new region
SetWindowRgn(handle,NewRgn,false);
DeleteObject(newrgn);
DeleteObject(tmprgn);
DeleteObject(tmprgn2);
end;

end.

Enjoy !

How to create a non-rectangular form

2006-07-13T21:19:00.000+03:00

And how to do this? Here you will find a simple example that just gives some text and sets the region like it. Expand it by your mind!

unit uMainForm;

interface

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

type
TfrmMainForm = class(TForm)
btnDoAction: TButton;
pmnPopup: TPopupMenu;
miDrawText: TMenuItem;
miExit: TMenuItem;
procedure btnDoActionClick(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure miExitClick(Sender: TObject);
private
{ Private declarations }
HRgn: THandle;
public
{ Public declarations }
end;

var
frmMainForm: TfrmMainForm;

implementation

{$R *.DFM}

procedure TfrmMainForm.btnDoActionClick(Sender: TObject);
var
s: String;
begin
DeleteObject(HRgn);
s := InputBox('Region Text', 'Please enter some text to set to the region', 'CoolRgn');

BeginPath(Canvas.Handle);
with Canvas do
begin
Font.Name := 'Comic Sans MS'; Font.Size := 64; Font.Style := [fsBold];
TextOut(0, 0, s);
end;

EndPath(Canvas.Handle);
HRgn := PathToRegion(Canvas.Handle);
SetWindowRgn(Handle, HRgn, True);

btnDoAction.Visible := False;
Color := clRed;
end;

procedure TfrmMainForm.FormClose(Sender: TObject;
var Action: TCloseAction);
begin
DeleteObject(HRgn);
end;

procedure TfrmMainForm.FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
if Button = mbLeft then
begin
ReleaseCapture;
SendMessage(Handle, WM_NCLBUTTONDOWN, HTCAPTION, 0);
end;
end;

procedure TfrmMainForm.miExitClick(Sender: TObject);
begin
Application.MainForm.Close;
end;

end.

Using Google Translate from Delphi

2006-06-24T13:03:00.000+03:00

This is how to translate a text unsing Google Translate from Delphi:
For sending data to Google will use http GET method.

function translate(ss,lng:string):string;
var s:widestring;
a,b:integer;
http:tidhttp;
begin
http:=tidhttp.Create;
s:=http.Get('http://translate.google.com/translate_t?text='
+httpencode(ss)+'&langpair='+lng);
a:=posex('›',s,pos('‹textarea',s));
b:=posex('‹/textarea›',s,a);
result:=copy(s,a+1,b-a-1);
http.Free;
end;

where ss is the text to be translated and lng is the string that tell
Google from and to what language to translate.
Here is some definiton of lng:

lng:array[0..17]of string=('zh-CN%7Cen',
'en%7Czh-CN',
'en%7Cfr',
'en%7Cde',
'en%7Cit',
'en%7Cja',
'en%7Cko',
'en%7Cpt',
'en%7Ces',
'fr%7Cen',
'fr%7Cde',
'de%7Cen',
'de%7Cfr',
'it%7Cen',
'ja%7Cen',
'ko%7Cen',
'pt%7Cen',
'es%7Cen');

Making life easier with Indy

2006-02-17T01:14:00.000+02:00

Let's take a look at the networking in Delphi.
One of the best library for writing network applications in Delphi is with no doubt Indy. It has almost everything someone wished for internt programming.

In the begining because today Google makes the net goes round ;) , let see how can use pop3 for retrieving mails from your Gmail account.

Drop on your form: a button, a listbox, one TIdPOP3, one TIdSSLIOHandlerSocketOpenSSL and one TIdMessage. Make the set the components that .dfm look like this:

object Form1: TForm1
Left = 0
Top = 0
Width = 420
Height = 378
Caption = 'Form1'
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'Tahoma'
Font.Style = []
OldCreateOrder = False
PixelsPerInch = 96
TextHeight = 13
object Button1: TButton
Left = 16
Top = 16
Width = 75
Height = 25
Caption = 'Button1'
TabOrder = 0
OnClick = Button1Click
end
object ListBox1: TListBox
Left = 32
Top = 72
Width = 345
Height = 265
ItemHeight = 13
TabOrder = 1
end
object pop: TIdPOP3
IOHandler = IdSSLIOHandlerSocketOpenSSL1
AutoLogin = True
Host = 'pop.gmail.com'
Username = 'youruser@gmail.com'
UseTLS = utUseImplicitTLS
Password = 'yourpassword'
Port = 995
SASLMechanisms = <>
Left = 208
Top = 16
end
object msg: TIdMessage
AttachmentEncoding = 'MIME'
BccList = <>
CCList = <>
Encoding = meDefault
FromList = <>
Recipients = <>
ReplyTo = <>
ConvertPreamble = True
Left = 304
Top = 24
end
object IdSSLIOHandlerSocketOpenSSL1: TIdSSLIOHandlerSocketOpenSSL
Destination = 'pop.gmail.com:995'
Host = 'pop.gmail.com'
MaxLineAction = maException
Port = 995
DefaultPort = 0
SSLOptions.Method = sslvSSLv2
SSLOptions.Mode = sslmUnassigned
SSLOptions.VerifyMode = []
SSLOptions.VerifyDepth = 0
Left = 160
Top = 32
end
end

This is a simple application and i only show here how to retrieve the number of messages from the inbox and the subject. For everything eles use your imagination :D

unit Unit1;

interface

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, IdIOHandler, IdIOHandlerSocket, IdIOHandlerStack, IdSSL,
IdSSLOpenSSL, IdMessage, IdBaseComponent, IdComponent, IdTCPConnection,
IdTCPClient, IdExplicitTLSClientServerBase, IdMessageClient, IdPOP3;

type
TForm1 = class(TForm)
Button1: TButton;
pop: TIdPOP3;
msg: TIdMessage;
IdSSLIOHandlerSocketOpenSSL1: TIdSSLIOHandlerSocketOpenSSL;
ListBox1: TListBox;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);
var n,i:integer;
begin
pop.Connect;
n:=pop.CheckMessages;
listbox1.Items.Add(format('There are %d messages',[n]));
for i:=0 to n-1 do
begin
pop.Retrieve(i,msg);
listbox1.Items.Add(format('%d - %s',[i,msg.Subject]));
application.ProcessMessages;
end;
pop.Disconnect;
end;

end.

I hope this helps you and if you got any questions feel free to ask.
Good luck !

First steps

2006-02-16T01:26:00.000+02:00

Hello Delphi fans and users!

I'd like to share you my knowledge in Delphi programming and also some piece of code that'll make your life easyer.

Living in the era of internet, make us bump into it every step we make, so any day-by-day applications make use of internet. Maybe many of you tried to make a program that use some network, and maybe you found that is not that easy. I try to post here some tips and techniques to help you.

DISCLAIMER

All you can find here you may freely use into yor programs.
I strongly recommend NOT to use any piece of code for malware developement.
Any abuse you make you make on your own. I didn't assume any responsability of code usage, even it destroys your hardware, software or even your life.