OpenGL II: moving and rotating 2D shapes

Problem/Question/Abstract:

On this article I'll show you some basic movement and rotating, I also try to explain how openGL works

Answer:

After showing you how to setup an openGL window and draw a simple quad (OpenGL I: Hello World) plus doing all the message handling and correctly shutting down your openGL application on this article we will add some movement and rotating to our shapes This article is based on the first article, so if you didn't read it you may do so now, so it makes more sense

After reading this article you should be able to move shapes around the screen and rotate them in all the different axis, what can you do with that? well, some basic 2D games... of course moving a quad on the screen is not so exciting, but at least we're moving now =o) later we will see how to add textures to our shapes so they look way better.

Drawing in openGL is relatively easy, because when you draw, say a quad and you want to rotate it, you don't have to do any calculations, openGL works using a turtle graphics kinda of thing, where the pen that is drawing just follows instructions like "go forward", "turn left 90 degrees", etc... and so, as I say the advantage on this is that that many paths are more simply described in relative than in absolute terms.
For example, it's easy to indicate the absolute coordinates of the corners of a square with vertical and horizontal sides, but it's not so easy to find the corners of an inclined square.

A good way to describe this is if you hold a map (is the screen) and then walk following the directions, then you find a square that is facing you, you see it with vertical and horizontal sides to you (then pen), but when you first saw the map that same square was inclined, make sense?

those instructions in OpenGL look like this:

glTranslatef(-1.5, 0.0, PosZ);
//move to position 3.0, 0.0, PosZ (coming and going to/from view)
glRotatef(Angle, 0.0, 0.0, 1.0); // Rotate The quad On The Z axis
glBegin(GL_QUADS); // Draw A Quad
glVertex3f(-1.0, 1.0, 0.0); // Top Left
glVertex3f(1.0, 1.0, 0.0); // Top Right
glVertex3f(1.0, -1.0, 0.0); // Bottom Right
glVertex3f(-1.0, -1.0, 0.0); // Bottom Left
glEnd(); // end of the Quad

The glTranslatef is the "go -1.5 in the X axis", "go O in the Y" and "go PosZ in the Z axis", as you can see there's only one variable, and that's the one that is going to allow my shape to move (only in the Z axis for now, which is going into the screen depth or coming out)

Then the glRotatef is "rotate Angle degrees in the Z axis", if I had put 1.0 in the second parameter is would rotate in the X axis, the third parameter in the Y axis and the last parameter in the Z axis.

Then I tell openGL, glBegin(GL_QUAD): "I'm going to draw a square", and then you specify the four points of the Quad, because you already told openGL that you're going to draw a square is expecting four points if you give it five or six points it will discard them, it will only take four by four (which make a quad) If I put 8 points it will create 2 quads, and so on the same applies if you tell openGL that you are going to draw triangles, you have to give 3 by 3 points

Ok, with no more here's the main code of our article:

Since we are going to do some movement, we now need some variables

var
Angle: glfloat; //angle of the shapes
PosZ: glfloat; //Position in the Z axis
DForward: Boolean; //going forward? or backwards if false

That's all we need, now we initialize our variables on the InitGL part of our program:

Angle := 0;
PosZ := -20.0;
DForward := True;

And that's all we need, we can draw now:

function DrawGLScene(): Bool; { All Rendering Done Here }
begin
glClear(GL_COLOR_BUFFER_BIT or GL_DEPTH_BUFFER_BIT); //Clear Screen and Depth Buffer
glLoadIdentity(); //Reset The View (move to 0, 0, 0)
glColor3f(0.0, 0.0, 1.0); //set the color (1.0=totally blue)
glTranslatef(-1.5, 0.0, -15.0); //Draw triangle always at same position
glRotatef(Angle, 0.0, 1.0, 0.0); // Rotate The Triangle On The Y axis ( NEW )
glBegin(GL_TRIANGLES); // Drawing Using Triangles
glVertex3f(0.0, 1.0, 0.0); // Top
glVertex3f(-1.0, -1.0, 0.0); // Bottom Left
glVertex3f(1.0, -1.0, 0.0); // Bottom Right
glEnd(); // end of the triangle

glLoadIdentity(); //move to position 0, 0, 0
glColor3f(0.5, 0.0, 0.5); //set the color (0.5 red and 0.5 blue)
glTranslatef(-1.5, 0.0, PosZ);
//move to position 3.0, 0.0, PosZ (coming and going to/from view)
glRotatef(Angle, 0.0, 0.0, 1.0); // Rotate The quad On The Z axis
glBegin(GL_QUADS); // Draw A Quad
glVertex3f(-1.0, 1.0, 0.0); // Top Left
glVertex3f(1.0, 1.0, 0.0); // Top Right
glVertex3f(1.0, -1.0, 0.0); // Bottom Right
glVertex3f(-1.0, -1.0, 0.0); // Bottom Left
glEnd(); // end of the Quad

if (DForward) then
//control the position of the quad, it just goes forward or backward
begin
PosZ := PosZ + 0.05; //go Forward
if (PosZ > -10.5) then
//have I gone too far? go backwards now (towards screen depth)
DForward := False
end
else
begin //go backward
PosZ := PosZ - 0.05;
if (PosZ < -20.0) then //have I gone too far into depth? go forward (towards user)
DForward := True
end;
Angle := Angle + 0.4; //change the angle
DrawGLScene := True
end;

Simple right? once you understand how the drawing is done "internally" it's easier to figure out what we can do with openGL.

That's all for this article, let me know what you think about these openGL articles I try to make them as easy to understand as posible, because I know that is not that easy at the begining but let me know if you are interested in more advanced openGL articles and I will try to post some more topics soon.

Disable the mouse wheel

Problem/Question/Abstract:

Is there any way to disable the mouse wheel for a particular application or form?

Answer:

You can use a handler for the Application.OnMessage event to filter out messages (e.g WM_MOUSEWHEEL) before any control in your application sees them. Note that this will not work with all mouse drivers. There are some that can be configured to not post the standard wheel messages but to send WM_VSCROLL messages instead if the control under the mouse has scrollbars. This "compatibility mode" is there to make the wheel usable with applications that do not have wheel support build in.

procedure TMainForm.FormCreate(Sender: TObject);
begin
Application.OnMessage := AppMessage;
end;

procedure TMainform.Appmessage(var Msg: TMsg; var Handled: Boolean);
begin
Handled := msg.Message = WM_MOUSEWHEEL;
end;

If you only want to do this for a specific form class you would modify this method to

procedure TMainform.Appmessage(var Msg: TMsg; var Handled: Boolean);
begin
Handled := (msg.Message = WM_MOUSEWHEEL) and
(Screen.Activeform is TMySpecialFormclass);
end;

Random Number Engine with UNIQUE property

Problem/Question/Abstract:

This class can be used to generate random numbers from MinNumber to MaxNumber returning a number only once if Unique is set. A check is also available to see if the numbers has been used. A dynamic TBit array is used to ensure numbers are returned only once and to see if ALL the numbers have been used.

Useful particularly for card games eg. random numbers from 1 to 52, and once drawn do not draw same card again until pack is empty.

properties

MinNumber Random Number from.
MaxNumber Random Number to.
NumbersTotal Total available numbers.
NumbersUsed  Unique numbers used of total.
NumbersFree Unique numbers free of total.
Unique If true then a number will not be repeated. If false then numbers may be repeated.

methods

IsUsed(Index) Returns true if UNIQUE used and number has been used.

Reset Resets the NumbersUsed and NumbersFree (Used by UNIQUE)

GetRandom Returns a random number from MinNumber  to MaxNumber
(will not repeat a number if UNIQUE is set)

// =========================
// Simple Example
// =========================

procedure TForm1.Button2Click(Sender: TObject);
var
R: TRandomEngine;
begin
R := TRandomEngine.Create;
R.MinNumber := 1;
R.MaxNumber := 52;
R.Unique := true;

repeat
Memo1.Lines.Add(inttostr(R.GetRandom) + '   ' +
inttostr(R.NumbersTotal) + '  ' +
inttostr(R.NumbersUsed) + '  ' +
inttostr(R.NumbersFree));
until R.NumbersFree = 0;

R.Free;
end;

Answer:

unit REngine;
interface

uses Windows, Classes;

type
TRandomEngine = class(TObject)
private
FSelected: TBits;
FArrSize, FNumbersUsed: longint;
FMinNumber, FMaxNumber: longint;
FUnique: boolean;
procedure SizeSelArray;
procedure SetFMinNumber(NewValue: longint);
procedure SetFMaxNumber(NewValue: longint);
function GetFNumbersFree: longint;
public
constructor Create;
destructor Destroy; override;
procedure Reset;
function GetRandom: longint;
function IsUsed(Index: longint): boolean;
property MinNumber: longint read FMinNumber write SetFMinNumber;
property MaxNumber: longint read FMinNumber write SetFMaxNumber;
property Unique: boolean read FUnique write FUnique;
property NumbersUsed: longint read FNumbersUsed;
property NumbersTotal: longint read FArrSize;
property NumbersFree: longint read GetFNumbersFree;
end;

// -------------------------------------------------------------
implementation

// ===================================
// Create and Free the Object
// ===================================

constructor TRandomEngine.Create;
begin
FSelected := TBits.Create;
FNumbersUsed := 0;
FMinNumber := 0;
FMaxNumber := 0;
FArrSize := 0;
FUnique := false;
Randomize;
end;

destructor TRandomEngine.Destroy;
begin
inherited Destroy;
FSelected.Free;
end;

// ===========================
// Property Get/Set methods
// ===========================

procedure TRandomEngine.SetFMinNumber(NewValue: longint);
begin
if (NewValue <> FMinNumber) then
begin
FMinNumber := NewValue;
if FMinNumber > FMaxNumber then
FMaxNumber := FMinNumber;
SizeSelArray;
end;
end;

procedure TRandomEngine.SetFMaxNumber(NewValue: longint);
begin
if (NewValue <> FMaxNumber) then
begin
FMaxNumber := NewValue;
if FMaxNumber < FMinNumber then
FMinNumber := FMaxNumber;
SizeSelArray;
end;
end;

function TRandomEngine.GetFNumbersFree: longint;
begin
Result := FArrSize - FNumbersUsed;
end;

// =======================================
// Resize the boolean array (FSelected)
// =======================================

procedure TRandomEngine.SizeSelArray;
var
i: longint;
begin
FArrSize := FMaxNumber - FMinNumber + 1;

if FArrSize > 0 then
begin
FSelected.Size := FArrSize;
for i := 0 to FArrSize - 1 do
FSelected[i] := false;
end;

FNumbersUsed := 0;
end;

// =======================================
// Reset avail,used and free numbers.
// Reset FSelected array to false for
// IsUsed()
// =======================================

procedure TRandomEngine.Reset;
begin
SizeSelArray;
end;

// ===================================================
// Return true/false if numbers has been used if
// Unique is set
// ===================================================

function TRandomEngine.IsUsed(Index: longint): boolean;
var
Retvar: boolean;
begin
if (Index < FMinNumber) or (Index > FMaxNumber) then
Retvar := false
else
RetVar := FSelected[Index - FMinNumber];

Result := RetVar;
end;

// ===================================================
// Return a random number based on Min - Max
// If Unique then generate based on FSelected
// array (ie. make sure number has not been used
// ===================================================

function TRandomEngine.GetRandom: longint;
var
V: longint;
NumSelected: boolean;
begin
if FUnique and (FNumbersUsed = FArrSize) then
V := 0
else
begin
repeat
V := Random(FMaxNumber - FMinNumber + 1) + FMinNumber;
if not FUnique then
NumSelected := true
else
begin
if FSelected[V - FMinNumber] then
NumSelected := false
else
begin
NumSelected := true;
FSelected[V - FMinNumber] := true;
inc(FNumbersUsed);
end;
end;
until NumSelected;
end;

Result := V;
end;

end.

Handle lots of classes at runtime

Problem/Question/Abstract:

Classes which can't support TPersistent or TPersistentClass had to implement another technique to manage the creation of obejcts at runtime

Answer:

If a class inherits from TPersistent we can use RegisterClass in several units so we can use the function GetClass to convert a class name to a class instance:

TFinanceClass = class of TFinance;

var
refClass: TFinanceClass;

refClass := TFinanceClass(getClass(values['RegClass']));
dynObj := refClass.Create;
dynObj.getCharge(9.2);

RegisterClass(TFinance);

If you can't inherit from TPersistent we can use a "Name=Value" pair of objects in a stringlist and loaded when a module is created or by user events. So you can determine which object should be created.

function initObjinList;
var //refClass: TFinanceClass;
dynObj: TFinance;
myClsname: string[240];
begin
with TStringList.Create do
begin
clear;
values['RegClass'] := 'TRegularCharge2';
values['PrefClass'] := 'TPreferredCharge2';
values['TrialClass'] := 'TTrialCharge2';
myClsname := 'TrialClass';
if indexofname(myClsname) > -1 then
begin
{refClass:= TFinanceClass(getClass(values['RegClass']));
dynObj:= refClass.Create;
dynObj.getCharge(9.2); }
case IndexOfname(myClsname) of
0: dynObj := TRegularCharge2.create;
1: dynObj := TPreferredCharge2.create;
2: dynObj := TTrialCharge2.create;
end;
dynObj.getcharge(9.1);
dynObj.Free;
result := true;
end;
Free;
end;
end;

The value is the class type and the name simplifies the maintainability of the classes.

syntax:

mystringlist.values[name] := value //write
myname := mystringlist.values[name] //read

I made only one function to show the simplicity but registering classes in a StringList and choosen from a case of structure should be separated in differnt functions.
All the classes inherit from TFinance and in comparison to RegisterClass we don't use a ClassReference.
Descendants override the public or protected getCharge() methods to perform their actions.

TFinance = class
public
function getCharge(const Balance: double): double; virtual;
abstract;
end;

TRegularCharge2 = class(TFinance)
public
function getCharge(const Balance: double): double; override;
end;

TPreferredCharge2 = class(TFinance)
public
function getCharge(const Balance: double): double; override;
end;

TTrialCharge2 = class(TFinance)
public
function getCharge(const Balance: double): double; override;
end;

Build a Table Tree from Records to Objects

Problem/Question/Abstract:

In a relational database like the well known IBLocal you find a table DEPARTMENT which has a self join on her own, means there is a tree inside with a Parent/Child structure.

Answer:

In a relational database like the well known IBLocal you find a table DEPARTMENT which has a  self join on her own, means there is a tree inside with a Parent/Child structure:

DEPT_NO       DEPARTMENT                 HEAD_DEPT
100           Sales and Marketing        000
120           European Headquarters      100
121           Field Office Swiss         120
and so on...

This article is aimed mainly at people interested in trees and recurcions who need to find their  way around self referencing system and get going with a object-visualisation in a tree. Furthermore it's an example for the Composite Design Pattern.
First we need a startprocedure mainly to call the query, build the tree with records in objects and   show the tree at last:

procedure TForm1.btnTreeSelfClick(Sender: TObject);
var
dimlist: TStringList;
begin
dimlist := TStringlist.create;
datdepartment := TBusinessObj.Create(nil);
try
if datDepartment.open_recursiveQuery then
with TDims.create(nil, DimList) do
begin
FillTree(treeview1, nil);
Free;
end;
treeview1.FullExpand;
btnLTree.visible := true;
finally;
dimlist.Free;
datDepartment.Free;
end;
end;

The records in the query must follow one condition [child# > parent#], means a child like  "FieldOffice Swiss" has a child# 121 so the parent it belongs is 120. So we call the query and open the dataset:

function TBusinessObj.open_recursiveQuery: boolean;
begin
result := false;
with qryselfTree do
begin
try
SQL.Clear;
SQL.add('SELECT dept_no, department, location, head_dept' +
' FROM department ORDER BY dept_no');
open;
result := true;
except on EDataBaseError do
showmessage('data not found');
end;
end;
end;

Next we implement a class which holds at runtime the whole tree table in objects. Every object is a stored record from the table DEPARTMENT with the attributes you want to publish or  manipulate at runtime. Grace the members FParent, FChild the whole table is chained in objects  with a top level object, in our case the CORPORATE HEADQUARTERS. This top level object doesn't have a parent, the parent is NIL.

TDims = class(TObject)
private
FstrDimArt: string;
FstrDimArtBez: string;
FParent: TDims;
FChilds: TList;
public
constructor create(Sender: TDims; myRegister: TStringList);
destructor Destroy; override;
procedure FillTree(aOl: TTreeview; xnode: TTreenode);
function IsDimartInChilds(DimArt: string): Boolean;
property DimArtBez: string read FstrDimArtBez;
property DimArt: string read FstrDimArt;
property treechilds: TList read FChilds;
end;

Now comes the real power part, a recursive constructor which collects all records to build the  tree in memory. When a parent like "Sales and Marketing" finds some childs like "European  Headquarters" it creates new objects in a recursion and adds the object to the list:

FChilds.Add(TDims.create(self, myRegister));

Recursions aren't dark chapter by opening in Delphi the debug windows "Call Stack and Local  Variables" you'll learn a lot. When a function name appears anywhere else in a statement block,  the compiler interprets it as a recursive call to the function itself.
The constructor has been used to recursively include another objects. But in every tree an object  without childs terminates without having cycles in them. The last level of a tree is almost the  deepness of recursions.
By the way do you know the explanation of a recursion in a "well behaved" dictionary:

Recursion: See under Recursion ;)

Let jokes aside, here it is:
A programming technique in which a subroutine calls itself. Use care to ensure that a recursion eventually exits. Otherwise, an infinite recursion will cause a stack fault.

constructor TDims.create(Sender: TDims; myRegister: TStringList);
var
bmAkt: TBookmark;
begin
inherited Create;
with datDepartment.qrySelfTree do
begin
FstrDimArt := fieldByName('DEPT_NO').AsString;
FstrDimArtBez := fieldbyName('DEPARTMENT').AsString;
myRegister.AddObject(Format('%10s', [FstrDimArt]), self);
FChilds := TList.Create;
FParent := Sender;
bmAkt := GetBookmark;
if Locate('DEPT_NO', FstrDimArt, []) then
while not (EOF) do
begin
if (fieldByName('HEAD_DEPT').Asstring = FstrDimArt) then
FChilds.Add(TDims.create(self, myRegister));
Next;
end;
GotoBookmark(bmAkt);
FreeBookmark(bmAkt);
end;
end;

destructor TDims.Destroy;
var
i: integer;
begin
if FChilds <> nil then
for i := 0 to FChilds.Count - 1 do
TDims(FChilds[i]).Free;
FChilds.Free;
inherited Destroy;
end;

Now comes the last part, the most efficient way to represent the tabel tree in a view. TTreeView represents a window that displays a hierarchical list of items, such as the headings in a document, the entries in an index, or the files and directories on a disk.
Use TTreeView to add an expanding and contracting outline to a form. Each node in a tree view  control consists of a label and a number of optional bitmapped images. Each node can have a  list of subnodes associated with it. By clicking on a node, the user can expand or collapse the associated list of subnodes.
At run-time nodes can be added and inserted by using the TTreeNodes methods AddChildFirst, AddChild, AddChildObjectFirst, AddChildObject, AddFirst, Add, AddObjectFirst, AddObject and Insert. We only need AddChild:

procedure TDims.FillTree(aOl: TTreeview; xnode: TTreenode);
var
i: integer;
dbcontent: string[255];
begin
dbcontent := dimart + ' ' + dimartbez;
xnode := aOl.items.addchild(xnode, dbcontent);
for i := 0 to treechilds.Count - 1 do
TDims(treechilds.items[i]).FillTree(aOl, xnode);
end;

Copy all Files in directory

Problem/Question/Abstract:

How to copy all Files inDirectory

Answer:

...copy / move / delete whole directory?
Autor: Rainer K�mmerle
Homepage: http://www.delphimania.de

uses
ShellApi;

function CopyDir(const fromDir, toDir: string): Boolean;
var
fos: TSHFileOpStruct;
begin
ZeroMemory(@fos, SizeOf(fos));
with fos do
begin
wFunc  := FO_COPY;
fFlags := FOF_FILESONLY;
pFrom  := PChar(fromDir + #0);
pTo    := PChar(toDir)
end;
Result := (0 = ShFileOperation(fos));
end;


function MoveDir(const fromDir, toDir: string): Boolean;
var
fos: TSHFileOpStruct;
begin
ZeroMemory(@fos, SizeOf(fos));
with fos do
begin
wFunc  := FO_MOVE;
fFlags := FOF_FILESONLY;
pFrom  := PChar(fromDir + #0);
pTo    := PChar(toDir)
end;
Result := (0 = ShFileOperation(fos));
end;

function DelDir(dir: string): Boolean;
var
fos: TSHFileOpStruct;
begin
ZeroMemory(@fos, SizeOf(fos));
with fos do
begin
wFunc  := FO_DELETE;
fFlags := FOF_SILENT or FOF_NOCONFIRMATION;
pFrom  := PChar(dir + #0);
end;
Result := (0 = ShFileOperation(fos));
end;


procedure TForm1.Button1Click(Sender: TObject);
begin
if cCopyDir('d:\download', 'e:\') = True then
ShowMessage('Directory copied.');
end;

replace characters while typing

Problem/Question/Abstract:

Replace chracters while typing

This code allows you to replaces umlauts (i.e. '�', '�', etc.)  with 'ae', 'oe', etc. while typing.

Answer:

procedure TForm1.AppOnMessage(var Msg: TMsg; var Handled: Boolean);
type
TReplacement = record
chIn: Char;
chOut: string[2]
end;
TReplacements = array[0..6] of TReplacement;
const
Replacements: TReplacements = ((chIn: '�'; chOut: 'ae'),
(chIn: '�'; chOut: 'oe'),
(chIn: '�'; chOut: 'ue'),
(chIn: '�'; chOut: 'Ae'),
(chIn: '�'; chOut: 'Oe'),
(chIn: '�'; chOut: 'Ue'),
(chIn: '�'; chOut: 'ss'));
var
i: Integer;
c: Char;
begin
Handled := False;
if Msg.Message = WM_CHAR then
begin
if Chr(Msg.wParam) in ['�', '�', '�', '�', '�', '�', '�'] then
begin
for i := Low(Replacements) to High(Replacements) do
if Chr(Msg.wParam) = Replacements[i].chIn then
begin
Msg.wParam := Ord(Replacements[i].chOut[1]);
with Longrec(Msg.lParam) do
Hi := (Hi and $FF00) or VKKeyScan(Replacements[i].chOut[2]);
PostMessage(Msg.hwnd, WM_CHAR, Ord(Replacements[i].chOut[2]),
Msg.wParam);
with Longrec(Msg.lParam) do
Hi := (Hi and $FF00) or VKKeyScan(Char(Msg.wParam));
Break;
end;
end;
end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
Application.OnMessage := AppOnMessage;
end;

Creating Themed Custom Controls

Problem/Question/Abstract:

Creating Themed Custom Controls

Answer:

I have to admit: visual styles are starting to annoy me. It's not that I don't like them - it's that every piece of visual code I write now has to take them into account.

In this short article, I'll discuss some of the implications of supporting visual styles when developing custom controls in Delphi. You can read more about visual styles in my previous article "Visual Styles in Delphi", which deals with drawing system elements.

Borderline Personality

In terms of visual design, every custom control can contain both standard and non-standard elements. Standard elements are the parts that make the control look like other visual elements in Windows, such as its border and scroll bars. Non-standard elements are what makes the control unique. In most Windows controls, this concept is implemented by separating the client and non-client areas of the control.

Traditionally, the non-client area of a control is painted by Windows. This works well in most cases. A form's non-client area, for example, includes the form's border, its caption (and caption buttons), and scroll bars. By letting Windows take over this part, windows have a standard look throughout the system. Windows also provides some default non-client area handling for other controls. Unfortunately, the default processing does not fully support visual styles. The control border has to be drawn separately.

In ancient times (that is, before visual styles were inflicted on us), most controls had just three border styles: a sunken 3D border, a flat border, or no border at all. Many Delphi controls expose these styles by using the BorderStyle and Ctl3D properties. These styles were implemented internally by Windows, and were controlled by setting various bits in the call to CreateWindow or CreateWindowEx. The WS_BORDER style gave a control a flat border, while the WS_EX_CLIENTEDGE extended style gave it a sunken border.

Control borders in Windows XP are a little more complicated. Instead of a fixed set of styles, XP controls can have any sort of border. Borders can have a variety of colors, patterns, shapes, and levels of transparency. Different controls can have different border styles. For example, group boxes have round corners, while edit boxes have a rectangular border, but use a different color. Because there is no single standard for borders, the default non-client area painting code doesn't draw any of the new border styles. This means we have to do it ourselves.

Shoplifting

Obviously, there's a catch. We want our control to look "right" when using visual styles, so we need a standard border. The problem is that there is no single border style. One solution offered by Microsoft is to borrowhttp://www.shoplifting.com/ elements from other controls. That's the solution I'll use here.

TThemedCustomControl is a simple TCustomControl descendant. It handles the WM_NCPAINT message to draw a themed border:

procedure TThemedCustomControl.WMNCPaint(var Message: TMessage);
var
R: TRect;
Details: TThemedElementDetails;
DC: HDC;
XEdge, YEdge: Integer;
begin
inherited;
if (ThemeServices.ThemesEnabled) and Ctl3D then
begin
R := Rect(0, 0, Width, Height);
DC := GetWindowDC(Handle);
XEdge := GetSystemMetrics(SM_CXEDGE);
YEdge := GetSystemMetrics(SM_CYEDGE);
ExcludeClipRect(DC, XEdge, YEdge, Width - XEdge, Height - YEdge);
try
Details := ThemeServices.GetElementDetails(teEditRoot);
ThemeServices.DrawParentBackground(Handle, DC, @Details, True);
ThemeServices.DrawElement(DC, Details, R);
finally
ReleaseDC(Handle, DC);
end;
end;
end;

Although the code is fairly simple, certain parts require explanation. Let's start at the top.

The procedure starts by invoking the default handler for the message. Although this causes the standard border to be drawn even if themes are supported, we need this in order to draw other non-client elements - specifically, scroll bars.

Once we've established that a themed border needs to be drawn, we get the control's device context. To make sure we only draw over the border area, we call ExcludeClipRect so that Windows clips everything else. The calls to GetSystemMetrics get the size of the standard border that was already painted. The border is usually 2 pixels wide, but it's safer to ask.

To draw our border, we need access to the theme data. This is where we decide what our border looks like. I've decided to use the same border as an edit box, but you can use any control you want. Simply replace teEditRoot with the appropriate value.

Conclusion

That's it. If you download the controlhttp://download.shorterpath.com/ThemeCC.zip, you'll see a little more code. That's just housekeeping code for handling the Ctl3D property.

The code was written in Delphi 7, but should work with earlier versions. You will the ThemeServices class, though. You can download it from Mike Lischke's Delphi Gems site.


Component Download: http://download.shorterpath.com/ThemeCC.ziphttp://download.shorterpath.com/ThemeCC.zip

Simple TBitmap blur algorithm

Problem/Question/Abstract:

How to blur a TBitmap

Answer:

The algorithm is very simple. The value of every pixel in the bitmap is replaced by the sum of the pixels information around the taken pixel divided by 8 (because there are 8 pixels around one pixel). To avoid problems we skip the pixels on the first and the last line and on the first and the last column.

function blur(source: TBitmap): TBitmap;
var
x, y: integer;
tline, mline, bline: PByteArray;
begin
for y := 1 to source.Height - 2 do
begin
tline := source.ScanLine[y - 1];
mline := source.ScanLine[y];
bline := source.ScanLine[y + 1];
for x := 1 to source.Width - 2 do
begin
mline^[x * 3] := (mline^[x * 3 - 3] + mline^[x * 3 + 3] +
tline^[x * 3 - 3] + tline^[x * 3 + 3] + tline^[x * 3] +
mline^[x * 3 - 3] + mline^[x * 3 + 3] + mline^[x * 3]) div 8;
mline^[x * 3 + 1] := (mline^[x * 3 - 2] + mline^[x * 3 + 4] +
tline^[x * 3 - 2] + tline^[x * 3 + 4] + tline^[x * 3 + 1] +
mline^[x * 3 - 2] + mline^[x * 3 + 4] + mline^[x * 3 + 1]) div 8;
mline^[x * 3 + 2] := (mline^[x * 3 - 1] + mline^[x * 3 + 5] +
tline^[x * 3 - 1] + tline^[x * 3 + 5] + tline^[x * 3 + 2] +
mline^[x * 3 - 1] + mline^[x * 3 + 5] + mline^[x * 3 + 2]) div 8;
end;
end;
result := source;
end;

Usage example:

image1.picture.bitmap := blur(image1.picture.bitmap);

where image1 is a TPicture object.

Give a process or thread administrator attributes

Problem/Question/Abstract:

I am trying to write a launcher program that can launch applications with administrator rights, kind of like the option in Windows 2000 to have an application "Run As" administrator. I think the way to do this is to use createprocess() function with something set in lpProcessAttributes or lpThreadAttributes that gives the process or thread administrator attributes. Unfortunatily, I'm not sure what to do beyond this. If anyone can give me answers as to what I can do next, I would be grateful.

Answer:

function CreateProcessWithLogonW(lpUsername, lpDomain, lpPassword: PWideChar;
dwLogonFlags: dword; lpApplicationName: PWideChar; lpCommandLine: PWideChar;
dwCreationFlags: DWORD; lpEnvironment: Pointer; lpCurrentDirectory: PWideChar;
const lpStartupInfo: TStartupInfo; var lpProcessInformation: TProcessInformation):
BOOL; stdcall; external 'advapi32.dll';

function RunAsUser(const Filename, Domain, Username, Password: string): Boolean;
var
StartupInfo: TStartupInfo;
ProcessInfo: TProcessInformation;
wFilename, wDomain, wUsername, wPassword: PWideChar;
begin
FillChar(StartupInfo, SizeOf(StartupInfo), #0);
StartupInfo.cb := SizeOf(StartupInfo);
StartupInfo.dwFlags := STARTF_USESHOWWINDOW;
StartupInfo.wShowWindow := SW_SHOWNORMAL;
GetMem(wFilename, Length(Filename) * SizeOf(WideChar) + SizeOf(WideChar));
GetMem(wDomain, Length(Domain) * SizeOf(WideChar) + SizeOf(WideChar));
GetMem(wUsername, length(Username) * SizeOf(WideChar) + SizeOf(WideChar));
GetMem(wPassword, length(Password) * SizeOf(WideChar) + SizeOf(WideChar));
StringToWideChar(Filename, wFilename, Length(Filename) * SizeOf(WideChar)
+ SizeOf(WideChar));
StringToWideChar(Domain, wDomain, Length(Domain) * SizeOf(WideChar)
+ SizeOf(WideChar));
StringToWideChar(Username, wUsername, Length(Username) * SizeOf(WideChar)
+ SizeOf(WideChar));
StringToWideChar(Password, wPassword, Length(Password) * SizeOf(WideChar)
+ SizeOf(WideChar));
Result := CreateProcessWithLogonW(wUsername, wDomain, wPassword, 0, wFilename,
nil, 0, nil, nil, StartupInfo, ProcessInfo);
if Result then
begin
WaitForSingleObject(ProcessInfo.hProcess, INFINITE);
CloseHandle(ProcessInfo.hProcess);
CloseHandle(ProcessInfo.hThread);
end
else
RaiseLastOSError;
FreeMem(wFilename);
FreeMem(wDomain);
FreeMem(wUsername);
FreeMem(wPassword);
end;

Determine file and tree sizes larger 2 GB

Problem/Question/Abstract:

How to determine file and tree sizes larger 2 GB

Answer:

Solve 1:

You will need to use the FindFirstFile, FindNextFile and FindClose functions, e.g.:

function GetFileSize(const FileName: string): Int64;
var
F: TWin32FindData;
H: THandle;
begin
H := FindFirstFile(PChar(FileName), F);
if H = INVALID_HANDLE_VALUE then
RaiseLastWin32Error;
try
Result := F.nFileSizeHigh shl 32 + F.nFileSizeLow;
finally
Windows.FindClose(H);
end;
end;

function GetTreeSize(FileName: string): Int64;

procedure TreeSize(const FileName: string);
var
F: TWin32FindData;
H: THandle;
begin
H := FindFirstFile(PChar(FileName), F);
if H = INVALID_HANDLE_VALUE then
RaiseLastWin32Error;
try
repeat
if ((F.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) > 0) and (F.cFileName[0]
<> '.') then
TreeSize(ExtractFilePath(FileName) + F.cFileName + '\*.*')
else
Result := Result + F.nFileSizeHigh shl 32 + F.nFileSizeLow;
until not FindNextFile(H, F);
finally
Windows.FindClose(H);
end;
end;

begin
Result := 0;
TreeSize(IncludeTrailingBackslash(ExtractFilePath(FileName)) + '*.*');
end;

I would add one little detail to your function. By calculating the filesize, you should cast the values to Int64. In the helpfile you can read, that this is necessary, because the operation would normally return an integer. In this case, (F.nFileSizeHigh shl 32) would return an Integer and not an Int64.

Result := Int64(F.nFileSizeHigh) shl 32 + Int64(F.nFileSizeLow);

I think, casting "nFileSizeLow" is not necessary, but better to make it safe.


Solve 2:

Use the WinAPI version of the function GetFileSize() as follows:

procedure CardinalsToI64(var I: Int64; const LowPart, HighPart: Cardinal);
begin
TULargeInteger(I).LowPart := LowPart;
TULargeInteger(I).HighPart := HighPart;
end;

{ ... }
var
fLOdword: dword;
fHIdword: dword;
FFilesize: Int64;
FFileHandle: THandle;
begin
FFileHandle := CreateFile(PChar(FFileName), GENERIC_READ, FILE_SHARE_READ, nil,
OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);
fLOdword := GetFileSize(FFileHandle, @fHIdword);
CardinalsToI64(FFilesize, fLOdword, fHIdword);


Solve 3:

function GetFileSize(const FileName: string): Int64;
var
SizeLow, SizeHigh: DWord;
hFile: THandle;
begin
Result := 0;
hFile := FileOpen(FileName, fmOpenRead);
try
if hFile <> 0 then
begin
SizeLow := Windows.GetFileSize(hFile, @SizeHigh);
Result := (SizeHigh shl 32) + SizeLow;
end;
finally
FileClose(hFile);
end;
end;

Convert a Flash SWF to EXE

Problem/Question/Abstract:

How to convert a Flash SWF to EXE?

Answer:

function Swf2Exe(S, D, F: string): string;
//S = Source file (swf)
//D = Destionation file (exe)
//F = Flash Player
var
SourceStream, DestinyStream, LinkStream: TFileStream;
flag: Cardinal;
SwfFileSize: Integer;
begin
Result := 'something error';
DestinyStream := TFileStream.Create(D, fmCreate);
try
LinkStream := TFileStream.Create(F, fmOpenRead or fmShareExclusive);
try
DestinyStream.CopyFrom(LinkStream, 0);
finally
LinkStream.Free;
end;

SourceStream := TFileStream.Create(S, fmOpenRead or fmShareExclusive);
try
DestinyStream.CopyFrom(SourceStream, 0);
flag := $FA123456;
DestinyStream.WriteBuffer(flag, SizeOf(Integer));
SwfFileSize := SourceStream.Size;
DestinyStream.WriteBuffer(SwfFileSize, SizeOf(Integer));
Result := '';
finally
SourceStream.Free;
end;
finally
DestinyStream.Free;
end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
Swf2Exe('c:\somefile.swf', 'c:\somefile.exe',
'c:\Program Files\Macromedia\Flash MX\Players\SAFlashPlayer.exe');
end;

Set a Printer to Duplex Mode

Problem/Question/Abstract:

How to set a printer to duplex mode?

Answer:

You typically switch a printer to duplex mode by changing its TDeviceMode(API: DEVMODE)record .But first you should test whether the installed printer driver supports this:

uses
printers, winspool;

function PrinterSupportsDuplex: Boolean;
var
Device, Driver, Port: array[0..255] of Char;
hDevMode: THandle;
begin
Printer.GetPrinter(Device, Driver, Port, hDevmode);
Result := WinSpool.DeviceCapabilities(Device, Port, DC_DUPLEX, nil, nil) <> 0;
end;

If it does you can try to switch the duplex mode on before you call  richedit.print:

var
Device, Driver, Port: array[0..80] of Char;
DevMode: THandle;
pDevmode: PDeviceMode;
begin
// Get printer device mode handle.
Printer.GetPrinter(Device, Driver, Port, DevMode);
if Devmode <> 0 then
begin
// lock it to get pointer to DEVMODE record
pDevMode := GlobalLock(Devmode);
if pDevmode <> nil then
try
with pDevmode^ do
begin
dmDuplex := DMDUP_VERTICAL;
dmFields := dmFields or DM_DUPLEX;
end;
finally
// unlock devmode handle.
GlobalUnlock(Devmode);
end;
end; { If }
end;

Implement the Choice Pattern

Problem/Question/Abstract:

The Choice Design Pattern is new and relies on interfaces and runtime associations. No aggregation or composition between classes are needed.

Answer:

The Choice Pattern needs one interface, n-classes which supports the interface and a worker-class to provide the choice of an algorithm at runtime. The Choice Pattern is like the Strategy Pattern, but smaller and more runtime in his behaviour.

With interfaces we don't have to concern about memory management.
Interface references are managed through reference-counting, which depends on the _AddRef and _Release methods inherited from IUnknown. When an object is referenced only through interfaces, there is no need to destroy it manually; the object is automatically destroyed when the last reference
to it goes out of scope.

The following restrictions apply.

The member List can include only methods and properties.
Fields are not allowed in interfaces.
Interfaces have no constructors or destructors. They cannot be instantiated, except through classes that implement their methods.

Methods cannot be declared as virtual, dynamic, abstract, or override. Since interfaces do not implement their own methods, these bindings have no meaning. So let's practice the Choice Pattern in 5 steps:

1.  We need an Interface in order to be type-compatible.

IChoicePattern = interface
procedure doPatternSearch;
end;

2. We declare 2 or n classes.

A class from an Interface can support/implement multiple interfaces. TInterfacedObject implements the methods of IUnknown, so TInterfacedObject automatically handles reference counting and memory management of interfaced objects.
One of the concepts behind the design of interfaces is ensuring the lifetime management of the objects that implement them. The AddRef and Release methods of IUnknown provide a way of implementing this functionality.

TCheckFormatA = class(TInterfacedObject, IChoicePattern)
public
procedure doPatternSearch;
end;

TCheckFormatB = class(TInterfacedObject, IChoicePattern)
public
procedure doPatternSearch;
end;

3. We need a worker-class which calls the runtime Interface-methods:

TDirWorker = class
procedure callCheck(myInst: IChoicePattern);
end;

4. Now we implement the Interface Classes and the Worker Class too:

procedure TCheckFormatA.doPatternSearch;
var
ldbPath: string;
begin
if FileExists(extractFileDir(application.exeName) + '\' + DBNAME) then
ldbPath := extractFileDir(application.exeName) + '\' + DBNAME;
messageDlg('formatASearch doing', mtInformation, [mbok], 0);
end;

procedure TCheckFormatB.doPatternSearch;
var
ldbPath: string;
begin
if OpenDialog1.Execute then
ldbPath := openDialog1.FileName;
messageDlg('formatBSearch doing', mtInformation, [mbok], 0);
end;

procedure TDirWorker.callCheck(myInst: IChoicePattern);
begin
myInst.doPatternSearch;
messageDlg('do_some_Work', mtInformation, [mbok], 0);
end;

Here we can see, no myInst.Free is needed. Each object from TCheckFormatA or TCheckFormatB is automatically destroyed. Interfaces track the lifetime of an object by incrementing the reference count on the object when an interface reference is passed, and will destroy the object when that reference count is zero.

5. At least the client calls the Choice Pattern and every object is local at runtime:

procedure TMainFrm.Button1Click(Sender: TObject);
begin
with (TDirWorker.Create) do
begin
callCheck(TCheckFormatA.create);
callCheck(TCheckFormatB.create);
Free;
end;
end;