How to interprete property values as textual values instead of integer

Problem/Question/Abstract:

I have an application that uses RTTI to access object properties. Is it possible to interprete property values like TColor as their textual values (ie clRed) instead of an integer? Is there anything in a property's RTTI to indicate it's a type TColor and not just an integer?

Answer:

This should get you there:

unit PropertyList;

interface

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

type
  TMyStream = class(TFileStream)
  private
    FFred: integer;
  published
    property Fred: integer read FFred write FFred;
  end;
type
  TFrmPropertyList = class(TForm)
    SpeedButton1: TSpeedButton;
    ListBox1: TListBox;
    procedure SpeedButton1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  FrmPropertyList: TFrmPropertyList;

implementation

{$R *.DFM}

uses
  TypInfo;

procedure ListProperties(AInstance: TPersistent; AList: TStrings);
var
  i: integer;
  pInfo: PTypeInfo;
  pType: PTypeData;
  propList: PPropList;
  propCnt: integer;
  tmpStr: string;
begin
  pInfo := AInstance.ClassInfo;
  if (pInfo = nil) or (pInfo^.Kind <> tkClass) then
    raise Exception.Create('Invalid type information');
  pType := GetTypeData(pInfo); {Pointer to TTypeData}
  AList.Add('Class name: ' + pInfo^.Name);
  {If any properties, add them to the list}
  propCnt := pType^.PropCount;
  if propCnt > 0 then
  begin
    AList.Add(EmptyStr);
    tmpStr := IntToStr(propCnt) + ' Propert';
    if propCnt > 1 then
      tmpStr := tmpStr + 'ies'
    else
      tmpStr := tmpStr + 'y';
    AList.Add(tmpStr);
    FillChar(tmpStr[1], Length(tmpStr), '-');
    AList.Add(tmpStr);
    {Get memory for the property list}
    GetMem(propList, sizeOf(PPropInfo) * propCnt);
    try
      {Fill in the property list}
      GetPropInfos(pInfo, propList);
      {Fill in info for each property}
      for i := 0 to propCnt - 1 do
        AList.Add(propList[i].Name + ': ' + propList[i].PropType^.Name);
    finally
      FreeMem(propList, sizeOf(PPropInfo) * propCnt);
    end;
  end;
end;

function GetPropertyList(AControl: TPersistent; AProperty: string): PPropInfo;
var
  i: integer;
  props: PPropList;
  typeData: PTypeData;
begin
  Result := nil;
  if (AControl = nil) or (AControl.ClassInfo = nil) then
    Exit;
  typeData := GetTypeData(AControl.ClassInfo);
  if (typeData = nil) or (typeData^.PropCount = 0) then
    Exit;
  GetMem(props, typeData^.PropCount * SizeOf(Pointer));
  try
    GetPropInfos(AControl.ClassInfo, props);
    for i := 0 to typeData^.PropCount - 1 do
    begin
      with Props^[i]^ do
        if (Name = AProperty) then
          result := Props^[i];
    end;
  finally
    FreeMem(props);
  end;
end;

procedure TFrmPropertyList.SpeedButton1Click(Sender: TObject);
var
  c: integer;
begin
  ListProperties(self, ListBox1.Items);
  for c := 0 to ComponentCount - 1 do
  begin
    ListBox1.Items.Add(EmptyStr);
    ListProperties(Components[c], ListBox1.Items);
  end;
end;

end.

How to do 24bit dithering in Delphi

Problem/Question/Abstract:

In my precalculations for some gradient rendering I use a higher bit depths per channel than normal 8bit (actually doubles between 0..1) - how can I dither these to normal 24bit and achieve better quality than just simple scaling to 8bit?

Answer:

This works for me. It reduces 8 bit per channel to 4 bit per channel. If you want 16 bit per channel -> 8 bit, you should change the numbers in the downsampling part, the rest should hold as it stands.

{ ... }
type
  PIntegerArray = ^TIntegerArray;
  TIntegerArray = array[0..maxInt div sizeof(integer) - 2] of integer;
  TColor3 = packed record
    b, g, r: byte;
  end;
  TColor3Array = array[0..maxInt div sizeof(TColor3) - 2] of TColor3;
  PColor3Array = ^TColor3Array;

procedure Swap(var p1, p2: PIntegerArray);
var
  t: PIntegerArray;
begin
  t := p1;
  p1 := p2;
  p2 := t;
end;

function clamp(x, min, max: integer): integer;
begin
  result := x;
  if result < min then
    result := min;
  else
    if result > max then
      result := max;
end;

procedure Dither(bmpS, bmpD: TBitmap);
var
  bmpS, bmpD: TBitmap;
  scanlS, scanlD: PColor3Array;
  error1R, error1G, error1B,
    error2R, error2G, error2B: PIntegerArray;
  x, y: integer;
  dx: integer;
  c, cD: TColor3;
  sR, sG, sB: integer;
  dR, dG, dB: integer;
  eR, eG, eB: integer;
begin
  bmpD.Width := bmpS.Width;
  bmpD.Height := bmpS.Height;
  bmpS.PixelFormat := pf24bit;
  bmpD.PixelFormat := pf24bit;
  error1R := AllocMem((bmpS.Width + 2) * sizeof(integer));
  error1G := AllocMem((bmpS.Width + 2) * sizeof(integer));
  error1B := AllocMem((bmpS.Width + 2) * sizeof(integer));
  error2R := AllocMem((bmpS.Width + 2) * sizeof(integer));
  error2G := AllocMem((bmpS.Width + 2) * sizeof(integer));
  error2B := AllocMem((bmpS.Width + 2) * sizeof(integer));
  {dx holds the delta for each iteration as we zigzag, it'll change between 1 and -1}
  dx := 1;
  for y := 0 to bmpS.Height - 1 do
  begin
    scanlS := bmpS.ScanLine[y];
    scanlD := bmpD.ScanLine[y];
    if dx > 0 then
      x := 0
    else
      x := bmpS.Width - 1;
    while (x >= 0) and (x < bmpS.Width) do
    begin
      c := scanlS[x];
      sR := c.r;
      sG := c.g;
      sB := c.b;
      eR := error1R[x + 1];
      eG := error1G[x + 1];
      eB := error1B[x + 1];
      dR := (sR * 16 + eR) div 16;
      dG := (sR * 16 + eR) div 16;
      dB := (sR * 16 + eR) div 16;
      {actual downsampling}
      dR := clamp(dR, 0, 255) and (255 shl 4);
      dG := clamp(dR, 0, 255) and (255 shl 4);
      dB := clamp(dR, 0, 255) and (255 shl 4);
      cD.r := dR;
      cD.g := dG;
      cD.b := dB;
      scanlD[x] := cD;
      eR := sR - dR;
      eG := sG - dG;
      eB := sB - dB;
      inc(error1R[x + 1 + dx], (eR * 7)); {next}
      inc(error1G[x + 1 + dx], (eG * 7));
      inc(error1B[x + 1 + dx], (eB * 7));
      inc(error2R[x + 1], (eR * 5)); {top}
      inc(error2G[x + 1], (eG * 5));
      inc(error2B[x + 1], (eB * 5));
      inc(error2R[x + 1 + dx], (eR * 1)); {diag forward}
      inc(error2G[x + 1 + dx], (eG * 1));
      inc(error2B[x + 1 + dx], (eB * 1));
      inc(error2R[x + 1 - dx], (eR * 3)); {diag backward}
      inc(error2G[x + 1 - dx], (eG * 3));
      inc(error2B[x + 1 - dx], (eB * 3));
      inc(x, dx);
    end;
    dx := dx * -1;
    Swap(error1R, error2R);
    Swap(error1G, error2G);
    Swap(error1B, error2B);
    FillChar(error2R^, sizeof(integer) * (bmpS.Width + 2), 0);
    FillChar(error2G^, sizeof(integer) * (bmpS.Width + 2), 0);
    FillChar(error2B^, sizeof(integer) * (bmpS.Width + 2), 0);
  end;
  FreeMem(error1R);
  FreeMem(error1G);
  FreeMem(error1B);
  FreeMem(error2R);
  FreeMem(error2G);
  FreeMem(error2B);
end;

Taskbar hides windows/ size of taskbar

Problem/Question/Abstract:

Taskbar hides windows/ size of taskbar

Answer:

Sometimes the taskbar covers a part of your application window and you would like to avoid that. The following procedure shows how to retrieve the size of the taskbar ('tray window'); the key information is the internal window's classname Shell_TrayWnd:


procedure TForm1.Button1Click(Sender: TObject);
var
  Tasklist: HWnd;
  Bordered: TRect;
begin
  Tasklist := FindWindow('Shell_TrayWnd', nil);
  GetWindowRect(Tasklist, Bordered);
  Label1.Caption := 'Left: ' + IntToStr(Bordered.Left);
  Label2.Caption := 'Right: ' + IntToStr(Bordered.Right);
  Label3.Caption := 'Top: ' + IntToStr(Bordered.Top);
  Label4.Caption := 'Bottom: ' + IntToStr(Bordered.Bottom);
end;


Note:
The taskbar window is always two pixels broader or higher than the screen, e.g. at a screen resolution of 800x600, the with would be 802 pixels.

Connect to an ftp server and download a file

Problem/Question/Abstract:

How to connect to an ftp server and download a file?

Answer:

The following function shows how to connect to a ftp server  and download a file.  It uses the functions from wininet.dll. You need a ProgressBar to show the progress and a Label to show progress informations.

uses
  WinInet, ComCtrls;

function FtpDownloadFile(strHost, strUser, strPwd: string;
  Port: Integer; ftpDir, ftpFile, TargetFile: string; ProgressBar: TProgressBar):
    Boolean;

  function FmtFileSize(Size: Integer): string;
  begin
    if Size >= $F4240 then
      Result := Format('%.2f', [Size / $F4240]) + ' Mb'
    else if Size < 1000 then
      Result := IntToStr(Size) + ' bytes'
    else
      Result := Format('%.2f', [Size / 1000]) + ' Kb';
  end;

const
  READ_BUFFERSIZE = 4096; // or 256, 512, ...
var
  hNet, hFTP, hFile: HINTERNET;
  buffer: array[0..READ_BUFFERSIZE - 1] of Char;
  bufsize, dwBytesRead, fileSize: DWORD;
  sRec: TWin32FindData;
  strStatus: string;
  LocalFile: file;
  bSuccess: Boolean;
begin
  Result := False;

  { Open an internet session }
  hNet := InternetOpen('Program_Name', // Agent
    INTERNET_OPEN_TYPE_PRECONFIG, // AccessType
    nil, // ProxyName
    nil, // ProxyBypass
    0); // or INTERNET_FLAG_ASYNC / INTERNET_FLAG_OFFLINE

  {
    Agent contains the name of the application or
    entity calling the Internet functions
  }

  { See if connection handle is valid }
  if hNet = nil then
  begin
    ShowMessage('Unable to get access to WinInet.Dll');
    Exit;
  end;

  { Connect to the FTP Server }
  hFTP := InternetConnect(hNet, // Handle from InternetOpen
    PChar(strHost), // FTP server
    port, // (INTERNET_DEFAULT_FTP_PORT),
    PChar(StrUser), // username
    PChar(strPwd), // password
    INTERNET_SERVICE_FTP, // FTP, HTTP, or Gopher?
    0, // flag: 0 or INTERNET_FLAG_PASSIVE
    0); // User defined number for callback

  if hFTP = nil then
  begin
    InternetCloseHandle(hNet);
    ShowMessage(Format('Host "%s" is not available', [strHost]));
    Exit;
  end;

  { Change directory }
  bSuccess := FtpSetCurrentDirectory(hFTP, PChar(ftpDir));

  if not bSuccess then
  begin
    InternetCloseHandle(hFTP);
    InternetCloseHandle(hNet);
    ShowMessage(Format('Cannot set directory to %s.', [ftpDir]));
    Exit;
  end;

  { Read size of file }
  if FtpFindFirstFile(hFTP, PChar(ftpFile), sRec, 0, 0) <> nil then
  begin
    fileSize := sRec.nFileSizeLow;
    // fileLastWritetime := sRec.lastWriteTime
  end
  else
  begin
    InternetCloseHandle(hFTP);
    InternetCloseHandle(hNet);
    ShowMessage(Format('Cannot find file ', [ftpFile]));
    Exit;
  end;

  { Open the file }
  hFile := FtpOpenFile(hFTP, // Handle to the ftp session
    PChar(ftpFile), // filename
    GENERIC_READ, // dwAccess
    FTP_TRANSFER_TYPE_BINARY, // dwFlags
    0); // This is the context used for callbacks.

  if hFile = nil then
  begin
    InternetCloseHandle(hFTP);
    InternetCloseHandle(hNet);
    Exit;
  end;

  { Create a new local file }
  AssignFile(LocalFile, TargetFile);
{$I-}
  Rewrite(LocalFile, 1);
{$I+}

  if IOResult <> 0 then
  begin
    InternetCloseHandle(hFile);
    InternetCloseHandle(hFTP);
    InternetCloseHandle(hNet);
    Exit;
  end;

  dwBytesRead := 0;
  bufsize := READ_BUFFERSIZE;

  while (bufsize > 0) do
  begin
    Application.ProcessMessages;

    if not InternetReadFile(hFile,
      @buffer, // address of a buffer that receives the data
      READ_BUFFERSIZE, // number of bytes to read from the file
      bufsize) then
      Break; // receives the actual number of bytes read

    if (bufsize > 0) and (bufsize <= READ_BUFFERSIZE) then
      BlockWrite(LocalFile, buffer, bufsize);
    dwBytesRead := dwBytesRead + bufsize;

    { Show Progress }
    ProgressBar.Position := Round(dwBytesRead * 100 / fileSize);
    Form1.Label1.Caption := Format('%s of %s / %d %%', [FmtFileSize(dwBytesRead),
      FmtFileSize(fileSize), ProgressBar.Position]);
  end;

  CloseFile(LocalFile);

  InternetCloseHandle(hFile);
  InternetCloseHandle(hFTP);
  InternetCloseHandle(hNet);
  Result := True;
end;

Dialog with Oracle

Problem/Question/Abstract:

Oracle Enterprise manager gives the database administrator enough instruments to accomplish a database backup. But what if you want to provide your Delphi database application with its own facility to perform this task? This option could be very useful especially for relatively small Oracle databases, where the DBA-responsible person usually has a lot of other functions in the organization. To extend the Delphi application capacity to have a dialog with Oracle is not only interesting, but also easy. Both Delphi and Oracle give us quite a few suitable approaches.

Answer:

BACKING UP AN ORACLE DATABASE

Most probably you will plan the backing up as an additional supporting activity in your Delphi database server application. In this case the most useful approach could be to use the Oracle's Export utility. It allows you to carry out the task even if the database is open and available for use. The result is a file which consists of a view of the database's objects. You could use the Import utility afterwards if you need to recover the data.To operate Export/Import even from an outside application is not only an easy task, but also allows backing up a single user or even a single table. There is one important thing you should consider when using the Export. The information in your backup file will not be logically consistent if someone makes changes to the database while the Export takes place. You could prevent this in two ways: scheduling the Export for a time when no one else can access the data: nights, weekends (if applicable in your case) or killing all the users' sessions before starting the Export and switching to restricted mode. Performing a full offline backup is another option which could also be performed by your Delphi application. If the process finishes successfully, the result is the most reliable you could achieve. As distinct from using the Export, where the system audit options are not exported, now you are copying the datafiles, the online redo log files and the current control file, so you will have on side all the files that constitute your database. Your result will be consistent only if the entire set of files corresponds to one exact point in time. To achieve this, you should initiate this backup only after the database is shut down in normal priority, not after an instance crash or shutdown abort!

Of course, a lot of additional information about the backup could be found in the Oracle technical documentation. But after this very short outline we will turn to the Delphi's implementation of the database backup.

THE DIALOG PRINCIPLES

For my project I have developed an unit which enables scheduling and accomplishing of the main Oracle backup approaches: export, export in Resricted session mode and Full Offline Backup. Moreover, Delphi can receive information back from the Oracle on the running of the backup process and report this to the user. Both Delphi and Oracle talk face to face to exchange information, so the word 'Dialog' is really very apt.

A table contains the tasks planned by the user. In my implementation, this is a Paradox table, but you could use just a file and a TclientDataSet to keep this data. I do not recommend placing it in Oracle, especially if you are going to shut down the database. Day, Hour and Minute fields provide information about the time of the task, the Repetition (&#8216;This&#8217;/&#8217;Every&#8217;) field allows both one-time and repeated backups to be carried out, the User/Password field indicates which user is to be exported and, finally, two boolean fields mark if this is a restricted session or Full shutdown backup task. The Locate function scans the table every minute to check the current task. If a task is identified, Delphi gathers from Oracle some additional data, if need be, and &#8220; talks &#8220; to Oracle about what it is supposed to do. Oracle executes and Delphi controls the results.

I use three ways to &#8220;talk&#8221; to Oracle: the SQL, the Export Utility (EXP) and the Server Manager (SVRMGR). Trough run-time produced batch files Delphi sends commands directly to the last two. Curiously this is exactly the approach Oracle uses by itself when the client is commanding the server. And Oracle has the good manners to return the rvcesults after a command execution in the form of log files if you ask it for this favour. It is not hard for Delphi to read the files and report to you in the end.

This is the &#8216;dialog&#8217; scheme. The implementation is, as I have already mentioned, very easy to carry out.Before starting, you should bear in mind some features of the different Oracle versions. For instance , there are different ways to call the ServerManager and the Export in different versions. For Oracle 7.3 these are &#8216;SVRMGR23&#8217; and&#8216;EXP73&#8217; , but for Oracle 8.05 &#8216;EXP80&#8217; and &#8216;SVRMGR30&#8217;.


Figure 1:The Oracle Task Scheduler.

The export command in Oracle 8 doesn't insist on password identification of the exported user. You could turn to Oracle documentation for more details about your specific version. It is also very important to give the OS a chance to complete fully one task before asking for the result. So I have used the popular &#8220;ExecandWait&#8221; function instead of ShellExecute. The last consideration is the user you are using to connect to Oracle to perform the backups. You should have permissions to do all the operations, and you should know the identification of your user in order not to kill its sessions if you are going to switch to restricted mode. By bad style &#8211; I do like the unlimited power &#8211; I am still using INTERNAL but Oracle has promised to drop it, so using just your system manager user is more recommendable.

EXPORT AND THE RESTRICTED SESSION OPTION

To export you should send a command line something like:

exp73 system/manager userid=ntr/kelantr
file=\\ntr_nt\Data\MbBackup\ntr LOG=ORAEXP80.LOG ;

The first parameter here is your user identification, the second is the user you are intending to export and the last is the logfile where the results will be reported by Oracle (additional parameters are available, but for my task this combination works well). It is advisable to identify the log file in a unique way for every operation. This could be an additional information source for you. I have used the time parameters in the Task table to create names for the log files, all the other parameters are also from the Task table. Before the export Delphi rewrites the batch file with &#8220;fresh stuff&#8221;, executes it, reads the Oracle log file and reports the resume on the screen. That is the scheme .
If you want to switch to restricted mode before export, some additional work should be done. First, you should obtain a list of all sessions. It could be gained by querying the V$SESSION view. For example,

SELECT SID, SERIAL# FROM V$SESSION WHERE USER#<>0

gives all the sessions except those owned by INTERNAL. You should update this statement according to your user. Next kill the sessions, which is easy already having their SID:

ALTER SYSTEM KILL SESSION {the SID of the session}

And finally, you restrict the database &#8211;

'ALTER SYSTEM ENABLE RESTRICTED SESSION'

Now no one else can access it. At this point you are free to do your consistent export. Don't forget to disable the restricted session, otherwise your clients will not be able to access the database after the export.

THE FULL OFFLINE BACKUP

This process is a little bit more complex, but also achievable by Delphi. Before starting, you should have a list of the datafiles and the redo log files by quering Oracle:

'SELECT NAME FROM V$DATAFILE'
'SELECT MEMBER FROM V$LOGFILE'

These are the files you will copy after the shutdown. You could also copy the controlfile, or back it up by using the ALTER DATABASE command with the BACKUP CONTROLFILE TO &#8216;filename&#8217; option. See the Oracle documentation for more information about backing up control files. It is important to shut the database down with immediate, rather than abort priority. A simple script is sent by Delphi to Server Manager to obtain this:

Connect internal/oracle;
Shutdown immediate;
Exit;

After shutdown, Delphi re-checks the log file and &#8211; ithe shutdown is successful, starts copying thfiles on the selected destination. I find the Windows.CopyFile function useful enough for this task, altough other approaches are also possible. The last step is to restart the database after the backup with pretty simple set of commands to the Server Manager:

Connect internal/Oracle;
Startup;
Exit;

Delphi re-checks the execution and reports the results.

CONCLUSION

Working on this topic, I enjoyed how open for dialog both Delphi and Oracle can be. It is enjoyable and it can reveal new approaches and new ideas for database developers. So, the Delphi/Oracle combination is something worth trying: they not only work together excellently, but also talk to each other in many ways and for the benefit of different developers' and administrators' tasks.


Component Download: DialogWithOra.zip

Make the results of a query permanent

Problem/Question/Abstract:

How to make the results of a query permanent

Answer:

Traditionally, to write the results of a query to disk, you use a TBatchMove and a TTable in addition to your query. But you can short-circuit this process by making a couple of simple, direct calls to the BDE.

Make sure you have BDE declared in your uses section

procedure MakePermTable(Qry: TQuery; PermTableName: string);
var
  h: HDBICur;
  ph: PHDBICur;
begin
  Qry.Prepare;
  Check(dbiQExec(Qry.StmtHandle, ph));
  h := ph^;
  Check(DbiMakePermanent(h, PChar(PermTableName), True));
end;

Save/load a font information in INI/text-file

Problem/Question/Abstract:

How can I save/restore the TFont-object in INI and/or text file?

Answer:

Sometimes you need to save/to load a font information in INI-file, Registry or some text file.

Now I desribe the some different methods.

1. very easy but not result isn't compact and effective (by data storage)

procedure SaveFont(FStream: TIniFile; Section: string; smFont: TFont);
begin
  FStream.WriteString(Section, Ident + 'Name', smFont.Name);
  FStream.WriteInteger(Section, Ident + 'CharSet', smFont.CharSet);
  FStream.WriteInteger(Section, Ident + 'Color', smFont.Color);
  FStream.WriteInteger(Section, Ident + 'Size', smFont.Size);
  FStream.WriteInteger(Section, Ident + 'Style', Byte(smFont.Style));
end;

procedure LoadFont(FStream: TIniFile; Section: string; smFont: TFont);
begin
  smFont.Name := FStream.ReadString(Section, Ident + 'Name', smFont.Name);
  smFont.CharSet := TFontCharSet(FStream.ReadInteger(Section, Ident + 'CharSet',
    smFont.CharSet));
  smFont.Color := TColor(FStream.ReadInteger(Section, Ident + 'Color', smFont.Color));
  smFont.Size := FStream.ReadInteger(Section, Ident + 'Size', smFont.Size);
  smFont.Style := TFontStyles(Byte(FStream.ReadInteger(Section, Ident + 'Style',
    Byte(smFont.Style))));
end;

2. more hardly than first method, but result is compact. I use this method in all own apps.

procedure SaveFont(FStream: TIniFile; Section: string; smFont: TFont);
begin
  FStream.WriteString(Section, 'Font', smFont.Name + ',' +
    IntToStr(smFont.CharSet) + ',' +
    IntToStr(smFont.Color) + ',' +
    IntToStr(smFont.Size) + ',' +
    IntToStr(Byte(smFont.Style)));
end;

procedure LoadFont(FStream: TIniFile; Section: string; smFont: TFont);
var
  s, Data: string;
  i: Integer;
begin
  s := FStream.ReadString(Section, 'Font', ',,,,');
  try
    i := Pos(',', s);
    if i > 0 then
    begin
      {Name}
      Data := Trim(Copy(s, 1, i - 1));
      if Data <> '' then
        smFont.Name := Data;
      Delete(s, 1, i);
      i := Pos(',', s);
      if i > 0 then
      begin
        {CharSet}
        Data := Trim(Copy(s, 1, i - 1));
        if Data <> '' then
          smFont.Charset := TFontCharSet(StrToIntDef(Data, smFont.Charset));
        Delete(s, 1, i);
        i := Pos(',', s);
        if i > 0 then
        begin
          {Color}
          Data := Trim(Copy(s, 1, i - 1));
          if Data <> '' then
            smFont.Color := TColor(StrToIntDef(Data, smFont.Color));
          Delete(s, 1, i);
          i := Pos(',', s);
          if i > 0 then
          begin
            {Size}
            Data := Trim(Copy(s, 1, i - 1));
            if Data <> '' then
              smFont.Size := StrToIntDef(Data, smFont.Size);
            Delete(s, 1, i);
            {Style}
            Data := Trim(s);
            if Data <> '' then
              smFont.Style := TFontStyles(Byte(StrToIntDef(Data,
                Byte(smFont.Style))));
          end
        end
      end
    end;
  except
  end;
end;

3. as alternative for 1&2 methods I can offer the third - you can create a temporary stream, save the wished font component in this stream (Stream.SaveComponent) and then you can navigate the byte-by-byte in stream, to convert each byte into hex (or some other radix) and save into your text file as string. Each byte is a two symbols for hex radix. For font reading - on the contrary...

How to create logical colour palettes

Problem/Question/Abstract:

Can someone explain the palPalEntry? I don't understand what the array[0..0] does and how to use it.

Answer:

You can use this for indicating the number of colours your palette is to contain. You should allocate memory for the palette dynamically, this way you can decide how much memory you want to put aside for the palette, i.e.

var
  LogPal: PLogPalette;
  Palette: HPalette;
  PalSize: LongInt;
begin
  { ... }
  PalSize := 2 * SizeOf(Word) + n_Colors * SizeOf(TPaletteEntry));
{2 * SizeOf(Word) to get space for palVersion and palNumEntries,  n_Colors is the number
of colors in the palette}
GetMem(LogPal, PalSize);
LogPal^.palVersion := $0300;
LogPal^.palNumEntries := n_Colors;
LogPal^.palPalEntry[0] := {Some colour};
LogPal^.palPalEntry[1] := {Some other colour};
{ etc. }
FreeMem(LogPal, PalSize);
{ ... }
end;

This has to be compiled with $R- (no range checking), otherwise you will get an error when you try using palPalEntry with an index higher than 0.

How to create a high resolution timer

Problem/Question/Abstract:

How to create a high resolution timer

Answer:

Windows is not a real time operating system so it is not really able to reliably achieve high accuracy timing without using a device driver. The best I have been able to get is a few nanoseconds using QueryPerformanceCounter. This is the procedure I use:

var
  WaitCal: Int64;

procedure Wait(ns: Integer);
var
  Counter, Freq, WaitUntil: Int64;
begin
  if QueryPerformanceCounter(Counter) then
  begin
    QueryPerformanceFrequency(Freq);
    WaitUntil := Counter + WaitCal + (ns * (Freq div 1000000));
    while Counter < WaitUntil do
      QueryPerformanceCounter(Counter);
  end
  else
    Sleep(ns div 1000);
end;

To get improved accuracy do this a little while before using Wait()

var
  Start, Finish: Int64;

Application.ProcessMessages;
Sleep(10);
QueryPerformanceCounter(Start);
Wait(0);
QueryPerformanceCounter(Finish);
WaitCal := Start - Finish;

A trick I have found to increase the reliability of this on my computer is to call Wait like this:

Application.ProcessMessages;
Sleep(0);
DoSomething;
Wait(10);
DoSomethingElse;

How to modify dialog boxes

Problem/Question/Abstract:

To define additional controls for a dialog box, I use a custom template as demonstrated by the TOpenPictureDialog source code. My component is a TOpenDialog descendant which needs space for extra controls on the bottom of the dialog. This works fine, except for the dimensions of the dialog.

Answer:

I've found the idea of using a dialog template to be a real pain - you basically have to throw away the Delphi TOpenDialog and do everything through the API functions. Instead, I modify the dialog in the OnShow event. At the time this event occurs, the component's Handle is valid.

I can change the size of the dialog window, or change its caption, using simple messages. I can enumerate its controls by simply stepping through with FindWindowEx. And I can add new controls using CreateWindow(). E.g. in a recent project I added a button to the Font dialog that lets the user take action regarding the selected font. I had calculated the position of the Rightmost control, and the Lowest control, and used those to place the button. It's also necessary to set the font for the new button, and to subclass the dialog, thus:


{ ... }
BtnHandle := CreateWindow('BUTTON', '&Ban', WS_CHILD or WS_CLIPSIBLINGS or
  WS_VISIBLE or WS_TABSTOP or BS_PUSHBUTTON, Rightmost - 72,
  Lowest - 21, 72, 21, DlgH, BanBtn_ID, HInstance, nil);
{Set the new button's font}
TempFont := TFont.Create;
try
  PostMessage(BtnHandle, WM_SETFONT, Longint(TempFont.Handle), MAKELPARAM(1, 0));
finally
  TempFont.Free;
end;
{Subclass the dialog to process the new button}
Integer(@GlobalWas) := SetWindowLong(DlgH, GWL_WNDPROC, Longint(@BanBtnWndProc));
{ ... }


The replacement dialog proc is pretty simple - if any control but our new button is pressed, it passes the processing to the old dlgproc. If it IS our button, it checks to make sure there IS a selection in the font name combobox (whose window handle was obtained during the enumeration of the box's controls) and, if so, calls a routine in the main form.


function BanBtnWndProc(HWindow: HWND; Msg: UINT; wParam: WPARAM;
  lParam: LPARAM): LRESULT; stdcall;
{This wndproc subclasses the font dialog and responds to the added Ban button}
var
  buff: array[0..MAX_PATH] of Char;
  sel: Integer;
begin
  if (Msg = WM_COMMAND) and (Lo(wParam) = BanBtn_ID) then
  begin
    sel := SendMessage(GlobalCBH, CB_GETCURSEL, 0, 0);
    if Sel >= 0 then
      SendMessage(GlobalCBH, WM_GETTEXT, MAX_PATH, Integer(@buff))
    else
      Buff[0] := #0;
    if StrLen(Buff) > 0 then
      MainForm.BanFont(StrPas(Buff))
    else
      MessageBeep(MB_ICONSTOP);
    Result := 0;
  end
  else
    Result := GlobalWas(HWindow, Msg, wParam, lParam);
end;


You can accomplish your modification of the file common dialogs using a similar technique.

How to convert a currency value into a string

Problem/Question/Abstract:

How can I convert a value like $ 405.00 into a string?

Answer:

Solve 1:

I have written a function similar to what you want, but some modification need to be done. CurrToStrFunc(1234.56, 'Dollar', 'Cent');

unit CurrToStrProc;

interface

uses
  SysUtils;

function CurrToStrFunc(InputCur: Currency; InputDollar: string; InputCent: string):
  string;
function Length_1(InputString: string): string;
function Length_2(InputString: string): string;
function Length_3(InputString: string): string;
function Length_4(InputString: string): string;
function Length_5(InputString: string): string;
function Length_6(InputString: string): string;
function Length_7(InputString: string): string;
function Length_8(InputString: string): string;
function Length_9(InputString: string): string;

implementation

function CurrToStrFunc(InputCur: Currency; InputDollar: string; InputCent: string):
  string;
var
  InputStr, DollarValue, DollarStr, CentValue, CentStr: string;
  Counter, CentCounter: Integer;
  CentFlag: Boolean;
begin
  InputStr := CurrToStr(InputCur);
  DollarValue := '';
  DollarStr := '';
  CentValue := '';
  CentStr := '';
  CentCounter := 0;
  CentFlag := False;
  for Counter := 1 to StrLen(PChar(InputStr)) do
  begin
    if (InputStr[Counter] <> '.') and (CentFlag = False) then
      DollarValue := DollarValue + InputStr[Counter]
    else
    begin
      if (InputStr[Counter] <> '.') then
      begin
        if (CentCounter < 2) then
          CentValue := CentValue + InputStr[Counter];
        CentCounter := CentCounter + 1;
      end;
      CentFlag := True;
    end;
  end;
  if (CentCounter = 1) then
    CentValue := CentValue + '0';
  case StrLen(PChar(DollarValue)) of
    0: DollarStr := '';
    1: DollarStr := Length_1(DollarValue);
    2: DollarStr := Length_2(DollarValue);
    3: DollarStr := Length_3(DollarValue);
    4: DollarStr := Length_4(DollarValue);
    5: DollarStr := Length_5(DollarValue);
    6: DollarStr := Length_6(DollarValue);
    7: DollarStr := Length_7(DollarValue);
    8: DollarStr := Length_8(DollarValue);
    9: DollarStr := Length_9(DollarValue);
  else
    DollarStr := '?';
  end;
  if (CentFlag = True) then
    CentStr := Length_2(CentValue);
  if (InputDollar = '') then
  begin
    if (InputCent = '') then
    begin
      if (CentFlag = True) then
        Result := DollarStr + ' ' + CentStr + ' ' + 'Only'
      else
        Result := DollarStr + ' ' + 'Only';
    end
    else if (CentFlag = True) then
      Result := DollarStr + ' ' + InputCent + ' ' + CentStr + ' ' + 'Only'
    else
      Result := DollarStr + ' ' + 'Only';
  end
  else
  begin
    if (InputCent = '') then
    begin
      if (CentFlag = True) then
        Result := InputDollar + ' ' + DollarStr + ' ' + CentStr + ' ' + 'Only'
      else
        Result := InputDollar + ' ' + DollarStr + ' ' + 'Only';
    end
    else if (CentFlag = True) then
      Result := InputDollar + ' ' + DollarStr + ' ' + InputCent + ' ' + CentStr +
                                 ' ' + 'Only'
    else
      Result := InputDollar + ' ' + DollarStr + ' ' + 'Only';
  end;
end;

function Length_1(InputString: string): string;
begin
  case StrToInt(InputString) of
    1: Result := 'One';
    2: Result := 'Two';
    3: Result := 'Three';
    4: Result := 'Four';
    5: Result := 'Five';
    6: Result := 'Six';
    7: Result := 'Seven';
    8: Result := 'Eight';
    9: Result := 'Nine';
  end;
end;

function Length_2(InputString: string): string;
begin
  case StrToInt(InputString[1]) of
    0:
      begin
        Result := Length_1(InputString[2])
      end;
    1:
      begin
        case StrToInt(InputString[2]) of
          0: Result := 'Ten';
          1: Result := 'Eleven';
          2: Result := 'Twelve';
          3: Result := 'Thirteen';
          4: Result := 'Fourteen';
          5: Result := 'Fiveteen';
          6: Result := 'Sixteen';
          7: Result := 'Seventeen';
          8: Result := 'Eighteen';
          9: Result := 'Nineteen';
        end;
      end;
    2:
      begin
        if (InputString[2] = '0') then
          Result := 'Twenty'
        else
          Result := 'Twenty' + ' ' + Length_1(InputString[2])
      end;
    3:
      begin
        if (InputString[2] = '0') then
          Result := 'Thirty'
        else
          Result := 'Thirty' + ' ' + Length_1(InputString[2])
      end;
    4:
      begin
        if (InputString[2] = '0') then
          Result := 'Fourty'
        else
          Result := 'Fourty' + ' ' + Length_1(InputString[2])
      end;
    5:
      begin
        if (InputString[2] = '0') then
          Result := 'Fivety'
        else
          Result := 'Fivety' + ' ' + Length_1(InputString[2])
      end;
    6:
      begin
        if (InputString[2] = '0') then
          Result := 'Sixty'
        else
          Result := 'Sixty' + ' ' + Length_1(InputString[2])
      end;
    7:
      begin
        if (InputString[2] = '0') then
          Result := 'Seventy'
        else
          Result := 'Seventy' + ' ' + Length_1(InputString[2])
      end;
    8:
      begin
        if (InputString[2] = '0') then
          Result := 'Eighty'
        else
          Result := 'Eighty' + ' ' + Length_1(InputString[2])
      end;
    9:
      begin
        if (InputString[2] = '0') then
          Result := 'Ninety'
        else
          Result := 'Ninety' + ' ' + Length_1(InputString[2])
      end;
  end;
end;

function Length_3(InputString: string): string;
begin
  if (Copy(InputString, 1, 2) = '00') then
    Result := Length_1(InputString[3])
  else if (Copy(InputString, 2, 2) = '00') then
    Result := Length_1(InputString[1]) + ' ' + 'Hundred'
  else if (Copy(InputString, 1, 1) = '0') then
    Result := Length_2(Copy(InputString, 2, 2))
  else
    Result := Length_1(InputString[1]) + ' ' + 'Hundred' + ' ' +
      Length_2(Copy(InputString, 2, 2));
end;

function Length_4(InputString: string): string;
begin
  if (Copy(InputString, 2, 3) = '000') then
    Result := Length_1(InputString[1]) + ' ' + 'Thousand'
  else if (InputString[2] = '0') then
    Result := Length_1(InputString[1]) + ' ' + 'Thousand' + ' ' +
      Length_2(Copy(InputString, 3, 2))
  else
    Result := Length_1(InputString[1]) + ' ' + 'Thousand' + ' ' +
      Length_1(InputString[2]) + ' ' + 'Hundred' + ' ' + Length_2(Copy(InputString, 3,
        2));
end;

function Length_5(InputString: string): string;
begin
  if (Copy(InputString, 2, 4) = '0000') then
    Result := Length_2(Copy(InputString, 1, 2)) + ' ' + 'Thousand'
  else if (InputString[3] = '0') then
    Result := Length_2(Copy(InputString, 1, 2)) + ' ' + 'Thousand' + ' ' +
      Length_2(Copy(InputString, 4, 2))
  else
    Result := Length_2(Copy(InputString, 1, 2)) + ' ' + 'Thousand' + ' ' +
      Length_1(InputString[3]) + ' ' + 'Hundred' + ' ' + Length_2(Copy(InputString, 4,
        2));
end;

function Length_6(InputString: string): string;
begin
  if (Copy(InputString, 1, 3) = '000') then
    Result := Length_3(Copy(InputString, 4, 3))
  else if (Copy(InputString, 2, 5) = '00000') then
    Result := Length_3(Copy(InputString, 1, 3)) + ' ' + 'Thousand'
  else if (InputString[4] = '0') then
    Result := Length_3(Copy(InputString, 1, 3)) + ' ' + 'Thousand' + ' ' +
      Length_2(Copy(InputString, 5, 2))
  else
    Result := Length_3(Copy(InputString, 1, 3)) + ' ' + 'Thousand' + ' ' +
      Length_1(InputString[4]) + ' ' + 'Hundred' + ' ' + Length_2(Copy(InputString, 5,
        2));
end;

function Length_7(InputString: string): string;
begin
  if (Copy(InputString, 2, 6) = '000000') then
    Result := Length_1(InputString[1]) + ' ' + 'Million'
  else if (Copy(InputString, 2, 3) = '000') then
    Result := Length_1(InputString[1]) + ' ' + 'Million' + ' ' +
      Length_3(Copy(InputString, 5, 3))
  else
    Result := Length_1(InputString[1]) + ' ' + 'Million' + ' ' +
      Length_6(Copy(InputString, 2, 6));
end;

function Length_8(InputString: string): string;
begin
  if (Copy(InputString, 2, 7) = '0000000') then
    Result := Length_2(Copy(InputString, 1, 2)) + ' ' + 'Million'
  else if (Copy(InputString, 3, 3) = '000') then
    Result := Length_2(Copy(InputString, 1, 2)) + ' ' + 'Million' + ' ' +
      Length_3(Copy(InputString, 6, 3))
  else
    Result := Length_2(Copy(InputString, 1, 2)) + ' ' + 'Million' + ' ' +
      Length_6(Copy(InputString, 3, 6));
end;

function Length_9(InputString: string): string;
begin
  if (Copy(InputString, 2, 8) = '00000000') then
    Result := Length_3(Copy(InputString, 1, 3)) + ' ' + 'Million'
  else if (Copy(InputString, 7, 3) = '000') then
    Result := Length_3(Copy(InputString, 1, 3)) + ' ' + 'Million' + ' ' +
      Length_3(Copy(InputString, 7, 3))
  else
    Result := Length_3(Copy(InputString, 1, 3)) + ' ' + 'Million' + ' ' +
      Length_6(Copy(InputString, 4, 6));
end;

end.


Solve 2:

function CurrencyToString(const Value: Double): string;
  function IntToEnglish(const Value: LongInt): string;

  implementation

uses
    Math;

const
    ENGLISH_ONES: array[1..19] of string = (
      'one',
      'two',
      'three',
      'four',
      'five',
      'six',
      'seven',
      'eight',
      'nine',
      'ten',
      'eleven',
      'twelve',
      'thirteen',
      'fourteen',
      'fifteen',
      'sixteen',
      'seventeen',
      'eighteen',
      'nineteen');

    ENGLISH_TENS: array[1..9] of string = (
      'ten',
      'twenty',
      'thirty',
      'forty',
      'fifty',
      'sixty',
      'seventy',
      'eighty',
      'ninety');

    ENGLISH_GROUP_SUFFIXES: array[1..3] of string = (
      'thousand',
      'million',
      'billion');

  function CurrencyToString(const Value: Double): string;
var
  Cents: LongInt;
begin
  Cents := Round(Value * 100);
  Result := IntToEnglish(Cents div 100) + ' and ' + IntToStr(Cents mod 100) +
    '/100 dollars';
end;

function IntToEnglish(const Value: LongInt): string;
var
  GroupIndex: Integer;
  GroupValue: Integer;
begin
  if (Value = 0) then
    Result := 'zero'
  else if (Value < 0) then
    Result := 'negative ' + IntToEnglish(-Value)
  else
  begin
    Result := '';
    for GroupIndex := (Trunc((8 * SizeOf(Value) - 1) / (3 * Ln(10) / Ln(2)))) downto 0
      do
    begin
      GroupValue := Value div Round(IntPower(10, 3 * GroupIndex)) mod 1000;
      if (GroupValue > 0) then
      begin
        if (GroupValue div 100 > 0) then
          Result := Result + ENGLISH_ONES[GroupValue div 100] + ' hundred';
        case (GroupValue mod 100) of
          0: ;
          1..19:
            Result := Result + ENGLISH_ONES[GroupValue mod 100] + ' ';
        else
          begin
            Result := Result + ENGLISH_TENS[GroupValue div 10 mod 10];
            if (GroupValue mod 10 > 0) then
              Result := Result + '-' + ENGLISH_ONES[GroupValue mod 10];
            Result := Result + ' ';
          end;
        end;
        if (GroupIndex > 0) then
          Result := Result + ENGLISH_GROUP_SUFFIXES[GroupIndex] + ' ';
      end;
    end;
    SetLength(Result, Length(Result) - 1); {Remove the trailing space}
  end;
end;

Calling CurrencyToString(12345678.90) returns: 'twelve million three hundred forty-five thousand six hundred seventy-eight and 90/100 dollars'

How to abort a print job and print to a file instead

Problem/Question/Abstract:

How to abort a print job and print to a file instead

Answer:

Print to file:

uses
  printers;

{$R *.DFM}

procedure StartPrintToFile(filename: string);
var
  CTitle: array[0..31] of Char;
  DocInfo: TDocInfo;
begin
  with Printer do
  begin
    BeginDoc;
    { Abort job just started on API level. }
    EndPage(Canvas.handle);
    Windows.AbortDoc(Canvas.handle);
    { Restart it with a print file as destination. }
    StrPLCopy(CTitle, Title, SizeOf(CTitle) - 1);
    FillChar(DocInfo, SizeOf(DocInfo), 0);
    with DocInfo do
    begin
      cbSize := SizeOf(DocInfo);
      lpszDocName := CTitle;
      lpszOutput := PChar(filename);
    end;
    StartDoc(Canvas.handle, DocInfo);
    StartPage(Canvas.handle);
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  StartPrintToFile('C:\temp\temp.prn');
  try
    Printer.Canvas.TextOut(100, 100, 'Hello World.');
  finally
    Printer.endDoc;
  end;
end;

Use extended Windows dialogs

Problem/Question/Abstract:

How to use extended Windows dialogs

Answer:

Today I want to show a few samples how you can use the extended dialogs from MS Windows (Find Files, Find Computer, Select Icon etc) in own code.

Usually the MessageDlg is most used from standard dialogs but inside of Windows you'll find a lot of other useful dialogs too.

The any such dialog is declared in the Shell32.dll library and you can use it so:

Select an Icon

this dialog is a same which you'll see when you'll edit an icon of any lnk-file (icon on desktop, for example)

Declaration:

function PickIconDlgA(OwnerWnd: HWND; lpstrFile: PAnsiChar; var nMaxFile: LongInt; var
  lpdwIconIndex: LongInt): LongBool; stdcall; external 'SHELL32.DLL' index 62;

Example (icon of current application will be changed!):

procedure TForm1.Button4Click(Sender: TObject);
var
  FileName: array[0..MAX_PATH - 1] of Char;
  Size, Index: LongInt;
begin
  Size := MAX_PATH;
  FileName := 'c:\windows\system\shell32.dll';
  if PickIconDlgA(0, FileName, Size, Index) then
  begin
    if (Index <> -1) then
      Application.Icon.Handle := ExtractIcon(hInstance, FileName, Index);
  end;
end;

Of course, you can define any other file and in the dialog you'll see available icons of this executable file.

Find Computer

Declaration:

function SHFindComputer(pidlRoot: PItemIDList; pidlSavedSearch: PItemIDList): Boolean;
  stdcall; external 'Shell32.dll' index 91;

Example:

begin
  SHFindComputer(nil, nil);
end;

Find Files

Declaration:

function SHFindFiles(pidlRoot: PItemIDList; pidlSavedSearch: PItemIDList): Boolean;
  stdcall; external 'Shell32.dll' index 90;

Example:

begin
  SHFindFiles(nil, nil);
end;

Here the first parameter is a folder where you want to begin a search (nil is a Desktop). The second parameter allow to define a previous saved state of search process.

IMPORTANT: Note that SHFindFiles and SHFindComputer are not modal dialogs (these dialogs will be started in separated thread) so the result of function will be True if dialog is created succesfully.

Shutdown Dialog

Declaration:

procedure ExitWindowsDialog(ParentWnd: HWND); stdcall; external 'Shell32.dll' index
  60;

Example:

begin
  ExitWindowsDialog(0)
end;

Restart Dialog

this dialog allow to ask end-user about Windows restarting and is used when changes are made to system that require a shutdown/restart before they will take effect.

Declaration:

function RestartDialog(ParentWnd: HWND; Reason: PAnsiChar; Flags: LongInt): LongInt;
  stdcall; external 'Shell32.dll' index 59;

Example:

begin
  if RestartDialog(0, 'I want to call a RestartDialog ', EW_RESTARTWINDOWS)
                        = IDYES then ShowMessage('succesfully started')
end;

You can define any reason of restarting (second parameter - additionally to default text or nil for default only) and use the another flag (one from the next available):

EWX_LOGOFF
EWX_SHUTDOWN
EWX_REBOOT
EW_RESTARTWINDOWS
EW_REBOOTSYSTEM
EW_EXITANDEXECAPP

This dialog is very useful for application which have embedded install procedure.

Out Of Space

Will display a notification dialog about "Out Of Space" for some defined drive.

Declaration:

procedure SHHandleDiskFull(Owner: HWND; Drive: UINT); stdcall; external
'Shell32.dll' index 185;

Example:

begin
  SHHandleDiskFull(0, 2);
end;

Note that second parameter is Drive number where 0 is A:, 1 is B:, 2 is C: etc

Of course, in the Shell32.dll you'll find other dialogs too (Object Properties, Map Network Drive, Browse For Folder etc) and you can use these dialogs without any problems.

IMPORTANT: Don't forget to add ShlObj and ShellAPI units into uses-clause.

How to get the drive letter of a CD-ROM drive

Problem/Question/Abstract:

I am writing a program which needs the drive name (c , d ,e, ...) of the CD-ROM drive. But that name can be different on different computers. In which file (win.ini , system.ini, registry or something else) can I find the special drive name?

Answer:

Solve 1:

function FindFirstCDROMDrive: Char;
var
  drivemap, mask: DWORD;
  i: Integer;
  root: string;
begin
  Result := #0;
  root := 'A:\';
  drivemap := GetLogicalDrives;
  mask := 1;
  for i := 1 to 32 do
  begin
    if (mask and drivemap) <> 0 then
      if GetDriveType(PChar(root)) = DRIVE_CDROM then
      begin
        Result := root[1];
        Break;
      end;
    mask := mask shl 1;
    Inc(root[1]);
  end;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  ShowMEssage('First CD drive is ' + FindFirstCDROMDrive);
end;


Solve 2:

function getcdroms: string;
var
  i: Byte;
begin
  Result := '';
  for i := 65 to 90 do
    if GetDriveType(Char(i) + ':\') = DRIVE_CDROM then
      Result := Result + Char(i);
end;


Solve 3:

Use the GetDriveType API function. The following will show all CD-ROM drives, to get only the first one put a 'Break' into the loop.


var
  ch: Char;
  s: string;
begin
  for ch := 'D' to 'Z' do
  begin
    s := ch + ':\';
    if GetDriveType(PChar(s)) = DRIVE_CDROM then
      ShowMessage('CDROM is ' + s[1])
  end;
end;

How to change the color of a menu

Problem/Question/Abstract:

How to change the color of a menu

Answer:

You can set the menu to owner-drawn and draw the items yourself in the OnDrawItem handlers. This does not work for the menubar, however.

The menu colors are a system setting which the user can specify in the display properties applet. You should not mess with that. One can do so when the app is activated and restore the old setting when it is deactivated or closed, but that is also not very satisfactory since the change still hits all other running apps as well and in the case of changes to the color scheme it also may take a noticable delay to take effect.

If you want to play with it: drop a TApplicationEvents component on the form, connect the OnActivate and OnDeactivate events of it to handlers, add one for the forms OnClose event, modify as below.

{ ... }
private
{ Private declarations }
FOldMenuColor: TColorRef;
FOldMenuTextColor: TColorRef;
public
{ Public declarations }
end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.ApplicationEvents1Activate(Sender: TObject);
var
  newcolors: array[0..1] of TColorRef;
  indices: array[0..1] of Integer;
begin
  FOldMenuColor := ColorToRGB(clMenu);
  FOldMenuTextColor := ColorToRGB(clMenuText);
  newcolors[0] := ColorToRGB(clAqua);
  newcolors[1] := ColorToRGB(clNavy);
  indices[0] := COLOR_MENU;
  indices[1] := COLOR_MENUTEXT;
  SetSysColors(2, indices, newcolors);
end;

procedure TForm1.ApplicationEvents1Deactivate(Sender: TObject);
var
  newcolors: array[0..1] of TColorRef;
  indices: array[0..1] of Integer;
begin
  newcolors[0] := FOldMenuColor;
  newcolors[1] := FOldMenuTextColor;
  indices[0] := COLOR_MENU;
  indices[1] := COLOR_MENUTEXT;
  SetSysColors(2, indices, newcolors);
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  ApplicationEvents1Deactivate(self);
end;

Date and time of creation/modification of a file

Problem/Question/Abstract:

Date and time of creation/modification of a file

Answer:

The function FileAge() returns the date/time stamp of a file. The returned value is an integer number; it has to be converted to Delphi's TDateTime format (a floating point number) before you can use it. You can use the following code to test the functions involved:


procedure TForm1.Button1Click(Sender: TObject);
var
  File_Name: string;
  DateTimeStamp: integer;
  Date_Time: TDateTime;
begin
  File_Name := 'c:\mydocuments\test.doc';
  DateTimeStamp := FileAge(File_Name);
  // FileAge returns -1 if file not found
  if DateTimeStamp < 0 then
    ShowMessage('File not found')
  else
  begin
    // Convert to TDateTime format
    Date_Time := FileDateToDateTime(DateTimeStamp);
    Label1.Caption := DateToStr(Date_Time);
    Label2.Caption := TimeToStr(Date_Time);
  end;
end;

How to add items to a program's system menu

Problem/Question/Abstract:

How to add items to a program's system menu

Answer:

Solve 1:

unit Unit1;

interface

uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs, Menus;

type
  TForm1 = class(TForm)
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
  public
    procedure winmsg(var msg: TMsg; var handled: boolean);
    {This is what handles the messages}
    procedure Anything; {Procedure to do whatever}
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

const
  ItemID = 99; {The ID number for your menu item - can be anything}

procedure TForm1.winmsg(var msg: TMsg; var handled: boolean);
begin
  {If the message is a system one ...}
  if msg.message = WM_SYSCOMMAND then
    {... then check if its parameter is your Menu items ID}
    if msg.wparam = ItemID then
      Anything;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  application.onmessage := winmsg;
  {Tell your app that 'winmsg' is the application message handler}
  AppendMenu(GetSystemMenu(form1.handle, false), mf_separator, 0, '');
  {Add a seperator bar to form1}
  AppendMenu(GetSystemMenu(form1.handle, false), mf_byposition, ItemID, '&New Item');
  {Add your menu item to form1}
  AppendMenu(GetSystemMenu(application.handle, false), mf_separator, 0, '');
  {Add a seperator bar to the application system menu(used when app is minimized)}
  AppendMenu(GetSystemMenu(application.handle, false), mf_byposition, ItemID, '&New Item');
  {Add your menu itemto the application system menu(used when app is minimized)}
end;

procedure TForm2.Anything;
begin
  {Add whatever you want to this procedure}
end;

end.


Solve 2:

First, you need to add the items to the existing system menu:


var
  SysMenu: HMenu;
  { ... }
  SysMenu := GetSystemMenu(Handle, False);
  { Note: the low order four bits of the command values must be 0 }
  AppendMenu(SysMenu, mf_String or mf_ByPosition, $F210, 'New Item 1');
  AppendMenu(SysMenu, mf_String or mf_ByPosition, $F220, 'New Item 2');
  { ... }


Then you need a message handler for the WM_SYSCOMMAND message:


procedure WMSysCommand(var MSg: TWMSysCommand); message WM_SYSCOMMAND;


Which you implement like so:


procedure TForm1.WMSysCommand(var MSg: TWMSysCommand);
begin
  inherited;
  case Msg.CmdType of
    $F210:
      begin
        { Handle new item 1 here }
        ShowMessage('New Item 1');
      end;
    $F220:
      begin
        { Handle new item 2 here }
        ShowMessage('New Item 2');
      end;
  end;
end;

How to close the help file when terminating the program

Problem/Question/Abstract:

How to close the help file when terminating the program

Answer:

procedure TMainForm.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  Winhelp(Handle, 'WinHelp.Hlp', HELP_QUIT, 0);
  Action := caFree;
end;

How to break strings into individual tokens (substrings)

Problem/Question/Abstract:

How to break strings into individual tokens (substrings)

Answer:

The following (simple) functions helped me handling substrings:

function GetToken(aString, SepChar: string; TokenNum: Byte): string;

{Parameters:
aString: the complete string
SepChar: a single character used as separator between the substrings
TokenNum: the number of the substring you want
result: the substring or an empty string if the are less then 'TokenNum' substrings}

var
  Token: string;
  StrLen: Byte;
  TNum: Byte;
  TEnd: Byte;
begin
  StrLen := Length(aString);
  TNum := 1;
  TEnd := StrLen;
  while ((TNum <= TokenNum) and (TEnd <> 0)) do
  begin
    TEnd := Pos(SepChar, aString);
    if TEnd <> 0 then
    begin
      Token := Copy(aString, 1, TEnd - 1);
      Delete(aString, 1, TEnd);
      Inc(TNum);
    end
    else
    begin
      Token := aString;
    end;
  end;
  if TNum >= TokenNum then
  begin
    GetToken1 := Token;
  end
  else
  begin
    GetToken1 := '';
  end;
end;

function NumToken(aString, SepChar: string): Byte;

{Parameters:
aString: the complete string
SepChar: a single character used as separator between the substrings
result: the number of substrings}

var
  RChar: Char;
  StrLen: Byte;
  TNum: Byte;
  TEnd: Byte;
begin
  if SepChar = ' # ' then
  begin
    RChar := ' * '
  end
  else
  begin
    RChar := ' # '
  end;
  StrLen := Length(aString);
  TNum := 0;
  TEnd := StrLen;
  while TEnd <> 0 do
  begin
    Inc(TNum);
    TEnd := Pos(SepChar, aString);
    if TEnd <> 0 then
    begin
      aString[TEnd] := RChar;
    end;
  end;
  NumToken1 := TNum;
end;

How to load a TImageList from a resource file

Problem/Question/Abstract:

Is there a way to load all the icons at once from a BMP into a TImageList? Is there a way to save all the images in a TImageList to a BMP file?

Answer:

The best way to load an imagelist from a resource is to pack all images into one bitmap and load them all in one go. For this you need the bitmap, of course.

So, create a new project, drop a TImagelist on the form and add the icons to it at design-time, as usual. Add a handler for the forms OnCreate event and do this in the handler:

var
  bmp: TBitmap;
  i: integer;
begin
  bmp := TBitmap.Create;
  try
    bmp.width := imagelist1.width * imagelist1.count;
    bmp.height := imagelist1.height;
    with bmp.canvas do
    begin
      brush.color := clOlive;
      brush.style := bsSolid;
      fillrect(cliprect);
    end;
    for i := 0 to imagelist1.count - 1 do
      imagelist1.draw(bmp.canvas, i * imagelist1.width, 0, i);
    bmp.savetofile('d:\temp\images.bmp');
  finally
    bmp.free
  end;
end;

The result is a "strip" bitmap with all images in the list. Open this bitmap in MSPaint and save it again under the same name as a 256 or 16 color bitmap, it will usually have a higher color depth since the VCL creates bitmaps with the color depth of your current video mode by default. The "transparent" color for this bitmap is clOlive, since that is what we filled the bitmap with before painting the images on it transparently.

The next step is to add this bitmap to a resource file and add the resource to your project. You can do that with the image editor as usual or create a RC file and add it to your project group (requires D5). The RC file would contain a line like

IMAGES1 BITMAP d:\temp\images.bmp

You can now load this resource into your projects imagelist with

imagelist2.ResInstLoad(HInstance, rtBitmap, 'IMAGES1', clOlive);

Note that the width and height setting of the imagelist has to be the same as the one you saved the images from, otherwise the bitmap will not be partitioned correctly.

Get a list of dates of specific days in a given date range

Problem/Question/Abstract:

Can anyone help with a routine that will return a list of dates of specific days in a given date range? For example, I want a list of dates of the third Monday of each month in a given date range. The user will be able to nominate the date range, the day of the week, and which day (i.e. 1st, 2nd, 3rd or 4th).

Answer:

The procedure to call is ListDates(). The important function is DateInPeriod(). Because of DayOfWeek(), Sunday is WeekDay = 1. Tested briefly.

function ValidateWeekDay(const WeekDay: Word): Word;
begin
  Result := WeekDay mod 7;
  if Result = 0 then
    Result := 7;
end;

function DayInMonth(const Year, Month, WeekDay, Nr: Word): Word;
var
  MonthStart, Shift: Word;
begin
  MonthStart := DayOfWeek(EncodeDate(Year, Month, 1));
  Shift := ValidateWeekDay(8 + WeekDay - MonthStart);
  Result := Shift + (7 * (Nr - 1));
end;

function DateInPeriod(const Date, FromDate, ToDate: TDate): Boolean;
begin
  Result := (Trunc(Date) >= Trunc(FromDate)) and (Trunc(Date) <= Trunc(ToDate))
end;

procedure ListDates(const FromDate, ToDate: TDate; const WeekDay, Nr: Word;
  const DatesList: TStrings);
var
  Year, Month, Day: Word;
  Date: TDate;

  procedure NextMonth;
  begin
    if Month = 12 then
    begin
      Month := 1;
      inc(Year);
    end
    else
      inc(Month);
  end;

begin
  DatesList.Clear;
  DecodeDate(FromDate, Year, Month, Day);
  while EncodeDate(Year, Month, 1) <= Trunc(ToDate) do
  begin
    Date := EncodeDate(Year, Month, DayInMonth(Year, Month, WeekDay, Nr));
    if DateInPeriod(Date, FromDate, ToDate) then
      DatesList.Add(FormatDateTime(ShortDateFormat, Date));
    NextMonth;
  end;
end;

How to move any component at runtime

Problem/Question/Abstract:

How to move any component at runtime

Answer:

Solve 1:

There is a simple trick for allowing the user to move components at runtime. However, this will only work for components which derive from a TWinControl as it requires a Handle property. The solution I am about to give will work with ANY component. Although it uses the same method, I have achieved moving components without a handle property by temporarily placing them inside a TPanel. Make sure ExtCtrls is in your USES clause, then point the OnMouseDown event for each component at the following code:


procedure TForm1.MoveControl(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
var
  TempPanel: TPanel;
  Control: TControl;
begin
  {Release the MOUSEDOWN status}
  ReleaseCapture;
  {If the component is a TWinControl, just move it directly}
  if Sender is TWinControl then
    TWinControl(Sender).Perform(WM_SysCommand, $F012, 0)
  else
  try
    Control := TControl(Sender);
    TempPanel := TPanel.Create(Self);
    with TempPanel do
    begin
      {Replace the component with TempPanel}
      Caption := '';
      BevelOuter := bvNone;
      SetBounds(Control.Left, Control.Top, Control.Width, Control.Height);
      Parent := Control.Parent;
      {Put our control in TempPanel}
      Control.Parent := TempPanel;
      {Move TempPanel with control inside of it}
      Perform(WM_SysCommand, $F012, 0);
      {Put the component where the panel was dropped}
      Control.Parent := Parent;
      Control.Left := Left;
      Control.Top := Top;
    end;
  finally
    TempPanel.Free;
  end;
end;


Solve 2:

unit Unit1;

interface

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

type
  TControlDragKind = (dkNone, dkTopLeft, dkTop, dkTopRight, dkRight, dkBottomRight,
    dkBottom, dkBottomLeft, dkLeft, dkClient);

  TForm1 = class(TForm)
    procedure FormClick(Sender: TObject);
  private
    { Private declarations }
    FDownPos: TPoint; { position of last mouse down, screen-relative }
    FDragKind: TcontrolDragKind; { kind of drag in progress }
    procedure ControlMouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure ControlMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
    procedure ControlMouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    function GetDragging: Boolean;
  public
    { Public declarations }
    property DraggingControl: Boolean read GetDragging;
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

const
  { Set of cursors to use while moving over and dragging on controls. }
  DragCursors: array[TControlDragKind] of TCursor =
  (crDefault, crSizeNWSE, crSizeNS, crSizeNESW, crSizeWE,
    crSizeNWSE, crSizeNS, crSizeNESW, crSizeWE, crHandPoint);
  {Width of "hot zone" for dragging around the control borders. }
  HittestMargin = 3;

type
  TCracker = class(TControl); { Needed since TControl.MouseCapture is protected }

  { Perform hittest on the mouse position. Position is in client coordinates for the passed control. }

function GetDragKind(control: TControl; X, Y: Integer): TControlDragKind;
var
  r: TRect;
begin
  r := control.Clientrect;
  Result := dkNone;
  if Abs(X - r.left) <= HittestMargin then
    if Abs(Y - r.top) <= HittestMargin then
      Result := dkTopLeft
    else if Abs(Y - r.bottom) <= HittestMargin then
      Result := dkBottomLeft
    else
      Result := dkLeft
  else if Abs(X - r.right) <= HittestMargin then
    if Abs(Y - r.top) <= HittestMargin then
      Result := dkTopRight
    else if Abs(Y - r.bottom) <= HittestMargin then
      Result := dkBottomRight
    else
      Result := dkRight
  else if Abs(Y - r.top) <= HittestMargin then
    Result := dkTop
  else if Abs(Y - r.bottom) <= HittestMargin then
    Result := dkBottom
  else if PtInRect(r, Point(X, Y)) then
    Result := dkClient;
end;

procedure TForm1.FormClick(Sender: TObject);
var
  pt: TPoint;
begin
  {get cursor position, convert to client coordinates}
  GetCursorPos(pt);
  pt := ScreenToClient(pt);
  {create label with top left corner at mouse position}
  with TLabel.Create(Self) do
  begin
    Autosize := False; { Otherwise resizing is futile. }
    SetBounds(pt.x, pt.y, width, height);
    Caption := Format('Hit at %d, %d', [pt.x, pt.y]);
    Color := clBlue;
    Font.Color := clWhite;
    Parent := Self;
    {attach the drag handlers}
    OnMouseDown := ControlMouseDown;
    OnMouseUp := ControlMouseUp;
    OnMouseMove := ControlMouseMove;
  end;
end;

procedure TForm1.ControlMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  { Go into drag mode if left mouse button went down and no modifier key is pressed. }
  if (Button = mbLeft) and (Shift = [ssLeft]) then
  begin
    { Determine where on the control the mouse went down. }
    FDragKind := GetDragKind(Sender as TControl, X, Y);
    if FDragKind <> dkNone then
    begin
      with TCracker(Sender) do
      begin
        { Record current position screen-relative, the origin for the client-relative position will move if the form is moved or resized on left/top sides. }
        FDownPos := ClientToScreen(Point(X, Y));
        MouseCapture := True;
        Color := clRed;
      end;
    end;
  end;
end;

procedure TForm1.ControlMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
var
  dx, dy: Integer;
  pt: TPoint;
  r: TRect;
begin
  { Set controls cursor depending on position in control. }
  (Sender as TControl).Cursor := DragCursors[GetDragKind(TControl(Sender), X, Y)];
  { If we are dragging the control, get amount the mouse has moved since last call
  and calculate a new boundsrect for the control from it, depending on drag mode. }
  if DraggingControl then
    with Sender as TControl do
    begin
      pt := ClientToScreen(Point(X, Y));
      dx := pt.X - FDownPos.X;
      dy := pt.Y - FDownPos.Y;
      { Update stored mouse position to current position. }
      FDownPos := pt;
      r := BoundsRect;
      case FDragKind of
        dkTopLeft:
          begin
            r.Left := r.Left + dx;
            r.Top := r.Top + dy;
          end;
        dkTop:
          begin
            r.Top := r.Top + dy;
          end;
        dkTopRight:
          begin
            r.Right := r.Right + dx;
            r.Top := r.Top + dy;
          end;
        dkRight:
          begin
            r.Right := r.Right + dx;
          end;
        dkBottomRight:
          begin
            r.Right := r.Right + dx;
            r.Bottom := r.Bottom + dy;
          end;
        dkBottom:
          begin
            r.Bottom := r.Bottom + dy;
          end;
        dkBottomLeft:
          begin
            r.Left := r.Left + dx;
            r.Bottom := r.Bottom + dy;
          end;
        dkLeft:
          begin
            r.Left := r.Left + dx;
          end;
        dkClient:
          begin
            OffsetRect(r, dx, dy);
          end;
      end;
      { Don't let the control be resized to nothing }
      if ((r.right - r.left) > 2 * HittestMargin) and ((r.bottom - r.top) > 2 *
        HittestMargin) then
        Boundsrect := r;
    end;
end;

procedure TForm1.ControlMouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  if DraggingControl then
  begin
    { Revert to non-dragging state. }
    FDragKind := dkNone;
    with TCracker(Sender) do
    begin
      MouseCapture := False;
      Color := clBlue;
    end;
  end;
end;

{ Read method for ControlDragging property, returns true if form is in drag mode. }

function TForm1.GetDragging: Boolean;
begin
  Result := FDragKind <> dkNone;
end;

end.


Solve 3:

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Panel1: TPanel;
    procedure Panel1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
    procedure Panel1MouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
  private
    { Private declarations }
    LastX, LastY: Integer;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Panel1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
begin
  with (Sender as TPanel) do
  begin
    if csLButtonDown in ControlState then
    begin
      Left := ScreenToClient(Point(ClientToScreen(Point(Left, Top)).X,
        ClientToScreen(Point(Left, Top)).Y)).X + (X - LastX);
      Top := ScreenToClient(Point(ClientToScreen(Point(Left, Top)).X,
        ClientToScreen(Point(Left, Top)).Y)).Y + (Y - LastY);
    end;
  end;
end;

procedure TForm1.Panel1MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  LastX := X;
  LastY := Y;
end;

end.

Introduction to COM

Problem/Question/Abstract:

Introduction to COM

Answer:

Introduction

A few months ago, while I was looking for my first house, I spent quite a lot of time with a real estate agent which taught me the three most important elements in business marketing: location, location, location.

Well, in the Component Object Model (COM) this can be translated in integration, integration, integration while location is ideally the last thing you are interested in. Every Windows user deals with COM every day, knowing it or not. COM is used by Microsoft Office when we run the spell check utility, is used by many web sites running IIS and is also used by the underlying operating system for some of its mundane tasks. Many others instead choose COM to build complex, scalable and secure enterprise systems.

Component oriented integration is what COM is all about.

Intergration yesterday

The general meaning of the word integration is "to make into a whole by bringing all parts together; unify". In our field, this can be done in many ways and can be applied to many things: imagine you are developing a word processor application. You will create or inherit a custom memo box for editing purposes, you may include a spell checker and, if you want to get fancy, you may also want to include a set of custom routines that will allow your users to convert the document to HTML or RTF. The integration of all these parts will make your word processor.

Now, imagine that for some reasons, you want to be able to update any of these single elements without redeploying the whole application. You may also want to make those components available to a second application, maybe developed by somebody else in another language. These capabilities are very common today.

Todays applications are much bigger than they used to be few years ago and anything that can help managing this complexity is welcome.

The first approach you may try is using DLLs. Dynamic linking is the ability to bind and invoke executable code at runtime. In that hypothetical word processor, the DLL that includes the conversion routines may export functions such as:

function GetConverters: TConverterList;
  procedure Convert(anID: integer; aDocument, aFileName: string);

TConverter = record
  ID: integer;
  Name, FileExtension, Description: string;
end;

Any time we want to add a converter you'd only have to update the DLL and the word processor would automatically have access to the new functionality. This works fine and you will achieve what your objective. GetConverters returns a custom TList which may have some methods in pure Delphi style that make it very handy and easy to use (a TConverterList). Unfortunately this is not an optimal solution and, worst of all, it doesn't work unless you are using Delphi or Borland C++ Builder... In order to use the result of the function GetConverters pointer as a TConverterList, the client needs to know what a TConverterList is. In order to do this, we need to inject into our client that information but still, even if we do this we'd have a problem with non-Borland compilers. TList is a VCL class. It is not included for instance in Microsoft Visual C++ or Visual Basic. Those developers couldn't benefit in any way from the pointer we return.You could have structured your DLL differently, following for instance the approach of the Windows API EnumWindows which takes a pointer to a call back routine. Another solution could have been exporting more functions. Whichever approach you may chose you'd still be confined in a word of simple data types which is everything but object oriented and, in top of that, the DLL has to be run on the client's computer... COM is one of the technologies that help us to solving some of those issues.

Integration, today

COM has a long story. Officially the acronym COM was born somewhere around 1993. We can trace COM roots back to Windows 3.x where DDE and OLE were used in Microsoft Word and Excel as a sort of rudimentary communication and inter operability glue. Today COM is everywhere on the Windows platform. Small applications such as ICQ, CuteFTP or Allaire HomeSite are accessible through COM. Applications suites such as Microsoft Office are based on it. Windows based enterprise systems leverage COM and Microsoft Transaction Server for business critical operations. If you develop on Windows you will have to face COM sooner or later. The faster you'll do it, the better it will be. This article is about understanding COM and the reasons behind it rather than an providing another how-to tutorial. I will start with the basic principles behind COM and then I provide a concrete example. The first part won't take long but will definitely give you a better understanding of what happens in the example and why that happens. Make sure you download the sample by clicking here. The factors that lead to COM are the followings: Object Oriented language independence Dynamic Linking Location independence.

Object Oriented language independence

The DLL example above had a serious problem: in order for functions to return an object, the client has to know its interface. An interface is a very important concept in both object oriented programming and COM. An interface is the declaration of all the public methods and properties of a class. Without knowing it, that pointer could be anything and the compiler wouldn't know how to find the correct method addresses, the parameters and result types of them, etc. Does COM allow me to return objects without knowing their interface? No, although it may look that way in some cases. The concept of interface is the heart of COM. In order to be language independent, COM defines a binary standard for interface definition and introduces the concept of type libraries. Type libraries are binary files that contain information about a numbers of interfaces (you define how many you want to declare and what you want them to look like). From inside Delphi, open the type library COMConverter.tlb contained in the COMConverter directory. You will see the following window opening:  



This is the Borland type library editor which allows us to look and edit COM type libraries. As you can see, this type library defines the interface IConverterList which contains the properties Count and Items in perfect Delphi style. Delphi knows how to interpret type libraries and through the type libray editor, presents them in a user- friendly fashion. Visual Basic, Borland C++ Builder or Visual C++ do the same. They all agreed to support the COM binary standard and to play according to its rules. Now, from within the type library editor, press F12. Delphi will create a unit named COMConverter_TLB.pas  



Through COM I can define an interface that I am sure other COM enabled languages can understand. Delphi will use that information to generate interfaces that it can understand and use, as we just saw. It's all there and ready to be used now, almost as it was a regular Delphi object. There are some key differences but for now, let's continue with the principles.

Dynamic Linking

Similarly to DLLs, COM allows (and actually only works through) dynamic linking. You can choose to take advantage of this in two ways: early binding or late binding. Before we continue there's an important thing you need to do: register your COM library. Registration is the process through which Windows becomes aware of a COM object and learns how to instantiate it. In order to do this you need to use a special tool called RegSvr32.exe (contained in Windows\System32) or the Borland's equivalent TRegSvr.exe (contained in Program Files\Borland\Delphi5\Bin). Another way of doing it, when you have the Delphi source code, is to open the COM project (in our case COMConverter.dpr) and press Run\Register ActiveX Server. Registering a COM server means inserting special keys into the Windows registry. The information you will store include the name of the DLL or EXE file that hosts your COM object, the identifiers that uniquely identify it (see the yellow on green code above) and a few extra things. If you don't do this Windows won't be able to instantiate your COM object. By continuing our analogy with DLLs, early binding is similar to importing routines from a DLL by using the external directive. When you do that, you embed in your client the definition of those routines and you expect them to match exactly that definition when you connect to them at runtime. If the name, the parameters or the result type is changed, you will have an error as soon as the application starts. Late binding instead is similar to the GetProcAddress API call, where you specify the name of the function you want to connect to using a string and you get back a pointer to it. When you do that, your client runs fine unless you try to use that function passing wrong parameters. Invoking methods of a COM object through early binding is faster than doing it using late binding. Every time you use late binding, you are asking Windows to look for a method called with a certain name, return a pointer to it and then, finally, invoke it. By using early binding you immediately call it, without any additional overhead because you already know where that method's entry point is. On the other side instead, using late binding allows much more flexibility and make things such as scripting possible. This is the content of the file VBTest.vbs contained in the WordProcessor directory:

dim MyObj, i, s

set MyObj = CreateObject("COMConverter.ConverterList")
s = ""
for i = 0 to (MyObj.Count - 1)
  s = s & MyObj.Items(i).Description & ", "

next

msgbox("You can save as " & s)

Double click on it and see what happens. Our ConverterList object will be created and the names of all supported converters will be displayed. All this without Delphi, VB or anything else. This is done using a late bound call to the methods Get_Items and Get_Count. The Active Scripting Engine embedded in Windows (which, by the way is also accessible through COM) took care of parsing the text file and asking to find and invoke them. You can do the same in Delphi too but how do you make sure you are using one instead of the other? It is very easy. The way you can do late binding in Delphi is generally by using OleVariant variables. By using typed variables you are using early binding. This is a snippet of code from the unit fMainForm.pas in the WordProcessor directory:

implementation

uses ComObj;

{$R *.DFM}

procedure TForm1.bLateBindingClick(Sender: TObject);
var
  myobj: OleVariant;
begin
  myobj := CreateOLEObject('COMCOnverter.ConverterList');
  ShowMessage('There are ' + IntToStr(myobj.Count) + ' converters available');
end;

procedure TForm1.bEarlyBindingClick(Sender: TObject);
var
  myobj: IConverterList;
begin
  myobj := CoConverterList.Create;
  ShowMessage('There are ' + IntToStr(myobj.Count) + ' converters available');
end;

As you can see, the only differences between the two are the type of myobj and the instantiation of it. The fact that you declared myobj as an OleVariant is the key here. That tells Delphi how you invoke the methods of a COM object. Anytime you use an OleVariant you can specify any method name. The compiler won't complain. Try putting myobj.XYZ in the first event handler. Delphi will successfully compile it but at runtime will raise an exception as soon as you hit that line of code. Late binding . In the second case you wouldn't be able to compile it, because IConverterList doesn't define have a method called XYZ. Early binding .

Location independence

Not to many years ago the terms "distributed" and "thin client" became very popular. The two terms are often used together when discussing about systems physically split into presentation, business and data storage tiers (multi-tier or 3-tier systems). By physically split I mean that each of those tiers can be running on the same machine or on separate ones. The reasons behind this type or architecture have to do with both a need for cleaner designs and scalability. Since this is not an article about multi tier design, I won't go any deeper in this discussion. In the next articles on COM I will discuss about this topic in detail. The things we said so far showed how COM lets us use objects embedded in DLLs. Wouldn't be nice if, on top of that, those DLLs could be located and actually executed on a more powerful machine? Wouldn't be nice not to have to worry about TCP/IP communication and sockets? Well, this is all possible using distributed COM (DCOM). DCOM is an extension of COM that allows us to do inter process communication across machine boundaries. The real nice thing behind DCOM is that the only thing that changes for the developer is the way you instantiate your COM object. Instead of calling CoCreate you would now call CoCreateRemote() passing either an IP address or the name of the machine that executes the COM object. When you do this, Windows creates an object (proxy) on the client machine that looks exactly like the real object. When you call a method on the proxy, it takes care of delivering your call and the parameters you specified to the other machine where a listener (stub) is waiting. The stub then invokes the real method and packages back the result. All this is done transparently for you. Code wise, the only thing difference for you is to specify CoCreate or CoCreateRemote when creating your COM object.

Conclusion

COM is the ideal technology to develop flexible, expandable and open application on Windows. It defines a standard, object oriented way of exposing functionality and promotes integration between them. By embracing COM you can make your application more open, expandable and controllable (whenever needed) from the outside world. You will get access to a wide set of tools and functionality embedded in your operating system and other applications such as Microsoft Office which will enanche the functionality you can provide. If you need to develop enterprise systems you will be able to leverage your investment in this technology and get access to another set of tools and servers (i.e. Microsoft Transaction Server, BizTalk, Application Center) that won't require a switch in language or approach. If you were not familiar with COM, I hope this article provided some interesting information to get you started. If instead, you are already using COM, I hope it helped you understanding a little better why COM exists and when you can benefit from using it. Understanding the reasons behind a technology instead of jumping immediately into some step- by-step code example is a much more rewarding approach in both short and long run.

What's coming next...

COM is a very large topic. ActiveX, OLE, OLE/DB, ADO, MTS and other acronyms have been created to separate the COM world into smaller, specific areas or categories. COM has to do with networking, security, data storage and many, many other things... Many books have been written on these topics but still COM is considered very complex or obscure. Well, COM is everything but very complex or obscure. It is all about finding the right information at the right time. The key is understanding the whats and whys behind it as in any other technology. In the next articles I will try to get a little more technical and I will go into real code. I will also write other generic articles like this before approaching any of the sub categories mentioned above but I will try to keep a balance between theoretical and practical.

Resources

If you want to read more I recommend the following books:

Understanding COM+, David Platt, Microsoft Press
Inside COM, Dale Rogerson, Microsoft Press
COM and DCOM: Microsoft's Vision for Distributed Objects, Roger Sessions, John Wiley Sons

You may find some more informations online at:

Microsoft's COM pages
Binh Ly's website
Dan Miser's Distribucon site
Deborah Pate's "Rudimentary" home page

How to do an auto-splash screen with progression

Problem/Question/Abstract:

A convenience forms auto-creation while showing progression on application start.

Answer:

{
///////////////////////////////////////////////////////////////////////////////
                            Auto splash form class
///////////////////////////////////////////////////////////////////////////////
USE : Replace the Delphi standard form creation (Application.CreateForm) by

      with TfmToolsAutoSplash.Create(nil) do
        try
          Add('Data Module', TdmMain, dmMain, 100);
          Add('Main Form',   TfmMain, fmMain, 100);
          Add('Log',         TfmLog,  fmLog,  100);
          Execute;
        finally
          Free;
        end;
///////////////////////////////////////////////////////////////////////////////
}

unit F_TOOLS_AutoSplash;

// ############################################################################

interface

uses
  Forms, Controls, StdCtrls, Classes, ExtCtrls, ComCtrls;

const
  SPLASH_STEP_CAPTION: string = 'Creating : ';
  SPLASH_INITIALIZATION_CAPTION: string = 'Initialization...';
  SPLASH_FINALISATION_CAPTION: string = 'Finalization...';

type
  TfmToolsAutoSplash = class(TForm)
    pn1: TPanel;
    pn2: TPanel;
    pn3: TPanel;
    lbTitle: TLabel;
    lbVersion: TLabel;
    lbCopyright: TLabel;
    lbStep: TLabel;
    prgbStep: TProgressBar;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    FFormsList: TCollection;
  protected
    procedure DoStep(ALabel: string; ADelay: integer); virtual;
  public
    procedure Clear;
    procedure Add(Caption: string; FormClass: TComponentClass; var Ref; Delay: integer
      = 250);
    procedure Execute;
  end;

  // ############################################################################

implementation

uses
  Windows, SysUtils, Dialogs;

{$R *.DFM}

type
  TSplashFormPtr = ^TForm;

  TSplashFormAllocItem = class(TCollectionItem)
  protected
    Text: string;
    InstanceClass: TComponentClass;
    Reference: TSplashFormPtr;
    Tempo: integer;
  end;

  //----------------------------------------------------------------------
  // TfmToolsAutoSplash.FormCreate
  //----------------------------------------------------------------------

procedure TfmToolsAutoSplash.FormCreate(Sender: TObject);
begin
  FFormsList := TCollection.Create(TSplashFormAllocItem);
end;

//----------------------------------------------------------------------
// TfmToolsAutoSplash.FormDestroy
//----------------------------------------------------------------------

procedure TfmToolsAutoSplash.FormDestroy(Sender: TObject);
begin
  FFormsList.Free;
end;

//----------------------------------------------------------------------
// TfmToolsAutoSplash.Clear
//----------------------------------------------------------------------

procedure TfmToolsAutoSplash.Clear;
begin
  FFormsList.Clear;
end;

//----------------------------------------------------------------------
// TfmToolsAutoSplash.Add
//----------------------------------------------------------------------
// SPEC : Add a form in the list.
// IN   : Caption     -> Title, if '' then use classname
//        FormClass   -> Class
//        Ref         -> Reference
//        Delay -> Delay
//----------------------------------------------------------------------

procedure TfmToolsAutoSplash.Add(Caption: string; FormClass: TComponentClass; var Ref;
  Delay: integer);
begin
  with (FFormsList.Add as TSplashFormAllocItem) do
  begin
    case (Caption = '') of
      True: Text := SPLASH_STEP_CAPTION + FormClass.ClassName;
      False: Text := SPLASH_STEP_CAPTION + Caption;
    end;
    InstanceClass := FormClass;
    Reference := @TForm(Ref);
    Tempo := Delay;
  end;
end;

//----------------------------------------------------------------------
// TfmToolsAutoSplash.DoStep
//----------------------------------------------------------------------

procedure TfmToolsAutoSplash.DoStep(ALabel: string; ADelay: integer);
begin
  prgbStep.StepIt;
  lbStep.Caption := ALabel;
  Refresh;
  Sleep(ADelay);
end;

//----------------------------------------------------------------------
// TfmToolsAutoSplash.Execute
//----------------------------------------------------------------------
// SPEC : Lance la cr�ation des feuilles.
//----------------------------------------------------------------------

procedure TfmToolsAutoSplash.Execute;
var
  i: integer;
begin
  prgbStep.Max := FFormsList.Count + 2;
  Show;
  DoStep(SPLASH_INITIALIZATION_CAPTION, 2);
  for i := 0 to FFormsList.Count - 1 do
    with (FFormsList.Items[i] as TSplashFormAllocItem) do
    begin
      DoStep(Text, Tempo);
      if (not Application.Terminated) then
        Application.CreateForm(InstanceClass, Reference^);
    end;
  DoStep(SPLASH_FINALISATION_CAPTION, 2);
end;

end.

How to reduce the window and GDI handles an application is using

Problem/Question/Abstract:

I am trying to reduce the resources required to run my application. My application was pulling available resources down to 44%. I moved a large section of code containing two graphs out of an "available" form that does not get dynamically created and freed, into a separate form that is called with application.formcreate() and then freed after use.

Answer:

Resources (the ones you can run out of in win9x) are things like window handles, menu handles, bitmap handles, handles of GDI objects like fonts, brushes, pens. These are not correlated with memory use or code size at all. All of these handles are used by Windows internally to reference some data structures for these objects (they are a kind of indirect pointer). The data structures are used by the 16 bit code that still makes up the core of Win9x/Me and come from a restricted pool of memory, a set of 64KByte memory blocks that are not extensible (the infamous USER and GDI heaps, USER and GDI are two of the core Windows modules).

The way to deal with resource-shortages is to reduce the number of window and GDI handles your app is using at any time. And the recipes for that are:

Do not autocreate your forms, with the exception of the main form. All other forms (at least the ones only used modally) should be created as needed and destroyed when no longer needed. Note that calling Close on a form will NOT destroy the forms memory image (and control handles), by default it only hides the form. For modeless forms you need a handler for the OnClose event of the form that sets the Action parameter to cafree. For modal forms you manually call the Free method of the form after the ShowModal call returned.
Try to replace controls that use Window handles with TGraphicControl descendents, e.g. TPanels and TGroupBoxes by TBevels. TGraphicControls do not use window handles, TWinControls do. Some, like TCombobox, even use more than one window handle.
If you use tabbed notebooks or pagecontrols a lot you can save resources by destroying the window handles of controls on hidden pages of the notebook, using the controls DestroyHandle method.
Replace groups of TEdit controls with a TStringGrid. A grid uses only two window handles, regardless how many cells it has.