Tips 12

Listbox with colored lines

Colored lines in listbox are more user-friendly and easy to read. Here is how to do it…
First of all, place ListBox component on a form and set Style property to lbOwnerDrawFixed. The rest is simple:

unit Unit1;

interface

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

type
TForm1 = class(TForm)
ListBox1: TListBox;
Button1: TButton;
procedure FormCreate(Sender: TObject);
procedure ListBox1DrawItem(Control: TWinControl; Index: Integer; Rect: TRect; State: TOwnerDrawState);
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.FormCreate(Sender: TObject);
begin
ListBox1.Style := lbOwnerDrawFixed;
end;

procedure TForm1.ListBox1DrawItem(Control: TWinControl; Index: Integer; Rect: TRect; State: TOwnerDrawState);
begin
with Control as TListBox do
begin
Canvas.FillRect(Rect);
Canvas.Font.Color := TColor(Items.Objects[Index]);
Canvas.TextOut(Rect.Left + 2, Rect.Top, Items[Index]);
end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
ListBox1.Items.AddObject('Red line', Pointer(clRed));
ListBox1.Items.AddObject('Green line', Pointer(clGreen));
end;

end.

Tips 11

Change color of ListView items

To change background color of ListView items, you need to write your own OnCustomDrawItem event handler.
The best result is when you set the ViewStyle to vsReport, but it’s completely functional even with vsList style. OnCustomDrawItem code is very simple:

unit Unit1;

interface

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

type
TForm1 = class(TForm)
ListView1: TListView;
procedure ListView1CustomDrawItem(Sender: TCustomListView; Item: TListItem; State: TCustomDrawState; var DefaultDraw: Boolean);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.ListView1CustomDrawItem(Sender: TCustomListView; Item: TListItem; State: TCustomDrawState; var DefaultDraw: Boolean);
begin
with ListView1.Canvas.Brush do
begin
case Item.Index of
0: Color := clYellow;
1: Color := clGreen;
2: Color := clRed;
end;
end;
end;

end.

Tips 10

Change font, size and style of hint

Hints are everywhere. Almost every GUI element in Windows can be “hinted”. When user hover mouse over element, small yellow bubble with help text pops up. Is it possible to change hint “window” behavior? Of course…

To see how to change default color and timeouts of hint bubble, visit this post. To change font, size and style of the hint text, just use this code:

unit Unit1;

interface

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

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

type
TExHint = class(THintWindow)
constructor Create(AOwner: TComponent); override;
end;

var
Form1: TForm1;

implementation

{$R *.dfm}

constructor TExHint.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
with Canvas.Font do
begin
Name := 'Verdana';
Size := Size + 15;
Style := [fsBold, fsItalic];
end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
HintWindowClass := TExHint;
end;

end.

Tips 9

Get Process Memory Info

If you want to know how many bytes of memory is using your process, here is simple example.
We will need standard psAPI unit. Using API function GetProcessMemoryInfo, we can get amount of used bytes of memory.

unit Unit1;

interface

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

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
pmc: PPROCESS_MEMORY_COUNTERS;
cb: Integer;
begin
cb := SizeOf(_PROCESS_MEMORY_COUNTERS);
GetMem(pmc, cb);
pmc^.cb := cb;
if GetProcessMemoryInfo(GetCurrentProcess(), pmc, cb) then ShowMessage(IntToStr(pmc^.WorkingSetSize) + ' Bytes')
else ShowMessage('Unable to get process info');
FreeMem(pmc);
end;

end.

Tips 8

How to detect system time change

If the user changes the system time either with Date and Time properties dialog box or using command line, we can detect this by catching WM_TIMECHANGE system message. Here is how.

unit Unit1;

interface

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

type
TForm1 = class(TForm)
private
{ Private declarations }
procedure WMTimeChange(var Msg: TMessage); message WM_TIMECHANGE;
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.WMTimeChange(var Msg: TMessage);
begin
ShowMessage('System time was just changed!');
end;

end.

Tips 7

How to detect clipboard change

Detecting clipboard change is very similar to detecting system time change. We will detect WM_DRAWCLIPBOARD system message.

unit Unit1;

interface

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

type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
procedure ClipBoardChanged(var Message: TMessage); message WM_DRAWCLIPBOARD;
end;

var
Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.ClipBoardChanged(var Message: TMessage);
begin
ShowMessage('Clipboard changed!');
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
SetClipboardViewer(Handle);
end;

end.

Tips 6

Add own item to Internet Explorer Tools menu

If you want to add own items to Tools menu of Internet Explorer, it’s simple. All we have to do is to add some keys to Windows registry, therefore we must use Registry unit.
As you can see in source code, we must specify the menu item label (or button label) and of course the path of file we want to run. As example, we will run Calc.exe.

unit Unit1;

interface

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

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

var
Form1: TForm1;

implementation

{$R *.dfm}

procedure IEButton(Path: string);
const
Tagit = '\{10954C80-4F0F-11d3-B17C-00C0DFE39736}\';
var
Reg: TRegistry;
Key: string;
begin
Reg := TRegistry.Create;
try
with Reg do
begin
RootKey := HKEY_LOCAL_MACHINE;
Key := 'Software\Microsoft\Internet Explorer\Extensions' + Tagit;
OpenKey(Key, True);
WriteString('ButtonText', 'Toolbar button label');
WriteString('MenuText', 'Menu item label');
WriteString('MenuStatusBar', 'Run Script');
WriteString('ClSid', '{1FBA04EE-3024-11d2-8F1F-0000F87ABD16}');
WriteString('Default Visible', 'Yes');
WriteString('Exec', Path);
WriteString('HotIcon', ',4');
WriteString('Icon', ',4');
end
finally
Reg.CloseKey;
Reg.Free;
end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
IEButton('c:\windows\system32\calc.exe');
end;

end.

Tips 5

Own cool text cursor in Editbox

Standard text cursor is boring. What about replacing default vertical line with some cool shape?



unit Unit1;

interface

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

type
TForm1 = class(TForm)
Edit1: TEdit;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
CaretBm : TBitmap;
CaretBmBk : TBitmap;
OldEditsWindowProc : Pointer;
end;

type
WParameter = LongInt;
LParameter = LongInt;



var
Form1: TForm1;

implementation

{$R *.dfm}

function NewWindowProc(WindowHandle : hWnd; TheMessage : WParameter; ParamW : WParameter; ParamL : LParameter) : LongInt stdcall;
begin
NewWindowProc := CallWindowProc(Form1.OldEditsWindowProc, WindowHandle, TheMessage, ParamW, ParamL);

if TheMessage = WM_SETFOCUS then
begin
CreateCaret(WindowHandle, Form1.CaretBm.Handle, 0, 0);
ShowCaret(WindowHandle);
end;

if TheMessage = WM_KILLFOCUS then
begin
HideCaret(WindowHandle);
DestroyCaret;
end;

if TheMessage = WM_KEYDOWN then
begin
if ParamW = VK_BACK then CreateCaret(WindowHandle, Form1.CaretBmBk.Handle, 0, 0)
else CreateCaret(WindowHandle, Form1.CaretBm.Handle, 0, 0);
ShowCaret(WindowHandle);
end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin

//normal cursor
CaretBm := TBitmap.Create;
CaretBm.Canvas.Font.Name := 'WingDings';
CaretBm.Canvas.Font.Height := Edit1.Font.Height;
CaretBm.Canvas.Font.Color := clWhite;
CaretBm.Width := CaretBm.Canvas.TextWidth('J') + 2;
CaretBm.Height := CaretBm.Canvas.TextHeight('J') + 2;
CaretBm.Canvas.Brush.Color := clBlue;
CaretBm.Canvas.FillRect(Rect(0, 0, CaretBm.Width, CaretBm.Height));
CaretBm.Canvas.TextOut(1, 1, 'J');

//backspace cursor
CaretBmBk := TBitmap.Create;
CaretBmBk.Canvas.Font.Name := 'WingDings';
CaretBmBk.Canvas.Font.Height := Edit1.Font.Height;
CaretBmBk.Canvas.Font.Color := clWhite;
CaretBmBk.Width := CaretBmBk.Canvas.TextWidth('L') + 2;
CaretBmBk.Height := CaretBmBk.Canvas.TextHeight('L') + 2;
CaretBmBk.Canvas.Brush.Color := clBlue;
CaretBmBk.Canvas.FillRect(Rect(0, 0, CaretBmBk.Width, CaretBmBk.Height));
CaretBmBk.Canvas.TextOut(1, 1, 'L');
OldEditsWindowProc := Pointer(SetWindowLong(Edit1.Handle, GWL_WNDPROC, LongInt(@NewWindowProc)));
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
SetWindowLong(Edit1.Handle, GWL_WNDPROC, LongInt(OldEditsWindowProc));
CaretBm.Free;
CaretBmBk.Free;
end;

end.

Tips 4

Edit and Display Boolean Fields using a CheckBox in Delphi's DBGrid


A series of articles titled Adding components to a DBGrid discusses placing just about any Delphi control (visual component) into a cell of a . The idea is to create visually more attractive user interfaces for editing fields inside a DBGrid: a ComboBox for drop down lists; a DateTimePicker (calendar) for date values; a check box for boolean fields.
CheckBox for Boolean Fields
The article CheckBox inside a DBGrid provides one method of using a check box control to edit and display values for boolean fields.

As noticed by Rene van der Heijden the solution is rather lengthy, and it doesn't work, at least not when using the mouse to click on the checkboxes.

Rene suggest an easier approach needing only two even handlers: OnCellClick and OnCustomDrawCell for your DBGrid control:

//OnCellClik event of a DBGrid1
procedure TForm.DBGrid1CellClick(Column: TColumn) ;
begin
if (Column.Field.DataType=ftBoolean) then
begin
{toggle True and False}
Column.Grid.DataSource.DataSet.Edit;
Column.Field.Value:= not Column.Field.AsBoolean;
{immediate post - see for yourself whether you want this}
Column.Grid.DataSource.DataSet.Post;
{you may add additional functionality here,
to be processed after the change was made}
end;
end;

//OnDrawColumnCell event of a DBGrid1
procedure TForm.DBGrid1DrawColumnCell(
Sender: TObject;
const Rect: TRect;
DataCol: Integer;
Column: TColumn;
State: TGridDrawState) ;
const
CtrlState: array[Boolean] of integer = (DFCS_BUTTONCHECK, DFCS_BUTTONCHECK or DFCS_CHECKED) ;
begin
if (Column.Field.DataType=ftBoolean) then
begin
DBGrid1.Canvas.FillRect(Rect) ;
if VarIsNull(Column.Field.Value) then
DrawFrameControl(DBGrid1.Canvas.Handle,Rect, DFC_BUTTON, DFCS_BUTTONCHECK or DFCS_INACTIVE) {grayed}
else
DrawFrameControl(DBGrid1.Canvas.Handle,Rect, DFC_BUTTON, CtrlState[Column.Field.AsBoolean]) ; {checked or unchecked}
end;
end;

Tips 3

Convert a Drive Letter ("C") to a Drive Number (3)



I have an application that needs to "export" a set of files into a specified folder on a drive. Files can come from various sources: hard disk, usb disk, network drive, etc.

Before the export action an export folder needs to be specified, for example "c:\export folder".

For a more user friendly approach, before the actual export I need to make sure there's enough space on the drive specified by the export folder.
In the above case the drive I'm interested in is "C".

If the export folder is set to "d:\some folder\export folder" then I need to find out how many bytes are available on the "D" drive.
RTL's DiskFree function
Lucky for us working in Delphi, we do not have to invent hot water. Most of the times Delphi already provides a function that serves the purpose, in the Run Time Library.

DiskFree returns the amount of free space in bytes on a specified drive.

There's a "but" :(

DiskFree is declared as:

function DiskFree(Drive: Byte): Int64;

DiskFree function takes a byte (an integer type holding values from 0..255) value - while "C" in "c:\export folder" or "D" in "d:\some folder\export folder" is a character.

The help for DiskFree states: DiskFree returns the number of free bytes on the specified drive, where 0 = Current, 1 = A, 2 = B, 3 = C, 4 = D and so on.

The question is how to come from "D" to 4 (or from "E" to 5)?

Here's the answer:

var
driveLetter : char;
driveNumber : byte;
directory : string;
freeBytes : int64;
begin
//looking for free space on C drive
directory := 'c:\Export Folder';

driveLetter := UpperCase(ExtractFileDrive(directory))[1];

driveNumber := 1 + Ord(driveLetter) - Ord('A') ;

freeBytes := DiskFree(driveNumber) ;

//here "freeBytes" holds the number of free bytes on a drive
//specified by a directory
end;

Note: RTL's Ord returns an integer representing the ordinal value of an ordinal value. Character types are ordinal types (originally modeled after the ANSI character set) - this is why Ord('A') is 65 since 'A' holds a value of 65 in the ASCII table.

Once you have the number of free bytes on a drive you can display it nicely to the user: Formatting a File Size in Bytes for Display.

Tips 2

Is Computer Joined to a Domain - Programmatically Check using Delphi



If a computer is a part of a network it can either be part of a workgroup or a domain.

If you need to programmatically check if a machine running your application is a part of a domain you can exploit functions found in the netapi32.dll. The trick is in using the NetRenameMachineInDomain function which can be used to change the name of a computer in a domain.

If the function fails with the return value of "NERR_SetupNotJoined" when supplying it with "nil" values - a machine is NOT a part of a domain.

// returns true if the machine running this code is in a domain
function IsInDomain: boolean;
type
TNetRenameMachineInDomain = function(lpServer, MachineName, lpAccount, Password: PWideChar; Options: Longint): LongInt stdcall;
var
ResultCode: Integer;
NetRenameMachineInDomain: TNetRenameMachineInDomain;
NetAPIHandle: THandle;
const //ref : lmerr.h
NERR_BASE = 2100;
// This machine is already joined to a domain.
NERR_SetupAlreadyJoined = (NERR_BASE + 591) ;
// This machine is not currently joined to a domain.
NERR_SetupNotJoined = (NERR_BASE + 592) ;
// This machine is a domain controller and cannot be unjoined from a domain.
NERR_SetupDomainController = (NERR_BASE + 593) ;
// The destination domain controller does not support
// creating machine accounts in OUs.
NERR_DefaultJoinRequired = (NERR_BASE + 594) ;
// The specified workgroup name is invalid.
NERR_InvalidWorkgroupName = (NERR_BASE + 595) ;
// The specified computer name is incompatible with the
// default language used on the domain controller.
NERR_NameUsesIncompatibleCodePage = (NERR_BASE + 596) ;
// The specified computer account could not be found.
// Contact an administrator to verify the account is in the domain.
// If the account has been deleted unjoin, reboot, and rejoin the domain.
NERR_ComputerAccountNotFound = (NERR_BASE + 597) ;
// This version of Windows cannot be joined to a domain.
NERR_PersonalSku = (NERR_BASE + 598) ;
// An attempt to resolve the DNS name of a DC in the domain being joined has failed.
// Please verify this client is configured to reach a DNS server that can
// resolve DNS names in the target domain.
NERR_SetupCheckDNSConfig = (NERR_BASE + 599) ;
begin
try
NetAPIHandle := LoadLibrary(PChar('netapi32.dll')) ;
@NetRenameMachineInDomain := GetProcAddress(NetAPIHandle, PChar('NetRenameMachineInDomain')) ;
ResultCode := NetRenameMachineInDomain(nil, nil, nil, nil, 0) ;
FreeLibrary(NetAPIHandle) ;
finally
end;

Result := ResultCode <> NERR_SetupNotJoined;
end; (*IsInDomain*)

Tips 1

How to Check if a Given File Name is Valid Using Delphi

A custom IsFileNameValid Delphi function

If you have an application that operates on the file system and one of the tasks of the application is creating or manipulating files, then you might need to check if a given file name is valid.

For example, if you're using the Windows Explorer to create a new file manually and you try to use the "pipe" (vertical bar) character "|", you will get an error:

A file name cannot contain any of the following characters: \ / : * ? " < > |

The solution to this is to make sure Windows will allow your code to save a file using the specified file name. This can be done with a custom Delphi function: IsValidFileName.
Is File Name Valid
The IsValidFileName validates a given file name to report if a string value represents a valid Windows file name.

The function will return false if the parameter "fileName" is an empty string or if it contains any of the invalid characters:

//test if a "fileName" is a valid Windows file name
//Delphi >= 2005 version
function IsValidFileName(const fileName : string) : boolean;
const
InvalidCharacters : set of char = ['\', '/', ':', '*', '?', '"', '<', '>', '|'];
var
c : char;
begin
result := fileName <> '';

if result then
begin
for c in fileName do
begin
result := NOT (c in InvalidCharacters) ;
if NOT result then break;
end;
end;
end; (* IsValidFileName *)

Note: "InvalidCharacters" is a set type constant.

If your Delphi version (<= Delphi 7) does not support the for in loop, use the next implementation of the IsValidFileName function: //test if a "fileName" is a valid Windows file name //Dellphi <= 7 version function IsValidFileName(const fileName : string) : boolean; const InvalidCharacters : set of char = ['\', '/', ':', '*', '?', '"', '<', '>', '|'];
var
cnt : integer;
begin
result := fileName <> '';

if result then
begin
for cnt := 1 to Length(fileName) do
begin
result := NOT (fileName[cnt] in InvalidCharacters) ;
if NOT result then break;
end;
end;
end; (* IsValidFileName *)