Display a sort order indicator in the column header of a TListView

Problem/Question/Abstract:

How can I display a sort order arrow on the tiltle row in TListView control (on the right side of the column caption)?

Answer:

The easiest way would be to add the arrow picture to the imagelist, assign it to the listview's smallimages property and specify the image index to the column (ImageIndex property of the TListColumn). Now you'll see the picture on the left side of the column header.

Another approach would be to draw the header by yourself. In case you're working with the standard (not overridden)TListView control, you can set the new window proc to the header in the form's OnCreate event. In the new header's window procedure you can check up if the WM_PAINT message is coming and perform custom drawing for the header or its part. See the example below for details:

{ ... }
type
  TForm1 = class(TForm)
    ListView1: TListView;
    { ... }
  protected
    FHeader: longint;
    FOldWndProc: pointer;
    procedure HeaderWndProc(var Message: TMessage);
  end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  FHeader := ListView_GetHeader(ListView1.Handle);
  FOldWndProc := Pointer(GetWindowLong(FHeader, GWL_WNDPROC));
  SetWindowLong(FHeader, GWL_WNDPROC,
    integer(Classes.MakeObjectInstance(HeaderWndProc)));
end;

procedure TForm1.HeaderWndProc(var Message: TMessage);
var
  XCanvas: TCanvas;
  XDC: HDC;
  XSizeRect: TRect;
begin
  if Assigned(FOldWndProc) then
    Message.Result := CallWindowProc(FOldWndProc, FHeader, Message.Msg,
      Message.WParam, Message.LParam);
  case Message.Msg of
    WM_PAINT:
      begin
        XCanvas := TCanvas.Create;
        XDC := GetWindowDC(FHeader);
        try
          XCanvas.Handle := XDC;
          Windows.GetClientRect(FHeader, XSizeRect);
          XCanvas.Brush.Color := clRed;
          XCanvas.FillRect(XSizeRect);
          {draw the new header's content here...}
        finally
          ReleaseDC(FHeader, XDC);
          XCanvas.Free;
        end;
      end;
  end;
end;

TScreen, TApplication used in a DLL

Problem/Question/Abstract:

TScreen, TApplication used in a DLL

Answer:

Each DLL in Delphi maintains its own instance of Application & Screen, your DLL-calling application should send the its own Application and Screen values to the DLL. The DLL should save and restore its original values.

You should put this code somewhere in your DLL and call the Init() function from your application:


const
  SavedApplication: TApplication = nil;
  SavedScreen: TScreen = nil;

  // export this procedure and call it after loading the DLL

procedure Init(anApplicationHandle, aScreenHandle: LongWord);
begin
  if not Assigned(SavedApplication) then
  begin
    SavedApplication := Application;
    Application := TApplication(anApplicationHandle);
  end;

  if not Assigned(SavedScreen) then
  begin
    // ....same...
  end;
end;

initialization

finalization
  if Assigned(SavedApplication) then
  begin
    Application := SavedApplication;
  end;

  if Assigned(SavedScreen) then
  begin
    // ....same.....
  end;
end.

How to determine the absolute location of a control

Problem/Question/Abstract:

Is there a built-in method for getting the absolute location of a control or do I need to step through the hierarchy? E.g.: Form1...Group1...Button1 means that the absolute left of Button1 is Form1.Left+Group1.Left+Button1.Left

Answer:

Solve 1:

You need to use the ClientToScreen and ScreenToClient methods, like this:


procedure TForm1.Button1Click(Sender: TObject);
var
  P: TPoint;
begin
  P := Point(Button1.Left, Button1.Top);
  {Button1's coordinates are expressed relative to it's parent. Using Parent.ClientToScreen converts these client coordinates to screen coordinates, which are absolute, not relative.}
  P := Button1.Parent.ClientToScreen(P);
  {Using ScreenToClient here is the same as Self.ScreenToClient. Since Self is the current instance of TForm1, this statement converts the absolute screen coordinates back to coordinates relative to Self.}
  P := ScreenToClient(P);
  ShowMessage(Format('x: %d, y: %d', [P.X, P.Y]));
end;


Because this code uses the absolute screen coordinates in the conversion process, it will work regardless of how deeply nested the Button is. It could be on the form, on a group on the form, on a panel in a group on the form... it doesn't matter. The code will always return the same results, the coordinates expressed in the form's client system.


Solve 2:

I don't know if there is a simpler method, but this one works:


function GetScreenCoordinates(AControl: TControl): TPoint;
begin
  if AControl.Parent <> nil then
  begin
    Result := AControl.Parent.ClientToScreen(Point(AContol.Left, AControl.Top));
  end
  else
  begin
    Result := Point(AContol.Left, AControl.Top);
  end;
end;


The trick is: If a control has no parent, (Left, Top) should be the screen coordinates already (TForm). If it has a parent, the ClientToScreen function of the parent can be used to get it.


Solve 3:

Use TComponent.DesignInfo, which holds the Left and Top of the component. You can do this:


X := LongRec(MyComponent.DesignInfo).Lo;
Y := LongRec(MyComponent.DesignInfo).Hi;

How to synchronize the scrolling of three TScrollBoxes when only one shows a scrollbar

Problem/Question/Abstract:

I need to synchronize three scrollboxes, only one of which will show the scrollbars. The documentation for TControlScrollBar reads: "If Visible is set to False, the scroll bar is never visible. This is useful, for example, for programmatically controlling the scroll position of a form without allowing the user to control the scroll position." I have been unable to make the scrollbox scroll when the scrollbar is visible. In fact, the moment you set the scrollbar to invisible, the position jumps back to 0.

Answer:

I looked at the VCL source for TScrollbox and TControlScrollbar and found the source of the problem: the TControlscrollbar class has an internal field named FCalcRange. If you try to set the scrollbar position the passed position is clipped to the range 0..FCalcRange. The only problem is that FCalcRange is set to 0 when the scrollbar is set to invisible, so Position will always be set to 0, regardless of what you try to set it to. I see no way around that, so you need to use a different strategy: instead of using the invisible scrollbars for the two slave scrollboxes scroll them directly, using ScrollBy.

The following example uses three scrollboxes of same size and scroll ranges. AutoScroll and Autosize are false for all, the first two have invisible scrollbars, the last has visible scrollbars and controls the other two. Each scrollbox has an edit in it so there is something visible to scroll around.

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    ScrollBox1: TScrollBox;
    Edit1: TEdit;
    ScrollBox2: TScrollBox;
    Edit2: TEdit;
    ScrollBox3: TScrollBox;
    Edit3: TEdit;
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
    FOldProc: TWndMethod;
    procedure NewProc(var msg: TMessage);

  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
begin
  FoldProc := Scrollbox3.WindowProc;
  Scrollbox3.WindowProc := NewProc;
end;

procedure TForm1.NewProc(var msg: TMessage);
var
  oldpos, newpos: Integer;
begin
  case msg.Msg of
    WM_VSCROLL:
      begin
        oldpos := scrollbox3.VertScrollBar.Position;
        FoldProc(msg);
        newpos := scrollbox3.VertScrollBar.Position;
        if oldpos <> newpos then
        begin
          scrollbox1.ScrollBy(0, oldpos - newpos);
          scrollbox2.ScrollBy(0, oldpos - newpos);
        end;
      end;
    WM_HSCROLL:
      begin
        oldpos := scrollbox3.HorzScrollBar.Position;
        FoldProc(msg);
        newpos := scrollbox3.HorzScrollBar.Position;
        if oldpos <> newpos then
        begin
          scrollbox1.ScrollBy(oldpos - newpos, 0);
          scrollbox2.ScrollBy(oldpos - newpos, 0);
        end;
      end
  else
    FoldProc(msg);
  end;
end;

end.

Add proxy authorization support to the TNMHTTP component

Problem/Question/Abstract:

The NMHTTP component is a nice and simple way to retrieve URLs within your application using http. Although the component supports a proxy, it does not support proxy authentication (proxy username/password). This method solves this drawback.

Answer:

{
To add proxy authentication support you must:

  1. Have a proxy username and password (strings)
  2. Merge these strings with a ':' between as:

       totalString := UserName + ':' + PassWord

  3. Base-64 encode totalString
  4. On the OnAboutToSend event of the NMHTTP, add

     'Proxy-authorization: ' + totalString

     to the http header

The routine below encodes the Proxy username/password
to a string accepted by the proxy
}

uses Forms, Classes, NMUUE; // Don't forget these !

function EncodeAuth(username, password: string): string;
var
  uu: TNMUUProcessor;
  si, so: TStringStream;
  decoded: string;
  encoded: string;
begin
  decoded := username + ':' + password; // Username:Password
  SetLength(encoded, 20 * length(decoded)); // Estimate len
  uu := TNMUUProcessor.Create(Application); // UU Processor
  si := TStringStream.Create(decoded); // Input
  so := TStringStream.Create(encoded); // Output
  uu.InputStream := si;
  uu.OutputStream := so;
  uu.Method := uuMime;
  uu.Encode; // Decode
  result := so.ReadString(255); // Read Result
  result := copy(result, 1, pos(#13, result) - 1); // No CRLF
  si.free; // Free objects
  so.free;
  uu.free;
end;

{
The OnAboutToSend event on the NMHTTP should look like:
}

procedure TForm1.NMHTTP1AboutToSend(Sender: TObject);
begin
  if username <> '' then
    NMHTTP1.SendHeader.Insert(2, 'Proxy-authorization: ' +
      EncodeAuth(username, password));
end;

{
We are inserting the Proxy-authorization token
to the 3rd position as it is a valid position to
place it
}

DLLs: Import dynamic or static

Problem/Question/Abstract:

DLLs: Import dynamic or static

Answer:

Both techniques have their advantages. Static importing means you define functions like this:

function f: integer; external 'mydll.dll';

The advantage is that it is easy - it does not require ugly code. The application will only start up if all DLLs are present and can be loaded. All functions across all modules are bound during startup time.

Dynamic importing has its advantages as well.

it basically gives you full control over the usage of the DLL. If your DLL is only needed rarely for a seldomly used function, you may not want to load it at startup of your application. Your application will start faster then.

if the application will work without that DLL to a usable extent, you may allow the user to do so.

if you have different DLLs for different environments, for example one for Windows NT, another one for Windows 95 etc, then you MUST bind dynamic - you determine the operating system and load the DLL that you want.

dynamic binding allows you to release the DLL if you do not need it anymore

The following Article shows you how to do it: Dynamic loading and binding of DLLs

How to limit the number of characters per line and the number of lines in a TMemo

Problem/Question/Abstract:

Is there any way to control the amount of characters per line in a TMemo component, e.g. that I can only store 7 lines of 50 chars each. The MaxLength property does not help in this case as it controls the total number of characters in the control.

Answer:

Limiting a memo to 6 lines of input:

procedure TForm1.Memo1KeyPress(Sender: TObject; var Key: Char);
var
  line: Integer;
begin
  if key = #13 then
  begin
    with Sender as TMemo do
    begin
      if lines.count >= 6 then
      begin
        key := #0;
        line := Perform(EM_LINEFROMCHAR, SelStart, 0);
        if line < 5 then
          SelStart := Perform(EM_LINEINDEX, line + 1, 0);
      end;
    end;
  end;
end;

Limiting a memo to 5 lines of input of max. 25 characters each:

procedure TForm1.Memo1KeyPress(Sender: TObject; var Key: Char);
var
  line, col: Integer;
begin
  with Sender as TMemo do
  begin
    line := Perform(EM_LINEFROMCHAR, SelStart, 0);
    col := SelStart - Perform(EM_LINEINDEX, line, 0);
    if key = #8 then
    begin
      { Do not allow backspace if caret is on first column and deleting the
                        linebreak of the line in front would result in a line of more than 25
                        characters. Inconvenient for the user but specs are specs... }
      if (col = 0) and (line > 0) then
      begin
        if (Length(lines[line]) + Length(lines[line - 1])) > 25 then
          Key := #0;
      end;
    end
    else if key in [#13, #10] then
    begin
      { Handle hard linebreaks via Enter or Ctrl-Enter }
      if lines.count >= 5 then
      begin
        { Max number of lines reached or exceeded, set caret to start of next
                                line or this line, if on the last }
        key := #0;
        if line = 4 then
          SelStart := Perform(EM_LINEINDEX, line, 0)
        else
          SelStart := Perform(EM_LINEINDEX, line + 1, 0);
      end;
    end
    else if Key >= ' ' then
    begin
      { Do swallow key if current line has reached limit. }
      if Length(lines[line]) >= 25 then
        Key := #0;
    end;
  end;
  if Key = #0 then
    Beep;
end;

procedure TForm1.Memo1KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
var
  line, col: Integer;
begin
  if Key = VK_DELETE then
    with Sender as TMemo do
    begin
      line := Perform(EM_LINEFROMCHAR, SelStart, 0);
      col := SelStart - Perform(EM_LINEINDEX, line, 0);
      if col = Length(lines[line]) then
        if (line < 4) and ((Length(lines[line]) + Length(lines[line + 1])) > 25) then
        begin
          key := 0;
          Beep
        end;
    end;
end;

Create a TTable at runtime

Problem/Question/Abstract:

How to create a TTable at runtime

Answer:

Solve 1:

Delphi allows rapid addition and configuration of database elements to a Delphi project within the design environment, but there are situations where information needed to create and configure objects is not known at design time. For instance, you may want to add the ability to add columns of calculated values (using formulas of the users own creation) to an application at runtime. So without the benefit of the design environment, Object Inspector, and TFields editor, how do you create and configure TFields and other data related components programmatically?

The following example demonstrates dynamically creating a TTable, a database table based off the TTable, TFieldDefs, TFields, calculated fields, and attaches an event handler to the OnCalc event.

To begin, select New Application from the File menu. The entire project will be built on a blank form, with all other components created on-the-fly.

In the interface section of your forms unit, add an OnCalcFields\ event handler, and a TaxAmount field to the form declaration, as shown below. Later we will create a TTable and hook this handler to the TTable's OnCalcFields event so that each record read fires the OnCalcFields event and in turn executes our TaxAmountCalc procedure.

type
  TForm1 = class(TForm)
    procedure TaxAmountCalc(DataSet: TDataset);
  private
    TaxAmount: TFloatField;
  end;

in the implementation section add the OnCalc event handler as shown below.

procedure TForm1.TaxAmountCalc(DataSet: TDataset);
begin
  Dataset['TaxAmount'] := Dataset['ItemsTotal'] * (Dataset['TaxRate'] / 100);
end;

Create a OnCreate event handler for the form as shown below(for more information on working with event handlers see the Delphi Users Guide, Chapter 4 "Working with Code").

procedure TForm1.FormCreate(Sender: TObject);
var
  MyTable: TTable;
  MyDataSource: TDataSource;
  MyGrid: TDBGrid;
begin
  {Create the TTable component - the underlying database table is created later}
  MyTable := TTable.Create(Self);
  with MyTable do
  begin
    {Specify an underlying database and table. Note: Test.DB doesn't exist yet}
    DatabaseName := 'DBDemos';
    TableName := 'Test.DB';
    {Assign TaxAmountCalc as the event handler to use when the OnCalcFields
                event fires for MyTable}
    OnCalcFields := TaxAmountCalc;
    {Create and add field definitions to the TTable's FieldDefs array, then create
                a TField using  the field definition information}
    with FieldDefs do
    begin
      Add('ItemsTotal', ftCurrency, 0, false);
      FieldDefs[0].CreateField(MyTable);
      Add('TaxRate', ftFloat, 0, false);
      FieldDefs[1].CreateField(MyTable);
      TFloatField(Fields[1]).DisplayFormat := '##.0%';
      {Create a calculated TField, assign properties, and add to MyTable's
                        field definitions array}
      TaxAmount := TFloatField.Create(MyTable);
      with TaxAmount do
      begin
        FieldName := 'TaxAmount';
        Calculated := True;
        Currency := True;
        DataSet := MyTable;
        Name := MyTable.Name + FieldName;
        MyTable.FieldDefs.Add(Name, ftFloat, 0, false);
      end;
    end;
    {Create the new database table using MyTable as a basis}
    MyTable.CreateTable;
  end;
  {Create a TDataSource component and assign to MyTable}
  MyDataSource := TDataSource.Create(Self);
  MyDataSource.DataSet := MyTable;
  {Create a data aware grid, display on the form, and assign MyDataSource to
        access MyTable's data}
  MyGrid := TDBGrid.Create(Self);
  with MyGrid do
  begin
    Parent := Self;
    Align := alClient;
    DataSource := MyDataSource;
  end;
  {Start your engines!}
  MyTable.Active := True;
  Caption := 'New table ' + MyTable.TableName;
end;

The following is the full source for the project.

unit gridcalc;

interface

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

type
  TForm1 = class(TForm)
    procedure FormCreate(Sender: TObject);
    procedure TaxAmountCalc(DataSet: TDataset);
  private
    TaxAmount: TFloatField;
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.TaxAmountCalc(DataSet: TDataset);
begin
  Dataset['TaxAmount'] := Dataset['ItemsTotal'] * (Dataset['TaxRate'] / 100);
end;

procedure TForm1.FormCreate(Sender: TObject);
var
  MyTable: TTable;
  MyDataSource: TDataSource;
  MyGrid: TDBGrid;
begin
  MyTable := TTable.Create(Self);
  with MyTable do
  begin
    DatabaseName := 'DBDemos';
    TableName := 'Test.DB';
    OnCalcFields := TaxAmountCalc;
    with FieldDefs do
    begin
      Add('ItemsTotal', ftCurrency, 0, false);
      FieldDefs[0].CreateField(MyTable);
      Add('TaxRate', ftFloat, 0, false);
      FieldDefs[1].CreateField(MyTable);
      TFloatField(Fields[1]).DisplayFormat := '##.0%';
      TaxAmount := TFloatField.Create(MyTable);
      with TaxAmount do
      begin
        FieldName := 'TaxAmount';
        Calculated := True;
        Currency := True;
        DataSet := MyTable;
        Name := MyTable.Name + FieldName;
        MyTable.FieldDefs.Add(Name, ftFloat, 0, false);
      end;
    end;
    MyTable.CreateTable;
  end;
  MyDataSource := TDataSource.Create(Self);
  MyDataSource.DataSet := MyTable;
  MyGrid := TDBGrid.Create(Self);
  with MyGrid do
  begin
    Parent := Self;
    Align := alClient;
    DataSource := MyDataSource;
  end;
  MyTable.Active := True;
  Caption := 'New table ' + MyTable.TableName;
end;

end.


Solve 2:

procedure TForm1.FormCreate(Sender: TObject);
begin
  MyTable := TTable.Create(Self);
  with MyTable do
  begin
    Active := False;
    DatabaseName := 'c:\temp';
    TableName := 'Test.DB';
    if not FileExists(DatabaseName + '\' + TableName) then
    begin
      with FieldDefs do
      begin
        Clear;
        Add('InputNr', ftAutoInc, 0, false);
        Add('SName', ftString, 35, false);
        Add('name', ftString, 35, false);
      end;
      with IndexDefs do
      begin
        Clear;
        Add('InputNr', 'InputNr', [ixPrimary]);
        Add('SName', 'SName', []);
      end;
      CreateTable;
    end;
  end;
  DataSource1.DataSet := MyTable;
  MyTable.Open;
  MyTable.FieldByName('SName').visible := false;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  with OKBottomDlg do
  begin
    Edit1.text := '';
    ShowModal;
    if ModalResult = mrOK then
    begin
      MyTable.Append;
      MyTable.SetFields([nil, AnsiUppercase(Edit1.text), Edit1.text]);
      MyTable.Post;
    end;
  end;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  MyTable.IndexFieldNames := 'sname';
end;

procedure TForm1.Button3Click(Sender: TObject);
begin
  MyTable.IndexFieldNames := 'InputNr';
end;

procedure TForm1.Button4Click(Sender: TObject);
begin
  with OKBottomDlg do
  begin
    Edit1.text := MyTable.FieldValues['name'];
    ShowModal;
    if ModalResult = mrOK then
    begin
      MyTable.Edit;
      MyTable.SetFields([nil, AnsiUppercase(Edit1.text), Edit1.text]);
      MyTable.Post;
    end;
  end;
end;


Solve 3:

It depends on the type of database you want to build. However, I can show you how to do it with a Paradox table. Conceivably, it stands to reason that since the TTable is database-independent and if you've got the right settings in the BDE, you should be able to create a table with the TTable component in any database. This is not necessarily true. SQL tables are normally created using the SQL call CREATE TABLE. And each server has its own conventions for creating tables and defining fields. So it's important to note this if you're working with a SQL database. The problem is that SQL databases support different data types that aren't necessarily available in the standard BDE set. For instance, MS SQL server's NUMERIC data format is not necessarily a FLOAT as it's defined in the BDE. So your best bet would probably be to create SQL tables using SQL calls.

What you have to do is declare a TTable variable, create an instance, then with the TTable's FieldDefs property, add field definitions. Finally, you'll make a call to CreateTable, and your table will be created. Here's some example code:

{ "Add" is the operative function here.
  Add(const Name: string; DataType: TFieldType; Size: Word; Required: Boolean);
}

procedure CreateATable(DBName, //Alias or path
  TblName: string); //Table Name to Create
var
  tbl: TTable;
begin
  tbl := TTable.Create(Application);
  with tbl do
  begin
    Active := False;
    DatabaseName := DBName;
    TableName := TblName;
    TableType := ttParadox;
    with FieldDefs do
    begin
      Clear;
      Add('LastName', ftString, 30, False);
      Add('FirstName', ftString, 30, False);
      Add('Address1', ftString, 40, False);
      Add('Address2', ftString, 40, False);
      Add('City', ftString, 30, False);
      Add('ST', ftString, 2, False);
      Add('Zip', ftString, 10, False);
    end;

    {Add a Primary Key to the table}
    with IndexDefs do
    begin
      Clear;
      Add('Field1Index', 'LastName;FirstName', [ixPrimary, ixUnique]);
    end;

    CreateTable; {Make the table}
  end;
end;

The procedure above makes a simple contact table, first by defining the fields to be included in the table, then creating a primary key. As you can see, it's a pretty straightforward procedure. One thing you can do is to change the TableType property setting to a variable that's passed as a parameter to the procedure so you can create DBase or even ASCII tables. Here's snippet of how you'd accomplish that:

procedure CreateATable(DBName, //Alias or path
  TblName: string); //Table Name to Create
TblType: TTableType); //ttDefault, ttParadox, ttDBase, ttASCII
var
  tbl: TTable;
begin
  tbl := TTable.Create(Application);
  with tbl do
  begin
    Active := False;
    DatabaseName := DBName;
    TableName := TblName;
    TableType := TblType;
    with FieldDefs do
    begin
      Clear;
      Add('LastName', ftString, 30, False);
      Add('FirstName', ftString, 30, False);
      Add('Address1', ftString, 40, False);
      Add('Address2', ftString, 40, False);
      Add('City', ftString, 30, False);
      Add('ST', ftString, 2, False);
      Add('Zip', ftString, 10, False);
    end;

    {Add a Primary Key to the table}
    with IndexDefs do
    begin
      Clear;
      Add('Field1Index', 'LastName;FirstName', [ixPrimary, ixUnique]);
    end;

    CreateTable; {Make the table}
  end;
end;

Pretty simple, right? One thing you should note is that the TableType property is only used for desktop databases. It doesn't apply to SQL tables.

Oh well, that's it in a nutshell. Have fun!

How to assign the system time to a TDateField

Problem/Question/Abstract:

How can I assign the System time (returned by date function) to a TDateField in a TTable?

Answer:

Table1.Edit;
Table1.FieldByName('aDate').AsDateTime := Date;
Table1.Post;

How to scroll a TMemo through code

Problem/Question/Abstract:

How to scroll a TMemo through code

Answer:

procedure TForm1.Edit1KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
  if Key = VK_F8 then
    SendMessage(Memo1.Handle, WM_VSCROLL, SB_PAGEDOWN, 0)
  else if Key = VK_F7 then
    SendMessage(Memo1.Handle, WM_VSCROLL, SB_PAGEUP, 0);
end;

Change a form's caption font and alignment (2)

Problem/Question/Abstract:

Does anyone know how to write text with the TEXTOUT command in the title bar of a form in D5?

Answer:

You have to handle the WM_NCPAINT message.

{ ... }
type
  TForm1 = class(TForm)
  private
    procedure WMNCPaint(var Msg: TWMNCPaint); message WM_NCPAINT;
  public
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.WMNCPaint(var Msg: TWMNCPaint);
var
  ACanvas: TCanvas;
begin
  inherited;
  ACanvas := TCanvas.Create;
  try
    ACanvas.Handle := GetWindowDC(Form1.Handle);
    with ACanvas do
    begin
      Brush.Color := clActiveCaption;
      Font.Name := 'Tahoma';
      Font.Size := 8;
      Font.Color := clred;
      Font.Style := [fsItalic, fsBold];
      TextOut(GetSystemMetrics(SM_CYMENU) + GetSystemMetrics(SM_CXBORDER),
        Round((GetSystemMetrics(SM_CYCAPTION) - Abs(Font.Height)) / 2) + 1,
          ' Some Text');
    end;
  finally
    ReleaseDC(Form1.Handle, ACanvas.Handle);
    ACanvas.Free;
  end;
end;

Moving rows and columns of a StringGrid by code

Problem/Question/Abstract:

The user can move rows and columns of a StringGrid with the mouse. Can it also be done by code? In the help for TCustomGrid you can see the methods MoveColumn and MoveRow, but they are hidden in TStringGrid

Answer:

The user can move rows and columns of a StringGrid with the mouse. Can it also be done by code? In the help for TCustomGrid you can see the methods MoveColumn and MoveRow, but they are hidden in TStringGrid. We can make them accessible again by subclassing TStringGrid and declaring these methods as public:

type
  TStringGridX = class(TStringGrid)
  public
    procedure MoveColumn(FromIndex, ToIndex: Longint);
    procedure MoveRow(FromIndex, ToIndex: Longint);
  end;

The implementation of these methods simply consists of invoking the corresponding method of the ancestor:

procedure TStringGridX.MoveColumn(FromIndex, ToIndex: Integer);
begin
  inherited;
end;

procedure TStringGridX.MoveRow(FromIndex, ToIndex: Integer);
begin
  inherited;
end;

You don't have to register this component in the Components Palette. Use a TStringGrid or any TCustomGrid descendant, and when you need to call these methods simply cast the object to the new class. For example:

procedure TForm1.Button1Click(Sender: TObject);
begin
  TStringGridX(StringGrid1).MoveColumn(1, 3);
end;

Copyright (c) 2001 Ernesto De Spirito
Visit: http://www.latiumsoftware.com/delphi-newsletter.php

Connect to server databases (InterBase) without the login dialog

Problem/Question/Abstract:

Connect to server databases (InterBase) without the login dialog

Answer:

To bypass the login dialog when connecting to a server database, use the property LoginPrompt.You will have to provide the username & password at runtime, but you also can set that up at design time in the object inspector, property Params.

This short source code shows how to do it:

Database1.LoginPrompt := false;
with Database1.Params do
begin
  Clear;
  // the parameters SYSDBA & masterkey should be
  // retrieved somewhat different :-)
  Add('USER NAME=SYSDBA');
  Add('PASSWORD=masterkey);
end;
Database1.Connected := tr

TDataSet => Excel (No OLE or EXCEL required)

Problem/Question/Abstract:

TDataSet => Excel (No OLE or EXCEL required)

Answer:

This class will produce an Excel Spreadsheet from a TDataSet. No OLE is required or Excel Installation needed to create the file. The one problem with Excel OLE is that is tends to be rather Sloooow. The class uses tandard Delphi I/O functions and is considerably faster than the OLE calls.

Example.

var
  XL: TDataSetToExcel;
begin
  XL := TDataSetToExcel.Create(MyQuery, 'c:\temp\test.xls');
  XL.WriteFile;
  XL.Free;
end;

The columns are neatly sized, Numerics are formatted in "Courier" and obey "###,###,##0.00" for floats and "0" for integers. Dates are formatted "dd-MMM-yyyy hh:nn:ss". Column headers are in Bold and are boxed and shaded.

unit MahExcel;
interface
uses Windows, SysUtils, DB, Math;

// =============================================================================
// TDataSet to Excel without OLE or Excel required
// Mike Heydon Dec 2002
// =============================================================================

type
  // TDataSetToExcel
  TDataSetToExcel = class(TObject)
  protected
    procedure WriteToken(AToken: word; ALength: word);
    procedure WriteFont(const AFontName: string; AFontHeight,
      AAttribute: word);
    procedure WriteFormat(const AFormatStr: string);
  private
    FRow: word;
    FDataFile: file;
    FFileName: string;
    FDataSet: TDataSet;
  public
    constructor Create(ADataSet: TDataSet; const AFileName: string);
    function WriteFile: boolean;
  end;

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

const
  // XL Tokens
  XL_DIM = $00;
  XL_BOF = $09;
  XL_EOF = $0A;
  XL_DOCUMENT = $10;
  XL_FORMAT = $1E;
  XL_COLWIDTH = $24;
  XL_FONT = $31;

  // XL Cell Types
  XL_INTEGER = $02;
  XL_DOUBLE = $03;
  XL_STRING = $04;

  // XL Cell Formats
  XL_INTFORMAT = $81;
  XL_DBLFORMAT = $82;
  XL_XDTFORMAT = $83;
  XL_DTEFORMAT = $84;
  XL_TMEFORMAT = $85;
  XL_HEADBOLD = $40;
  XL_HEADSHADE = $F8;

  // ========================
  // Create the class
  // ========================

constructor TDataSetToExcel.Create(ADataSet: TDataSet;
  const AFileName: string);
begin
  FDataSet := ADataSet;
  FFileName := ChangeFileExt(AFilename, '.xls');
end;

// ====================================
// Write a Token Descripton Header
// ====================================

procedure TDataSetToExcel.WriteToken(AToken: word; ALength: word);
var
  aTOKBuffer: array[0..1] of word;
begin
  aTOKBuffer[0] := AToken;
  aTOKBuffer[1] := ALength;
  Blockwrite(FDataFile, aTOKBuffer, SizeOf(aTOKBuffer));
end;

// ====================================
// Write the font information
// ====================================

procedure TDataSetToExcel.WriteFont(const AFontName: string;
  AFontHeight, AAttribute: word);
var
  iLen: byte;
begin
  AFontHeight := AFontHeight * 20;
  WriteToken(XL_FONT, 5 + length(AFontName));
  BlockWrite(FDataFile, AFontHeight, 2);
  BlockWrite(FDataFile, AAttribute, 2);
  iLen := length(AFontName);
  BlockWrite(FDataFile, iLen, 1);
  BlockWrite(FDataFile, AFontName[1], iLen);
end;

// ====================================
// Write the format information
// ====================================

procedure TDataSetToExcel.WriteFormat(const AFormatStr: string);
var
  iLen: byte;
begin
  WriteToken(XL_FORMAT, 1 + length(AFormatStr));
  iLen := length(AFormatStr);
  BlockWrite(FDataFile, iLen, 1);
  BlockWrite(FDataFile, AFormatStr[1], iLen);
end;

// ====================================
// Write the XL file from data set
// ====================================

function TDataSetToExcel.WriteFile: boolean;
var
  bRetvar: boolean;
  aDOCBuffer: array[0..1] of word;
  aDIMBuffer: array[0..3] of word;
  aAttributes: array[0..2] of byte;
  i: integer;
  iColNum,
    iDataLen: byte;
  sStrData: string;
  fDblData: double;
  wWidth: word;
begin
  bRetvar := true;
  FRow := 0;
  FillChar(aAttributes, SizeOf(aAttributes), 0);
  AssignFile(FDataFile, FFileName);

  try
    Rewrite(FDataFile, 1);
    // Beginning of File
    WriteToken(XL_BOF, 4);
    aDOCBuffer[0] := 0;
    aDOCBuffer[1] := XL_DOCUMENT;
    Blockwrite(FDataFile, aDOCBuffer, SizeOf(aDOCBuffer));

    // Font Table
    WriteFont('Arial', 10, 0);
    WriteFont('Arial', 10, 1);
    WriteFont('Courier New', 11, 0);

    // Column widths
    for i := 0 to FDataSet.FieldCount - 1 do
    begin
      wWidth := (FDataSet.Fields[i].DisplayWidth + 1) * 256;
      if FDataSet.FieldDefs[i].DataType = ftDateTime then
        inc(wWidth, 2000);
      if FDataSet.FieldDefs[i].DataType = ftDate then
        inc(wWidth, 1050);
      if FDataSet.FieldDefs[i].DataType = ftTime then
        inc(wWidth, 100);
      WriteToken(XL_COLWIDTH, 4);
      iColNum := i;
      BlockWrite(FDataFile, iColNum, 1);
      BlockWrite(FDataFile, iColNum, 1);
      BlockWrite(FDataFile, wWidth, 2);
    end;

    // Column Formats
    WriteFormat('General');
    WriteFormat('0');
    WriteFormat('###,###,##0.00');
    WriteFormat('dd-mmm-yyyy hh:mm:ss');
    WriteFormat('dd-mmm-yyyy');
    WriteFormat('hh:mm:ss');

    // Dimensions
    WriteToken(XL_DIM, 8);
    aDIMBuffer[0] := 0;
    aDIMBuffer[1] := Min(FDataSet.RecordCount, $FFFF);
    aDIMBuffer[2] := 0;
    aDIMBuffer[3] := Min(FDataSet.FieldCount - 1, $FFFF);
    Blockwrite(FDataFile, aDIMBuffer, SizeOf(aDIMBuffer));

    // Column Headers
    for i := 0 to FDataSet.FieldCount - 1 do
    begin
      sStrData := FDataSet.Fields[i].DisplayName;
      iDataLen := length(sStrData);
      WriteToken(XL_STRING, iDataLen + 8);
      WriteToken(FRow, i);
      aAttributes[1] := XL_HEADBOLD;
      aAttributes[2] := XL_HEADSHADE;
      BlockWrite(FDataFile, aAttributes, SizeOf(aAttributes));
      BlockWrite(FDataFile, iDataLen, SizeOf(iDataLen));
      if iDataLen > 0 then
        BlockWrite(FDataFile, sStrData[1], iDataLen);
      aAttributes[2] := 0;
    end;

    // Data Rows
    while not FDataSet.Eof do
    begin
      inc(FRow);

      for i := 0 to FDataSet.FieldCount - 1 do
      begin
        case FDataSet.FieldDefs[i].DataType of
          ftBoolean,
            ftWideString,
            ftFixedChar,
            ftString:
            begin
              sStrData := FDataSet.Fields[i].AsString;
              iDataLen := length(sStrData);
              WriteToken(XL_STRING, iDataLen + 8);
              WriteToken(FRow, i);
              aAttributes[1] := 0;
              BlockWrite(FDataFile, aAttributes, SizeOf(aAttributes));
              BlockWrite(FDataFile, iDataLen, SizeOf(iDataLen));
              if iDataLen > 0 then
                BlockWrite(FDataFile, sStrData[1], iDataLen);
            end;

          ftAutoInc,
            ftSmallInt,
            ftInteger,
            ftWord,
            ftLargeInt:
            begin
              fDblData := FDataSet.Fields[i].AsFloat;
              iDataLen := SizeOf(fDblData);
              WriteToken(XL_DOUBLE, 15);
              WriteToken(FRow, i);
              aAttributes[1] := XL_INTFORMAT;
              BlockWrite(FDataFile, aAttributes, SizeOf(aAttributes));
              BlockWrite(FDataFile, fDblData, iDatalen);
            end;

          ftFloat,
            ftCurrency,
            ftBcd:
            begin
              fDblData := FDataSet.Fields[i].AsFloat;
              iDataLen := SizeOf(fDblData);
              WriteToken(XL_DOUBLE, 15);
              WriteToken(FRow, i);
              aAttributes[1] := XL_DBLFORMAT;
              BlockWrite(FDataFile, aAttributes, SizeOf(aAttributes));
              BlockWrite(FDataFile, fDblData, iDatalen);
            end;

          ftDateTime:
            begin
              fDblData := FDataSet.Fields[i].AsFloat;
              iDataLen := SizeOf(fDblData);
              WriteToken(XL_DOUBLE, 15);
              WriteToken(FRow, i);
              aAttributes[1] := XL_XDTFORMAT;
              BlockWrite(FDataFile, aAttributes, SizeOf(aAttributes));
              BlockWrite(FDataFile, fDblData, iDatalen);
            end;

          ftDate:
            begin
              fDblData := FDataSet.Fields[i].AsFloat;
              iDataLen := SizeOf(fDblData);
              WriteToken(XL_DOUBLE, 15);
              WriteToken(FRow, i);
              aAttributes[1] := XL_DTEFORMAT;
              BlockWrite(FDataFile, aAttributes, SizeOf(aAttributes));
              BlockWrite(FDataFile, fDblData, iDatalen);
            end;

          ftTime:
            begin
              fDblData := FDataSet.Fields[i].AsFloat;
              iDataLen := SizeOf(fDblData);
              WriteToken(XL_DOUBLE, 15);
              WriteToken(FRow, i);
              aAttributes[1] := XL_TMEFORMAT;
              BlockWrite(FDataFile, aAttributes, SizeOf(aAttributes));
              BlockWrite(FDataFile, fDblData, iDatalen);
            end;

        end;
      end;

      FDataSet.Next;
    end;

    // End of File
    WriteToken(XL_EOF, 0);
    CloseFile(FDataFile);
  except
    bRetvar := false;
  end;

  Result := bRetvar;
end;

end.

Open a TOpenDialog in detail view

Problem/Question/Abstract:

I use the standard OpenDialog to select a file to open. To see the creation date of a file, I have to change the view to Details (in fact my preferred view) every time. I was looking for an attribute (in the Options) to configure, that always detail view is selected when the OpenDialog is activated. However I didn't find anything. Does somebody have a hint for this problem?

Answer:

Add this code to the OnFolderChange event of the dialog:

procedure TForm1.OpenDialog1FolderChange(Sender: TObject);
var
  H, H2: THandle;
begin
  H := FindWindowEx(GetParent(OpenDialog1.Handle), 0, PChar('SHELLDLL_DefView'), nil);
  H2 := FindWindowEx(H, 0, PChar('SysListView32'), nil);
  if (H <> 0) and (H2 <> 0) then
  begin
    SendMessage(H, WM_COMMAND, $702C, 0);
    Windows.SetFocus(H2);
    PostMessage(H2, WM_KEYDOWN, VK_SPACE, 0);
  end;
end;

Checking for Numlock and Capslock and displaying on Statusbar

Problem/Question/Abstract:

How do I check for a Numlock enabled and Capslock enable?

Answer:

Here are two procedures that you add to the main form of your application:

procedure TfrmMain.CheckCapslock;
begin
  if Odd(Getkeystate(VK_CAPITAL)) then
    Statusline.Panels[1].text := 'CAPS'
  else
    Statusline.Panels[1].text := '';
end;

procedure TfrmMain.CheckNumlock;
begin
  if Odd(Getkeystate(VK_NUMLOCK)) then
    Statusline.Panels[2].text := 'NUM'
  else
    Statusline.Panels[2].text := '';
end;

Add a application component to your project and simply call both these procedures in  the Application.onmessage event i.e.:

procedure TfrmMain.ApplicationEvents1Message(var Msg: tagMSG;
  var Handled: Boolean);
begin
  CheckCapslock;
  CheckNumlock;
end;

Creating a Delphi-Expert (Part I)

Problem/Question/Abstract:

Sometimes you want to define some routines to make your life easier while using Delphi. A simple way to do this, is creating an Expert. This first article shows you the basics.

Answer:

This article introduces you to the world of Delphi Experts. Delphi Experts are DLLs, that will be loaded during the startup sequence of Delphi. This article first appeared on Delphi-PRAXiS in German.

NOTE: The techniques shown in this article are valid starting with Delphi 3 or 4 and since Delphi 7 they are deprecated, however, still fully suported by the Delphi IDE.

Installation of a Delphi-IDE-Expert

Every Delphi-Expert has to be registered in the Windows-Registry. For each Delphi-Version installed on a machine, as well as for each user using the machine, the Delphi-Expert has to be registered separately.

In the Registry the Delphi-Expert has to be registered under the folowing key:

HKCU\Software\Borland\Delphi\X.0\Experts

, where the X has to be replaced by the appropriate Delphi-Version supported. It may happen that the Experts key is not installed, in such case you are required to create it.

Underneath the Experts key you have to create a string value for the Delphi-Expert. The name must be unique. The value must point to the Delphi-Expert DLL, including both complete path and file name of the Delphi-Expert. Next time Delphi starts, the Expert will be loaded automatically.

The interface of the Delphi-Expert

In order for the Delphi Expert to interact with the Delphi-IDE ist has to export a function with the name ExpertEntryPoint, using the following parameters:

function InitExpert(ToolServices: TIToolServices; RegisterProc:
  TExpertRegisterProc; var Terminate: TExpertTerminateProc): Boolean; export;
  stdcall;

The first parameter ToolServices offers all "documented" interfaces to the Delphi-IDE. The second parameter RegisterProc is used to load the expert into the Delphi-IDE. The last parameter Teminate is used to notify the Expert-DLL when it is about to be unloaded by the Delphi-IDE.

The InitExpert method returns True, if the Expert has loaded successfully, otherwise it can eiter return False or raises an exception to unload the DLL from the Delphi-IDE (see code sample for solution).

The PlugIn class TIExpert

Any Delphi-Expert must be derived from the class TIExpert, which is declared in the unit ExptIntf. This class defines some abstract methods, which must be implemented by each PlugIn: GetName, GetAuthor, GetComment, GetPage, GetGlyph (different for Windows and Linux), GetStyle, GetState, GetIDString, GetMenuText and Execute. The purpose of each method is explained in the source code below.

The simplest Delphi-Expert

This Delphi-Expert want do much good, however, it shows you the basic way of getting the job done. It will show an entry in the Help menu (default behavior). Once the user clicks the menu item the method Execute from the Expert will be called. The following points must be respected in order to get the expert working:

The method GetState must return [esEnabled]
The method GetStyle must return esStandard
The method GetMenuText returns the text to be shown in the Help menu
The method Execute defines the expert action upon activation


The Library Source Code (DelphiPlugI.dpr)

{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
*
* App. Name : DelphiPlug
* Autor     : Daniel Wischnewski
* Copyright : Copyright &copy; 2000-2003 by gate(n)etwork GmbH. All Right Reserved.
* Urheber   : Daniel Wischnewski
*
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}

library DelphiPlug;

{ Important note about DLL memory management: ShareMem must be the
  first unit in your library's USES clause AND your project's (select
  Project-View Source) USES clause if your DLL exports any procedures or
  functions that pass strings as parameters or function results. This
  applies to all strings passed to and from your DLL--even those that
  are nested in records and classes. ShareMem is the interface unit to
  the BORLNDMM.DLL shared memory manager, which must be deployed along
  with your DLL. To avoid using BORLNDMM.DLL, pass string information
  using PChar or ShortString parameters. }

uses
  ShareMem,
  ExptIntf,
  uPlugIn in 'uPlugIn.pas';

{$R *.res}

exports
  InitExpert name ExpertEntryPoint;

begin
end.

The Unit Source Code (uPlugIn.pas)

{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
*
* Unit Name : uPlugIn
* Autor     : Daniel Wischnewski
* Copyright : Copyright &copy; 2000-2003 by gate(n)etwork GmbH. All Right Reserved.
* Urheber   : Daniel Wischnewski
*
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}

unit uPlugIn;

interface

uses
  ToolIntf, EditIntf, ExptIntf, VirtIntf, Windows, Messages;

const
  MIdx_Main = $0001;
  MIdx_ShowItems = $0002;
  MIdx_RunCommand = $0003;

type
  TDelphiPlug = class(TIExpert)
  private
  protected
  public
    // abstract methods to be overriden
    { Expert UI strings }
    function GetName: string; override; stdcall;
    function GetAuthor: string; override; stdcall;
    function GetComment: string; override; stdcall;
    function GetPage: string; override; stdcall;
{$IFDEF MSWINDOWS}
    function GetGlyph: HICON; override; stdcall;
{$ENDIF}
{$IFDEF LINUX}
    function GetGlyph: Cardinal; override; stdcall;
{$ENDIF}
    function GetStyle: TExpertStyle; override; stdcall;
    function GetState: TExpertState; override; stdcall;
    function GetIDString: string; override; stdcall;
    function GetMenuText: string; override; stdcall;
    { Launch the Expert }
    procedure Execute; override; stdcall;
  end;

function InitExpert(ToolServices: TIToolServices; RegisterProc:
  TExpertRegisterProc; var Terminate: TExpertTerminateProc): Boolean; export;
stdcall;

implementation

uses
  SysUtils, ShellAPI;

function InitExpert(ToolServices: TIToolServices; RegisterProc:
  TExpertRegisterProc; var Terminate: TExpertTerminateProc): Boolean; export;
  stdcall;
var
  DelphiPlug: TDelphiPlug;
begin
  Result := True;
  try
    // assign tools services
    ExptIntf.ToolServices := ToolServices;
    // create the Delphi-Plug
    DelphiPlug := TDelphiPlug.Create;
    // register with Delphi
    RegisterProc(DelphiPlug);
  except
    // kill assistant
    ToolServices.RaiseException(ReleaseException);
  end;
end;

{ TDelphiPlug }

procedure TDelphiPlug.Execute;
begin
  // en:
  //   Execute will be called, whenever the user clicks on the menu entry in the
  //   help menu
  // de:
  //   Execute wird aufgerufen, wenn der User auf den Eintrag im Hilfe-Men�
  //   klickt
  MessageBox(ToolServices.GetParentHandle, 'How may I help you?', 'Hmm',
    MB_ICONQUESTION + MB_OK);
end;

function TDelphiPlug.GetAuthor: string;
begin
  // en:
  //   returns the name of the author of the plugin
  // de:
  //   liefert den Namen des Autoren des PlugIns zur�ck (wof�r auch immer)
  Result := 'sakura (Daniel Wischnewski)';
end;

function TDelphiPlug.GetComment: string;
begin
  // en:
  //   I got no idea where this comment will be displayed, ever.
  // de:
  //   Auch hier wei� ich nicht, wo das jemals angezeigt wird, aber bitte...
  Result := 'A simple Delphi-PlugIn example.';
end;

{$IFDEF MSWINDOWS}

function TDelphiPlug.GetGlyph: HICON;
begin
  // en:
  //   an icon handle for the entry in the help menu
  // de:
  //   Ein Icon-Handle f�rs Men�
  Result := NOERROR;
end;
{$ENDIF}
{$IFDEF LINUX}

function TDelphiPlug.GetGlyph: Cardinal;
begin
  // en:
  //   an icon handle for the entry in the help menu
  // de:
  //   Ein Icon-Handle f�rs Men�
  Result := NOERROR;
end;
{$ENDIF}

function TDelphiPlug.GetIDString: string;
begin
  // en:
  //   id of the expert
  // de:
  //   ID des Experten
  Result := 'DelphiPlugSampleI';
end;

function TDelphiPlug.GetMenuText: string;
begin
  // en:
  //   this text will be schon in the help menu. each time the menu drops down,
  //   this method will be called.
  //   NOTE:
  //     the method GetState must return esStandard, otherwise the help menu
  //     entry will not be generated and shown
  //
  // de:
  //   Text der im Hilfe Men� angezeigt wird. Diese Funktion wird jedesmal
  //   aufgerufen, wenn das Hilfemen� angezeigt wird.
  //   HINWEIS:
  //     die Methode GetState mu� esStandard zur�ckliefern, damit dieser Eintrag
  //     im Hilfemen� automatisch generiert wird
  Result := 'You''l find me in the help menu';
end;

function TDelphiPlug.GetName: string;
begin
  // en:
  //   this name must be unique
  // de:
  //   dieser Name muss!!! einmalig sein
  Result := 'sakura_DelphiPlugSample';
end;

function TDelphiPlug.GetPage: string;
begin
  // en:
  //   interesting to experts expanding the default dialogs of the Delphi-IDE
  // de:
  //   Ist f�r Experte interessant, welche Standard-Dialoge erweitern sollen
  Result := '';
end;

function TDelphiPlug.GetState: TExpertState;
begin
  // en:
  //   returns a set of states
  //   possible values: esEnabled, esChecked
  // de:
  //   liefert ein Set von Stati zur�ck
  //   m�gliche Werte: esEnabled, esChecked
  Result := [esEnabled];
end;

function TDelphiPlug.GetStyle: TExpertStyle;
begin
  // en:
  //   returns the type of expert
  // de:
  //   liefert die Art des Experten zur�ck
  //   m�gliche Werte: esStandard, esForm, esProject, esAddIn
  Result := esStandard;
end;

end.

Create smaller EXEs

Problem/Question/Abstract:

Create smaller EXEs

Answer:

Delphi 3 can create reasonable smaller executables (*.EXE files) than Delphi 1/ 2.

Go to menu "Project | Options", select tab "Packages" and check the option "Build with runtime packages".
The packages listed in the text - by default:

vclx30;VCL30;vcldb30;vcldbx30;VclSmp30;inetdb30;inet30;Qrpt30;
teeui30;teedb30;tee30;dss30;IBEVNT30

will not be compiled into the EXE file. Instead you will have to ship a *.DCP file.

This makes (only) sense if you have several applications using the same controls = the same *.DCP file.

Add a submenu to the system menu of a program

Problem/Question/Abstract:

I'm trying to insert a submenu into my application's system menu. Anyone have a code example of adding a submenu and menu items underneath that new submenu?

Answer:

Here's some sample code to play with:

{ ... }

procedure WMSysCommand(var Msg: TWMSysCommand); message WM_SYSCOMMAND;
{ ... }

const
  SC_ITEM = $FF00; {Should be a multiple of 16}

procedure TForm1.WMSysCommand(var Msg: TWMSysCommand);
begin
  {See if this is a command we added}
  if (Msg.CmdType and $FFF0) = SC_ITEM then
  begin
    ShowMessage('Item command received');
    Msg.Result := 0;
  end
  else
    inherited;
end;

procedure TForm1.FormCreate(Sender: TObject);
var
  MenuItemInfo: TMenuItemInfo;
  PopupMenu: HMENU;
  Result: Boolean;
  SysMenu: HMenu;
begin
  {Create the popup menu}
  PopupMenu := CreatePopupMenu;
  Assert(PopupMenu <> 0);
  {Insert an item into it}
  FillChar(MenuItemInfo, SizeOf(MenuItemInfo), 0);
  with MenuItemInfo do
  begin
    cbSize := SizeOf(MenuItemInfo);
    fMask := MIIM_TYPE or MIIM_ID;
    fType := MFT_STRING;
    wID := SC_ITEM;
    dwTypeData := PChar('Item');
    cch := 4; {'Item' is 4 chars}
  end;
  Result := InsertMenuItem(PopupMenu, 0, True, MenuItemInfo);
  Assert(Result, 'InsertMenuItem failed');
  {Insert the popup into the system menu}
  FillChar(MenuItemInfo, SizeOf(MenuItemInfo), 0);
  with MenuItemInfo do
  begin
    cbSize := SizeOf(MenuItemInfo);
    fMask := MIIM_SUBMENU or MIIM_TYPE;
    fType := MFT_STRING;
    hSubMenu := PopupMenu;
    dwTypeData := PChar('SubMenu');
    cch := 7; {'SubMenu' is 7 chars}
  end;
  SysMenu := GetSystemMenu(Handle, False);
  Assert(SysMenu <> 0);
  Result := InsertMenuItem(SysMenu, GetMenuItemCount(SysMenu), True, MenuItemInfo);
  Assert(Result, 'InsertMenuItem failed');
end;

Using Console in non-console applications

Problem/Question/Abstract:

How to implement console input/output for non-console applications?

Answer:

For implementing console input/output for non-console applications you should use the AllocConsole and FreeConsole functions.
Example below demonstrates using these functions:

procedure TForm1.Button1Click(Sender: TObject);
var
  s: string;
begin
  AllocConsole;
  try
    Write('Type here your words and press ENTER: ');
    Readln(s);
    ShowMessage(Format('You typed: "%s"', [s]));
  finally
    FreeConsole;
  end;
end;

Resize a *.jpg image and save the result to a file

Problem/Question/Abstract:

How do I resize a *.jpg or *.gif image from say 640 x 480 to 50 x 50 and then save the image as a new one?

Answer:

procedure TForm1.Button1Click(Sender: TObject);
var
  bmp: TBitmap;
  jpg: TJpegImage;
  scale: Double;
begin
  if opendialog1.execute then
  begin
    jpg := TJpegImage.Create;
    try
      jpg.Loadfromfile(opendialog1.filename);
      if jpg.Height > jpg.Width then
        scale := 50 / jpg.Height
      else
        scale := 50 / jpg.Width;
      bmp := TBitmap.Create;
      try
        {Create thumbnail bitmap, keep pictures aspect ratio}
        bmp.Width := Round(jpg.Width * scale);
        bmp.Height := Round(jpg.Height * scale);
        bmp.Canvas.StretchDraw(bmp.Canvas.Cliprect, jpg);
        {Draw thumbnail as control}
        Self.Canvas.Draw(100, 10, bmp);
        {Convert back to JPEG and save to file}
        jpg.Assign(bmp);
        jpg.SaveToFile(ChangeFileext(opendialog1.filename, '_thumb.JPG'));
      finally
        bmp.free;
      end;
    finally
      jpg.free;
    end;
  end;
end;

What is DelphiX?

Problem/Question/Abstract:

What is DelphiX?

Answer:

DelphiX is a very good DirectX implementation with 12 visual components for the Delphi versions 3, 4 and 5. The componets were programmed by Hiroyuki Hori (his homepage:  http://www.yks.ne.jp/~hori/index-e.html). DelphiX supports all DirectX technologies (DirectDraw, Direct3D, DirectPlay, DirectInput...) to program high performance graphic applications with Delphi.

This components are:

TDXDraw                                - DirectDraw surface for graphic output
TDXDIB                                - DIB-Image
TDXImageList                - Imagelist of DIB-Images
TDX3D                                        - Direct3D support for TDXDraw surface
TDXSound                        - DirectSound support
TDXWave                                - Soundfile-component for DirectSound
TDXWaveList                - Soundfile-list
TDXInput                                - DirectInput, controller support
TDXPlay                                - DirectPlay, for multiplayer network games
TDXSpriteEngine        - Spriteengine for DirectDraw-surface
TDXTimer                        - High-performance Timer
TDXPaintBox                - Like TPaintbox but faster

Related links:

Microsoft's DirectX
- http://www.microsoft.com/directx

Hori's homepage    
- http://www.yks.ne.jp/~hori/index-e.html

DelphiX download
- http://www.yks.ne.jp/~hori/DelphiX-e.html

Game FinalFighter, programmed using DelphiX
- http://www.finalfighter.com

Good page about DelphiX
- http://turbo.gamedev.net/delphix.asp


Component Download: http://www.yks.ne.jp/~hori/DelphiX-e.html

Read Adobe Acrobat PDF files from my application

Problem/Question/Abstract:

Adobe Acrobat PDF is a well known format that some users love, so how can I open PDF files from a Delphi Application?

Answer:

Ok, you must have installed the Acrobat Reader program in your machine, if you don�t have it you can download it from Adobe�s site: www.adobe.com

After that you have to install the type library for Acrobat (Project -> Import Type Library from Delphi�s menu) select "Acrobat Control for ActiveX (version x)". Where x stands for the current version of the type library. Click the install button to install it into the IDE.

Now, Start a new Application, drop from whatever page of the component palette you have installed a TPDF component in a form, next add an OpenDialog, and finally a Button, in the Onclick event of the Button use:

procedure TForm1.Button1Click(Sender: TObject);
begin
  if OpenDialog1.Execute then
    pdf1.src := OpenDialog1.FileName;
end;

in PdfLib_TLB Unit you can find the interface of the TPdf class in order to know the behaviour of that class so here it is:

TPdf = class(TOleControl)
private
  FIntf: _DPdf;
  function GetControlInterface: _DPdf;
protected
  procedure CreateControl;
  procedure InitControlData; override;
public
  function LoadFile(const fileName: WideString): WordBool;
  procedure setShowToolbar(On_: WordBool);
  procedure gotoFirstPage;
  procedure gotoLastPage;
  procedure gotoNextPage;
  procedure gotoPreviousPage;
  procedure setCurrentPage(n: Integer);
  procedure goForwardStack;
  procedure goBackwardStack;
  procedure setPageMode(const pageMode: WideString);
  procedure setLayoutMode(const layoutMode: WideString);
  procedure setNamedDest(const namedDest: WideString);
  procedure Print;
  procedure printWithDialog;
  procedure setZoom(percent: Single);
  procedure setZoomScroll(percent: Single; left: Single; top:
    Single);
  procedure setView(const viewMode: WideString);
  procedure setViewScroll(const viewMode: WideString; offset:
    Single);
  procedure setViewRect(left: Single; top: Single; width: Single;
    height: Single);
  procedure printPages(from: Integer; to_: Integer);
  procedure printPagesFit(from: Integer; to_: Integer; shrinkToFit:
    WordBool);
  procedure printAll;
  procedure printAllFit(shrinkToFit: WordBool);
  procedure setShowScrollbars(On_: WordBool);
  procedure AboutBox;
  property ControlInterface: _DPdf read GetControlInterface;
  property DefaultInterface: _DPdf read GetControlInterface;
published
  property TabStop;
  property Align;
  property DragCursor;
  property DragMode;
  property ParentShowHint;
  property PopupMenu;
  property ShowHint;
  property TabOrder;
  property Visible;
  property OnDragDrop;
  property OnDragOver;
  property OnEndDrag;
  property OnEnter;
  property OnExit;
  property OnStartDrag;
  property src: WideString index 1 read GetWideStringProp write
    SetWideStringProp stored False;
end;

finally here�s an advice:

You can�t be sure your users will have Acrobat Reader installed so please fisrt check that situation before you take any actions with the TPdf component. And second if your PDF file have links for an AVI file for example, they don�t work from Delphi.

Use RTTI to determine if a property is a TDateTime

Problem/Question/Abstract:

How to use RTTI to determine if a property is a TDateTime

Answer:

When it comes to RTTI, TDateTime and Double are not the same. That's what the extra "type" keyword in TDateTime's declaration is for: to give it its own RTTI, distinct from that of Double. Here is an example:

program Test;

uses
  TypInfo;

{$APPTYPE CONSOLE}
{$M+}
type
  TTest = class
  private
    FDateTime: TDateTime;
  published
    property D: TDateTime read FDateTime write FDateTime;
  end;

var
  T: TTest;
  DateInfo: Pointer;
  TestInfo: PPropInfo;
begin
  T := TTest.Create;
  DateInfo := TypeInfo(TDateTime);
  TestInfo := GetPropInfo(T, 'D');
  writeln(DateInfo = TestInfo^.PropType^);
  readln;
end.

It should print TRUE on the console.

Remove the popup menu from Flash's ActiveX

Problem/Question/Abstract:

I wanted to insert an Macromedia Flash intro into my program using the provided ActiveX, but I also wanted to remove the ugly Flash's popup menu. That's the way.
And if it's not enought, you can replace it with your own popup menu!

Answer:

In your Form, where the Flash ActiveX is, place an "Application Events" component.
Into the "OnMessage" Event put this code:

procedure TfrmMain.AppEvents1Message(var Msg: tagMSG;
  var Handled: Boolean);
begin
  if (Msg.Message = WM_RBUTTONDOWN) then
    Handled := True;
end;

It's not enought? Do you want to put your own PopupMenu? There's the solution:

procedure TfrmMain.AppEvents1Message(var Msg: tagMSG;
  var Handled: Boolean);
begin
  if (Msg.Message = WM_RBUTTONDOWN) then
  begin
    popupmnuFlash.Popup(Mouse.CursorPos.X, Mouse.CursorPos.Y);
    Handled := True;
  end;
end;

How to start or stop Interbase service

Problem/Question/Abstract:

How to start or stop Interbase service

Answer:

Do you need to shutdown the Interbase db service e.g. for an installation program and afterwards restart it?

You could do this with a lot of Delphi code involving unit WinSvc and function calls to

OpenSCManager()
EnumServicesStatus()
OpenService()
StartService() or ControlService().

But luckily there is a much easier solution that uses the NET.EXE program which has been part of Windows since Windows for Workgroups (Wfw 3.11). Just create the two batch files

IBSTOP.BAT
IBSTART.BAT

and call them from your code. You may want to call them and wait for their termination.

IBSTOP.BAT
=============
@echo off
net stop "InterBase Guardian" >NULL
net stop "InterBase Server" >NULL

IBSTART.BAT
=============
@echo off
net start "Interbase Guardian" >NULL

How to search and replace strings in a TMemo

Problem/Question/Abstract:

How to search and replace strings in a TMemo

Answer:

Doing search and replace on strings has been made trivial because of these 3 functions: Pos(), Delete(), and Insert(). Pos() takes two parameters, a pattern search string, and a string to find the pattern in - it returns the location of the string, or 0 if it does not exist. Delete() takes three parameters, the string to delete from, location of where to start deleting, and how much to delete. Similarly, Insert() takes three parameters too. The string that will be inserted, the string to insert into, the location to insert.

Many class properties use strings to store values, so one can use this method on any of them. For instance, the searching and replacing of an entire TMemo component might look like this:

procedure TForm1.Button2Click(Sender: TObject);
var
  i: integer;
  s1: string;
  SearchStr: string;
  NewStr: string;
  place: integer;
begin
  SearchStr := 'line';
  NewStr := 'OneEye';
  for i := 0 to Memo1.Lines.Count - 1 do
  begin
    s1 := Memo1.Lines[i];
    repeat
      Place := pos(SearchStr, s1);
      if place > 0 then
      begin
        Delete(s1, Place, Length(SearchStr));
        Insert(NewStr, s1, Place);
        Memo1.Lines[i] := s1;
      end;
    until
      place = 0;
  end;
end;

Create a borderless TComboBox

Problem/Question/Abstract:

Is it possible to create a flat or borderless combo box? If so, how would I go about it.

Answer:

{ ... }
TNoBorderComboBox = class(TComboBox)
protected
  procedure WMPaint(var Msg: TMessage); message WM_PAINT;
end;

procedure TNoBorderComboBox.WMPaint(var Msg: TMessage);
var
  C: TControlCanvas;
  R: TRect;
begin
  inherited;
  C := TControlCanvas.Create;
  try
    C.Control := Self;
    with C do
    begin
      Brush.Color := clBtnFace;
      R := ClientRect;
      FrameRect(R);
      InflateRect(R, -1, -1);
      FrameRect(R);
    end;
  finally
    C.Free;
  end;
end;

Various image XOR effects

Problem/Question/Abstract:

Various image XOR effects

Answer:

Solve 1:

Create a new application, add a button to the form, and add the following code for the button's OnClick event:

{ ... }
var
  bih: TBitmapInfo;
  i, j: Byte;
  ptrBits, ptrTemp: Pointer;
begin
  {Initialise BITMAPINFO structure}
  ZeroMemory(@bih, SizeOf(bih));
  with bih.bmiHeader do
  begin
    biSize := SizeOf(TBitmapInfoHeader);
    biWidth := 256;
    biHeight := 256;
    biPlanes := 1;
    biBitCount := 24;
    biSizeImage := 256 * 256 * 3;
  end;
  {Allocate memory for pixel data}
  ptrBits := GlobalAllocPtr(GMEM_FIXED or GMEM_ZEROINIT, 256 * 256 * 3);
  try
    ptrTemp := ptrBits;
    {Manipulate pixels using XOR operator}
    for j := 0 to 255 do
    begin
      for i := 0 to 255 do
      begin
        PByte(ptrTemp)^ := i xor j; {Blue component}
        Inc(PByte(ptrTemp));
        PByte(ptrTemp)^ := i xor j; {Green component}
        Inc(PByte(ptrTemp));
        PByte(ptrTemp)^ := i xor j; {Red component}
        Inc(PByte(ptrTemp));
      end;
    end;
    {Draw to screen}
    StretchDIBits(Canvas.Handle, 0, 255, 256, -256, 0, 0, 256, 256,
      ptrBits, bih, DIB_RGB_COLORS, SRCCOPY);
  finally
    GlobalFreePtr(ptrBits);
  end;
end;


Solve 2:

Mark, this was a very interesting effect. I first tried your code in a FormCreate but saw nothing. Your code works fine from a ButtonClick method, but will need to be moved to an OnPaint for persistence.

Code using Scanline in my opinion is easier to understand - and like your code will also work in D3 - D6:

procedure TFormXOReffect.ButtonScanlineMethodClick(Sender: TObject);
type
  TRGBTripleArray = array[Word] of TRGBTriple;
  pRGBTripleArray = ^TRGBTripleArray;
var
  Bitmap: TBitmap;
  i: Byte;
  j: Byte;
  row: pRGBTripleArray;
begin
  Bitmap := TBitmap.Create;
  try
    Bitmap.Width := 256;
    Bitmap.Height := 256;
    Bitmap.PixelFormat := pf24bit;
    for j := 0 to 255 do
    begin
      row := Bitmap.Scanline[j];
      for i := 0 to 255 do
      begin
        row[i].rgbtBlue := i xor j;
        row[i].rgbtGreen := i xor j;
        row[i].rgbtRed := i xor j
      end;
    end;
    {Display in 256-by-256 TImage}
    Image1.Picture.Graphic := Bitmap
  finally
    Bitmap.Free
  end;
end;


Solve 3:

I played around with it for a few minutes and came up with a very subtle gradient effect:

{ ... }
  {Shade}
Bmp.Canvas.Brush.Color := clBlack;
Bmp.Canvas.FillRect(Rect(0, 0, Bmp.Width - 1, Bmp.Height - 1));
for j := 0 to Bmp.Height - 1 do
begin
  row := Bmp.Scanline[j];
  for i := 0 to Bmp.Width - 1 do
  begin
    row[i].rgbtBlue := row[i].rgbtBlue xor j;
    row[i].rgbtGreen := row[i].rgbtGreen xor j;
    row[i].rgbtRed := row[i].rgbtRed xor j
  end;
end;
{ ... }

if you change 1 or 2 of the xor j's to XOR i, then it does another nice gradient effect.:

begin
  row[i].rgbtBlue := row[i].rgbtBlue xor i;
  row[i].rgbtGreen := row[i].rgbtGreen xor i;
  row[i].rgbtRed := row[i].rgbtRed xor j
end;


Solve 4:

I like that one, too. And if you add ...

{ ... }
  {now gray scale it}
row[i].rgbtRed := (row[i].rgbtRed + Row[i].rgbtGreen + row[i].rgbtBlue) div 3;
row[i].rgbtGreen := row[i].rgbtRed;
row[i].rgbtBlue := row[i].rgbtRed;

... you get a nice metalic look.

Search and replace text in a Word document

Problem/Question/Abstract:

How to search and replace text in a Word document

Answer:

Solve 1:

You should use a variant because the Find.Execute method is a bit buggy. Something like this, for example:

{ ... }
var
  Rnge: OleVariant;
{ ... }

Rnge := Doc.Content;
Rnge.Find.Execute('old', Wrap := wdFindContinue, ReplaceWith := 'new', Replace :=
  wdReplaceAll);
{ ... }


Solve 2:

{ ... }
  { Create the OLE Object }
WordApp := CreateOLEObject('Word.Application');
WordApp.Documents.Open(yourDocFile);
WordApp.Selection.Find.ClearFormatting;
WordApp.Selection.Find.Text := yourOldStr;
WordApp.Selection.Find.Replacement.Text := yourNewStr;
WordApp.Selection.Find.Forward := True;
WordApp.Selection.Find.Wrap := 1; {wdFindContinue}
WordApp.Selection.Find.Format := False;
WordApp.Selection.Find.MatchCase := False;
WordApp.Selection.Find.MatchWholeWord := False;
WordApp.Selection.Find.MatchWildcards := True;
WordApp.Selection.Find.MatchSoundsLike := False;
WordApp.Selection.Find.MatchAllWordForms := False;
WordApp.Selection.Find.Execute(Replace := 2); {wdReplaceAll}
{Or as alternative:  WordApp.Selection.Find.Execute(Replace := 1); for one replace}
WordApp.ActiveDocument.SaveAs(yourNewDocFile);
WordApp.Quit;
WordApp := Unassigned;
{ ... }