Tile the open windows when calling an external application from your program

Problem/Question/Abstract:

I want to execute an external program from my Delphi application when I click on a button. However, when the program is executed, I want both my Delphi application and the external program to tile side by side (just like in Windows own "Tile windows") vertically.

Answer:

The problem boils down to finding the started programs window handle. Once you have that the tiling boils down to a single call to the TileWIndow API function. The following is starting an application and tiling its window with the current application window.

procedure StartAppAndTileWindows(const appname: string; const windows: array of HWND;
  tileHorizontal: Boolean = true);
const
  tileflags: array[Boolean] of UINT = (MDITILE_VERTICAL, MDITILE_HORIZONTAL);
var
  currhwnd: HWND;
  newhwnd: HWND;
  counter: Integer;
  wndArray: array of HWND;
begin
  currhwnd := GetForegroundWindow;
  if ShellExecute(currhwnd, nil, Pchar(appname), nil, nil, SW_SHOWNORMAL) > 32 then
  begin
    counter := 0;
    repeat
      Sleep(100);
      newhwnd := GetForegroundWindow;
      if (newhwnd <> 0) and (newhwnd <> currhwnd) then
      begin
        SetLength(wndArray, High(windows) + 2);
        Move(windows[0], wndArray[0], (High(windows) + 1) * sizeof(HWND));
        wndArray[High(wndArray)] := newhwnd;
        TileWindows(0, {tile on desktop}
          tileflags[tileHorizontal], {mode as per param}
          nil, {use desktops full client area}
          Length(wndArray), {count of windows to tile}
          @wndArray[0]); {array of window handles to tile}
        Exit;
      end
      else
        Inc(counter);
    until
      counter >= 20;
    raise Exception.CreateFmt('Could not find main window of %s', [appname]);
  end;
  raise Exception.CreateFmt('Could not execute %s', [appname]);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  StartAppAndTileWindows('notepad.exe', [handle]);
end;

Display a long text in a TLabel with an end ellipsis

Problem/Question/Abstract:

How to display a long text in a TLabel with an end ellipsis

Answer:

You must turn off AutoSize for the label, of course. Otherwise the current content of the label determines where the string will be trimmed.

{ ... }
var
  S: string;
  R: TRect;
  { ... }
begin
  {Get the text you want into S}
  S := 'this is way too long to fit into a label - trim it down';
  {Make it unique, because DrawText is going to change it}
  UniqueString(S);
  {Get the rectangle available for drawing}
  R := Label1.ClientRect;
  {Make sure you're using the same font the label will use}
  Label1.Canvas.Font := Label1.Font;
  {Ask Windows to trim it up with out replacing "&" by an underscore}
  DrawText(Label1.Canvas.Handle, PChar(S), Length(S), R, DT_END_ELLIPSIS or
    DT_MODIFYSTRING or DT_NOPREFIX);
  {Now plug that trimmed text into Label1}
  Label1.Caption := S;
  { ... }

Rotate a polygon

Problem/Question/Abstract:

How to rotate a polygon

Answer:

Start a new project add this OnPaint handler to the form:

procedure TForm1.FormPaint(Sender: TObject);

  function Translate(APoint: TPoint; AX, AY: Integer): TPoint;
  begin
    Result.X := APoint.X + AX;
    Result.Y := APoint.Y + AY;
  end;

  function Rotate(APoint: TPoint; AAngle: Double): TPoint;
  begin
    Result.X := Round(APoint.X * Cos(AAngle) - APoint.Y * Sin(AAngle));
    Result.Y := Round(APoint.X * Sin(AAngle) + APoint.Y * Cos(AAngle));
  end;

var
  po: array of TPoint;
  pr: array of TPoint;
  i: Integer;
begin
  {Setup the polygon}
  SetLength(po, 5);
  SetLength(pr, Length(po));
  po[0] := Point(-50, -50);
  po[1] := Point(50, -50);
  po[2] := Point(50, 50);
  po[3] := Point(-50, 50);
  po[4] := Point(-75, 0);
  for i := 0 to Pred(Length(po)) do
  begin
    pr[i] := Translate(Rotate(po[i], GetTickCount / 1000), ClientWidth div 2,
      ClientHeight div 2);
  end;
  Canvas.Polygon(pr);
  Invalidate;
end;

Mouse cursor hourglass/normal changer unit

Problem/Question/Abstract:

Howto change the mousecursor into a hourglass/normal.

Answer:

unit waitcursor;
{ WaitCursor  -  Copyright (c) 2001 by E.J.Molendijk

  A mousecursor hourglass/normal changer tool. Supports layered requests.

  WCursor.SetWait     = mouse cursor as Hourglass
  WCursor.SetWaitSQL  = mouse cursor as SQL Hourglass
  WCursor.SetNormal   = mouse cursor as normal

  example:
      WCursor.setWait;
      try
        DoSometingVerySlow;
      finally
        WCursor.setNormal;
      end;
}

interface

type
  TWaitCursor = class
  private
    FCursor: integer;
    FCnt: integer;
  public
    constructor Create;
    destructor Destroy; override;
    procedure SetCursor(Index: integer);
    procedure SetWait;
    procedure SetWaitSQL;
    procedure SetNormal;
  end;

var
  WCursor: TWaitCursor;

implementation

uses Forms, Controls;

constructor TWaitCursor.Create;
begin
  inherited;
  // depth is zero
  FCnt := 0;

  // remember default cursor
  FCursor := Screen.Cursor;
end;

destructor TWaitCursor.Destroy;
begin
  // Reset to default cursor
  Screen.Cursor := FCursor;
  inherited;
end;

procedure TWaitCursor.SetCursor(Index: integer);
begin
  // select cursor
  Screen.Cursor := Index;
end;

procedure TWaitCursor.SetNormal;
begin
  // decrease depth
  if FCnt > 0 then
    Dec(FCnt);

  // if we reach depth 0 we restore default cursor
  if FCnt = 0 then
    SetCursor(FCursor);
end;

procedure TWaitCursor.SetWait;
begin
  // increase depth
  Inc(FCnt);

  // select wait cursor
  SetCursor(crHourglass);
end;

procedure TWaitCursor.SetWaitSQL;
begin
  // increase depth
  Inc(FCnt);

  // select wait cursor
  SetCursor(crSQLWait);
end;

initialization
  WCursor := TWaitCursor.Create;
finalization
  WCursor.Free;
end.

Type casting and type checking with Interfaces

Problem/Question/Abstract:

If you are new to interfaces and you are use to type casting and type checking with objects you will find that Interfaces must be dealt with differently.  This artical shows you the basics to get started with doing type checking and type casting with Interfaces.

Answer:

If you are like me, you are impatient and can get the point without a bunch of explaining and you hate reading of bunch of stuff just to get a couple bits of info. So for you guys/girls here is the summary and then if you like you can read the rest of the artical:

SUMMARY

First off, your interface must have a GUID, use delphi Shift-Ctrl-G to create one. It should be entered as the first line in your interface definition, ex:

ITypeX = interface
  ['{A002AF60-5684-11D5-B4F9-525405F6BE8D}']
  procedure ShowX;
end;

Object Type Cast

Customer := TCustomer(SomeObject);

Interface Way

You cannot do it this way with interfaces

Object Type Cast (with type checking)

Customer := SomeObject as TCustomer;

Interface Way

Customer := SomeInterface as ICustomer; // assuming Customer is declared as ICustomer

Object Type Checking

if SomeObject is TCustomer then
  // Do Something

interface Way

if SomeInterface.QueryInterface(ICustomer, Customer) = S_OK then
begin
  Customer.DoSomething;
end;

Read further if you like more explaining

First I will summarize type casting and type checking with objects to get us on the same ground and then show how it is done when using interfaces.

Type casting with objects is done in 2 ways

Direct without type checking

Customer := TCustomer(SomeObject);

Using "built in" type checking

Customer := SomeObject as TCustomer

The second will raise an exception if SomeObject is not a TCustomer object or a descendent of one.

Type checking with objects can be done as....

if (SomeObject is TCustomer) then
  // Do something

Now for Interfaces, you MUST have a GUID for your interface before you can do any type checking or type casting. To make your interface have a GUID simply insert it as the first line in your interface definition like this:

ITypeX = interface
  ['{A002AF60-5684-11D5-B4F9-525405F6BE8D}']
  procedure ShowX;
end;

First off you may ask where the heck do I get a GUID, in Delphi just put your cursor where you want the GUID and then press Shift-Ctrl-G and Delphi will insert one for you.  That easy.

These are the interfaces I will use in my explaining:

ITypeX = interface
  ['{A002AF60-5684-11D5-B4F9-525405F6BE8D}']
  procedure ShowX;
end;

ITypeY = interface
  ['{56DA8BE0-5685-11D5-B4F9-525405F6BE8D}']
  procedure ShowY;
end;

Classes to implement them
TTypeX = class(TInterfacedObject, ITypeX)
public
  procedure ShowX;
end;

TTypeY = class(TInterfacedObject, ITypeY)
public
  procedure ShowY;
end;

TTypeXY = class(TInterfacedObject, ITypeX, ITypeY)
public
  procedure ShowX;
  procedure ShowY;
end;

Type casting.

The following code will not work!

procedure TForm_Interfaces.TypeCastXtoY;
var
  X: ITypeX;
begin
  X := TTypeXY.Create;
  ITypeY(X).ShowY;
end;

What happens is that the method ShowX gets called rather than ShowY, I do not know the technical reason... but bottom line, it does not work and you should not type cast this way.

The proper way to do it is this way:

procedure TForm_Interfaces.TypeCastXtoY;
var
  X: ITypeX;
begin
  X := TTypeXY.Create;
  (X as ITypeY).ShowY;
end;

You must use the as operator, also this way of doing it will raise an exception if X in some way does not implement Y.  If you need to do type checking then read more...

The "is" operator does not work with interfaces, so code like this will not compile

if X is ITypeY then
  // Do Something

The proper way to do it is this way:

U := TTypeY.Create;

if U.QueryInterface(ITypeX, Ret) = S_OK then
  ShowMessage('Supports ITypeX')
else
  ShowMessage('DOES NOT Support ITypeX');

if U.QueryInterface(ITypeY, Ret) = S_OK then
  ShowMessage('Supports ITypeY')
else
  ShowMessage('DOES NOT Support ITypeY')

Ret will contain a reference to the interface when the result is S_OK.

Note: If you read the Delphi help for QueryInterface you will see this line
After successfully obtaining an interface by calling QueryInterface, clients should increase the reference count by calling the IUnknown AddRef method.

I wrote code to verify this statement and found that the reference count was incermented and I did not have to call AddRef.

Full Source of my Research, you can also download the app from my website using the component link.

PAS

unit Frm_Interfaces;
{
  Discovery Typecasting interfaces

  You cannot typecast an interface in this manner,
  seems your method pointers are messed up
  X:= ITypeX(SomeInterface);
  // See "TypeCastXtoY" method to see the error, notice the message

  You must type cast in either of 2 ways
  1. X:= SomeInterface as ITypeX
  // See "TypeCastXtoY" method, this can raise an exception

  or
  2. if SomeInterface.QueryInterface(ITypeX, X) = S_OK then
       X.ShowX;
  // See "TypeChecking" method, this does not raise an exception

  Difference between 1 and 2 is that 1 will raise an exception and 2 will not.

  *** IMPORTANT ***
  In order for this to work you MUST include a GUID in your interface, it is
  the first line in the interface definition, use keyboard Shift-Ctrl-G to
  create a GUID.
}

interface

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

type

  ITypeX = interface
    ['{A002AF60-5684-11D5-B4F9-525405F6BE8D}']
    procedure ShowX;
  end;

  ITypeY = interface
    ['{56DA8BE0-5685-11D5-B4F9-525405F6BE8D}']
    procedure ShowY;
  end;

  TTypeX = class(TInterfacedObject, ITypeX)
  public
    procedure ShowX;
  end;

  TTypeY = class(TInterfacedObject, ITypeY)
  public
    procedure ShowY;
  end;

  TTypeXY = class(TInterfacedObject, ITypeX, ITypeY)
  public
    procedure ShowX;
    procedure ShowY;
  end;

  TForm_Interfaces = class(TForm)
    FbtnTestCreate: TButton;
    FbtnTypeCastX2Y: TButton;
    FbtnTypeCastU2Y: TButton;
    FbtnTypeChecking: TButton;
    procedure Ev_FbtnTestCreateClick(Sender: TObject);
    procedure Ev_FbtnTypeCastX2YClick(Sender: TObject);
    procedure Ev_FbtnTypeCastU2YClick(Sender: TObject);
    procedure Ev_FbtnTypeCheckingClick(Sender: TObject);
  private
    { Private declarations }
    procedure TestCreate;
    procedure TypeCastXtoY;
    procedure TypeCastUnknownToY;
    procedure TypeChecking;
  public
    { Public declarations }
  end;

var
  Form_Interfaces: TForm_Interfaces;

implementation

{$R *.DFM}

{ TTypeX }

procedure TTypeX.ShowX;
begin
  ShowMessage('TTypeX.ShowX: Supports "ITypeX" only');
end;

{ TTypeY }

procedure TTypeY.ShowY;
begin
  ShowMessage('TTypeY.ShowY: Supports "ITypeY" only');
end;

{ TTypeXY }

procedure TTypeXY.ShowX;
begin
  ShowMessage('TTypeXY.ShowX: Supports both "ITypeX" and "ITypeY"');
end;

procedure TTypeXY.ShowY;
begin
  ShowMessage('TTypeXY.ShowY: Supports both "ITypeX" and "ITypeY"');
end;

{ TForm1 }

procedure TForm_Interfaces.Ev_FbtnTestCreateClick(Sender: TObject);
begin
  TestCreate;
end;

procedure TForm_Interfaces.Ev_FbtnTypeCastX2YClick(Sender: TObject);
begin
  TypeCastXtoY;
end;

procedure TForm_Interfaces.Ev_FbtnTypeCastU2YClick(Sender: TObject);
begin
  TypeCastUnknownToY;
end;

procedure TForm_Interfaces.Ev_FbtnTypeCheckingClick(Sender: TObject);
begin
  TypeChecking;
end;

procedure TForm_Interfaces.TestCreate;
var
  TypeX: ITypeX;
  TypeY: ITypeY;
begin
  TypeX := TTypeX.Create;
  TypeX.ShowX;

  TypeY := TTypeY.Create;
  TypeY.ShowY;

  // Implements both
  TypeX := TTypeXY.Create;
  TypeX.ShowX;

  TypeY := TTypeXY.Create;
  TypeY.ShowY;
end;

procedure TForm_Interfaces.TypeCastXtoY;
var
  X: ITypeX;
begin
  // Notice the message, this does not work.
  X := TTypeXY.Create;
  ITypeY(X).ShowY;

  // This does work
  (X as ITypeY).ShowY;
end;

procedure TForm_Interfaces.TypeCastUnknownToY;
var
  U: IUnknown;
  Y: ITypeY;
begin
  U := TTypeXY.Create;
  Y := U as ITypeY;
  Y.ShowY;
end;

procedure TForm_Interfaces.TypeChecking;
var
  U: IUnknown;
  Ret: IUnknown;
begin
  // Select whichever you want below
//********************************
  //  U:= TTypeXY.Create;
  //  U:= TTypeX.Create;
  U := TTypeY.Create;
  //********************************

    // "Is" does not work with interfaces.
  {
    if U is ITypeX then
      ShowMessage('Supports ITypeX')
    else
      ShowMessage('DOES NOT Support ITypeX')

    if U is ITypeY then
      ShowMessage('Supports ITypeY')
    else
      ShowMessage('DOES NOT Support ITypeY')
  }

  if U.QueryInterface(ITypeX, Ret) = S_OK then
    ShowMessage('Supports ITypeX')
  else
    ShowMessage('DOES NOT Support ITypeX');

  if U.QueryInterface(ITypeY, Ret) = S_OK then
    ShowMessage('Supports ITypeY')
  else
    ShowMessage('DOES NOT Support ITypeY')
end;

end.

DFM

object Form_Interfaces: TForm_Interfaces
  Left = 273
    Top = 278
    BorderStyle = bsDialog
    Caption = 'Experimenting with Typecasting interfaces'
    ClientHeight = 222
    ClientWidth = 341
    Color = clBtnFace
    Font.Charset = DEFAULT_CHARSET
    Font.Color = clWindowText
    Font.Height = -11
    Font.Name = 'MS Sans Serif'
    Font.Style = []
    OldCreateOrder = False
    Position = poScreenCenter
    PixelsPerInch = 96
    TextHeight = 13
    object FbtnTestCreate: TButton
    Left = 118
      Top = 39
      Width = 105
      Height = 25
      Caption = 'FbtnTestCreate'
      TabOrder = 0
      OnClick = Ev_FbtnTestCreateClick
  end
  object FbtnTypeCastX2Y: TButton
    Left = 118
      Top = 79
      Width = 105
      Height = 25
      Caption = 'FbtnTypeCastX2Y'
      TabOrder = 1
      OnClick = Ev_FbtnTypeCastX2YClick
  end
  object FbtnTypeCastU2Y: TButton
    Left = 118
      Top = 119
      Width = 105
      Height = 25
      Caption = 'FbtnTypeCastU2Y'
      TabOrder = 2
      OnClick = Ev_FbtnTypeCastU2YClick
  end
  object FbtnTypeChecking: TButton
    Left = 118
      Top = 159
      Width = 105
      Height = 25
      Caption = 'FbtnTypeChecking'
      TabOrder = 3
      OnClick = Ev_FbtnTypeCheckingClick
  end
end

Component Download: http://www.eggcentric.com/InterfaceTypeCast.zip

The ActiveX Foundry

Problem/Question/Abstract:

The ActiveX Foundry

Answer:

It's spring again, a time when many eyes look to Borland for a new generation of Delphi development tools. This spring brings us the third incarnation of Delphi, a lush garden of new tools and technologies designed to expedite business-critical data handling and analysis.

The most exotic fruits of Borland's year-long labors include the ActiveX Component Foundry, Business Object Broker, multi-tier Remote Data Brokers, Distributed COM, Web Deployment, and a suite of IDE features known collectively as Code Insight. These are just the big ones - items major enough to earn buzzwords on the box cover.

There are so many new technical bits in Delphi 3 that it's difficult to grasp the scope of the whole product simply by looking at its technical pieces. Let's first take a high-level tour, focusing on how Delphi 3's new tools enable new ways to solve tough development and deployment problems. After all, you have a whole year of Delphi Informant articles ahead of you to pick apart the technical bits.

ActiveX Component Foundry

Delphi 3 goes completely overboard to support, adopt, and internalize Microsoft's ActiveX technology initiative. Delphi 3 is to ActiveX creation as Delphi 1 was to Windows application creation. Through a combination of new language extensions, new classes, and new design-time wizards and tools (see Figure 1), Delphi 3 cuts through the Microsoft rhetoric to deliver what Microsoft has been trying to do for ages: a development environment that makes creation, debugging, deployment, and maintenance of ActiveX controls, COM servers, and COM interfaces simple, easy, and reliable.


Figure 1: One aspect of the ActiveX Component Foundry, a page of wizards makes it short work to create an ActiveX control. Delphi 3 makes creation, debugging, deployment, and maintenance of ActiveX controls, COM servers, and COM interfaces simple, easy, and reliable.

Revisionist Terminology

Microsoft's Component Object Model specification, COM, is the standard to which all OLE objects are implemented. COM is the low-level stuff; OLE is a service built on COM. Depending on who you talk to at Microsoft, ActiveX is the new name for OLE Controls (OCXs, the 32-bit replacement for VBXs), the new name for all things formerly known as OLE, or the new name for all things new. Pessimists are already assuming the latter definitions. In any case, ActiveX is also a group of services and standards built on COM interfaces.

Create ActiveX Controls from VCL Components

Delphi 3 has a new wizard that generates an ActiveX control class wrapper around the VCL component you specify (see Figure 2). It's as simple as that. If you write VCL components for a living, you're now just a few button clicks away from selling those components as ActiveX controls to the Visual Basic and C++ markets. If you work in a mixed-tool environment, you can develop your core business objects as VCL components, then spit out ActiveX versions of your work for folks hopelessly shackled to other tools.


Figure 2: Delphi 3 has a new wizard that generates an ActiveX control class wrapper around the VCL component you specify. It's as simple as that.

Create COM Servers and Automation Servers from Scratch

A new OLE type library (typelib) editor (see Figure 3) makes short work of defining a new COM interface definition, saving it into an OLE-standard typelib file, and generating a source code unit with the interface type declaration. You create new COM interfaces whenever you build a new COM server, be it a visual ActiveX control or a non-visual data processing server.


Figure 3: A new OLE type library editor makes short work of defining a new COM interface definition, saving it into an OLE-standard typelib file, and generating a source code unit with the interface type declaration.

OLE typelibs are symbol files that tell other applications what methods are available in your COM server, and how to call them. Just as the IDE form designer and source code editor are linked two-way tools (i.e. modifications to one are reflected immediately in the other), the new typelib editor is also a two-way tool - modifications made to the Pascal interface type declaration source code are reflected in the typelib editor, and vice-versa.

Generate Pascal Declarations from Typelibs

As a side effect of the extensive typelib editor work, you can also generate Object Pascal source-code constants and interface type declarations from any OLE typelib. You can think of this as a vast expansion of the OCX wrapper class generation in Delphi 2. If you can obtain a typelib file for a COM object you want to use in Delphi (ActiveX controls are required to have a typelib), creating Pascal interface declarations to use that COM object are a snap, and considerably more accurate than trying to mechanically convert ambiguous C header files into Pascal declarations. Unfortunately, some COM objects do exist without typelibs; Microsoft's DirectX is probably the biggest offender in this category.

Create VCL components from ActiveX controls

The ActiveX wrapper class generation found in Delphi 2 has been expanded to take advantage of new language features like interface types, and new buzzwords like ActiveX. You can now directly access interfaces provided by ActiveX controls and take advantage of other control features that were previously only available through variant variables (see Figure 4).


Figure 4: You can now directly access interfaces provided by ActiveX controls and take advantage of other control features that were previously only available through variant variables.

ActiveForms

Another nifty spin-off of the core ActiveX development work is the creation of an ActiveX control to encapsulate an entire Delphi form (again, see Figure 1). This is necessary to support ActiveX property pages, but it's also handy for creating mini-application modules that can be automatically downloaded over the Internet and displayed inside a Web browser such as Microsoft Internet Explorer 3.0. The Web browser sees the thing as an ActiveX control, but you can pack an entire application into it.

Web Deployment

To support Web-deployed ActiveX controls, the Delphi 3 IDE includes tools to digitally sign and seal your .DLL or .EXE file with your Software Publisher digital certificate, and deliver it to a directory of your choosing (see Figure 5). This signature is checked by the Microsoft Internet Explorer 3.0 Web browser after downloading the ActiveX control as part of an HTML document to verify that the file is from who it says it's from, and that the file has not been tampered with or corrupted in transfer.


Figure 5: The new Web Deployment Options dialog box. To support Web-deployed ActiveX controls, Delphi 3 can digitally sign and seal your .DLL or .EXE file with your Software Publisher digital certificate, and deliver it to a directory you select.

The IDE deployment wizard can also bundle and compress multiple files into the Microsoft .CAB file format, generate .INF files needed for a downloadable component to refer to required modules downloadable separately, and generate an HTML object tag for you to paste into your Web page, to refer to your downloadable component (see Figure 6).


Figure 6: The Web deployment wizard can also bundle and compress multiple files into the Microsoft .CAB file format, generate .INF files needed for a downloadable component to refer to required modules downloadable separately, and much more.

Distributed COM

Delphi 3 supports Distributed COM, Microsoft's newest implementation of COM that enables an application on one machine to talk to an application on another across the network wire. Basically, DCOM is the heir-apparent to Remote Procedure Calls (RPC). Delphi 3's remote datasets use DCOM to make the hop from the client machine to the middle-tier data broker. You can implement your own middle-tier business logic by creating a COM server in Delphi 3, and call its methods using interfaces in the client application. DCOM takes care of the network transport; you just have to ask for it.

New Interface Type

OLE objects are always accessed through COM interfaces - abstract, virtual, base classes that define a group of related functions, but not their implementation. All COM interfaces are derived from the IUnknown standard interface, which defines simple reference-counting methods and a QueryInterface method to gain access to other interfaces supported by that object.

By far the most common programming error when using OLE objects is forgetting to increment or decrement the reference count of interfaces onto which you're holding. If you forget to call AddRef on an interface, the object behind that interface may delete itself if some other action causes the object's reference count to drop to zero. Subsequent use of the interface pointer you held onto will cause an access violation. If you forget to call Release on an interface when you're finished with it, the object behind that interface will remain in memory, never to be freed, because its reference count is artificially inflated.

Delphi 3 eliminates this debugging nightmare by adding a new standard type to the Object Pascal language definition: the interface type. An interface type declaration looks much like a class type declaration, but an interface type is only a declaration - it has no implementation of its own. An interface is like a standardized subset of methods that an object can implement. Regardless of what else the implementing object implements, you know that if it implements the XYZ interface, you can use the XYZ methods on it. Furthermore, you can obtain the XYZ interface from the implementing object, and use it without knowing anything about the implementor's class type.

In use, interface variables are initialized, reference-counted (through standard IUnknown methods), and released automatically by compiler-generated code, just as long strings and variants are dynamically allocated, reference counted, and released in Delphi 2. In Delphi 3, transferring values between interface variables or passing them as parameters is now as simple and reliable as transferring integer or string values. In many respects, passing interface values around is safer than passing object instances around, because interface reference-counting eliminates the question of who is responsible for freeing the object.

MI = Multiple Interfaces, not Multiple Inheritance

The flip side of interfaces is how they are implemented by an object. An OLE object may support many different interfaces, such as for streaming, printing, or drawing on the screen. Delphi 3 extends the declaration syntax of the class type, so you can declare a class as an implementor of one or more interface specifications. The Delphi compiler takes care of binding declared methods in the interface types to implemented methods in the class type. No tables of macros of pointers to functions, to crosswire with a typo - the compiler does it all. When something isn't quite right, the Delphi compiler tells you where and what you've missed in your declarations. For example, an interface-implementing class must implement all methods declared in the interface type. If you forget one of the interface methods, the compiler will remind you, just as it reminds you when you declare a method in a class type, but forget to give it a method body.

When a class implements an interface, instances of that class type are assignment-compatible with variables of the interface type. You can take an object instance and assign it to an interface variable, and the compiler will do the magic of extracting the correct interface pointer from the object instance automatically. You can also do late-bound (run-time) interface extraction using the as typecast operator, which calls the implementor's QueryInterface method to obtain the desired interface at run time.

Note that while an object may implement multiple interfaces, this is not the same as multiple inheritance; you are not inheriting any implementation details from the multiple interfaces.

What this means is that implementing OLE objects (such as ActiveX controls and custom COM servers) is now almost trivial. Delphi 3 requires none of the unintelligible tables of macros of pointers that Microsoft's ActiveX SDK heaps upon itself. Where Microsoft implements ActiveX as a system of macros and C++ template classes on top of the C/C++ language, Delphi implements ActiveX by incorporating the essential enabling technologies into the Object Pascal language and VCL classes. Why bother with macros and well-meaning source code conventions when you can have the compiler do the dirty work for you?

Data Visualization

Delphi 3's Component palette includes three new heavy-hitters: an all-new version of QuickReport, powerful charting capabilities in TeeChart, and the DecisionCube interactive crosstab (see Figure 7). You can embed TeeCharts in QuickReport reports, as well as link a TeeChart to the DecisionCube to graphically display the crosstab data on-the-fly.


Figure 7: Delphi 3's Component palette includes three new heavy-hitters, including the powerful DecisionCube.

Application Deployment: Web or Otherwise

If you've ever installed multiple Delphi applications on the same machine, you've probably wondered if there was some way to share the VCL component code between the multiple applications. Well, now there is: a Delphi package. A package is a special .DLL which contains and exports one or more units for applications or other packages to share. A package is different from a .DLL in that it's Delphi-specific (non-Delphi apps should not try to link directly to a package .DLL) and you don't have to change any Delphi source code to use it.

In compiler parlance, packaging is a code-generation option (see Figure 8), which means it should have no effect on the semantics of your source code. When your Delphi application is compiled to use the VCL core package, for example, the compiler generates code to reference the Forms unit in the VCL package .DLL instead of placing the Forms unit code in your .EXE. The result is that your .EXE size drops from around 200KB to less than 20KB. With packages, the .EXE file contains only your application logic and form resources. This also makes ActiveX control .DLLs extremely small - about 25KB - far smaller than Microsoft's 50KB minimum ActiveX template-based control library, or 800KB minimum, MFC-based ActiveX control library.


Figure 8: The new Packages page of the Project Options dialog box. A package is a special .DLL which contains and exports one or more units for applications or other packages to share.

The price for packages is that the package .DLL must contain every bit of code and data that its member units define in their interface sections. This makes the core VCL package weigh in at just over 1MB. (Because most units in the core VCL package are used by the simplest blank form application, and that minimal application produces a 150KB .EXE file, that should tell you something about the value of smart linking.)

Packages are a great way to reduce the overall size of a suite of applications, and open up interesting options for such bandwidth-sensitive applications as ActiveX controls deployed over the Internet (as objects embedded in HTML documents) or network-deployed shareware. The common packages could be bundled separately from the main application file set, so that folks who already have the packages don't have to download them again. Better yet, you could refer to the Borland Web site as the source for the Delphi core packages instead of bundling them yourself, and consuming disk space on your file server.

Code Insight

How many times have you started to write a function call statement, but forgotten what parameters that function call requires? Wouldn't it be great if you could type a function name and hit a hotkey to show the function's parameter declaration, right there in the editor? Wouldn't it be great if it showed functions you created, as well as the Borland-documented stuff? Wouldn't it be wild if it would help you fill in the parameters too?

Delphi's Code Insight provides all of this, and much more. Its Code Parameters feature uses the compiler to determine what function you're trying to use, what its parameters are, and the types of those parameters. Moreover, it's nearly instantaneous and non-intrusive. (Beware of similar-sounding features in other products, which only give you help on functions defined by the tool vendor. Delphi uses the compiler symbols to give you help on all functions in your project - Borland's, yours, and all third-party units used by your project.)

Using code templates, you can define standard code blocks (if/then/else, begin/end, for loops, while loops, etc.) with shortcut names to insert into the editor with just a keystroke or two.

The Code Completion feature helps you enter field names and parameter values by displaying a pop-up list of identifiers that are type-compatible with the source code expression to the left of the editor cursor. For example, typing:

"Caption := IntToStr(ProgressBar1."

and pressing a hotkey will show all the integer properties and functions available on the form's ProgressBar1 component. The helper knows that ProgressBar1 is a component, and that IntToStr requires an integer type parameter, so it shows you the things in ProgressBar1 that can provide an integer-compatible value.

For debugging, the Tool Tip Expression Evaluation feature shows the values of variables in a hint balloon as your mouse moves over the source code symbols in the Code Editor. I may never use the Evaluate/Modify dialog box again!

To make it easier to debug ActiveX control .DLLs and COM servers, particularly when they are used by non-Delphi applications, you can tell the Delphi IDE debugger to run a particular .EXE in order to debug the current .DLL project. So, you can compile your ActiveX control .DLL project, set a few breakpoints in the source code, tell the debugger that the host .EXE for your .DLL is VB.EXE, select Run | Run, and Visual Basic is displayed. Tell VB to load your ActiveX control .DLL - and bing! - execution stops at a breakpoint in the Delphi debugger. You can step, evaluate, watch (and so forth) items in your .DLL while it's being used by VB.

Virtualized Datasets

To enable BDE-less remote datasets (and to respond to a common customer request), Delphi 3 virtualizes all database activity through a - now abstract -TDataSet class. BDE awareness is introduced in a new TDataSet descendant, TBDEDataSet, which serves as the ancestor of TDBDataSet and the familiar TTable, TQuery, and TStoredProc classes (see Figure 9).


Figure 9: Class hierarchy of TDataSet for Delphi 2 and 3. In Delphi 3, TDataSet is now abstract and has a new ancestor, TBDEDataSet. The Delphi 3 BDE now features direct links to Access and DB2, as well as dBASE, Paradox, ODBC, Informix, InterBase, Microsoft SQL Server, Oracle, and Sybase.

Delphi 3 also implements support for "thin-client" remote datasets as a descendant of the base TDataSet class, independent of the BDE. This abstraction of the dataset will also enable third parties to implement Delphi dataset support for other data providers and file formats, without resorting to fate-tempting BDE .DLL hacks.

Breaking Up Client/Server

Seasoned SQL database folks can rattle off all sorts of weaknesses and liabilities of the industry standard two-tier SQL client/server application model. For example, the client machine and application are often intimately bound to the SQL server's network name and SQL dialect or vendor. BDE aliases allow you to re-vector server references on a client machine without recompiling the client application, but those aliases are still on the client machine. If your SQL server goes down and you have to prop up your business with a backup machine, how do you make all your clients automatically talk to the backup machine instead?

Another problem with two-tier is related to centralization of business rules and data policies. In the standard two-tier SQL model, the rules that determine data relationships and links within the database must be implemented on either the server or the client. SQL has proven itself to be an adequate tool for describing and managing data, but is terrible for implementing the programming logic required for complex business rules, such as non-tabular tax calculations or least-cost resource allocation. This means enterprise-wide business rules tend to be implemented in the client application instead of on the centralized server, inflating the size of the client application and creating a maintenance liability.

Multi-Tier Remote Data Brokers

The solution to these and many other weaknesses of the traditional two-tier SQL model is to break the direct connection between the client application and the server. Multi-tier data models make the client application talk to an intermediate machine or service (a broker), which can then process or forward the information to an appropriate server. The client never talks directly to the final SQL server that owns the actual data, so the client application doesn't need to know how to talk SQL - the client application can speak simply and frankly to the intermediate data broker, and the broker can carry the burden of speaking SQL to the data servers, and fret with maintaining connections to multiple data servers - SQL and otherwise. Because business rules and other data-handling logic can live on a middle tier broker, a significant portion of what you've been calling your client application can be moved off the client machine and onto centrally managed servers. What's more, the middle-tier broker can be implemented - and debugged - using real programming tools (such as Delphi, of course) instead of primitive SQL stored procedures (see Figures 10 and 11).


Figure 10: The two-tier SQL server model.


Figure 11: The multi-tier server model.

Delphi 3 opens the floodgates to multi-tier distributed application development with the introduction of the remote dataset. A remote dataset looks and acts like any other dataset (TTable, TQuery), serving rows of data to data-aware controls. The difference is that a remote dataset doesn't require the presence of a full database engine on the client machine - the dataset talks to a second machine (the middle-tier data broker) that contains the database engine, complete with querying, filtering, and SQL connectivity intelligence. With no BDE to install or configure on the client machine, remote datasets enable you to reduce the size and complexity of your client application's file set by an order of magnitude.

With only a handful of middle-tier machines connecting to your SQL servers, Delphi 3's remote datasets could save you an enormous amount of money in SQL server connection licenses alone. Disconnecting the client from the server also opens many options for failover and server load balancing, simply by causing the middle-tier broker to forward client requests to the least busy machine in a server farm.

Conclusion

There are far too many exciting new features in Delphi 3 to cover in one article, or even to try to absorb in one sitting. I'd love to rattle on about the Web-server dispatch and database components for building Netscape and Microsoft Internet Server extension .DLLs, or the extensive support for DIB image formats and direct pixel memory pointers in TBitmap, the new TJPEGImage class, or the new "globalization" of the Delphi RTL and VCL classes to support multi-byte character sets in Asian locales, or the all-new documentation set and online Help, but for now a tease will have to do. So many ideas, so little time.

Get disk free space

Problem/Question/Abstract:

How can i get disk free space?

Answer:

function GetDiskFree(Drive: char): int64;
{ func to return the free space of a drive in bytes. }
var
{$IFDEF Delphi3Below}
  lpFreeBytesAvailableToCaller,
    lpTotalNumberOfBytes,
    lpTotalNumberOfFreeBytes: comp;
{$ELSE}
  lpFreeBytesAvailableToCaller,
    lpTotalNumberOfBytes,
    lpTotalNumberOfFreeBytes: TLargeInteger;
{$ENDIF}
begin
  if GetDiskFreeSpaceEx(PChar(Drive + ':\'), lpFreeBytesAvailableToCaller,
    lpTotalNumberOfBytes, @lpTotalNumberOfFreeBytes) then
    Result := lpTotalNumberOfFreeBytes
  else
    Result := -1;
end;

procedure TForm1.SpeedButton1Click(Sender: TObject);
begin
  ShowMessage('a:' + IntToStr(GetDiskFree('a')));
  ShowMessage('c:' + IntToStr(GetDiskFree('c')));
end;

Creating a splash screen

Problem/Question/Abstract:

How do I make a splash screen for my application?

Answer:

First make a new form, this will be your SpashSreen.

Set Name to "Splash".
Set BorderStyle to "bsNone".
Put an image or whatever on it.
Make sure it is not auto-created. (Shift-Ctrl-F11)
Now edit your main program body:

program MyApp;
{... }
begin
  Application.Initialize;

  { ---------- PUT THIS IN: ------------- }
  Splash := TSplash.Create(Application);
  Splash.Show;
  Splash.Refresh;
  { ------------------------------------- }

  ..
    Application.CreateForm(...);
    Application.Run;
end;

Now edit the OnShow event of your main form:

procedure TMainForm.FormShow(Sender: TObject);
begin
  {...}
  { Free Splash screen }
  Splash.Free;
end;

You now have a splash screen!
Tip: If you place the Spash.Free in a OnTimer event, you can control how long the user sees your splash screen.

Format a disk

Problem/Question/Abstract:

How to format a disk

Answer:

Use the SHFormatDrive- function in then Shell32.dll. You will get (Windows NT, Win95 ???) the standard format-disk- dialog. Put the following in your interface-part:

const
  SHFMT_ID_DEFAULT = $FFFF; {Default for physical format}
  SHFMT_OPT_QUICKFORMAT = $0000; {do quick formatting}
  SHFMT_OPT_FULL = $0001; {complete formatting}
  SHFMT_OPT_SYSONLY = $0002; {copy system files only}
  SHFMT_ERROR = $FFFFFFFF; {formatting error}
  SHFMT_CANCEL = $FFFFFFFE; {formatting aborted}
  SHFMT_NOFORMAT = $FFFFFFFD; {unable to format}

function SHFormatDrive(hWnd: HWND; Drive, fmtID, Options: Word): Longint; stdcall;

implementation

const
  Shell32 = 'Shell32.dll';

function SHFormatDrive; external Shell32 name 'SHFormatDrive';

And a little example for executing the function and formatting drive A:

procedure TMainFrm.DiskFormatClick(Sender: TObject);
var
  FmtRes: longint;
  DriveNo: word;
begin
  DriveNo := 0; {Drive A}
  try
    FmtRes := ShFormatDrive(Handle, DriveNo, SHFMT_ID_DEFAULT, SHFMT_OPT_QUICKFORMAT);
    if FmtRes < 0 then
      ShowMessage('Error or Abort Formatting');
  except
  end;
end;


Solve 2:

procedure FormatFloppy(Drive: byte);
{Procedure to bring up the standard Windows format dialog to format a floppy drive.
Pass 0 for A:\ or 1 for B:\ }
type
  TSHFormatDrive = function(hWnd: HWND; Drive: Word; fmtID: Word;
    Options: Word): Longint stdcall;
var
  SHFormatDrive: TSHFormatDrive;
  LibHandle: THandle;
begin
  LibHandle := LoadLibrary(PChar('Shell32.dll'));
  if LibHandle <> 0 then
    @SHFormatDrive := GetProcAddress(LibHandle, 'SHFormatDrive')
  else
  begin
    MessageDlg('Failed to load Shell32.dll.', mtError, [mbOK], 0);
    Exit;
  end;
  if @SHFormatDrive <> nil then
    SHFormatDrive(Application.Handle, Drive, { 0 = A:\, 1 = B:\ } $FFFF, 0);
  FreeLibrary(LibHandle);
  @SHFormatDrive := nil;
end;

Add Menu Item To Explorer Context Menu

Problem/Question/Abstract:

How to add menu items to windows explorer / desktop context menu

Answer:

// Open Delphi select dynamic link library
// Copy / paste this into the DLL
// Then compile
// You will have to customize this code. To suite your needs.
// once the dll has been compiled you will now have to register this
// com server.
// Use regsvr32.exe sendtoweb.dll
// now open windows explorer and you will see a new menu item
// which can be accessed by the desktop also..

unit Sendtoweb;

// Author C Pringle Cjpsoftware.com

{ Implementation of the context menu shell extension COM object. This
  COM object is responsible for forwarding requests to its partner
  TPopupMenu component. The TPopupMenu component must reside on the
  MenuComponentForm, and is referred to explicitly in this example.
  You can modify this code to make it more flexible and generic in
  the future.

  The TContextMenu component registers itself as a global context menu
  handler. This is accomplished by adding a key to the
  HKEY_CLASSES_ROOT\*\ShellEx\ContextMenuHandlers key in the registry.

  jfl
}

interface

uses

  Classes, ComServ, ComObj, ActiveX, Windows, ShlObj, Interfaces, Menus,
  ShellAPI, SysUtils, registry;

type
  TContextMenuFactory = class(TComObjectFactory)
  public
    procedure UpdateRegistry(Register: Boolean); override;
  end;

  TContextMenu = class(TComObject, IShellExtInit, IContextMenu)
  private
    FFileName: string;
    function BuildSubMenu(Menu: HMENU; IndexMenu: Integer;
      var IDCmdFirst: Integer): HMENU;
  protected
    szFile: array[0..MAX_PATH] of Char;
    // Required to disambiguate TComObject.Initialize otherwise a compiler
    // warning will result.
    function IShellExtInit.Initialize = IShellExtInit_Initialize;
  public
    { IShellExtInit members }
    function IShellExtInit_Initialize(pidlFolder: PItemIDList; lpdobj: IDataObject;
      hKeyProgID: HKEY): HResult; stdcall;
    { IContextMenu }
    function QueryContextMenu(Menu: HMENU;
      indexMenu, idCmdFirst, idCmdLast, uFlags: UINT): HResult; stdcall;
    function InvokeCommand(var lpici: TCMInvokeCommandInfo): HResult; stdcall;
    function GetCommandString(idCmd, uType: UINT; pwReserved: PUINT;
      pszName: LPSTR; cchMax: UINT): HResult; stdcall;
  end;

var
  // Must be set prior to instantiation of TContextMenu!
  GFileExtensions: TStringList;

const
  MenuCommandStrings: array[0..3] of string = (
    '', '&STW Web Upload', '&STW FTPClient', '&STW Setup'
    );

implementation

{ TContextMenuFactory }
{ Public }

function ReadDefaultPAth: string;
var
  path: string;
  Reg: TRegistry;
begin

  Reg := TRegistry.CReate;
  try
    with Reg do
    begin
      RootKey := HKEY_LOCAL_MACHINE;
      Path := 'SOFTWARE\Microsoft\Windows\CurrentVersion\App Paths';

      if KeyExists(Path) then
      begin
        OpenKey(Path + '\sendtoweb.exe', false);
        Result := ReadString(#0);
        closekey;
      end;

      // Key Added to shell ext.

    end;
  finally
    Reg.CloseKey;
    Reg.Free;
  end;

end; // Custom registration code

procedure TContextMenuFactory.UpdateRegistry(Register: Boolean);
begin
  inherited UpdateRegistry(Register);

  // Register our global context menu handler
  if Register then
  begin
    CreateRegKey('*\ShellEx\ContextMenuHandlers\SendToWeb', '',
      GUIDToString(Class_ContextMenu));
    CreateRegKey('CLSID\' + GUIDToString(ClassID) + '\' +
      ComServer.ServerKey, 'ThreadingModel', 'Apartment');
  end
  else
  begin
    DeleteRegKey('*\ShellEx\ContextMenuHandlers\SendToWeb');
  end;
end;

{ TContextMenu }
{ Private }

{ Build a context menu using the existing Menu handle. If Menu is nil,
  we create a new menu handle and return it in the function's return
  value. Note that this function does not handle nested (recursive)
  menus. This exercise is left to the reader. }

function TContextMenu.BuildSubMenu(Menu: HMENU; IndexMenu: Integer;
  var IDCmdFirst: Integer): HMENU;
var
  i: Integer;
  menuItemInfo: TMenuItemInfo;
begin
  if Menu = 0 then
    Result := CreateMenu
  else
    Result := Menu;

  // Build the menu items here
  with menuitemInfo do
  begin
    cbSize := SizeOf(TMenuItemInfo);
    fMask := MIIM_CHECKMARKS or MIIM_DATA or MIIM_ID or
      MIIM_STATE or MIIM_SUBMENU or MIIM_TYPE or MIIM_CHECKMARKS;
    fType := MFT_STRING;
    fState := MFS_ENABLED;
    hSubMenu := 0;
    hbmpChecked := 0;
    hbmpUnchecked := 0;
  end;

  for i := 0 to High(MenuCommandStrings) do
  begin
    if i = 0 then
      menuitemInfo.fType := MFT_SEPARATOR
    else
      menuiteminfo.ftype := MFT_String;
    if i = 1 then
      menuitemInfo.fstate := MFS_ENABLED or MFS_DEFAULT
    else
      menuitemInfo.fstate := MFS_ENABLED;

    menuitemInfo.dwTypeData := PChar(MenuCommandStrings[i]);
    menuitemInfo.wID := IDCmdFirst;
    InsertMenuItem(Result, IndexMenu + i, True, menuItemInfo);
    Inc(IDCmdFirst);
  end;
end;

{ IShellExtInit }

function TContextMenu.IShellExtInit_Initialize(pidlFolder: PItemIDList;
  lpdobj: IDataObject; hKeyProgID: HKEY): HResult;
var
  medium: TStgMedium;
  fe: TFormatEtc;

begin
  with fe do
  begin
    cfFormat := CF_HDROP;
    ptd := nil;
    dwAspect := DVASPECT_CONTENT;
    lindex := -1;
    tymed := TYMED_HGLOBAL;
  end;
  // Fail the call if lpdobj is Nil.
  if lpdobj = nil then
  begin
    Result := E_FAIL;
    Exit;
  end;
  // Render the data referenced by the IDataObject pointer to an HGLOBAL
  // storage medium in CF_HDROP format.
  Result := lpdobj.GetData(fe, medium);
  if Failed(Result) then
    Exit;
  // If only one file is selected, retrieve the file name and store it in
  // szFile. Otherwise fail the call.
  if DragQueryFile(medium.hGlobal, $FFFFFFFF, nil, 0) = 1 then
  begin
    DragQueryFile(medium.hGlobal, 0, szFile, SizeOf(szFile));
    Result := NOERROR;
  end
  else
    Result := E_FAIL;
  ReleaseStgMedium(medium);
end;

{ IContextMenu }

function TContextMenu.QueryContextMenu(Menu: HMENU;
  indexMenu, idCmdFirst, idCmdLast, uFlags: UINT): HResult;
var
  extension: string;
  I: Integer;
  idLastCommand: Integer;
begin
  Result := E_FAIL;
  idLastCommand := idCmdFirst;

  // Extract the filename extension from the file dropped, and see if we
  // have a handler registered for it
//  extension := UpperCase( ( FFileName ) );

//for i := 0 to GFileExtensions.Count - 1 do
//   if Pos(Lowercase(GFileExtensions[ i ]),lowercase(extension))=0 then
  //  begin
  BuildSubMenu(Menu, indexMenu, idLastCommand);
  // Return value is number of items added to context menu
  Result := idLastCommand - idCmdFirst;
  //      Exit;
  //    end;
end;

function TContextMenu.InvokeCommand(var lpici:
  TCMInvokeCommandInfo): HResult;
var
  idCmd: UINT;
begin
  if HIWORD(Integer(lpici.lpVerb)) <> 0 then
    Result := E_FAIL
  else
  begin
    idCmd := LOWORD(lpici.lpVerb);
    Result := S_OK;

    // Activate the Dialog And prepare to send data to the
    // web

    case idCmd of
      1:
        begin

          ShellExecute(GetDesktopWindow, nil, Pchar(ExtractFileName(ReadDefaultPath)),
            Pchar('Direct' + '"' + szfile + '"'), nil, SW_SHOW);

        end;
      3:
        begin
          ShellExecute(GetDesktopWindow, nil, Pchar(ExtractFileName(ReadDefaultPath)),
            Pchar('Path'), nil, SW_SHOW);

        end;
      2:
        ShellExecute(GetDesktopWindow, nil, Pchar(ExtractFileName(ReadDefaultPath)),
          PChar(''), nil, SW_SHOW);
    else
      Result := E_FAIL;
    end;
  end;
end;

function TContextMenu.GetCommandString(idCmd, uType: UINT;
  pwReserved: PUINT; pszName: LPSTR; cchMax: UINT): HResult;

begin
  //  StrCopy( pszName, 'Send To The Web') ;

  Result := S_OK;
end;

initialization
  { Note that we create an instance of TContextMenuFactory here rather
    than TComObjectFactory. This is necessary so that we can add some
    custom registry entries by overriding the UpdateRegistry virtual
    function. }
  TContextMenuFactory.Create(ComServer, TContextMenu, Class_ContextMenu,
    'ContextMenu', 'Send To The Web', ciMultiInstance);

  // Initialize the file extension list
  GFileExtensions := TStringList.Create;
  // GFileExtensions.Add( 'setup msn' );

finalization
  GFileExtensions.Free;

end.

Convert a string to a mathematical expression and get its result

Problem/Question/Abstract:

How to convert a string to a mathematical expression and get its result.

Answer:

unit MathComponent;

interface

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

type
  TOperandtype = (ttradians, ttdegrees, ttgradients);
  TMathtype = (mtnil, mtoperator, mtlbracket, mtrbracket, mtoperand, mtfunction);
  TMathSubtype = (msnone, mstrignometric);
  TMathOperator = (monone, moadd, mosub, modiv, momul, mopow, momod, modivint);
  TMathFunction = (mfnone, mfsinh, mfcosh, mftanh, mfcosech, mfsech, mfcoth, mfsin,
    mfcos, mftan, mfcot, mfsec, mfcosec, mflog, mfln, mfsub, mfadd);

type
  pmathchar = ^Tmathchar;
  TMathChar = record
    case mathtype: Tmathtype of
      mtoperand: (data: extended);
      mtoperator: (op: TMathOperator);
      mtfunction: (func: TMathfunction; subtype: (mstnone, msttrignometric));
  end;

type
  TMathControl = class(TComponent)
  private
    input, output, stack: array of tmathchar;
    fmathstring: string;
    ftrignometrictype: Toperandtype;
    fExpressionValid: boolean;
    procedure removespace;
    function isvalidchar(c: char): boolean;
    function getresult: extended;
    function checkbrackets: boolean;
    function calculate(operand1, operand2, operator: Tmathchar): extended; overload;
    function calculate(operand1, operator: Tmathchar): extended; overload;
    function getoperator(pos: integer; var len: integer; var amathoperator:
      TMathOperator): boolean;
    function getoperand(pos: integer; var len: integer; var value: extended): boolean;
    function getmathfunc(pos: integer; var len: integer; var amathfunc:
      TmathFunction): boolean;
    function processstring: boolean;
    procedure convertinfixtopostfix;
    function isdigit(c: char): boolean;
    function getprecedence(mop: TMathchar): integer;
  protected
    procedure loaded; override;
  published
    property MathExpression: string read fmathstring write fmathstring;
    property MathResult: extended read getresult;
    property ExpressionValid: boolean read fExpressionvalid;
    property Trignometrictype: Toperandtype read ftrignometrictype write
      ftrignometrictype;
  end;

procedure Register;

implementation

function tmathcontrol.calculate(operand1, operator: Tmathchar): extended;
begin
  result := 0;
  if (operator.subtype = msttrignometric) then
  begin
    if ftrignometrictype = ttdegrees then
      operand1.data := operand1.data * (pi / 180);
    if ftrignometrictype = ttgradients then
      operand1.data := GradToRad(operand1.data);
  end;
  case operator.func of
    mfsub: result := -operand1.data;
    mfadd: result := operand1.data;
    mfsin: result := sin(operand1.data);
    mfcos: result := cos(operand1.data);
    mfcot: result := 1 / tan(operand1.data);
    mfcosec: result := 1 / sin(operand1.data);
    mfsec: result := 1 / cos(operand1.data);
    mftan: result := tan(operand1.data);
    mflog: result := log10(operand1.data);
    mfln: result := ln(operand1.data);
  end;
end;

function tmathcontrol.getmathfunc(pos: integer; var len: integer; var amathfunc:
  TmathFunction): boolean;
var
  tmp: string;
  i: integer;
begin
  amathfunc := mfnone;
  result := false;
  tmp := '';
  if (fmathstring[pos] = '+') then
  begin
    amathfunc := mfadd;
    len := 1;
    result := true;
  end;
  if (fmathstring[pos] = '-') then
  begin
    amathfunc := mfsub;
    len := 1;
    result := true;
  end;
  if (fmathstring[pos] = 's') then
  begin
    for i := pos to pos + 3 do
      tmp := tmp + fmathstring[i];
    if strcomp(pchar(tmp), 'sin(') = 0 then
    begin
      amathfunc := mfsin;
      len := 3;
      result := true;
    end
    else if strcomp(pchar(tmp), 'sec(') = 0 then
    begin
      amathfunc := mfsec;
      len := 3;
      result := true;
    end;
  end;
  if (fmathstring[pos] = 'c') then
  begin
    for i := pos to pos + 5 do
      tmp := tmp + fmathstring[i];
    if strlcomp(pchar(tmp), 'cos(', 4) = 0 then
    begin
      amathfunc := mfcos;
      len := 3;
      result := true;
    end
    else if strlcomp(pchar(tmp), 'cot(', 4) = 0 then
    begin
      amathfunc := mfcot;
      len := 3;
      result := true;
    end
    else if strlcomp(pchar(tmp), 'cosec(', 6) = 0 then
    begin
      amathfunc := mfcosec;
      len := 3;
      result := true;
    end
  end;
  if (fmathstring[pos] = 't') then
  begin
    for i := pos to pos + 3 do
      tmp := tmp + fmathstring[i];
    if strlcomp(pchar(tmp), 'tan(', 4) = 0 then
    begin
      amathfunc := mflog;
      len := 3;
      result := true;
    end;
  end;
  if (fmathstring[pos] = 'l') then
  begin
    for i := pos to pos + 3 do
      tmp := tmp + fmathstring[i];
    if strlcomp(pchar(tmp), 'log(', 4) = 0 then
    begin
      amathfunc := mflog;
      len := 3;
      result := true;
    end
    else if strlcomp(pchar(tmp), 'ln(', 3) = 0 then
    begin
      amathfunc := mfln;
      len := 3;
      result := true;
    end
  end;
end;

procedure tmathcontrol.loaded;
begin
  inherited;
  fexpressionvalid := processstring;
end;

procedure tmathcontrol.removespace;
var
  i: integer;
  tmp: string;
begin
  tmp := '';
  for i := 1 to length(fmathstring) do
    if fmathstring[i] <> ' ' then
      tmp := tmp + fmathstring[i];
  fmathstring := tmp;
end;

function tmathcontrol.isvalidchar(c: char): boolean;
begin
  result := true;
  if (not (isdigit(c))) and (not (c in ['(', ')', 't', 'l', 'c', 'm', 'd', 's', '*',
    '/', '+', '-', '^'])) then
    result := false;
end;

function tmathcontrol.checkbrackets: boolean;
var
  i: integer;
  bracketchk: integer;
begin
  result := true;
  bracketchk := 0;
  i := 1;
  if length(fmathstring) = 0 then
    result := false;
  while i <= length(fmathstring) do
  begin
    if fmathstring[i] = '(' then
      bracketchk := bracketchk + 1
    else if fmathstring[i] = ')' then
      bracketchk := bracketchk - 1;
    i := i + 1;
  end;
  if bracketchk <> 0 then
    result := false;
end;

function Tmathcontrol.calculate(operand1, operand2, operator: Tmathchar): extended;
begin
  result := 0;
  case operator.op of
    moadd:
      result := operand1.data + operand2.data;
    mosub:
      result := operand1.data - operand2.data;
    momul:
      result := operand1.data * operand2.data;
    modiv:
      if (operand1.data <> 0) and (operand2.data <> 0) then
        result := operand1.data / operand2.data
      else
        result := 0;
    mopow: result := power(operand1.data, operand2.data);
    modivint:
      if (operand1.data <> 0) and (operand2.data <> 0) then
        result := round(operand1.data) div round(operand2.data)
      else
        result := 0;
    momod:
      if (operand1.data >= 0.5) and (operand2.data >= 0.5) then
        result := round(operand1.data) mod round(operand2.data)
      else
        result := 0;
  end;
end;

function Tmathcontrol.getresult: extended;
var
  i: integer;
  tmp1, tmp2, tmp3: tmathchar;
begin
  fExpressionValid := processstring;
  if fExpressionValid = false then
  begin
    result := 0;
    exit;
  end;
  convertinfixtopostfix;
  setlength(stack, 0);
  for i := 0 to length(output) - 1 do
  begin
    if output[i].mathtype = mtoperand then
    begin
      setlength(stack, length(stack) + 1);
      stack[length(stack) - 1] := output[i];
    end
    else if output[i].mathtype = mtoperator then
    begin
      tmp1 := stack[length(stack) - 1];
      tmp2 := stack[length(stack) - 2];
      setlength(stack, length(stack) - 2);
      tmp3.mathtype := mtoperand;
      tmp3.data := calculate(tmp2, tmp1, output[i]);
      setlength(stack, length(stack) + 1);
      stack[length(stack) - 1] := tmp3;
    end
    else if output[i].mathtype = mtfunction then
    begin
      tmp1 := stack[length(stack) - 1];
      setlength(stack, length(stack) - 1);
      tmp2.mathtype := mtoperand;
      tmp2.data := calculate(tmp1, output[i]);
      setlength(stack, length(stack) + 1);
      stack[length(stack) - 1] := tmp2;
    end;
  end;
  result := stack[0].data;
  setlength(stack, 0);
  setlength(input, 0);
  setlength(output, 0);
end;

function Tmathcontrol.getoperator(pos: integer; var len: integer; var amathoperator:
  TMathOperator): boolean;
var
  tmp: string;
  i: integer;
begin
  tmp := '';
  result := false;
  if fmathstring[pos] = '+' then
  begin
    amathoperator := moadd;
    len := 1;
    result := true;
  end
  else if fmathstring[pos] = '*' then
  begin
    amathoperator := momul;
    len := 1;
    result := true;
  end
  else if fmathstring[pos] = '/' then
  begin
    amathoperator := modiv;
    len := 1;
    result := true;
  end
  else if fmathstring[pos] = '-' then
  begin
    amathoperator := mosub;
    len := 1;
    result := true;
  end
  else if fmathstring[pos] = '^' then
  begin
    amathoperator := mopow;
    len := 1;
    result := true;
  end
  else if fmathstring[pos] = 'd' then
  begin
    for i := pos to pos + 2 do
      tmp := tmp + fmathstring[i];
    if strcomp(pchar(tmp), 'div') = 0 then
    begin
      amathoperator := modivint;
      len := 3;
      result := true;
    end;
  end
  else if fmathstring[pos] = 'm' then
  begin
    for i := pos to pos + 2 do
      tmp := tmp + fmathstring[i];
    if strcomp(pchar(tmp), 'mod') = 0 then
    begin
      amathoperator := momod;
      len := 3;
      result := true;
    end;
  end;
end;

function Tmathcontrol.getoperand(pos: integer; var len: integer; var value: extended):
  boolean;
var
  i, j: integer;
  tmpnum: string;
  dotflag: boolean;
begin
  j := 1;
  result := true;
  dotflag := false;
  for i := pos to length(fmathstring) - 1 do
  begin
    if isdigit(fmathstring[i]) then
    begin
      if (fmathstring[i] = '.') and (dotflag = true) then
      begin
        result := false;
        break;
      end
      else if (fmathstring[i] = '.') and (dotflag = false) then
        dotflag := true;
      tmpnum := tmpnum + fmathstring[i];
      j := j + 1;
    end
    else
      break;
  end;
  if result = true then
  begin
    value := strtofloat(tmpnum);
    len := j - 1;
  end;
end;

function Tmathcontrol.processstring: boolean;
var
  i: integer;
  mov: integer;
  tmpfunc: tmathfunction;
  tmpop: tmathoperator;
  numoperators: integer;
  numoperands: integer;
begin
  i := 0;
  mov := 0;
  numoperators := 0;
  numoperands := 0;
  setlength(output, 0);
  setlength(input, 0);
  setlength(stack, 0);
  removespace;
  result := true;
  if checkbrackets = false then
  begin
    result := false;
    exit;
  end;
  fmathstring := '(' + fmathstring + ')';
  while i <= length(fmathstring) - 1 do
  begin
    if not (isvalidchar(fmathstring[i + 1])) then
    begin
      result := false;
      break;
    end;
    if fmathstring[i + 1] = '(' then
    begin
      setlength(input, length(input) + 1);
      input[length(input) - 1].mathtype := mtlbracket;
      i := i + 1;
    end
    else if fmathstring[i + 1] = ')' then
    begin
      setlength(input, length(input) + 1);
      input[length(input) - 1].mathtype := mtrbracket;
      i := i + 1;
    end
    else if getoperator(i + 1, mov, tmpop) then
    begin
      if (tmpop <> moadd) and (tmpop <> mosub) then
      begin
        if i = 0 then //first character cannot be an operator
        begin // other than a '+' or '-'.
          result := false;
          break;
        end;
        setlength(input, length(input) + 1);
        input[length(input) - 1].mathtype := mtoperator;
        input[length(input) - 1].op := tmpop;
        i := i + mov;
        numoperators := numoperators + 1;
      end
      else if (tmpop = mosub) or (tmpop = moadd) then
      begin
        if (i = 0) or (input[length(input) - 1].mathtype = mtoperator) or
          (input[length(input) - 1].mathtype = mtlbracket) then
        begin //makes use of fact the if the first part of if expression is true then
          //remaining parts are not evaluated thus preventing a
          //exception from occuring.
          setlength(input, length(input) + 1);
          input[length(input) - 1].mathtype := mtfunction;
          getmathfunc(i + 1, mov, tmpfunc);
          input[length(input) - 1].func := tmpfunc;
          i := i + mov;
        end
        else
        begin
          setlength(input, length(input) + 1);
          numoperators := numoperators + 1;
          input[length(input) - 1].mathtype := mtoperator;
          input[length(input) - 1].op := tmpop;
          i := i + 1;
        end;
      end;
    end
    else if isdigit(fmathstring[i + 1]) then
    begin
      setlength(input, length(input) + 1);
      input[length(input) - 1].mathtype := mtoperand;
      if getoperand(i + 1, mov, input[length(input) - 1].data) = false then
      begin
        result := false;
        break;
      end;
      i := i + mov;
      numoperands := numoperands + 1;
    end
    else
    begin
      getmathfunc(i + 1, mov, tmpfunc);
      if tmpfunc <> mfnone then
      begin
        setlength(input, length(input) + 1);
        input[length(input) - 1].mathtype := mtfunction;
        input[length(input) - 1].func := tmpfunc;
        if tmpfunc in [mfsin, mfcos, mftan, mfcot, mfcosec, mfsec] then
          input[length(input) - 1].subtype := msttrignometric
        else
          input[length(input) - 1].subtype := mstnone;
        i := i + mov;
      end
      else
      begin
        result := false;
        break;
      end;
    end;
  end;
  if numoperands - numoperators <> 1 then
    result := false;
end;

function Tmathcontrol.isdigit(c: char): boolean;
begin
  result := false;
  if ((integer(c) > 47) and (integer(c) < 58)) or (c = '.') then
    result := true;
end;

function Tmathcontrol.getprecedence(mop: TMathchar): integer;
begin
  result := -1;
  if mop.mathtype = mtoperator then
  begin
    case mop.op of
      moadd: result := 1;
      mosub: result := 1;
      momul: result := 2;
      modiv: result := 2;
      modivint: result := 2;
      momod: result := 2;
      mopow: result := 3;
    end
  end
  else if mop.mathtype = mtfunction then
    result := 4;
end;

procedure Tmathcontrol.convertinfixtopostfix;
var
  i, j, prec: integer;
begin
  for i := 0 to length(input) - 1 do
  begin
    if input[i].mathtype = mtoperand then
    begin
      setlength(output, length(output) + 1);
      output[length(output) - 1] := input[i];
    end
    else if input[i].mathtype = mtlbracket then
    begin
      setlength(stack, length(stack) + 1);
      stack[length(stack) - 1] := input[i];
    end
    else if (input[i].mathtype = mtoperator) then
    begin
      prec := getprecedence(input[i]);
      j := length(stack) - 1;
      if j >= 0 then
      begin
        while (getprecedence(stack[j]) >= prec) and (j >= 0) do
        begin
          setlength(output, length(output) + 1);
          output[length(output) - 1] := stack[j];
          setlength(stack, length(stack) - 1);
          j := j - 1;
        end;
        setlength(stack, length(stack) + 1);
        stack[length(stack) - 1] := input[i];
      end;
    end
    else if input[i].mathtype = mtfunction then
    begin
      setlength(stack, length(stack) + 1);
      stack[length(stack) - 1] := input[i];
    end
    else if input[i].mathtype = mtrbracket then
    begin
      j := length(stack) - 1;
      if j >= 0 then
      begin
        while (stack[j].mathtype <> mtlbracket) and (j >= 0) do
        begin
          setlength(output, length(output) + 1);
          output[length(output) - 1] := stack[j];
          setlength(stack, length(stack) - 1);
          j := j - 1;
        end;
        if j >= 0 then
          setlength(stack, length(stack) - 1);
      end;
    end;
  end;
end;

procedure Register;
begin
  RegisterComponents('Samples', [TMathControl]);
end;

end.

Make Application.ExeName work in DLLs

Problem/Question/Abstract:

When you work with DLL you will discover that Application.ExeName will not return the DLL filename, but the filename of the application that loaded your library. That's a problem in some cases. You can use the GetModuleFileName to achieve this problem.

Answer:

In Forms.pas, at line 6856 you'll find:

function TApplication.GetExeName: string;
begin
  Result := ParamStr(0);
end;

for DLLs you can use this:

function GetRealExeName: string;
var
  ExeName: array[0..MAX_PATH] of char;
begin
  fillchar(ExeName, SizeOf(ExeName), #0);
  GetModuleFileName(HInstance, ExeName, MAX_PATH);
  Result := ExeName;
end;

now, this will return also DLL file names.

Kill an application without any confirmation

Problem/Question/Abstract:

How to kill an application without any confirmation

Answer:

The following code searches for Notepad, and kills it - no questions asked. Use

WinHwnd := FindWindow(classname, nil);

or

WinHwnd := FindWindow(nil, 'window-caption');

with your apps details.

procedure TForm1.ButtonClick(Sender: TObject);
var
  ProcessHandle: THandle;
  WinHwnd: HWND;
  ProcessID, ExitCode: Integer;
begin
  ProcessID := 0;
  ExitCode := 0;
  WinHwnd := FindWindow('NotePad', nil);
  if not (IsWindow(WinHwnd)) then
  begin
    ShowMessage('NotePad not found');
    exit;
  end;
  GetWindowThreadProcessID(WinHwnd, @ProcessID);
  ProcessHandle := OpenProcess(PROCESS_CREATE_THREAD or PROCESS_VM_OPERATION
    or PROCESS_VM_WRITE or PROCESS_VM_READ or
    PROCESS_TERMINATE, False, ProcessID);
  if (ProcessHandle > 0) then
  begin
    GetExitCodeProcess(ProcessHandle, ExitCode);
    { or  GetExitCodeProcess(ProcessHandle, DWORD(ExitCode)); }
    TerminateProcess(ProcessHandle, ExitCode);
    CloseHandle(ProcessHandle);
  end
  else
    ShowMessage('Unable to get proccess Handle');
end;

How to save and retrieve font information to / from a TIniFile

Problem/Question/Abstract:

How to save and retrieve font information to / from a TIniFile

Answer:

Solve 1:

uses
  Inifiles;

procedure SaveFont(FName: string; Section: string; smFont: TFont);
var
  FStream: TIniFile;
begin
  FStream := TIniFile.Create(FName);
  try
    FStream.WriteString(Section, 'Name', smFont.Name);
    FStream.WriteInteger(Section, 'CharSet', smFont.CharSet);
    FStream.WriteInteger(Section, 'Color', smFont.Color);
    FStream.WriteInteger(Section, 'Size', smFont.Size);
    FStream.WriteInteger(Section, 'Style', Byte(smFont.Style));
  finally
    FStream.free;
  end;
end;

procedure LoadFont(FName: string; Section: string; smFont: TFont);
var
  FStream: TIniFile;
begin
  FStream := TIniFile.Create(Fname);
  try
    smFont.Name := FStream.ReadString(Section, 'Name', smFont.Name);
    smFont.CharSet := TFontCharSet(FStream.ReadInteger(Section, 'CharSet',
      smFont.CharSet));
    smFont.Color := TColor(FStream.ReadInteger(Section, 'Color', smFont.Color));
    smFont.Size := FStream.ReadInteger(Section, 'Size', smFont.Size);
    smFont.Style := TFontStyles(Byte(FStream.ReadInteger(Section, 'Style',
      Byte(smFont.Style))));
  finally
    FStream.free;
  end;
end;

Here 's how to use the procedures:

{Save Font}

procedure TForm1.Button1Click(Sender: TObject);
begin
  SaveFont('font.ini', 'label', Label1.Font);
end;

procedure TForm1.Label1DblClick(Sender: TObject);
begin
  if FontDialog1.Execute then
    Label1.Font := FontDialog1.Font
end;

{Load Font}

procedure TForm1.Button2Click(Sender: TObject);
begin
  LoadFont('font.ini', 'label', Label1.Font);
end;


Solve 2:

This code converts an instance of TFont to/ from a string. Just store that string whereever you want:

function GetAnyFontAsStr(Font: TFont): string;
begin
  Result := 'DEFAULT';
  if Assigned(Font) then
  begin
    Result := QuotedStr('Name=' + Font.Name);
    Result := Result + ';
      Size = ' + IntToStr(Font.Size);
      Result := Result + ';
      Color = ' + ColorToString(Font.Color);
      Result := Result + ';
      Pitch = ' + GetEnumName(TypeInfo(TFontPitch), Ord(Font.Pitch));
      Result := Result + ';
      Style = ' + IntToStr(Byte(Font.Style));
  end;
end;

procedure SetAnyFontAsStr(var Font: TFont; aFontStr: string);
var
  FontStrList: TStringList;
begin
  if Assigned(Font) then
  begin
    FontStrList := TStringList.Create;
    FontStrList.QuoteChar := '''';
    FontStrList.Delimiter := ';';
    FontStrList.DelimitedText := aFontStr;
    Font.Name := FontStrList.Values['Name'];
    Font.Size := StrToInt(FontStrList.Values['Size']);
    Font.Color := StringToColor(FontStrList.Values['Color']);
    Font.Pitch := TFontPitch(GetEnumValue(TypeInfo(TFontPitch),
      FontStrList.Values['Pitch']));
    Font.Style := TFontStyles(Byte(StrToIntDef(FontStrList.Values['Style'], 0)));
    FontStrList.Free;
  end;
end;


Solve 3:

uses
  IniFiles;

procedure SaveInfo;
var
  t: TIniFile;
  s: string;
begin
  s := ExtractFilePath(ParamStr(0)) + 'fontinfo.ini';
  t := TIniFile.Create(s);
  {load previous values into Font dialog if there are any}
  if FileExists(s) then
    with FontDialog1.Font do
    begin
      Name := t.ReadString('Font', 'Name', Name);
      Size := t.ReadInteger('Font', 'Size', Size);
      Color := t.ReadInteger('Font', 'Color', Color);
      if t.ReadBool('Font', 'Bold', False) then
        Style := Style + [fsBold];
      if t.ReadBool('Font', 'Italic', False) then
        Style := Style + [fsItalic];
      if t.ReadBool('Font', 'Underline', False) then
        Style := Style + [fsUnderline];
      if t.ReadBool('Font', 'Strikeout', False) then
        Style := Style + [fsStrikeOut];
    end;
  if FontDialog1.Execute then
  begin
    {write new values to INI file for next time}
    with FontDialog1.Font do
    begin
      t.WriteString('Font', 'Name', Name);
      t.WriteInteger('Font', 'Size', Size);
      t.WriteInteger('Font', 'Color', Color);
      t.WriteBool('Font', 'Bold', fsBold in Style);
      t.WriteBool('Font', 'Italic', fsItalic in Style);
      t.WriteBool('Font', 'Underline', fsUnderline in Style);
      t.WriteBool('Font', 'Strikeout', fsStrikeout in Style);
    end;
  end;
  t.Free;
end;

As you can see, the Color property is stored as an integer. Therefore, if you need to also store the ColorDialog.Color property, use the ReadInteger and WriteInteger methods.

Write the checked state of stand-alone TRadioButtons to a TIniFile

Problem/Question/Abstract:

I have three single TRadioButtons sitting on a TPanel (on Form1). How can I save the state of the checked TRadioButton to a TIniFile and read it back afterwards? I know how to do it with a TRadioGroup, but not with stand-alone radiobuttons.

Answer:

uses
  IniFiles;

procedure SaveRadioButtonState;
var
  data: TIniFile;
  K: Integer;
begin
  data := TIniFile.Create(ExtractFilePath(Application.ExeName) + 'test.ini');
  try
    for K := 0 to form1.ComponentCount - 1 do
      if Form1.Components[K] is TRadioButton then
        {We only look for the checked radiobutton and save its state, of course}
        data.WriteBool('Options', IntToStr(K),
          TRadioButton(Form1.Components[K]).Checked = True);
  finally
    data.Free;
  end;
end;

procedure ReadRadioButtonState;
var
  data: TIniFile;
  K: Integer;
begin
  data := TIniFile.Create(ExtractFilePath(Application.ExeName) + 'test.ini');
  try
    for K := 0 to Form1.ComponentCount - 1 do
      if Form1.Components[K] is TRadioButton then
        TRadioButton(form1.Components[K]).Checked := data.ReadBool('Options',
          IntToStr(K), True);
  finally
    data.Free;
  end;
end;

Add formatted line (with TAGs) to TRichEdit - ready function

Problem/Question/Abstract:

Add formatted line (with TAGs) to TRichEdit - ready function

Answer:

procedure AddRichLine(RichEdit: TRichEdit; const StrToAdd: string);
var
  StrLeft: string;
  TempStyle: TFontStyles;
  TempStr: string;

  function FromLeftUntilStr(var OriginalStr: string; const UntilStr: string; const
    ToEndIfNotFound, Trim: Boolean): string;
  var
    TempPos: Integer;
  begin
    TempPos := Pos(UntilStr, OriginalStr);
    if TempPos > 0 then
    begin
      Result := Copy(OriginalStr, 1, TempPos - 1);
      if Trim then
        Delete(OriginalStr, 1, TempPos - 1);
    end
    else
    begin
      if ToEndIfNotFound then
      begin
        Result := OriginalStr;
        if Trim then
          OriginalStr := '';
      end
      else
        Result := '';
    end;
  end;

  function StrStartsWith(var OriginalStr: string; const StartsWith: string; const
    IgnoreCase, Trim: Boolean): Boolean;
  var
    PartOfOriginalStr: string;
    NewStartsWith: string;
  begin
    PartOfOriginalStr := Copy(OriginalStr, 1, Length(StartsWith));
    NewStartsWith := StartsWith;

    if IgnoreCase then
    begin
      PartOfOriginalStr := LowerCase(PartOfOriginalStr);
      NewStartsWith := LowerCase(NewStartsWith);
    end;

    Result := PartOfOriginalStr = NewStartsWith;

    if (Result = True) and (Trim = True) then
      Delete(OriginalStr, 1, Length(NewStartsWith));
  end;

  procedure AddToStyle(var Style: TFontStyles; AStyle: TFontStyle);
  begin
    if not (AStyle in Style) then
      Style := Style + [AStyle];
  end;

  procedure RemoveFromStyle(var Style: TFontStyles; AStyle: TFontStyle);
  begin
    if AStyle in Style then
      Style := Style - [AStyle];
  end;
begin
  TempStyle := RichEdit.Font.Style;
  StrLeft := StrToAdd;
  RichEdit.SelStart := Length(RichEdit.Text);
  while StrLeft <> '' do
  begin
    if StrStartsWith(StrLeft, '<', True, False) then
    begin
      // Bold Style
      if StrStartsWith(StrLeft, '', True, True) then
        AddToStyle(TempStyle, fsBold);
      if StrStartsWith(StrLeft, '', True, True) then
        RemoveFromStyle(TempStyle, fsBold);

      // Italic Style
      if StrStartsWith(StrLeft, '', True, True) then
        AddToStyle(TempStyle, fsItalic);
      if StrStartsWith(StrLeft, '', True, True) then
        RemoveFromStyle(TempStyle, fsItalic);

      // Underline Style
      if StrStartsWith(StrLeft, '', True, True) then
        AddToStyle(TempStyle, fsUnderline);
      if StrStartsWith(StrLeft, '', True, True) then
        RemoveFromStyle(TempStyle, fsUnderline);

      // Color
      if StrStartsWith(StrLeft, '', True, True) then
        RichEdit.SelAttributes.Color := RichEdit.Font.Color;
      if StrStartsWith(StrLeft, '', False, True);
      try
        RichEdit.SelAttributes.Color := StringToColor(TempStr);
      except
        RichEdit.SelAttributes.Color := RichEdit.Font.Color;
      end;
      Delete(StrLeft, 1, 1);
    end;
  end
else
  begin
    RichEdit.SelAttributes.Style := TempStyle;
    RichEdit.SelText := FromLeftUntilStr(StrLeft, '<', True, True);
  end;

  RichEdit.SelStart := Length(RichEdit.Text);
end;
RichEdit.SelText := #13#10;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  AddRichLine(RichEdit1,
    'Test: This is a bold test line which is written in blue. Nice?');
end;

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.