Published Objects in Components

Problem/Question/Abstract:

Some properties of a component can 'drop-down' to reveal other properties (such as a Font property reveals various properties within itself). These are objects within the component, and a simple demonstration of how to add you own new 'drop-down' properties is given here. (You can also get a Static Analogue Clock Component too!!!)

Answer:

Please Note: I will only include here pertinent aspects of what is being explained. I will not flesh out all the examples for the sake of clarity.

To include an object within a component is a fairly simple matter, simply declare a field, and make a property public.

interface

type
  TMyComp = class(TComponent)
  private
    fFont: TFont;
  public
    property Font: TFont read fFont write fFont;
    constructor create(AOwner: TComponent); override;
    destructor destroy; override;
  end;

implementation

constructor TMyComp.create(AOwner: TComponent);
begin
  inherited create(AOwner);
  fFont := TFont.Create; //create the Object into the field reference,
  //  so it will not raise an exception
end;

destructor TMyComp.destroy;
begin
  fFont.free; //free the field to avoid memory leaks, etc.
  inherited;
end;

NB: When creating Objects, ALWAYS remember to free them, unless a help file tells you overwise (happens very rarely, eg exception handlers). Notice that what is created in the constructor is explicitly freed in the destructor.

This creates a fairly useless component admittedly, but it is an example after all! When accessing the Font property, it can be referenced in code using:

begin
  with MyComp1.Font do
  begin
    Color := clBlue;
    Size := 10;
  end;
end;

This is all well and good, but what about the Object Inspector?
If we move the property from public to published, the Font property is now available, with the plus sign to 'drop-down' as required.

This is a step in the right direction.

However, this is not the whole story. What if we were devising a component which could logically take completely new objects as properties. For instance an analogue clock face - three similar objects would be obvious.. the hour, minute and second hands! Each is the same, save for customisable features, such as colour, thickness, etc.

So - let us construst our AnalogueHand object:

type
  TAnalogueHand = class
    Colour: TColor;
    Thickness: integer;
  end;

Here is an object, descended from TObject, which has the properties we require.

Let us put it into a Clock face component:

type
  TAnalogueClock = class(TGraphicControl)
  private
    fHourHand, fMinuteHand, FSecHand: TAnalogueHand;
  protected
    procedure SetHand(index: integer; value: TAnalogueHand);
  public
    constructor create(AOwner: TComponent); override;
    destructor destroy; override;
  published
    property HourHand: TAnalogueHand index 0 read fHourHand write SetHand;
    property MinuteHand: TAnalogueHand index 1 read fMinuteHand write SetHand;
    property SecHand: TAnalogueHand index 2 read fSecHand write SetHand;
  end;

In the constructor, each field must be created separately, and freed on destruction:

constructor TAnalogueClock.create(AOwner: TComponent);
begin
  inherited create(AOwner);
  //Set up the Hand Objects
  fHourHand := TAnalogueHand.create;
  with fHourHand do
  begin
    colour := clBlue;
    Thickness := 2;
  end;
  fMinuteHand := TAnalogueHand.create;
  with fMinuteHand do
  begin
    colour := clRed;
    Thickness := 2;
  end;
  fSecHand := TAnalogueHand.create;
  with fSecHand do
  begin
    colour := clRed;
    Thickness := 1;
  end;
end;

destructor TAnalogueClock.destroy;
begin
  fSecHand.free;
  fMinuteHand.free;
  fHourHand.free;
  inherited;
end;

procedure TAnalogueClock.SetHand(index: integer; value: TAnalogueHand);
begin
  case index of
    0: fHourHand := Value;
    1: fMinuteHand := Value;
    2: fSecHand := Value;
  end;
  invalidate;
end;

Notice that the Hands are written to all using the same procedure, SetHand, each with a different index to refer to it.

If we install this, we end up with our object, but the object inspector gives an Access Violation if we try to view the properties - not what we wanted!

The reason being that to descend our Hand Object from TObject is the wrong ancestor.. For objects which are of a temporary nature, this is fine, but to allow properties to exist abit longer, to have their properties stored in a persistent fashion (put very simply!) - we must descend from TPersistent.

So, our new hand declaration looks like:

type
  TAnalogueHand = class(TPersistent)
    Colour: TColor;
    Thickness: integer;
  end;

Rebuild, and the Access Violation has gone - hooray!! But, there are no subproperties!! An inspection of the Hand object could provide a clue.. With a standard component, for a property to appear in the object inspector, it must be published:

type
  TAnalogueHand = class(TPersistent)
  private
    fColour: TColor;
    fThickness: integer;
  published
    property Colour: TColor read fColour write fColour;
    property Thickness: integer read fThickness write fThickness;
  end;

Rebuild again - and we have subproperties within properties, droppong down without Access Violations, etc.

At runtime the new subproperties can be accessed by:

with AnalagueClock1.HourHand do
begin
  Colour := clOlive;
  Thickness := 4;
end;

AnalagueClock1.SecHand.Colour := clFuchsia;

This has been a quick and simple overview to providing subproperties in a component. More complicated user defined objects can be created, which may have further subproperties (try publishing a TCanvas Object, and see how many layers you get..).

In summary:

descend your new object from TPersistant (if it is COMPLETELY new - as in  the example);
ensure that any methods declared in the object are written (such as constructors, setting procedures, functions, etc). - I've forgotten this a few times!!
use the standard of fields and published properties (and any public as required). The published properties will appear as subproperties.
ensure that when the new object is contained within a component that it is explicitly created and freed at the appropriate times.

This worked example appears in an expanded form in the component attached to this article. I had a requirement for a Clock face, but I needed it to be static - for inputting. All the Clock faces I found were very nice, but the darn things moved!! So I created my own static analogue clock face.

I make no apology for using British English within the component! Light diffractions have a 'U' (coloUr), and the free floating state contrary to digital has a 'UE' suffix (analogUE). If you don't like it - you have the source!!


Component Download: AnalogueClock.zip

Retrieve list of exported functions from a DLL

Problem/Question/Abstract:

Retrieve list of exported functions from a DLL

Answer:

To retrieve the list of exported functions from a DLL, pass the DLL name and a TStrings object to the function ListDLLFunctions() shown below.

This does not show the parameters for each export, which you can only get from the author of the DLL.


program Project1;

uses
  Forms,
  Classes,
  SysUtils,
  Dialogs,
  ImageHlp, // routines to access debug information
  Windows;


procedure ListDLLFunctions(DLLName: string; List: TStrings);
type
  chararr = array[0..$FFFFFF] of Char;
var
  H: THandle;
  I, fc: integer;
  st: string;
  arr: Pointer;
  ImageDebugInformation: PImageDebugInformation;
begin
  List.Clear;
  DLLName := ExpandFileName(DLLName);
  if FileExists(DLLName) then
  begin
    H := CreateFile(PChar(DLLName), GENERIC_READ, FILE_SHARE_READ or
      FILE_SHARE_WRITE, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);
    if H <> INVALID_HANDLE_VALUE then
    try
      ImageDebugInformation := MapDebugInformation(H, PChar(DLLName), nil, 0);
      if ImageDebugInformation <> nil then
      try
        arr := ImageDebugInformation^.ExportedNames;
        fc := 0;
        for I := 0 to ImageDebugInformation^.ExportedNamesSize - 1 do
          if chararr(arr^)[I] = #0 then
          begin
            st := PChar(@chararr(arr^)[fc]);
            if Length(st) > 0 then
              List.Add(st);
            if (I > 0) and (chararr(arr^)[I - 1] = #0) then
              Break;
            fc := I + 1
          end
      finally
        UnmapDebugInformation(ImageDebugInformation)
      end
    finally
      CloseHandle(H)
    end
  end
end;

// the following is an example how to use the procedure
var
  List: TStrings;
  I: integer;
  S: string;

begin
  List := TStringList.Create;

  ListDLLFunctions('c:\winnt\system32\mfc42.dll', List);

  S := 'List of functions';
  for I := 0 to List.Count - 1 do
    S := S + #13#10 + List[I];
  ShowMessage(S);
  List.Free
end.

Understanding what files are and choosing a Delphi file type - part 1

Problem/Question/Abstract:

What is a File? How are they stored? What format is best for my project? - The first part of a series by Philip Rayment

Answer:

File, n, 1. A metal tool with numerous small cutting ridges or teeth on its surface, for smoothing or cutting metal and other substances. 2. A cabinet in which papers, etc., are arranged or classified for convenient reference. 3. Computers, a portion of a memory storage device allocated to a set of data.

If you want explanations of the first two definitions, sorry you will have to look elsewhere. This article discusses the third definition, although of course a computer file is analogous to the cabinet of the second definition.

This article discusses what a file is by looking at the origins of files; at least in so far as they have been implemented on PCs.

Outline of this article:

Disk format of a file
File contents, part I
Language conventions and ASCII
Language conventions and machine code
File contents, part II
Delphi and files
Which file types should you use?

Disk format of a file

A file is a portion of a disk (or equivalent device) allocated to a set of data and referred to by a file name. With FAT file systems, disk space is allocated in blocks of (for example) 256, 1024, or 4096 bytes, depending on the capacity of the disk. A disk with 512-byte blocks will therefore allocate 512 bytes of storage for any file up to that size. If you create a file that only requires 6 bytes, 512 bytes will be allocated. If you create a file 513 bytes long, 1024 bytes (two blocks) will be allocated. So how does the operating system know the actual size of the file? Each disk keeps a directory of files. The entries for each file include the name of the file, the date and time the file was last written to, and the size of the file. It is an enhanced version of this directory that Windows Explorer presents in the 'Files' pane. This system has been around since the very first version of MSDOS, and in fact was based on an even earlier operating system, known as CP/M.

File contents, part I

So what goes into a file? Anything, actually. Files are sequences of bytes. A byte is of course 8 bits where each bit can, by definition, have one of two values, which can be represented as on and off, zero and one, or any other representation desired. Normally bits are represented by the numeric digits 0 and 1, and eight identical bits therefore can be represented as 00000000 or 11111111.

These are binary numbers, but are not convenient for most purposes, so are often combined into groups of four bits. Because a group of four bits can have any of 16 different values, these are normally represented by the ten numeric digits and the first six letters of the alphabet. This is known as hexadecimal. Of course decimal numbers can also represent 16 different values.

The table at below shows these 16 different values represented as binary, hexadecimal, and decimal.

Binary
Hexadecimal
Decimal
0000
0
00
0001
1
01
0010
2
02
0011
3
03
0100
4
04
0101
5
05
0110
6
06
0111
7
07
1000
8
08
1001
9
09
1010
A
10
1011
B
11
1100
C
12
1101
D
13
1110
E
14
1111
F
15


As a byte is eight bits, two hexadecimal digits are used to represent the value, giving values from 00 to FF, equivalent to 00000000 to 11111111 in binary or 0 to 255 in decimal.  Delphi distinguishes hexadecimal from other numbers by the dollar sign at the start of the number, thus 40 is a decimal number whereas $40 is hexadecimal number (equivalent to 64 in decimal). But of course files don't just contain numbers, do they. They can contain text, pictures, etc., as well. How do they do this? The answer lies in what can be termed language conventions.

Language conventions and ASCII

What does the sequence of letters 'c', 'a', and 't' mean? To English-speaking people, it is a furry pet with claws. The letters themselves have no inherent meaning, but English speakers agree to apply a particular meaning to that particular sequence of letters. Similarly, the sequence 'g', 'i', 'f', and 't' mean a present. But to German-speaking people that sequence means a poison. The same sequence of letters can mean different things to different people, and in fact any sequence of letters or other symbols can mean anything at all, as long as the writers and readers all understand the meaning.

English and similar languages use 26 letters, Morse code uses two, and DNA uses four. In the 1960s a language convention was adopted for computer data, known as ASCII (American Standard Code for Information Interchange). This convention allocated meanings to the first 128 of the 256 values a byte can have. There were already other conventions in use, and others again have modified or superseded ASCII, but ASCII was adopted by personal computers when they appeared and so it became quite widespread.

Under the ASCII standard or language convention, the value 01000001/$41/65 was given the job of representing the capital letter 'A'. Thus a file that contained the bytes $43, $41, and $54 will, if loaded into WordPad, display as 'CAT'. This is not because the file contains the word 'CAT', but because WordPad understands the bytes to represent the letters 'C', 'A', and 'T'. A different application may understand the same bytes differently. So if ASCII uses 128 different values and English only has 26 letters, what are all the others for?

Well English actually uses more than just the 26 letters. It uses both capital and lower-case letters, a space to separate words, and there other symbols to help with clarity, such as commas, full stops, question marks, etc. ASCII uses 95 of the values to represent the ten numeric digits, 26 capital letters, 26 lower case letters, various punctuation marks, the space character, and miscellaneous other symbols such as the dollar sign and '@' symbol. ASCII also defines 32 control characters. These were originally designed for data transmission and similar where specified values indicate the start and end of transmission, etc. Thus value 3 was ETX (End of Text) and 4 was EOT (End of Transmission). $A (10) is LF (Linefeed) and $C (13) is CR (Carriage Return). Most of these control characters (values $0 to $19) are not used as such in PCs. IBM also decided to allocate the remaining 128 characters (values $80 to $FF) to various mathematical symbols and foreign-language characters, but these are not part of the ASCII standard and under Windows different typefaces may allocate different symbols to these values.

Language conventions and machine code

There is another important language convention used on IBM-type PCs. This is the language convention of the processor itself. To the processor, the value $41 is not the letter 'A', but the instruction inc ecx (increment the ecx register). The processor understands the byte values to be instructions to perform, and these have no connection with the ASCII code at all. Thus the same "letters" can represent two or more completely unrelated ideas, just as gift means something totally different in English and German. File contents, part II So computer files contain sequences of bytes which may represent ASCII characters or machine code or something else altogether. So how does the Operating System (OS) know what the values represent? In a sense, it doesn't. It really doesn't matter to the OS what a file contains. A file is ANY sequence of byte values. If all it is asked to do is to copy, move, or delete the file, the contents don't matter at all.

If Explorer is told to open a file, it looks up a list (based on the filename extension) to see which application to pass the file to, starts that application, and passes the file to it. It has no idea whether the file actually contains what the application expects it to contain. About the only time the file contents matter to the OS (apart from its own files) is when it is asked to run the file as a program. In this case it will check to see if the filename extension is an appropriate one (.exe, .com, etc.), but in most cases it also checks the contents of the file to see if they have certain signature values.

Early .exe programs, for example, had to start with the bytes $4D and $58. These bytes did not represent machine code, but were an indication (by yet another convention) that the file was a program. (The values $4D and $58 were arbitrarily chosen as in ASCII they represent the letters 'MZ', reputedly the initials of the programmer who designed the .exe file format!) In CP/M days, files were saved in 128-byte blocks with no record of the exact file size. The actual end of a text file was marked with a byte with a (decimal) value of 26 (also known as Ctrl-Z).

Delphi file types

Delphi provides several methods for handling files, including wrappers for Windows' own file-handling methods. I will not cover the latter here. Delphi categorises files as untyped, typed, and text. The most basic is the untyped file, with which Delphi treats the file merely as a sequence of byte values. This essentially is what is done with the following procedure, which makes a copy of a file.

procedure�CopyFile(fromName, toName: string);
var
  � infile, outfile: file;
  � buffer: pointer;
  � fs: integer;
begin
  ��assignFile(infile, �fromName);
   �reset(infile, 1);
  ��assignFile(outfile, �toName);
   �rewrite(outfile, 1);
  ��fs := FileSize(infile);
  ��getmem(buffer, fs);
  ��blockread(infile, buffer^, fs);
  ��blockwrite(outfile, buffer^, fs);
  ��CloseFile(infile);
  � CloseFile(outfile);
  ��Freemem(buffer, fs);
end;

This rather simple procedure reads the entire contents of the file into the memory allocated to buffer then writes the same data to a new file. It assumes nothing about the contents of the file. Actually, for historical reasons (probably traceable back to the CP/M file record-size), Delphi assumes that an untyped file is composed of blocks of 128 bytes unless you specify a different size in the reset and rewrite procedures. In the code above, we have specified record sizes of one byte, then told Delphi to read and write fs "records". Unless you have a special reason for not doing so, you should always specify a record size of one byte when using untyped files. With a typed file, you tell Delphi what the file contains. This may be sequences of bytes, words, booleans, or a user-defined type such as a record. This last one is often referred to as a file of record. The following procedure also copies a file, but tells Delphi that the file contains MyRecord records.

type
  MyRecord� = �packed�record
    ��Surname: string[20];
      ChristianName: string[20];
      Birthdate: TDate;
end;
��� {MyRecord}

procedure�CopyFile(FromName, ToName);
var
   InFile, �OutFile: file�of�MyRecord;
  �Rec: MyRecord;
begin
  �AssignFile(InFile, �FromName);
  �reset(InFile);
  �AssignFile(OutFile, �ToName);
  �rewrite(OutFile);
   while�not�eof(InFile)�do�begin
    ���read(InFile, �rec);
  �����write(OutFile, �rec);
  �end;
  �{while}
  �CloseFile(InFile);
  �CloseFile(OutFile);
end;

Delphi knows that a MyRecord type occupies 50 bytes (21 for each string field and eight for the Birthdate field), so reads in and writes out 50 bytes at a time. If the file is not a multiple of 50 bytes, an error will occur when the end of the file is reached in the middle of reading a record. The following code does the same thing but uses an untyped file (it uses the same MyRecord as the previous example):

procedure�CopyFile(FromName, ToName);
var
  InFile, OutFile: file; {untyped file this time}
  Rec: MyRecord;
begin
  {specify &#8220;records&#8221; of the length of MyRecord}
  AssignFile(InFile, �FromName);
  reset(InFile, sizeof(MyRecord));
  AssignFile(OutFile, �ToName);
  rewrite(OutFile, sizeof(MyRecord));
  while�not�eof(InFile)�do�begin
    BlockRead(InFile, �rec, �1);
    {read one record}
    BlockWrite(OutFile, �rec, �1); {write one record}
  end;
  {while}
  CloseFile(InFile);
  CloseFile(OutFile);
end;

The remaining file type that Delphi understands is TextFile. This indicates to Delphi that the file contains bytes conforming to the ASCII language convention, although it will accept non-ASCII characters, i.e. characters in the range $80 to $FF. Particularly, it does assume that the file contains lines of text separated by CR (Carriage Return) characters, possibly followed by LF (Line Feed) characters. The following procedure copies a text file:

procedure�CopyFile(FromName,ToName);
var
  InFile, OutFile: textfile;
  S: string;
begin
��AssignFile(InFile,�FromName);�reset(InFile);
��AssignFile(OutFile,�ToName);�rewrite(OutFile,sizeof(MyRecord));
��while�not�eof(InFile)�do�begin
����Readln(InFile,�s); {read an entire line up to a CR character.  
                                                                                        The CR (and LF) is skipped.}
����Writeln(OutFile,�s);�{write a line and append CR and LF}
��end;���{while}
��CloseFile(InFile);
��CloseFile(OutFile);
end;

A text file gives you other options. One option is to read and write partial lines (use Read and Write instead of ReadLn and WriteLn). Another is to automatically convert certain ASCII sequences to their numerical equivalents. For example, given "i" being declared as a byte, if the file contains the string '123 ', read(InFile, i) will convert the string into the numeric value $7B (123 in decimal). Delphi also defines the TiniFile object which assumes that the file is a text file conforming to the layout of a Windows .ini file, wherein most lines are of the form <keyname>=<value>. Additionally the TStrings type has methods for reading and writing text files. Then there are database files, which are beyond the scope of this article (because I haven't used them and don't know much about them!).

How to read binary values from the registry

Problem/Question/Abstract:

I want to read out the binary value "problems" of the path HKEY_DYN_DATA\Config Manager\Enum\[add the key of a hardware component] to detect if a hardware component is troubled and not working right. But I cannot handle the ReadBinaryData-Method of TRegistry correct. Everytime I use it, it always returns "4" as content of the buffer. How do I detect if the content of the binary key "problems" is not "00 00 00 00" but something else like "16 00 00 00" or such?

Answer:

Here's an example of ReadBinaryData:


procedure TFrmReadBinary.Button1Click(Sender: TObject);
const
  CKeyName: string = 'System\Setup';
  CValName: string = 'NetcardDlls';
var
  keyGood: boolean;
  p: integer;
  regKey: TRegistry;
  tmpStr: string;
  vSize: integer;
begin
  regKey := TRegistry.Create;
  try
    regKey.RootKey := HKEY_LOCAL_MACHINE;
    keyGood := regKey.OpenKey(CKeyName, false);
    if (keyGood) then
    begin
      vSize := regKey.GetDataSize(CValName);
      if (vSize > 0) then
      begin
        SetLength(tmpStr, vSize);
        regKey.ReadBinaryData(CValName, tmpstr[1], vSize);
        repeat
          p := Pos(#0, tmpStr);
          if p <> 0 then
          begin
            Delete(tmpStr, p, 1);
            Insert(#13#10, tmpStr, p);
          end;
        until
          p = 0;
        {StringReplace(tmpStr, #0, #13#10, [rfReplaceAll]);}
        ListBox1.Items.Text := tmpStr;
      end;
    end;
  finally
    regKey.Free;
  end;
end;

How to set the item index in a TRadioGroup without firing the OnClick event

Problem/Question/Abstract:

How to set the item index in a TRadioGroup without firing the OnClick event

Answer:

procedure SetRadioItem(radiogroup: TRadioGroup; index: Integer);
var
  ev: TNotifyEvent;
begin
  ev := radiogroup.OnClick;
  radiogroup.OnClick := nil;
  radiogroup.ItemIndex := index;
  radiogroup.Onclick := ev;
end;

A bit roundabout but it works. A checkbox could be treated similarly but I think you can also set its state by sending a BM_SETCHECK to it without having the OnClick event fire. This is untested:

procedure SetCheckbox(checkbox: TCheckbox; checked: Boolean);
const
  flags: array[boolean] of Integer = (BST_UNCHECKED, BST_CHECKED);
begin
  checkbox.Perform(BM_SETCHECK, flags[checked], 0);
end;

Add a size grip to a TForm without using a status bar

Problem/Question/Abstract:

How to add a size grip to a TForm without using a status bar

Answer:

A size grip appears on a form in two cases: when a status bar is placed at the bottom of the form or when the form has both a horizontal and a vertical scrollbar. To place a size grip on a form without any of the above, you need to draw it yourself and handle mouse events. The following unit demonstrates drawing a size grip at the bottom right corner (including XP style, if supported):

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    procedure FormPaint(Sender: TObject);
    procedure FormResize(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    FSizeGripWidth: Integer;
    FSizeGripHeight: Integer;
    FSizeGripRect: TRect;
    procedure WMNCHitTest(var Message: TWMNCHitTest); message WM_NCHITTEST;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

uses
  Themes;

{$R *.dfm}

procedure TForm1.FormPaint(Sender: TObject);
begin
  if ThemeServices.ThemesAvailable then
  begin
    ThemeServices.DrawElement(Canvas.Handle,
      ThemeServices.GetElementDetails(tsSizeBoxRightAlign), FSizeGripRect);
  end
  else
    DrawFrameControl(Canvas.Handle, FSizeGripRect, DFC_SCROLL, DFCS_SCROLLSIZEGRIP);
end;

procedure TForm1.FormResize(Sender: TObject);
begin
  FSizeGripRect := ClientRect;
  FSizeGripRect.Left := FSizeGripRect.Right - FSizeGripWidth;
  FSizeGripRect.Top := FSizeGripRect.Bottom - FSizeGripHeight;
  Refresh;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  FSizeGripWidth := GetSystemMetrics(SM_CXVSCROLL);
  FSizeGripHeight := GetSystemMetrics(SM_CYHSCROLL);
end;

procedure TForm1.WMNCHitTest(var Message: TWMNCHitTest);
begin
  inherited;
  if PtInRect(FSizeGripRect, ScreenToClient(SmallPointToPoint(Message.Pos))) then
    Message.Result := HTBOTTOMRIGHT;
end;

end.

Get a printer settings

Problem/Question/Abstract:

How can I receive a current printer settings?

Answer:

At first, you must open the printer device:

var
  FDevice: PChar;
  FDriver: PChar;
  FPort: PChar;
  DeviceMode: THandle;
  DevMode: PDeviceMode;

procedure OpenThePrinterDevice;
var
  Driver_Info2: PDriverInfo2;
  Retrieved: dword;
  hPrinter: THandle;
begin
  Printer().GetPrinter(FDevice, FDriver, FPort, DeviceMode);
  if DeviceMode = 0 then
    Printer().GetPrinter(FDevice, FDriver, FPort, DeviceMode);
  OpenPrinter(FDevice, hPrinter, nil);
  GetMem(Driver_Info2, 255);
  GetPrinterDriver(hPrinter, nil, 2, Driver_info_2, 255, Retrieved);
  StrLCopy(FDriver, PChar(ExtractFileName(StrPas(Driver_Info2^.PDriverPath))
    + #0), 63);
  FreeMem(Driver_info_2, 255);
  DevMode := GlobalLock(DeviceMode);
end;

And now you can get the information from printer. For example, the orientation settings:

if ((DevMode^.dmFields and DM_ORIENTATION) = DM_ORIENTATION) and
  (DevMode^.dmOrientation = DMORIENT_LANDSCAPE) then
  //Landscape
else
  //Portrait

Also you can detect a paper size, paper source, print duplex and quality etc. View a const description in Windows.pas.

At last, don't forget to unlock a device:

GlobalUnlock(DeviceMode);

Description of Instancing and Threading Models in COM-servers

Problem/Question/Abstract:

How to select a correct value of Unstancing/Threading Model when I develop the Com object?

Answer:

When you create a new COM object, you must define the Instancing and Threading Model, which will be used in your COM object. For example, when you use the Automation Object Wizard (select File|New from main menu, click the ActiveX tab and select Automation Object Wizard item) you must select a desired values of Instancing/Threading Model from comboboxes.

In this article I'll include a short description for each value.

1. Instancing refers to how many instances of the COM object are created for a request of client. You can select a one option from three available items: Single Instance, Multiple Instance and Internal.

a) Single Instance - allows only a single COM interface for each executable. So creating multiple single instances results in creating multiple copies of the server application. This option is commonly used for multiple document interface (MDI) applications.

b) Multiple Instance - specifies that multiple applications can connect to the object. Any time a client requests service, a separete instance of the server gets invoked. That is, there can be multiple instances in a single executable. For example, any time a user attempts to open the Windows Explorer, a separate Explorer is created

c) Internal - means the object can only be created internally. An external application cannot create an instance of the object directly. For example, a word processor application may have an internal document object that can only be created by calling a method of the application that will create the document object.

2. The Threading Model refers to how your object is advertised to the client applications via its thread support. You can select one from the next options: Single, Apartment, Free or Both.

a) Single - no thread support. Client requests are serialized by the standard calling mechanism. serialized by the calling mechanism. With this threading model the clients are handled one at a time so no threading support is needed.

b) Apartment - different objects from the same server can be called on different threads or different clients, but each object is called only from that one thread. If two clients need to use the same object, they have to take turns. With this threading model the instance data is safe, global data must be protected using critical sections or some other form of serialization. Of course, the thread's local variables are reliable across multiple calls.

c) Free - clients can call any method of object from any thread at any time. Objects can handle any number of threads at any time. That is, more than one client can share the same object. Objects must protect all instance and global data using critical sections or some other form of serialization. Thread local variables are not reliable across multiple calls. Primarily used for distributed DCOM environments.

d) Both - objects can support clients that use either Aprtment or Free threading models. This threading model give a maximum performance and flexibility.

So a correct value selection of Instancing and Threading Model can affect on performance of your COM object and depends from task which you want realize in this object.

Write sorting/search methods that can be re-used

Problem/Question/Abstract:

I find that alot of developers that use sorting and search algorithms, taking the Quick Sort algorithm for an example, will reimplement it for every use.

Answer:

Sorting algorithms rarely depend on actual knowledge what they are sorting, and when we require an algorithm and implement it, why restrict the algorithm to a specific use, as the algorithm itself will never change.

They are only dependent on an index of which they then need to compare and exchange the information that resides at those indexes.

The quick sort algorithm for the example would require only 3 main factors of which could be passed to a quick sort method.

Start and End indexes
Method for Comparing points
Method for Exchanging points

This going to apply for practially all sorting/searching algorithms.

All that is required is that we specify the types that will define the Compare and Exchange methods.

type
  TIndexCompare = function(const ixA, ixB: integer): integer of object;
  TIndexExchange = procedure(const ixA, ixB: integer) of object;
  //-- Also these methods could be also reused for multiple sort algorythms.
  //-- e.g
  //-- procedure InsertionSortByIndex(ixLo, ixHi: Integer;
  //--                                IndexCompare: TIndexCompare;
  //--                                IndexExchange: TIndexExchange);
  //--  etc....

procedure QuickSortByIndex(ixLo, ixHi: Integer;
  IndexCompare: TIndexCompare;
  IndexExchange: TIndexExchange);
implementation

procedure QuickSortByIndex(ixLo, ixHi: Integer;
  IndexCompare: TIndexCompare;
  IndexExchange: TIndexExchange);

  procedure SortIndex(aLo, aHi: Integer);
  var
    I, J, P: Integer;
    tmpInt: Integer;
  begin
    repeat
      I := aLo;
      J := aHi;
      P := (aLo + aHi) shr 1;
      repeat
        while (I < aHi) and (IndexCompare(I, P) < 0) do
          Inc(I);
        while (J > aLo) and (IndexCompare(J, P) > 0) do
          Dec(J);
        if I <= J then
        begin
          IndexExchange(I, J);
          if P = I then
            P := J
          else if P = J then
            P := I;
          Inc(i);
          Dec(j);
        end;
      until I > J;
      if aLo < J then
        SortIndex(aLo, J);
      aLo := I;
    until I >= aHi;
  end;

begin
  SortIndex(ixLo, ixHi);
end;

Now to use this..lets say i want to sort a listbox for the example(rather than using  the Listbox standard sorting)

type
  TMyForm = class(TForm)
  private
    ListBox1: TListBox;
    btnSort: TButton;
    .....
    public
    function IndexCompare(const ixA, ixB: integer): integer;
    procedure IndexExchange(const ixA, ixB: integer);
  end;
  ..

implementation

function TMyForm.IndexCompare(const ixA, ixB: integer): integer;
//-- Source to compare items.
begin
  Result := AnsiCompareText(ListBox1.Items[ixA], ListBox1.items[ixB]);
end;

procedure TMyForm.IndexExchange(const ixA, ixB: integer);
// -- Source to exchange items.
var
  tmpStr: string;
begin
  tmpStr := ListBox1.Items[ixA];
  ListBox1.Items[ixA] := ListBox1.Items[ixB];
  ListBox1.Items[ixB] := tmpStr;
end;

procedure TMyForm.btnSortClick(Sender: TObject);
begin
  with ListBox1.items do
  begin
    BeginUpdate;
    try
      if UseQuickSort then
        QuickSortByIndex(0, count - 1, IndexCompare, IndexExchange)
      else
        InsertionSortByIndex(0, count - 1, IndexCompare, IndexExchange);
    finally
      EndUpdate;
    end;
  end;
end;

//----

Well hopefully that might of been some use

Later All

Convert a decimal number string to a Base36 number string

Problem/Question/Abstract:

I have a 20 digit string, all numbers, and I would like to convert this to a Base36 to take up less space. I have tried the Borland Radix() routine but this would not work on such a large number. Does anyone have an idea on how to convert the decimal number string to aBase36 number string?

Answer:

Solve 1:

Does the encoding have to result in a string having only "printable" characters (#32..#126) or is any byte value allowed? If so an easy packing method not requiring any complex calculation would be BCD: pack two digits into a byte, giving a 50% size reduction:

function NumStringToBCD(const inStr: string): string;

  function Pack(ch1, ch2: Char): Char;
  begin
    Assert((ch1 >= '0') and (ch1 <= '9'));
    Assert((ch2 >= '0') and (ch2 <= '9'));
    {Ord('0') is $30, so we can just use the low nybble of the character as value.}
    Result := Chr((Ord(ch1) and $F) or ((Ord(ch2) and $F) shl 4))
  end;

var
  i: Integer;
begin
  if Odd(Length(inStr)) then
    Result := NumStringToBCD('0' + inStr)
  else
  begin
    SetLength(Result, Length(inStr) div 2);
    for i := 1 to Length(Result) do
      Result[i] := Pack(inStr[2 * i - 1], inStr[2 * i]);
  end;
end;

function BCDToNumString(const inStr: string): string;

  procedure UnPack(ch: Char; var ch1, ch2: Char);
  begin
    ch1 := Chr((Ord(ch) and $F) + $30);
    ch2 := Chr(((Ord(ch) shr 4) and $F) + $30);
    Assert((ch1 >= '0') and (ch1 <= '9'));
    Assert((ch2 >= '0') and (ch2 <= '9'));
  end;

var
  i: Integer;
begin
  SetLength(Result, Length(inStr) * 2);
  for i := 1 to Length(inStr) do
    UnPack(inStr[i], Result[2 * i - 1], Result[2 * i]);
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  S1, S2: string;
begin
  S1 := '15151515151515151515';
  S2 := NumStringToBCD(S1);
  memo1.lines.add('S1: ' + S1);
  memo1.lines.add('Length(S2): ' + IntToStr(Length(S2)));
  memo1.lines.add('S2 unpacked again: ' + BCDToNumString(S2));
end;


Solve 2:

This DecimalStrToBase36Str seems to work on smaller inputs, but I suggest that you check output on the larger inputs.

{ ... }
const
  Base36Digits = '0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ';

type
  tArrayElement = Byte;
  tDoubleElement = Word;
  {tArrayElement  = Word;}
  {tDoubleElement = LongWord;}

const
  SizeOfAryElem = SizeOf(tArrayElement);
  BitsInBufElem = SizeOfAryElem * 8;

function DecimalStrToBase36Str(const Value: string): string;
var
  Man: array[0..19] of tArrayElement;
  NbrManElem, Cry, i, j, n, Tmp: integer;
  Tmp1, Tmp2: packed record
    case byte of
      0: (Wd: tDoubleElement);
      1: (Lo, Hi: tArrayElement);
  end;
begin
  n := length(Value);
  if n <> 20 then
    raise Exception.CreateFmt('Input string must be 20 decimal digits, not %d digits',
      [n]);
  NbrManElem := 0;
  for i := 1 to n do
  begin
    Cry := ord(Value[i]) - ord('0');
    if (Cry < 0) or (Cry > 9) then
      raise Exception.CreateFmt('Input string contains non-decimal digit (%s)',
        [Value[i]]);
    {Multiply accumulation by 10 and add k:}
    for j := 0 to NbrManElem - 1 do
    begin
      Tmp := Man[j] * 10 + Cry;
      Man[j] := Tmp and $FF;
      Cry := Tmp shr 8;
    end;
    if Cry <> 0 then
    begin
      Inc(NbrManElem);
      Man[NbrManElem - 1] := Cry;
    end;
  end;
  SetLength(Result, 14);
  for i := 14 downto 1 do
  begin
    {Divide by 36 and save the remainder:}
    Tmp1.Hi := 0;
    for j := NbrManElem - 1 downto 0 do
    begin
      Tmp1.Lo := Man[j];
      Tmp2.Wd := Tmp1.Wd div 36;
      Assert(Tmp2.Hi = 0);
      Man[j] := Tmp2.Lo;
      Tmp1.Hi := Tmp1.Wd mod 36;
    end;
    Result[i] := Base36Digits[Tmp1.Hi + 1];
    if (NbrManElem > 0) and (Man[NbrManElem - 1] = 0) then
    begin
      dec(NbrManElem);
    end;
  end;
end;

Starting and stopping Windows services

Problem/Question/Abstract:

Starting and stopping Windows services

Answer:

When installing certain types of programs it maybe necessary to restart related services to avoid conflicts. Regardless of the reason why you need to control services, following functions can help you with starting and stopping services running on the local computer or on a remote machine.

uses WinSvc;

//
// start service
//
// return TRUE if successful
//
// sMachine:
//   machine name, ie: \\SERVER
//   empty = local machine
//
// sService
//   service name, ie: Alerter
//

function ServiceStart(
  sMachine,
  sService: string): boolean;
var
  //
  // service control
  // manager handle
  schm,
    //
  // service handle
  schs: SC_Handle;
  //
  // service status
  ss: TServiceStatus;
  //
  // temp char pointer
  psTemp: PChar;
  //
  // check point
  dwChkP: DWord;
begin
  ss.dwCurrentState := -1;

  // connect to the service
  // control manager
  schm := OpenSCManager(
    PChar(sMachine),
    nil,
    SC_MANAGER_CONNECT);

  // if successful...
  if (schm > 0) then
  begin
    // open a handle to
    // the specified service
    schs := OpenService(
      schm,
      PChar(sService),
      // we want to
      // start the service and
      SERVICE_START or
      // query service status
      SERVICE_QUERY_STATUS);

    // if successful...
    if (schs > 0) then
    begin
      psTemp := nil;
      if (StartService(
        schs,
        0,
        psTemp)) then
      begin
        // check status
        if (QueryServiceStatus(
          schs,
          ss)) then
        begin
          while (SERVICE_RUNNING
            <> ss.dwCurrentState) do
          begin
            //
            // dwCheckPoint contains a
            // value that the service
            // increments periodically
            // to report its progress
            // during a lengthy
            // operation.
            //
            // save current value
            //
            dwChkP := ss.dwCheckPoint;

            //
            // wait a bit before
            // checking status again
            //
            // dwWaitHint is the
            // estimated amount of time
            // the calling program
            // should wait before calling
            // QueryServiceStatus() again
            //
            // idle events should be
            // handled here...
            //
            Sleep(ss.dwWaitHint);

            if (not QueryServiceStatus(
              schs,
              ss)) then
            begin
              // couldn't check status
              // break from the loop
              break;
            end;

            if (ss.dwCheckPoint <
              dwChkP) then
            begin
              // QueryServiceStatus
              // didn't increment
              // dwCheckPoint as it
              // should have.
              // avoid an infinite
              // loop by breaking
              break;
            end;
          end;
        end;
      end;

      // close service handle
      CloseServiceHandle(schs);
    end;

    // close service control
    // manager handle
    CloseServiceHandle(schm);
  end;

  // return TRUE if
  // the service status is running
  Result :=
    SERVICE_RUNNING =
    ss.dwCurrentState;
end;

The procedure to stop a service is similar to starting a service, except for calling "ControlService()" Win32 function instead of "StartService()", checking for SERVICE_STOPPED rather than SERVICE_RUNNING and using appropriate control codes.

// stop service
//
// return TRUE if successful
//
// sMachine:
//   machine name, ie: \\SERVER
//   empty = local machine
//
// sService
//   service name, ie: Alerter
//

function ServiceStop(
  sMachine,
  sService: string): boolean;
var
  //
  // service control
  // manager handle
  schm,
    //
  // service handle
  schs: SC_Handle;
  //
  // service status
  ss: TServiceStatus;
  //
  // check point
  dwChkP: DWord;
begin
  // connect to the service
  // control manager
  schm := OpenSCManager(
    PChar(sMachine),
    nil,
    SC_MANAGER_CONNECT);

  // if successful...
  if (schm > 0) then
  begin
    // open a handle to
    // the specified service
    schs := OpenService(
      schm,
      PChar(sService),
      // we want to
      // stop the service and
      SERVICE_STOP or
      // query service status
      SERVICE_QUERY_STATUS);

    // if successful...
    if (schs > 0) then
    begin
      if (ControlService(
        schs,
        SERVICE_CONTROL_STOP,
        ss)) then
      begin
        // check status
        if (QueryServiceStatus(
          schs,
          ss)) then
        begin
          while (SERVICE_STOPPED
            <> ss.dwCurrentState) do
          begin
            //
            // dwCheckPoint contains a
            // value that the service
            // increments periodically
            // to report its progress
            // during a lengthy
            // operation.
            //
            // save current value
            //
            dwChkP := ss.dwCheckPoint;

            //
            // wait a bit before
            // checking status again
            //
            // dwWaitHint is the
            // estimated amount of time
            // the calling program
            // should wait before calling
            // QueryServiceStatus() again
            //
            // idle events should be
            // handled here...
            //
            Sleep(ss.dwWaitHint);

            if (not QueryServiceStatus(
              schs,
              ss)) then
            begin
              // couldn't check status
              // break from the loop
              break;
            end;

            if (ss.dwCheckPoint <
              dwChkP) then
            begin
              // QueryServiceStatus
              // didn't increment
              // dwCheckPoint as it
              // should have.
              // avoid an infinite
              // loop by breaking
              break;
            end;
          end;
        end;
      end;

      // close service handle
      CloseServiceHandle(schs);
    end;

    // close service control
    // manager handle
    CloseServiceHandle(schm);
  end;

  // return TRUE if
  // the service status is stopped
  Result :=
    SERVICE_STOPPED =
    ss.dwCurrentState;
end;

Example usage:

if (ServiceStart('\\ComputerName', 'alerter')) then
begin
  // "alerter" service on \\ComputerName
  // was started
  // take appropriate action here
end;

// stop "alerter" service
// running on the local
// computer
if (ServiceStop('', 'alerter')) then
begin
end;

Retrieve folder size

Problem/Question/Abstract:

This function tells you how many bytes a folder, with all subfolders and contained files is taking on a HD, CD, floppy or whatever.

Answer:

function FolderSize(fld: string): dword;
var
  sr: tsearchrec;
  r: integer;
  s: dword;
begin
  fld := includetrailingbackslash(fld);
  s := 0;
  r := findfirst((fld + '*.*'), faanyfile, sr);
  while (r = 0) do
  begin
    application.processmessages;
    if ((sr.attr and fadirectory) <> 0) then
    begin
      if ((sr.name <> '.') and (sr.name <> '..')) then
        s := s + foldersize(fld + sr.name);
    end
    else
      S := S + SR.FindData.nFileSizeLow;
    r := findnext(sr);
  end;
  sysutils.findclose(sr);
  result := s;
end;

Soundex function

Problem/Question/Abstract:

Soundex function

Answer:

Solve 1:

This function will scan a string, and return a 'soundex' value. Comparing soundex values will give an indication of 'how alike' two strings sound... Play with it and see!!!

function Soundex(S: string): string;
const
  CvTable: array['B'..'Z'] of char = (
    '1', '2', '3', '0', '1', {'B' .. 'F'}
    '2', '0', '0', '2', '2', {'G' .. 'K'}
    '4', '5', '5', '0', '1', {'L' .. 'P'}
    '2', '6', '2', '3', '0', {'Q' .. 'U'}
    '1', '0', '2', '0', '2'); {'V' .. 'Z'}
var
  i, j: Integer;
  aGroup, Ch: Char;

  function Group(Ch: Char): Char;
  begin
    if (Ch in ['B'..'Z']) and not (Ch in ['E', 'H', 'I', 'O', 'U', 'W', 'Y']) then
      Result := CvTable[Ch]
    else
      Result := '0';
  end;

begin
  Result := '000';
  if S = '' then
    exit;

  S := Uppercase(S);
  i := 2;
  j := 1;
  while (i <= Length(S)) and (j <= 3) do
  begin
    Ch := S[i];
    aGroup := Group(Ch);
    if (aGroup <> '0') and (Ch <> S[i - 1]) and
      ((J = 1) or (aGroup <> Result[j - 1])) and
      ((i > 2) or (aGroup <> Group(S[1]))) then
    begin
      Result[j] := aGroup;
      Inc(j);
    end;
    Inc(i);
  end; {while}

  Result := S[1] + '-' + Result;
end;


Solve 2:

function StrSoundEx(const OrgString: string): string;
var
  s: string;
  PrevCh: char;
  Ch: char;
  i: integer;
begin
  s := UpperCase(Trim(OrgString));
  if s <> '' then
  begin
    PrevCh := #0;
    result := s[1];
    for i := 2 to Length(s) do
    begin
      if Length(result) = 4 then
        break;
      Ch := s[i];
      if (Ch <> PrevCh) then
      begin
        if Ch in ['B', 'P', 'F', 'V'] then
          result := result + '1'
        else if Ch in ['C', 'S', 'K', 'G', 'J', 'Q', 'X', 'Z'] then
          result := result + '2'
        else if Ch in ['D', 'T'] then
          result := result + '3'
        else if Ch in ['L'] then
          result := result + '4'
        else if Ch in ['M', 'N'] then
          result := result + '5'
        else if Ch in ['R'] then
          result := result + '6';
        PrevCh := Ch;
      end;
    end;
  end;
  while Length(result) < 4 do
    result := result + '0';
end;

Determine the version of the BDE

Problem/Question/Abstract:

Determine the version of the BDE

Answer:

This function determines some information about the BDE (version):

uses
  � DbiTypes, DbiProcs, DbiErrs;
...

function fDbiGetSysVersion(SysVerList: TStringList): SYSVersion;
begin
  � Check(DbiGetSysVersion(Result));
  � if SysVerList <> nil then
    �
  begin
    ��� with SysVerList do
      ���
    begin
      ����� Clear;
      ����� Add(Format('ENGINE VERSION=%d', [Result.iVersion]));
      ����� Add(Format('INTERFACE LEVEL=%d', [Result.iIntfLevel]));
      ����� Add(Format('VERSION DATE=%s', [DateToStr(Result.dateVer)]));
      ����� Add(Format('VERSION TIME=%s', [TimeToStr(Result.timeVer)]));
      ���
    end;
    �
  end;
end;
{from BDE32.hlp}

Storing Vlaues to the DFM files during design Time

Problem/Question/Abstract:

How can I store values in a DFM file during design Time, so that it can be used during run time?

Answer:

Most of use a table or some kind of files to store the data for the application to pick up the data during run time. Actually we can store the data in the form file ( dfm ). In the following example I have created a component derived from the TPersistent class. It uses the TReader and TWriter class to Read and write to the respective streams. The TComponentEditor allows to define the design time editors to work with the component class. The TPropertyEditor class allows to define a property editor for a specialized property in a component class.

In the following example I have given the component's source code. The design time property editor has a source file code(pas) and source form code for the form (dfm). copy the dfm code to create a dfm file, name it as "propdlg.dfm" and assign it's Name property to "fmpropdlg" and the source file code to create a pas file, name it as "propdlg.pas". Install the component TMyComponent, include the file "propdlg.pas" of the property editor in the the package.

The component will then allow you to invoke the design time editor by clicking on the object inspector for the specified property or by right clicking on the component itself and then selecting the respective verb in the menu context. You can store the fields of the class Tmydata in the form file ( dfm ) during design time.

//**********************************************************************
//***** Component source (pas) *****************************************
//**********************************************************************
unit Test;

interface

uses
  Windows, Forms, Classes, StdCtrls, SysUtils, ComCtrls, Messages, Controls,
  {DB, DBCtrls, CommCtrl, OCIH, OCI, OCL, ExtVCs,} dsgnintf;

type
  TMyPropertyEditor = class(TPropertyEditor)
  private
    { Private declarations }
  public
    { Public declarations }
    function GetAttributes: TPropertyAttributes; override;
    procedure Edit; override;
    function GetValue: string; override;
  end;

  TMyEditorPopup = class(TComponentEditor)
  private
    { Private declarations }
  public
    { Public declarations }
    procedure Edit; override;
    procedure ExecuteVerb(Index: Integer); override;
    function GetVerb(Index: Integer): string; override;
    function GetVerbCount: Integer; override;
  end;

  TMyData = class
  private
    Fstr: string;
    FInt: Integer;
  public
    property StringValue: string read Fstr write FStr;
    property IntegerValue: Integer read FInt write FInt;
  end;

  TMyTable = class(TPersistent)
  private
    FList: TList;
    function GetCount: Integer;
    function GetItem(Index: Integer): TMyData;

    procedure SetItem(Index: Integer; vItem: TMyData);
    procedure ReadProperties(Reader: TReader);
    procedure WriteProperties(Writer: TWriter);
  protected
    procedure DefineProperties(Filer: TFiler); override;
  public
    constructor Create;
    destructor Destroy; override;
    procedure AddItem;
    procedure DeleteItem(Index: Integer);
    property ItemCount: Integer read GetCount;
    property Items[Index: Integer]: TMyData read GetItem write SetItem; default;
  end;

  TMyComponent = class(TComponent)
  private
    FMyTable: TMyTable;
    procedure SetTables(Value: TMyTable);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property MyTables: TMyTable read FMyTable write SetTables;
  end;

procedure Register;

implementation

uses PropDlg;
{ TMyTable }

constructor TMyTable.Create;
begin
  FList := TList.Create;
  FList.Clear;
end;

destructor TMyTable.Destroy;
begin
  FList.Free;
  FList := nil;
  inherited destroy;
end;

procedure TMyTable.DefineProperties(Filer: TFiler);
begin
  Filer.DefineProperty('Tables', ReadProperties, WriteProperties, True);
end;

procedure TMyTable.ReadProperties(Reader: TReader);
begin
  Reader.ReadListBegin;
  while (not Reader.EndOfList) do
  begin
    AddItem;
    with Items[itemCount - 1] do
    begin
      Fstr := Reader.ReadString;
      FInt := Reader.ReadInteger;
    end;
  end;
  Reader.ReadListEnd;
end;

procedure TMyTable.WriteProperties(Writer: TWriter);
var
  I: Integer;
begin
  Writer.WriteListBegin;
  for I := 0 to (ItemCount - 1) do
  begin
    with Items[I] do
    begin
      Writer.WriteString(Fstr);
      Writer.WriteInteger(FInt);
    end;
  end;
  Writer.WriteListEnd;
end;

procedure TMyTable.AddItem;
var
  vData: TMyData;
begin
  vData := TMyData.Create;
  FList.Add(vData);
end;

function TMyTable.GetCount: Integer;
begin
  Result := FList.Count;
end;

function TMyTable.GetItem(Index: Integer): TMyData;
begin
  Result := TMyData(FList[Index]);
end;

procedure TMyTable.SetItem(Index: Integer; vItem: TMyData);
begin
  Flist[Index] := vItem;
end;

procedure TMyTable.DeleteItem(Index: Integer);
begin
  FList.Delete(Index);
end;

{ TMyComponent }

constructor TMyComponent.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FMyTable := TMyTable.Create;
end;

destructor TMyComponent.Destroy;
begin
  FMyTable.Free;
  FMyTable := nil;
  inherited Destroy;
end;

procedure TMyComponent.SetTables(Value: TMyTable);
begin
  {}
end;

function TMyPropertyEditor.GetAttributes: TPropertyAttributes;
begin
  Result := [paDialog, paReadOnly, paRevertable];
end;

procedure TMyPropertyEditor.Edit;
var
  MyComponent: TPersistent;
  FMyComponent: TMyComponent;
  MyDialog: TfmPropDlg;
begin
  MyComponent := GetComponent(0);
  if MyComponent is TMyComponent then
  begin
    FMyComponent := TMyComponent(MyComponent);

    MyDialog := TfmPropDlg.Create(Application);
    try
      MyDialog.FMyComponent := FMyComponent;
      MyDialog.FmyPropertyEditor := Self;
      MyDialog.ShowModal;
    finally
      MyDialog.Free;
      MyDialog := nil
    end;
  end;
end;

function TMyPropertyEditor.GetValue: string;
begin
  FmtStr(Result, '(%s)', [GetPropType^.Name]);
end;

procedure Register;
begin
  RegisterComponents('YOGI', [TMyComponent]);
  RegisterPropertyEditor(TypeInfo(TMyTable), TMyComponent, 'MyTables',
    TMyPropertyEditor);
  RegisterComponentEditor(TMyComponent, TMyEditorPopup);
end;

{ TMyEditorPopup }

procedure TMyEditorPopup.Edit;
var
  //  MyComponent : TPersistent;
  FMyComponent: TMyComponent;
  MyDialog: TfmPropDlg;
begin
  if Component is TMyComponent then
  begin
    FMyComponent := TMyComponent(Component);
    MyDialog := TfmPropDlg.Create(Application);
    try
      MyDialog.FMyComponent := FMyComponent;
      MyDialog.FMyEditorPopup := Self;
      MyDialog.ShowModal;
    finally
      MyDialog.Free;
      MyDialog := nil;
    end;
  end;
end;

procedure TMyEditorPopup.ExecuteVerb(Index: Integer);
begin
  if (Index = 0) then
    Edit;
end;

function TMyEditorPopup.GetVerb(Index: Integer): string;
begin
  if Index = 0 then
    Result := 'Yoganand''s Editor';
end;

function TMyEditorPopup.GetVerbCount: Integer;
begin
  Result := 1;
end;

{ TMyTest }

end.

//**********************************************************************
//***** Property Editor's source file (pas) code *******************
//**********************************************************************

unit propDlg;

interface

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

type
  TfmPropDlg = class(TForm)
    Label1: TLabel;
    Label2: TLabel;
    edtStr: TEdit;
    edtInt: TEdit;
    sbAdd: TSpeedButton;
    sbDelete: TSpeedButton;
    sbOk: TSpeedButton;
    sbCancel: TSpeedButton;
    sbup: TSpeedButton;
    sbDown: TSpeedButton;
    procedure sbAddClick(Sender: TObject);
    procedure sbOkClick(Sender: TObject);
    procedure sbupClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure sbDownClick(Sender: TObject);
    procedure sbDeleteClick(Sender: TObject);
  private
    { Private declarations }
    FCurrentIndex: Integer;
  public
    { Public declarations }
    FMyComponent: TMyComponent;
    FMyPropertyEditor: TPropertyEditor;
    FMyEditorPopup: TComponentEditor;
    FPageIndex: Integer;
  end;

var
  fmPropDlg: TfmPropDlg;

implementation

{$R *.DFM}

procedure TfmPropDlg.sbAddClick(Sender: TObject);
begin
  FMyComponent.MyTables.AddItem;
  edtStr.Text := '';
  edtInt.Text := '';
  edtStr.SetFocus;
end;

procedure TfmPropDlg.sbOkClick(Sender: TObject);
begin
  FMyComponent.MyTables[FMyComponent.MyTables.ItemCount - 1].StringValue :=
    edtStr.Text;
  FMyComponent.MyTables[FMyComponent.MyTables.ItemCount - 1].IntegerValue :=
    StrtoInt(edtInt.Text);
end;

procedure TfmPropDlg.sbupClick(Sender: TObject);
var
  I: Integer;
begin
  if (FCurrentIndex > 0) then
  begin
    Dec(FCurrentIndex);
    edtStr.Text := FMyComponent.MyTables[FCurrentIndex].StringValue;
    edtInt.Text := Inttostr(FMyComponent.MyTables[FCurrentIndex].IntegerValue);
  end;
end;

procedure TfmPropDlg.FormCreate(Sender: TObject);
begin
  FCurrentIndex := 0;
end;

procedure TfmPropDlg.FormShow(Sender: TObject);
begin
  if (FMyComponent.MyTables.ItemCount > 0) then
  begin
    FCurrentIndex := 0;
    edtStr.Text := FMyComponent.MyTables[FCurrentIndex].StringValue;
    edtInt.Text := Inttostr(FMyComponent.MyTables[FCurrentIndex].IntegerValue);
  end;
end;

procedure TfmPropDlg.sbDownClick(Sender: TObject);
begin
  if (FCurrentIndex < (FMyComponent.MyTables.ItemCount - 1)) then
  begin
    Inc(FCurrentIndex);
    edtStr.Text := FMyComponent.MyTables[FCurrentIndex].StringValue;
    edtInt.Text := Inttostr(FMyComponent.MyTables[FCurrentIndex].IntegerValue);
  end;
end;

procedure TfmPropDlg.sbDeleteClick(Sender: TObject);
begin
  if (FMyComponent.MyTables.ItemCount > 0) then
  begin
    FMyComponent.MyTables.DeleteItem(FCurrentIndex);
    FCurrentIndex := 0;
    edtStr.Text := FMyComponent.MyTables[FCurrentIndex].StringValue;
    edtInt.Text := Inttostr(FMyComponent.MyTables[FCurrentIndex].IntegerValue);
  end;
end;

end.

//**********************************************************************
//****** Property Editor's form file (dfm)  Code **************************
//**********************************************************************

object fmPropDlg: TfmPropDlg
  Left = 263
    Top = 371
    BorderStyle = bsDialog
    Caption = 'Editor Dlg'
    ClientHeight = 103
    ClientWidth = 218
    Color = clBtnFace
    Font.Charset = DEFAULT_CHARSET
    Font.Color = clWindowText
    Font.Height = -11
    Font.Name = 'MS Sans Serif'
    Font.Style = []
    OldCreateOrder = False
    Position = poScreenCenter
    OnCreate = FormCreate
    OnShow = FormShow
    PixelsPerInch = 96
    TextHeight = 13
    object Label1: TLabel
    Left = 16
      Top = 24
      Width = 36
      Height = 13
      Caption = 'Value 1'
  end
  object Label2: TLabel
    Left = 17
      Top = 51
      Width = 33
      Height = 13
      Caption = 'Value2'
  end
  object sbAdd: TSpeedButton
    Left = 26
      Top = 77
      Width = 23
      Height = 22
      Glyph.Data = {
    76010000424D7601000000000000760000002800000020000000100000000100
    04000000000000010000130B0000130B00001000000000000000000000000000
    800000800000008080008000000080008000808000007F7F7F00BFBFBF000000
    FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFFFF00333333333333
    33333333FF33333333FF333993333333300033377F3333333777333993333333
    300033F77FFF3333377739999993333333333777777F3333333F399999933333
    33003777777333333377333993333333330033377F3333333377333993333333
    3333333773333333333F333333333333330033333333F33333773333333C3333
    330033333337FF3333773333333CC333333333FFFFF77FFF3FF33CCCCCCCCCC3
    993337777777777F77F33CCCCCCCCCC3993337777777777377333333333CC333
    333333333337733333FF3333333C333330003333333733333777333333333333
    3000333333333333377733333333333333333333333333333333}
    NumGlyphs = 2
      OnClick = sbAddClick
  end
  object sbDelete: TSpeedButton
    Left = 62
      Top = 76
      Width = 23
      Height = 22
      Glyph.Data = {
    76010000424D7601000000000000760000002800000020000000100000000100
    04000000000000010000130B0000130B00001000000000000000000000000000
    800000800000008080008000000080008000808000007F7F7F00BFBFBF000000
    FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFFFF00333333333333
    333333333333333333FF33333333333330003333333333333777333333333333
    300033FFFFFF3333377739999993333333333777777F3333333F399999933333
    3300377777733333337733333333333333003333333333333377333333333333
    3333333333333333333F333333333333330033333F33333333773333C3333333
    330033337F3333333377333CC3333333333333F77FFFFFFF3FF33CCCCCCCCCC3
    993337777777777F77F33CCCCCCCCCC399333777777777737733333CC3333333
    333333377F33333333FF3333C333333330003333733333333777333333333333
    3000333333333333377733333333333333333333333333333333}
    NumGlyphs = 2
      OnClick = sbDeleteClick
  end
  object sbOk: TSpeedButton
    Left = 100
      Top = 76
      Width = 23
      Height = 22
      Glyph.Data = {
    76010000424D7601000000000000760000002800000020000000100000000100
    04000000000000010000120B0000120B00001000000000000000000000000000
    800000800000008080008000000080008000808000007F7F7F00BFBFBF000000
    FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFFFF00555555555555
    555555555555555555555555555555555555555555FF55555555555559055555
    55555555577FF5555555555599905555555555557777F5555555555599905555
    555555557777FF5555555559999905555555555777777F555555559999990555
    5555557777777FF5555557990599905555555777757777F55555790555599055
    55557775555777FF5555555555599905555555555557777F5555555555559905
    555555555555777FF5555555555559905555555555555777FF55555555555579
    05555555555555777FF5555555555557905555555555555777FF555555555555
    5990555555555555577755555555555555555555555555555555}
    NumGlyphs = 2
      OnClick = sbOkClick
  end
  object sbCancel: TSpeedButton
    Left = 144
      Top = 76
      Width = 23
      Height = 22
      Glyph.Data = {
    76010000424D7601000000000000760000002800000020000000100000000100
    04000000000000010000130B0000130B00001000000000000000000000000000
    800000800000008080008000000080008000808000007F7F7F00BFBFBF000000
    FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFFFF00333333333333
    333333333333333333333333333333333333333FFF33FF333FFF339993370733
    999333777FF37FF377733339993000399933333777F777F77733333399970799
    93333333777F7377733333333999399933333333377737773333333333990993
    3333333333737F73333333333331013333333333333777FF3333333333910193
    333333333337773FF3333333399000993333333337377737FF33333399900099
    93333333773777377FF333399930003999333337773777F777FF339993370733
    9993337773337333777333333333333333333333333333333333333333333333
    3333333333333333333333333333333333333333333333333333}
    NumGlyphs = 2
  end
  object sbup: TSpeedButton
    Left = 192
      Top = 16
      Width = 23
      Height = 22
      Glyph.Data = {
    76010000424D7601000000000000760000002800000020000000100000000100
    04000000000000010000120B0000120B00001000000000000000000000000000
    800000800000008080008000000080008000808000007F7F7F00BFBFBF000000
    FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFFFF00333333000333
    3333333333777F33333333333309033333333333337F7F333333333333090333
    33333333337F7F33333333333309033333333333337F7F333333333333090333
    33333333337F7F33333333333309033333333333FF7F7FFFF333333000090000
    3333333777737777F333333099999990333333373F3333373333333309999903
    333333337F33337F33333333099999033333333373F333733333333330999033
    3333333337F337F3333333333099903333333333373F37333333333333090333
    33333333337F7F33333333333309033333333333337373333333333333303333
    333333333337F333333333333330333333333333333733333333}
    NumGlyphs = 2
      OnClick = sbupClick
  end
  object sbDown: TSpeedButton
    Left = 192
      Top = 64
      Width = 23
      Height = 22
      Glyph.Data = {
    76010000424D7601000000000000760000002800000020000000100000000100
    04000000000000010000120B0000120B00001000000000000000000000000000
    800000800000008080008000000080008000808000007F7F7F00BFBFBF000000
    FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFFFF00333333303333
    333333333337F33333333333333033333333333333373F333333333333090333
    33333333337F7F33333333333309033333333333337373F33333333330999033
    3333333337F337F33333333330999033333333333733373F3333333309999903
    333333337F33337F33333333099999033333333373333373F333333099999990
    33333337FFFF3FF7F33333300009000033333337777F77773333333333090333
    33333333337F7F33333333333309033333333333337F7F333333333333090333
    33333333337F7F33333333333309033333333333337F7F333333333333090333
    33333333337F7F33333333333300033333333333337773333333}
    NumGlyphs = 2
      OnClick = sbDownClick
  end
  object edtStr: TEdit
    Left = 56
      Top = 21
      Width = 121
      Height = 21
      TabOrder = 0
  end
  object edtInt: TEdit
    Left = 56
      Top = 48
      Width = 121
      Height = 21
      TabOrder = 1
  end
end

//******************************************************

Read infos in MP3 files

Problem/Question/Abstract:

How to read infos in MP3 files

Answer:

{
   Description:
   Component MP3Info extracts/saves any ID3 Tag into/from it's
   properties from/to MP3 file.
   Keywords: MP3 ID3 TAG INFO

   Author: Rok Krulec (Rok@fpp.edu) (http://Rok.fpp.edu)
   Primary site: ftp://ftp.fpp.edu/pub/people/Rok_Krulec/mp3i-v12.zip

If you use this component, I would like to get 1 American dollar to Rok Krulec, Zagrad 6, 3000 Celje, Slovenia, Europe.

Description of Variables, Properties, Methods and Events:
    Genres: TStrings;                         - List of Genres
    constructor Create(AOwner: TComponent);   - Creates an instance
    destructor Destroy; override;             - Destroys an instance
    method Save;                              - Saves ID3 Tag to file
    method RemoveID3;                         - Removes ID3 Tag form file
    property Filename: TFilename;             - Filename of MP3 file, when changed it opens a new MP3 file
    property Artist: String;                  - Artist   (30 Chars)
    property Title: String;                   - Title    (30 Chars)
    property Album: String;                   - Album    (30 Chars)
    property Year: String;                    - Year     ( 4 chars)
    property Comment: String;                 - Comment  (30 Chars)
    property Genre: String;                   - Genre               [Read Only]
    Property GenreID: Byte;                   - Genre ID
    property Valid: Boolean;                  - Is ID3 valid        [Read Only]
    property Saved: Boolean;                  - Save success        [Read Only]
    property Error: String;                   - Error Message       [Read Only]
    property onChangeFile:TNotifyEvent;       - Triggers when other file is openned
    property onChange:TNotifyEvent;           - Triggers when one of propertis is changed (Artist, Title, Album, Year, Comment, GenreID)
    property onError:TNotifyEvent;            - Triggers when errors ocure (Wrong filename, Frong fileformat)
}

unit MP3Info;

interface

uses
  SysUtils, Classes;

const
  TAGLEN = 127;

type
  TMP3Info = class(TComponent)
  private
    { Private declarations }
    vFilename: TFilename;
    vMP3Tag, vArtist, vTitle, vAlbum, vComment, vYear, vGenre, vError: string;
    vGenreID: Byte;
    vValid: Boolean;
    vSaved: Boolean;
    vChangeFileEvent, vChangeEvent, vErrorEvent: TNotifyEvent;
    procedure SetFilename(Filename: TFilename);
    procedure SetArtist(Artist: string);
    procedure SetTitle(Title: string);
    procedure SetAlbum(Album: string);
    procedure SetYear(Year: string);
    procedure SetComment(Comment: string);
    procedure SetGenreID(ID: Byte);
    procedure Open;
  protected
    { Protected declarations }
  public
    { Public declarations }
  published
    { Published declarations }
    Genres: TStrings;
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Save;
    procedure RemoveID3;
    property Filename: TFilename read vFilename write SetFilename;
    property Artist: string read vArtist write SetArtist;
    property Title: string read vTitle write SetTitle;
    property Album: string read vAlbum write SetAlbum;
    property Year: string read vYear write SetYear;
    property Comment: string read vComment write SetComment;
    property Genre: string read vGenre;
    property GenreID: Byte read vGenreID write SetGenreID;
    property Valid: Boolean read vValid;
    property Saved: Boolean read vSaved;
    property Error: string read vError;
    property onChangeFile: TNotifyEvent read vChangeFileEvent write vChangeFileEvent;
    property onChange: TNotifyEvent read vChangeEvent write vChangeEvent;
    property onError: TNotifyEvent read vErrorEvent write vErrorEvent;
  end;

procedure Register;

implementation

constructor TMP3Info.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  Genres := TStringList.Create;
  vGenreID := 12;
  vValid := false;
  vSaved := false;

  { Fill the Genres String List so one can use it combo boxes e.t.c. Example: ComboBox.Items.Assign(MP3Info.Genres) }
  Genres.CommaText :=
    '"Blues","Classic Rock","Country","Dance","Disco","Funk","Grunge","Hip-Hop","Jazz","Metal","New Age","Oldies",'
    + '"Other","Pop","R&B","Rap","Reggae","Rock","Techno","Industrial","Alternative","Ska","Death Metal","Pranks",'
    + '"Soundtrack","Euro-Techno","Ambient","Trip-Hop","Vocal","Jazz+Funk","Fusion","Trance","Classical","Instrumental",'
    + '"Acid","House","Game","Sound Clip","Gospel","Noise","AlternRock","Bass","Soul","Punk","Space","Meditative",'
    + '"Instrumental Pop","Instrumental Rock","Ethnic","Gothic","Darkwave","Techno-Industrial","Electronic","Pop-Folk",'
    + '"Eurodance","Dream","Southern Rock","Comedy","Cult","Gangsta","Top 40","Christian Rap","Pop/Funk","Jungle",'
    + '"Native American","Cabaret","New Wave","Psychedelic","Rave","Showtunes","Trailer","Lo-Fi","Tribal","Acid Punk",'
    + '"Acid Jazz","Polka","Retro","Musical","Rock & Roll","Hard Rock","Folk","Folk/Rock","National Folk","Swing","Bebob",'
    + '"Latin","Revival","Celtic","Bluegrass","Avantgarde","Gothic Rock","Progressive Rock","Psychedelic Rock","Symphonic Rock",'
    + '"Slow Rock","Big Band","Chorus","Easy Listening","Acoustic","Humour","Speech","Chanson","Opera","Chamber Music","Sonata",'
    + '"Symphony","Booty Bass","Primus","Porn Groove","Satire","Slow Jam","Club","Tango","Samba","Folklore"'

end;

destructor TMP3Info.Destroy;
begin
  inherited Destroy;
end;

{ Procedure to run when Filename property is changed }

procedure TMP3Info.SetFilename(Filename: TFilename);
begin
  vFilename := Filename;
  Open;
end;

procedure TMP3Info.SetArtist(Artist: string);
begin
  vArtist := Copy(Artist, 0, 30);
  if Assigned(onChange) then
    onChange(Self);
end;

procedure TMP3Info.SetTitle(Title: string);
begin
  vTitle := Copy(Title, 0, 30);
  if Assigned(onChange) then
    onChange(Self);
end;

procedure TMP3Info.SetAlbum(Album: string);
begin
  vAlbum := Copy(Album, 0, 30);
  if Assigned(onChange) then
    onChange(Self);
end;

procedure TMP3Info.SetYear(Year: string);
begin
  vYear := Copy(Year, 0, 4);
  if Assigned(onChange) then
    onChange(Self);
end;

procedure TMP3Info.SetComment(Comment: string);
begin
  vComment := Copy(Comment, 0, 30);
  if Assigned(onChange) then
    onChange(Self);
end;

procedure TMP3Info.SetGenreID(ID: Byte);
begin
  if ((ID > 255) or (ID > Genres.Count - 1)) then
    ID := 12;
  vGenreID := ID;
  vGenre := Genres[vGenreID]; //this line is important because after changing
  //vGenreID whitout it vGenre will be the same like before !!!
  if Assigned(onChange) then
    onChange(Self);
end;

{ Opens file with Filename property, reads ID3 Tag and sets properties }

procedure TMP3Info.Open;

{ Strips empty spaces at the end of word }
  function Strip(WordToStrip: string; CharToStripAway: Char): string;
  var
    i: Integer;
  begin
    for i := length(WordToStrip) downto 1 do
    begin
      if WordToStrip[i] <> ' ' then
      begin
        Strip := Copy(WordToStrip, 0, i);
        exit;
      end;
    end;
    Strip := '';
  end;

var
  dat: file of char;
  id3: array[0..TAGLEN] of char;
begin
  vSaved := false;
  vValid := True;
  if FileExists(vFilename) then
  begin
    assignfile(dat, vFilename);
    reset(dat);
    seek(dat, FileSize(dat) - 128);
    blockread(dat, id3, 128);
    closefile(dat);
    vMP3tag := copy(id3, 1, 3);
    if vMP3Tag = 'TAG' then
    begin
      vTitle := strip(copy(id3, 4, 30), ' ');
      vArtist := strip(copy(id3, 34, 30), ' ');
      vAlbum := strip(copy(id3, 64, 30), ' ');
      vComment := strip(copy(id3, 98, 30), ' ');
      vYear := strip(copy(id3, 94, 4), ' ');
      vGenreID := ord(id3[127]);
      if vGenreID > Genres.Count then
        vGenreID := 12;
      vGenre := Genres[vGenreID];
      { Trigger OnChange Event }
      if Assigned(onChangeFile) then
        onChangeFile(Self);
    end
    else
    begin
      vValid := False;
      vTitle := '';
      vArtist := '';
      vAlbum := '';
      vComment := '';
      vYear := '';
      vGenreID := 12;
      vError := 'Wrong file format or no ID3 Tag !';
      if Assigned(onError) then
        onError(Self);
    end;
  end
  else
  begin
    vValid := False;
    vError := 'File doesn`t exist !';
    if Assigned(onError) then
      onError(Self);
  end;
end;

{ Removes the ID3-tag from currently open file }

procedure TMP3Info.RemoveID3;
var
  dat: file of char;
begin
  // does the file exist ?
  if not FileExists(vFilename) then
  begin
    vError := 'File doesn`t exist !';
    if Assigned(onError) then
      onError(Self);
    exit;
  end;
  // is the file already untagged ?
  if (vValid = false) then
  begin
    vError := 'File is already untagged !';
    if Assigned(onError) then
      onError(Self);
    exit;
  end;
  // remove readonly-attribute
  if (FileGetAttr(vFilename) and faReadOnly > 0) then
    FileSetAttr(vFileName, FileGetAttr(vFilename) - faReadOnly);
  // if readonly attr. already exists it cannot be removed to cut ID3 Tag
  if (FileGetAttr(vFilename) and faReadOnly > 0) then
  begin
    vError := 'Can�t write ID3 tag information !';
    if Assigned(onError) then
      onError(Self);
    exit;
  end;
  // open current mp3 file if ID3 tag exists
  if (vValid = true) then
  begin
    {I-}
    assignfile(dat, vFilename);
    reset(dat);
    {I+}
    if IOResult <> 0 then
    begin
      vError := 'Could not open file !';
      if Assigned(onError) then
        onError(Self);
      exit;
    end;
    seek(dat, FileSize(dat) - 128);
    truncate(dat); // cut all 128 bytes of file
    closefile(dat);
    vValid := false; // set vValid to false because the tag has been removed
  end;
end;

{ Saves ID3 Tag to currently opened file }

procedure TMP3Info.Save;

{ Empties 128 character array }{ Don't tell me that there is a function for this in Pascal }
  procedure EmptyArray(var Destination: array of char);
  var
    i: Integer;
  begin
    for i := 0 to TAGLEN do
    begin
      Destination[i] := ' ';
    end;
  end;

  { Insert a substring into character array at index position of array }
  procedure InsertToArray(Source: string; var Destination: array of char; Index:
    Integer);
  var
    i: Integer;
  begin
    for i := 0 to length(Source) - 1 do
    begin
      Destination[Index + i] := Source[i + 1];
    end;
  end;

var
  dat: file of char;
  id3: array[0..TAGLEN] of char;
begin
  vSaved := true;
  // does the filename exist ?
  if FileExists(vFilename) then
  begin
    // fill 128 bytes long array with ID3 Tag information
    EmptyArray(id3);
    InsertToArray('TAG', id3, 0);
    InsertToArray(vTitle, id3, 3);
    InsertToArray(vArtist, id3, 33);
    InsertToArray(vAlbum, id3, 63);
    InsertToArray(vComment, id3, 97);
    InsertToArray(vYear, id3, 93);
    id3[127] := chr(vGenreID);
    // remove readonly-attribute
    if (FileGetAttr(vFilename) and faReadOnly > 0) then
      FileSetAttr(vFileName, FileGetAttr(vFilename) - faReadOnly);
    // if readonly attr. already exists it cannot be removed to write ID3
    if (FileGetAttr(vFilename) and faReadOnly > 0) then
    begin
      vSaved := False;
      vError := 'Can�t write ID3 tag information !';
      if Assigned(onError) then
        onError(Self);
      exit;
    end;
    // if valid then overwrite existing ID3 Tag, else append to file
    if (vValid = True) then
    begin
      {I-}
      assignfile(dat, vFilename);
      reset(dat);
      seek(dat, FileSize(dat) - 128);
      blockwrite(dat, id3, 128);
      closefile(dat);
      {I+}
      if IOResult <> 0 then
        vSaved := false;
    end
    else
    begin
      {I-}
      assignfile(dat, vFilename);
      reset(dat);
      seek(dat, FileSize(dat));
      blockwrite(dat, id3, 128);
      closefile(dat);
      {I+}
      if IOResult <> 0 then
        vSaved := false;
    end
  end
  else
  begin
    vValid := False;
    vSaved := False;
    vError := 'File doesn`t exist or is not valid !';
    if Assigned(onError) then
      onError(Self);
  end;
end;

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

end.

{
   The ID3 Information is stored in the last 128 bytes of an MP3 file.
   The ID3 has the following fields, and the offsets given here, are from 0-127

   Field       Length            offsets
   -------------------------------------
   Tag           3                0-2
   Songname     30                3-32
   Artist       30                33-62
   Album        30                63-92
   Year          4                93-96
   Comment      30                97-126
   Genre         1                127
}

Putting a TDBLookupComboBox in a Grid

Problem/Question/Abstract:

How do I display a DBLookupComboBox in a Grid?

Answer:

The TDBGrid is an interesting component in that it's not really a "grid;" rather, it's more or less a collection of rectangles that are dynamically drawn to display data. The operative word here is "dynamic." If you take a look at the events of a TDBGrid, you'll see an event handler called OnDrawDataCell. Without going into a lot of technical mumbo-jumbo, this event is responsible for drawing data (or whatever) in the "cell" of a grid. The default action, obviously, is to display the underlying data of the grid, but since it's visible, we have the opportunity of adding some enhanced functionality. And that's exactly what we do to display a drop-down edit box. Now some of you might be thinking at this point that if we're adding our own functionality to the OnDrawDataCell, are we actually manipulating the grid itself? The answer to that is no. What we're actually doing in this case is drawing OVER the cell to make it look like the cell is a drop-down. Okay, let's get to specifics...

Setting Up Your Application

The sample application that we'll be building is going to be a simple order entry screen. For simplicity's sake, we'll be using the the Orders.db and Customer.db tables from the DBDEMOS database that gets installed with Delphi, though you easily transfer what you do here to any other application where you need a lookup. For our application, we'll be using the Orders table as the data entry table, and the Customer table as the lookup to retrieve customer identifications. Okay, here we go...

The first thing you need to do is to create a new application in Delphi. On the main form of the application, drop the following components:

Two (2) TTable Components
Two (2) TDatasource Components
One (1) TDBGrid
One (1) TDBLookupComboBox (You can drop this anywhere, we'll be positioning it at runtime)

To make things easier, set both TTables' DatabaseName properties to "DBDEMOS." Point the first table (Table1) to ORDERS.DB, and the second table (Table2) to CUSTOMER.DB (this will be our lookup table). Point DataSource1 to Table1 and DataSource2 to Table2. In plain english, you're setting DataSource1 and Table1 to point to the data entry table, while DataSource2 and Table2 point to the lookup data table. From there it's a matter of setting DBGrid1 to point to DataSource1.

Now with the TDBLookupComboBox, you've got to set a few properties, which is why I separated its setup from the other components. Besides, setting the properties of a TDBLookupComboBox has caused more than enough consternation among developers over time. From my point of view, or at least from what I remember when I wanted to just use this component by itself, one of the most confusing things about it was the way the properties were listed in the object inspector. But I guess that's neither here nor there. In any case here's what you do:

Set the DataSource property to DataSource1 (the same one that the DBGrid points to).
Set the DataField property to the CustNo field (this is the field that you're going to put lookup information into).
Now, set the ListSource property to DataSource2
Set the ListField property to the CustNo field.
This one's important: Drop down the KeyField property field and select CustNo from the list (It's the only field available). This will form the link between the two tables.
Finally, set the Visible property of the component to False - I'll explain that in a bit.

Once you're done with the steps above, set the Active properties of both tables to True. If you've done everything right, data should be displaying in the grid and you should see a value appear in the DBLookupComboBox. Now on to coding...

Making It Work

As I mentioned above, in order to make it appear that the DBGrid has a drop-down lookup, we use the OnDrawDataCell to draw the lookup combo box over the cell in which we want to get lookup information. In order to make this totally seamless to the user, we have to fulfill a few criteria:

Move and size the DBLookupComboBox over the cell in which we want to look up information.
Handle the lookup's visibility as the user scrolls from cell to cell in grid.
Handle focus control when the user enters the lookup cell.
Handle movement out of the DBLookupComboBox

The first and second criteria are easily met by writing code for OnDrawDataCell and OnColExit event handlers on the grid:

procedure TForm1.DBGrid1DrawDataCell(Sender: TObject; const Rect: TRect;
  Field: TField; State: TGridDrawState);
begin
  //Regardless of cell, do we have input focus? Also,
  //is the field we're on the same as the data field
  //pointed to by the DBLookupComboBox? If so, then
  //Move the component over the cell.
  if ((gdFocused in State) and
    (Field.FieldName = DBLookupComboBox1.DataField)) then
    with DBLookupComboBox1 do
    begin
      Left := Rect.Left + DBGrid1.Left;
      Top := Rect.Top + DBGrid1.Top;
      Width := Rect.Right - Rect.Left;
      if ((Rect.Bottom - Rect.Top) > Height) then
        Height := Rect.Bottom - Rect.Top;
      Visible := True;
    end;
end;

procedure TForm1.DBGrid1ColExit(Sender: TObject);
begin
  //Are we leaving the field in the grid that
  //is also the data field for our lookup?
  with DBGrid1, DBLookupComboBox1 do
    if (SelectedField.FieldName = DataField) then
      Visible := False;
end;

As you can see above, the OnDrawDataCell event handles the movement and sizing of the DBLookupComboBox and sets its visibility to True, while the OnColExit sets its visibility to False. In both cases, the conditional statement includes a comparison between the grid's field and the data field pointed to by the combo box. If they're the same, then they act. In the case of the OnDrawDataCell event though, the conditional also includes an evaluation of the State parameter. This is incredibly important because we only want to perform the drawing if a cell has input focus. If we were to remove this conditional, the component would be continuously drawn, causing an irritating strobe. Not good.

The third criteria exists because the DBLookupComboBox is not really part of the grid; it merely floats above it. Furthermore, since we're controlling the combo's behavior from the grid, it really doesn't ever receive input focus. The net result is that keystrokes don't get sent to the combo box, they get sent to the grid, even if the combo is displaying above the cell and is highlighted! If you tried typing a new customer number into the DBLookupComboBox at this point, nothing would appear to be happening. The combo box would remain highlighted. Actually, there is something happening - the grid's cell is actually getting updated. But you can't see it. In that case, what we have to do is make the grid give focus to the combo box as keys are pressed, and the place you do this is in the OnKeyPress event of the grid:

//If you edit the value in the lookup field, the grid actually
//has focus, so unless the keystroke is a Tab, then we need to
//send keystrokes to the LookupCombo

procedure TForm1.DBGrid1KeyPress(Sender: TObject; var Key: Char);
begin
  if (Key <> Chr(9)) then
    with DBGrid1, DBLookupComboBox1 do
      if (SelectedField.FieldName = DataField) then
      begin
        SetFocus;
        SendMessage(Handle, WM_CHAR, Word(Key), 0);
      end;
end;

The code above first checks the keypress to see if it isn't a Tab. If it was, it's ignored, and the user can move to an adjacent cell. But for any other key, we do our conditional to see if the field in the cell is the same as the data field for the combo. In that case, focus is set to the DBLookupComboBox and we send the keystroke message to it using the Win API SendMessage function. As much as possible, you want to avoid going to the Win API, but in this case, it's the only way to send a message.

Building on the third criteria, once you give focus control to the DBLookupCombo, it keeps focus. That's not bad in and of itself, but there's a catch. When you Tab out of the box, what happens is that focus is returned to the grid, but focus is also returned to the underlying cell. This means that in order to move to the next field, the user is forced to press Tab twice! There's no way to get around this phenomenon. However, there is a bit of trickery you can perform that will programmatically send another Tab to the grid. You do this in the OnKeyUp event of the DBGrid:

//If you choose an item from the lookup, you give focus
//control to it. The net result is that it takes two
//Tabs to move to the next cell. In that case, we need
//to send another Tab keystroke to the grid so that only
//one keystroke is needed to move to the next cell.

procedure TForm1.DBGrid1KeyUp(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
  if (Key in [VK_TAB]) and InBox then
  begin
    SendMessage(DBGrid1.Handle, WM_KEYDOWN, Key, 0);
    InBox := False;
  end;
end;

Notice the variable that's being set here: InBox. This is an implemenation-level variable that is used to determine whether or not the user has entered the CustNo cell. It's set to True in the OnEnter event of the combo box. Then in the OnKey up, if InBox is true and the keypress was a Tab, then we send the keystroke again. Otherwise, it's ignored. Here's the OnEnter of the DBLookupComboBox:

procedure TForm1.DBLookupComboBox1Enter(Sender: TObject);
begin
  InBox := True;
end;

Pretty straight forward....

But there is just one more tidbit that I have to throw at you to make this work problem-free.

One Last Tidbit

There's an option in the options property of the TDBGrid called dgCancelOnExit. This option is defined as follows in the online help:

When the user exits the grid from an inserted record to which the user made no modifications, the inserted record is not posted to the dataset. This prevents the inadvertent posting of empty records.

What does this have to do with what we're doing here? Well, let's say you insert a new record into the grid. If you immediately click on the CustNo lookup combo, your new record will disappear. Why? Well, based upon the definition above and based upon the code presented here, if you went to the CustNo field immediately following an insert, the grid would lose input focus! When dgCancelOnExit is set to True, if the grid loses focus before the record has been posted, the new row is deleted. Luckily, setting this option to False alleviates the problem.

Putting It All Together

To make the job of performing this technique easier, here's the full code listing of the form I used for the sample application:

unit main;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  Grids, DBGrids, DBCtrls, Db, DBTables;

type
  TForm1 = class(TForm)
    Table1: TTable;
    DataSource1: TDataSource;
    DataSource2: TDataSource;
    Table2: TTable;
    Table1OrderNo: TFloatField;
    Table1CustNo: TFloatField;
    Table1SaleDate: TDateTimeField;
    Table1ShipDate: TDateTimeField;
    Table1EmpNo: TIntegerField;
    Table1AmountPaid: TCurrencyField;
    Table2CustNo: TFloatField;
    DBLookupComboBox1: TDBLookupComboBox;
    DBGrid1: TDBGrid;
    procedure DBGrid1DrawDataCell(Sender: TObject; const Rect: TRect;
      Field: TField; State: TGridDrawState);
    procedure DBGrid1ColExit(Sender: TObject);
    procedure DBGrid1KeyPress(Sender: TObject; var Key: Char);
    procedure DBGrid1KeyUp(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure DBLookupComboBox1Enter(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation
var
  InBox: Boolean;
{$R *.DFM}

procedure TForm1.DBGrid1DrawDataCell(Sender: TObject; const Rect: TRect;
  Field: TField; State: TGridDrawState);
begin
  //Regardless of cell, do we have input focus? Also,
  //is the field we're on the same as the data field
  //pointed to by the DBLookupComboBox? If so, then
  //Move the component over the cell.
  if (gdFocused in State) and
    (Field.FieldName = DBLookupComboBox1.DataField) then
    with DBLookupComboBox1 do
    begin
      Left := Rect.Left + DBGrid1.Left;
      Top := Rect.Top + DBGrid1.Top;
      Width := Rect.Right - Rect.Left;
      if ((Rect.Bottom - Rect.Top) > Height) then
        Height := Rect.Bottom - Rect.Top;
      Visible := True;
    end;
end;

procedure TForm1.DBGrid1ColExit(Sender: TObject);
begin
  //Are we leaving the field in the grid that
  //is also the data field for our lookup?
  with DBGrid1, DBLookupComboBox1 do
    if (SelectedField.FieldName = DataField) then
      Visible := False;
end;

//If you edit the value in the lookup field, the grid actually
//has focus, so unless the keystroke is a Tab, then we need to
//send keystrokes to the LookupCombo

procedure TForm1.DBGrid1KeyPress(Sender: TObject; var Key: Char);
begin
  if (Key <> Chr(9)) then
    with DBGrid1, DBLookupComboBox1 do
      if (SelectedField.FieldName = DataField) then
      begin
        SetFocus;
        SendMessage(Handle, WM_CHAR, Word(Key), 0);
      end;
end;

//If you choose an item from the lookup, you give focus
//control to it. The net result is that it takes two
//Tabs to move to the next cell. In that case, we need
//to send another Tab keystroke to the grid so that only
//one keystroke is needed to move to the next cell.

procedure TForm1.DBGrid1KeyUp(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
  if (Key in [VK_TAB]) and InBox then
  begin
    SendMessage(DBGrid1.Handle, WM_KEYDOWN, Key, 0);
    InBox := False;
  end;
end;

procedure TForm1.DBLookupComboBox1Enter(Sender: TObject);
begin
  InBox := True;
end;

end.

So now, you have everything you need to "drop" a TDBLookupComboBox onto a grid. By the way, you can use this technique for ANY windowed component; that is, any component that has a Handle property. This includes forms, panels, memos, etc.. Try it out!

Note: Some of you old hats at Delphi might immediately exclaim, "What's the use of this article? In Delphi 3 and above, we have  the capability of specifying a cell in a DBGrid to be a drop-down edit." Well, that's the thing, isn't it? You have to fill in the values of the Items property yourself. What I'm suggesting here is adding a TDBLookupComboBox that will enable you to look up information from another data source. This isn't available in ANY version of Delphi.

By the way, this isn't my original idea, and in fact, the technique has been around since Delphi 1. But it's valid and applicable to later versions of Delphi.