Writing wave files to disk

Problem/Question/Abstract:

How do i write a wave file?

Answer:

type
  TPCMWaveHeader = record
    rID: array[0..3] of char; { 'RIFF' Identifier }
    rLen: longint;
    wID: array[0..3] of char; { 'WAVE' Identifier }
    fId: array[0..3] of char; { 'fmt ' Identifier }
    fLen: longint; { Fixed, must be 16 }
    wFormatTag: word; { Fixed, must be 1 }
    nChannels: word; { Mono=1, Stereo=2 }
    nSamplesPerSec: longint; { SampleRate in Hertz }
    nAvgBytesPerSec: longint;
    nBlockAlign: word;
    nBitsPerSample: word; { Resolution, e.g. 8 or 16 }
    dId: array[0..3] of char; { 'data' Identifier }
    dLen: longint; { Number of following data bytes }
  end;

procedure WritePCMWaveFile(Filename: string; Resolution, Channels, Samplerate,
  Samples: integer; Data: Pointer);
var
  h: TPCMWaveHeader;
  f: file;
  databytes: integer;
begin
  DataBytes := Samples;
  DataBytes := DataBytes * Channels; { double if stereo }
  DataBytes := DataBytes * (Resolution div 8); { double if 16 Bit }

  FillChar(h, SizeOf(TPCMWaveHeader), #0);
  with h do
  begin
    rID[0] := 'R';
    rID[1] := 'I';
    rID[2] := 'F';
    rID[3] := 'F'; { 1st identifier }
    rLen := DataBytes + 36;
    wID[0] := 'W';
    wID[1] := 'A';
    wID[2] := 'V';
    wID[3] := 'E'; { 2nd identifier }
    fId[0] := 'f';
    fId[1] := 'm';
    fId[2] := 't';
    fID[3] := Chr($20); { 3rdidentifier ends with a space character }
    fLen := $10; { Fixed, must be 16 }
    wFormatTag := 1; { Fixed, must be 1 }
    nChannels := Channels; { Channels }
    nSamplesPerSec := SampleRate; { Sample rate in Hertz }
    nAvgBytesPerSec := SampleRate * Channels * trunc(Resolution div 8);
    nBlockAlign := Channels * (Resolution div 8); { Byte order, see below }
    nBitsPerSample := Resolution;
    dId[0] := 'd';
    dId[1] := 'a';
    dId[2] := 't';
    dId[3] := 'a'; { Data identifier }
    dLen := DataBytes; { number of following data bytes }
  end;
  AssignFile(f, filename);
  ReWrite(f, 1);
  BlockWrite(f, h, SizeOf(h));
  BlockWrite(f, pbytearray(data), databytes);
  CloseFile(f);
  { The rest of the file is the wave data. Order is low-high for left channel,
      low-high for right channel, and so on.
      For mono or 8 bit files make the respective changes. }
end;

How to retrieve the version stamp of a file

Problem/Question/Abstract:

How do you retrieve the version stamp of a file? I'm getting real tired of setting versions in the Delphi Project | Options dialog box and then defining a (redundant) constant for use in my Help | About boxes !

Answer:

Solve 1:

procedure TfrmSplash.GetBuildInfo(var v1, v2, v3, v4: Word);
var
  VerInfoSize: DWord;
  VerInfo: Pointer;
  VerValueSize: DWord;
  VerValue: PVSFixedFileInfo;
  Dummy: DWord;
begin
  VerInfoSize := GetFileVersionInfoSize(PChar(Application.ExeName), dummy);
  GetMem(VerInfo, VerInfoSize);
  GetFileVersionInfo(PChar(Application.ExeName), 0, VerInfoSize, VerInfo);
  VerQueryValue(VerInfo, '\', Pointer(VerValue), VerValueSize);
  with VerValue^ do
  begin
    v1 := dwFileVersionMS shr 16;
    v2 := dwFileVersionMS and $FFFF;
    v3 := dwFileVersionLS shr 16;
    v4 := dwFileVersionLS and $FFFF;
  end;
  FreeMem(VerInfo, VerInfoSize);
end;

function TfrmSplash.GetBuildInfoString: string;
var
  v1, v2, v3, v4: Word;
begin
  GetBuildInfo(v1, v2, v3, v4);
  Result := Format('%d.%d.%d  (Build %d)', [v1, v2, v3, v4]);
end;


Solve 2:

This function should do it.

uses
  Windows, SysUtils, { ... };

function GetFileVersion(const Filename: string): string;
var
  VerInfSize, Sz: Cardinal;
  VerInfo: Pointer;
  FxFileInfo: PVSFixedFileInfo;

  function MSLSToString(MS, LS: DWORD): string;
  begin
    Result := Format('%d.%d.%d.%d', [MS shr 16, MS and $FFFF, LS shr 16, LS and
      $FFFF]);
  end;

begin
  Result := '';
  if FileExists(Filename) then
  begin
    VerInfSize := GetFileVersionInfoSize(PCHAR(Filename), Sz);
    if VerInfSize > 0 then
    begin
      VerInfo := Allocmem(VerInfSize);
      try
        GetFileVersionInfo(PCHAR(Filename), 0, VerInfSize, VerInfo);
        VerQueryValue(VerInfo, '\\', POINTER(FxFileInfo), Sz);
        if Sz > 0 then
          Result := MSLSToString(FxFileInfo^.dwFileVersionMS,
            FxFileInfo^.dwFileVersionLS);
      finally
        FreeMem(VerInfo);
      end;
    end;
  end;
end;


Solve 3:

type
  TFileVersionInfo = record
    fCompanyName,
      fFileDescription,
      fFileVersion,
      fInternalName,
      fLegalCopyRight,
      fLegalTradeMark,
      fOriginalFileName,
      fProductName,
      fProductVersion,
      fComments: string;
  end;

var
  FileVersionInfo: TFileVersionInfo

procedure GetAllFileVersionInfo(FileName: string);
{ proc to get all version info from a file. }
var
  Buf: PChar;
  fInfoSize: DWord;

  procedure InitVersion;
  var
    FileNamePtr: PChar;
  begin
    with FileVersionInfo do
    begin
      FileNamePtr := PChar(FileName);
      fInfoSize := GetFileVersionInfoSize(FileNamePtr, fInfoSize);
      if fInfoSize > 0 then
      begin
        ReAllocMem(Buf, fInfoSize);
        GetFileVersionInfo(FileNamePtr, 0, fInfoSize, Buf);
      end;
    end;
  end;

  function GetVersion(What: string): string;
  var
    tmpVersion: string;
    Len: Dword;
    Value: PChar;
  begin
    Result := 'Not defined';
    if fInfoSize > 0 then
    begin
      SetLength(tmpVersion, 200);
      Value := @tmpVersion;
      { If you are not using an English OS, then replace the language and
                        codepage identifier with the correct one. English (U.S.) is 0409 (language)
                        and 04E4 (codepage). See CodePage Identifiers and Language Identifiers in
                        the Win32 help file for info. }
      if VerQueryValue(Buf, PChar('StringFileInfo\040904E4\' + What), Pointer(Value),
        Len) then
        Result := Value;
    end;
  end;

begin
  Buf := nil;
  with FileVersionInfo do
  begin
    InitVersion;
    fCompanyName := GetVersion('CompanyName');
    fFileDescription := GetVersion('FileDescription');
    fFileVersion := GetVersion('FileVersion');
    fInternalName := GetVersion('InternalName');
    fLegalCopyRight := GetVersion('LegalCopyRight');
    fLegalTradeMark := GetVersion('LegalTradeMark');
    fOriginalFileName := GetVersion('OriginalFileName');
    fProductName := GetVersion('ProductName');
    fProductVersion := GetVersion('ProductVersion');
    fComments := GetVersion('Comments');
  end;
  if Buf <> nil then
    FreeMem(Buf);
end;

To use it just call it like

GetAllFileVersionInfo(ParamStr(0));


Solve 4:

Call GetVersionDetails and specify the filename.

{ ... }

type
  pTransArrar = ^TTransArrar;
  TTransArrar = record
    wLanugageID: Word;
    wCharacterSet: Word;
  end;

function DecodeTranslationInfo(Buffer: TTransArrar): string;
begin
  Result := IntToHex(Buffer.wLanugageID, 4) + IntToHex(Buffer.wCharacterSet, 4);
end;

function GetVersionDetails(Filename: string; const LookupString: string =
  'FileVersion'): string;
var
  ID: DWord;
  iStructSize: DWord;
  p: PChar;
  pbuf: Pointer;
  plen: DWord;
  ResponseString: string;
begin
  {get the size of the fileinfo structure}
  iStructSize := GetFileVersionInfoSize(PChar(Filename), ID);
  {allocate memory to hold file info data structure}
  p := stralloc(iStructSize);
  {retrieve file version details}
  ResponseString := '';
  if GetFileVersionInfo(PChar(Filename), 0, istructSize, p) then
  begin
    if VerQueryValue(p, pchar('\VarFileInfo\Translation'), pbuf, plen) then
    begin
      if VerQueryValue(p, pchar('\StringFileInfo\' +
        DecodeTranslationInfo(pTransArrar(pbuf)^)
        + '\' + LookupString), pbuf, plen) then
        ResponseString := PChar(pbuf);
    end;
  end;
  strdispose(p);
  Result := ResponseString;
end;


Solve 5:

This functions returns the version as a string.

function GetFileVersion(FileName: string): string;
var
  ResourceSize: Integer;
  ResourceBuffer: PChar;
  GetData: Boolean;
  Ignore: THandle;
  InfoPtr: Pointer;
  VerSize: Cardinal;
  FileInfo: VS_FIXEDFILEINFO;
  Major, Minor, Rleas, Build, Hex: string;
begin
  ResourceSize := GetFileVersionInfoSize(PChar(FileName), Ignore);
  if ResourceSize > 0 then
  begin
    {You need to allocate the ResourceBuffer before you can fillchar it}
    GetMem(ResourceBuffer, ResourceSize);
    GetData := GetFileVersionInfo(PChar(FileName), Ignore, ResourceSize,
      ResourceBuffer);
    if GetData then
    begin
      GetData := VerQueryValue(ResourceBuffer, '\', InfoPtr, VerSize);
      if GetData then
      begin
        Move(InfoPtr^, FileInfo, sizeof(VS_FIXEDFILEINFO));
        Hex := IntToHex(FileInfo.dwFileVersionMS, 8) +
          IntToHex(FileInfo.dwFileVersionLS, 8);
        Major := '$' + Copy(Hex, 1, 4);
        Minor := '$' + Copy(Hex, 5, 4);
        Rleas := '$' + Copy(Hex, 9, 4);
        Build := '$' + Copy(Hex, 13, 4);
        Result := IntToStr(StrToInt(Major)) + '.' + IntToStr(StrToInt(Minor)) + '.'
          + IntToStr(StrToInt(Rleas)) + '.' + IntToStr(StrToInt(Build));
      end
      else
      begin
        Result := '';
      end;
    end
    else
    begin
      Result := '';
    end;
    {need this because you allocated it up above}
    FreeMem(ResourceBuffer);
  end
  else
  begin
    Result := '';
  end;
end;

Runtime errors during loading of an application

Problem/Question/Abstract:

A short detective story of strange runtime errors in Delphi

Answer:

The Crime

&#8220;It was a nice day when if happened. Everything worked fine. I just had to replace one 3rd-party component. Everything compiled with the new version. The problem started when I tried to run the application with the new components. When the application started, it shot-out a fatal runtime error 217, no matter what I did. Compiling the application with or without runtime packages had no affect, nor did including or excluding debug info. Whatever I did, I got the same message.&#8221;

The Plot Thickens

The first thing I did was to check what is runtime error 217. Guess what &#8211; in Delphi help, it is written &#8220;EControlC is the exception class for Ctrl+C key presses in console applications.&#8221;
Well, this explanation does not provide any help, for a number of reasons:

The application is not a console application, but a GUI application.
Who the hell did press Ctrl+C ???

The investigation

First, I tried to place a break point in the dpr file.

The code is:

begin
  Application.Initialize;
  Application.CreateForm(TfrmMain, frmMain);
  Application.CreateForm(TdmReoprtObj, dmReoprtObj);
  Application.Run;
end.

When I placed the break point on the &#8220;Begin&#8221; line, the application reached that line.
When I placed the break point on the next line &#8211; &#8220;Application.Initialize&#8221;, the application did not reach that line.

Second, I tried to compile the application without runtime packages, with the hope that Delphi will point me to the offensive code, like Delphi does most of the time. This time was one of those times Delphi decided not to help. I had to find the problem my self.

Third, after some consultations, we (I and other code &#8216;detectives&#8217;) decided to go to broth force. We paced breakpoints everywhere - In the start of every initialization section in any unit. Here we found the problem.

When I replaced the 3rd-party component, the new version added a new class to the game, lets call it TOffecsiveClass. The 3rd-party component also registered the class:

RegisterClasses([TOffecsiveClass]);

In my code, we had another class, named also TOffecsiveClass, that was registered using the same function.
The result was that we registered the same class twice, there for getting an exception in the initialization section of a unit.

Conclusion

Runtime error 217 is not a Ctrl+C console application error.
If you have an exception in the initialization or finalization sections of a unit, don&#8217;t expect to get a nice message. Most likely, you&#8217;ll get a runtime error (216 or 217).
If you get runtime errors during the loading of the application, or during the shutdown of it, check the initialization and finalization sections.

How to select a sound card for the TMediaPlayer when two sound cards are installed

Problem/Question/Abstract:

How to select a sound card for the TMediaPlayer when two sound cards are installed

Answer:

procedure send(name: string; out: integer; );
var
  lpset: MCI_WAVE_SET_PARMS;
begin
  with MediaPlayer1 do
  begin
    try
      filename := name;
      Open;
      lpset.wOutput := out; {number of the sound card. zero through number of outputs-1}
      mciSendCommand(DeviceID, MCI_SET, MCI_WAVE_OUTPUT, longint(@lpset));
      Play;
    except
      on EMCIDeviceError do
        statusbar := '[OUTPUT FAILED]:' + IntToStr(out);
    else
      ShowMessage(Exception(ExceptObject).Message);
    end;
  end;
end;


Note that for MIDI files the right command to pass to MCI is related to the sequencer port, not to the wave port, so the following adjustments have to be made:


var
  lpset: MCI_SEQ_SET_PARMS;

  {number of the sound card. zero thru number of outputs-1}
  lpset.dwPort := mydeviceid;
  mciSendCommand(DeviceID, MCI_SET, MCI_SEQ_SET_PORT, longint(@lpset));

Something missing about packages

Problem/Question/Abstract:

Packages are a great feature of Delphi. You can put not only components into packages but also everything you want. This way you can build modular, customizable applications.
Many programmers do not use packages because they modify VCL units and they do not have VCL packages source code in order to rebuild them.

Answer:

Introduction

Packages are a great feature of Delphi. You can put not only components into packages but also everything you want. This way you can build modular, customizable applications.
Many programmers do not use packages because they modify VCL units and they do not have VCL packages source code in order to rebuild them.
In this article you will find instructions for using packages anytime, anywhere.

How do packages work

By default, when you compile your project every VCL unit required by your project is compiled into the generated .EXE file. This way a simple Delphi project has at least 300 KB. If you modify one line of one unit then you need to recompile the entire project. These kinds of applications are difficult to modularize. If you have more than one application running on the same computer then you are consuming more RAM than you need.
If you select Project | Options and go to the Packages tab you can instruct Delphi to use Runtime packages.
This way the .EXE file size decrease because the VCL units are not compiled into it. Using runtime packages VCL units are kept into VCL packages and you need to distribute them with your .EXE file. VCL packages have the .BPL extension and they are a special kind of dynamic link libraries (DLL). Delphi installs .BPL files in Windows\System32 directory.
When you use runtime packages Delphi uses .DCP files to build the .EXE file. These .DCP files are to .DPK files (packages source code) what .DCU files are to .PAS files. When you build a package Delphi puts all the .DCU files into a single .DCP file. Then, when you compile a project that uses runtime packages Delphi uses the .DCP files instead of .PAS or .DCU files. So, what happened if you modify, for example, ActnList.pas. If you want to use runtime packages then you need to rebuild VCL package, which includes this unit. And because VCL package is required by almost all the other VCL packages, then you need to rebuild them all.

How can you rebuild all the VCL packages?

Delphi includes a package for user components. The name of this package is dlcusr.dpk and it is located in the Delphi\Lib directory. Open it. In the package editor you can see the Contains and Requires clauses. Select the Requires clause and if there is not any package do the following:

Click the Add button.
Type vcl.dcp in the package name edit control in the Add dialog box
Click the OK button.

Now select the vcl.dcp package or any other VCL package and right click on it. From the popup menu select Open.
The VCL package is generated and now you can build it. Because this is a generated package you need to save it with a different name. Now you can build your project using the new generated package.

Your own VCL packages

Delphi packages were built according to Delphi needs. Your application's needs could be different. Maybe you need different packages. VCL.BPL is a big file (1.3 MB or so). With this trick now you know in which package each unit lives. So you can create your own VCL packages containing only the VCL units your project use.

Determine if a file is in use

Problem/Question/Abstract:

I want to do some manipulation in a file and was wondering if there was a function, say IsFileInUse(filename), which will return true if another application/ process is accessing the file at that moment. I need to be able to delete the file and exchange it with another one.

Answer:

Solve 1:

function IsFileInUse(path: string): Boolean;
var
  f: file;
  r: integer;
begin
  r := -1;
  system.AssignFile(f, path);
{$I-}
  reset(f);
{$I+}
  r := ioresult; {sm(ns(r));}
  {5 = access denied}
  if (r = 32) or (r = 5) then
    result := true
  else
    result := false;
  if r = 0 then
    system.close(f);
end;

Solve 2:

A few days ago I was asked how to tell if a given file is already being used by another application. Finding out if a file, given its name, is in use (open), is pretty simple. The process consists in trying to open the file for Exclusive Read/Write access. If the file is already in use, it will be locked (by the calling process) for exclusive access, and the call will fail.

Please note that some application do not lock the file when using it. One clear example of this is NOTEPAD. If you open a TXT file in Notepad, the file will not be locked, so the function below will report the file as not being in use.

The function below, IsFileInUse will return true if the file is locked for exclusive access. As it uses CreateFile, it would also fail if the file doesn't exists. In my opinion, a file that doesn't exist is a file that is not in use. That's why I added the FileExists call in the function. Anyway, here's the function:

function IsFileInUse(fName: string): boolean;
var
  HFileRes: HFILE;
begin
  Result := false;
  if not FileExists(fName) then
    exit;
  HFileRes := CreateFile(pchar(fName), GENERIC_READ or GENERIC_WRITE,
    0 {this is the trick!}, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);
  Result := (HFileRes = INVALID_HANDLE_VALUE);
  if not Result then
    CloseHandle(HFileRes);
end;
  
NOTE: The function will return false if the specified file doesn't exist, meaning that it is not in use and can be used for something else.

Download file via HTTP and load in memo

Problem/Question/Abstract:

Download file via HTTP and load in memo

Answer:

This tip is based on you using NMHTTP component (FastNet).

var
  HTTP: TNMHTTP;
begin
  HTTP := TNMHTTP.Create(nil);
  HTTP.Get('http://www.somesite.com/news.htm');
  Memo1.Lines := HTTP.Body;
  HTTP.Free;
end;

Read or write in the summary information of an Office document

Problem/Question/Abstract:

How read or write in the summary information of an Offiche document ?

Answer:

An Office document file is a structured storage file that an application can read with the StgOpenStorage function from the Windows API. This kind of file is made of storages and streams.
COM defines a standard common property set for storing summary information about document. This information is stored in a stream under the root storage. The following function shows how you can get the author property by giving a filename :

uses ActiveX, ComObj, SysUtils;

function GetSummaryInfAuthor(FileName: TFileName): string;
var
  PFileName: PWideChar;
  Storage: IStorage;
  PropSetStg: IPropertySetStorage;
  PropStg: IPropertyStorage;
  ps: PROPSPEC;
  pv: PROPVARIANT;
const
  FMTID_SummaryInformation: TGUID = '{F29F85E0-4FF9-1068-AB91-08002B27B3D9}';
begin
  PFileName := StringToOleStr(FileName);
  try
    // Open compound storage
    OleCheck(StgOpenStorage(PFileName, nil, STGM_DIRECT or STGM_READ or
      STGM_SHARE_EXCLUSIVE, nil, 0, Storage));
  finally
    SysFreeString(PFileName);
  end;

  // Summary information is in a stream under the root storage
  PropSetStg := Storage as IPropertySetStorage;
  // Get the IPropertyStorage
  OleCheck(PropSetStg.Open(FMTID_SummaryInformation, STGM_DIRECT or STGM_READ or
    STGM_SHARE_EXCLUSIVE, PropStg));

  // We want the author property value
  ps.ulKind := PRSPEC_PROPID;
  ps.propid := PIDSI_AUTHOR;

  // Read this property
  PropStg.ReadMultiple(1, @ps, @pv);

  Result := pv.pszVal;
end;

See http://msdn.microsoft.com/library/default.asp?url=/library/en-us/com/stgasstg_7agk.asp for more information about the Summary Information Property Set.

Get the text in a TDBGrid cell before focus is moved to another cell

Problem/Question/Abstract:

How can I get the text in a cell (for TDBGrid) as the user types, but before focus is moved from that cell?

Answer:

Solve 1:

{ ... }
type
  {To access TCustomGrid.InplaceEditor declared as protected}
  TMyGrid = class(TDBGrid);

procedure TForm1.DBGrid1KeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
  with TMyGrid(DBGrid1) do
    if EditorMode then
      Label1.Caption := InplaceEditor.Text;
end;


Solve 2:

My solution is very similar to Solve 1 but avoids the need for a subclass. You may prefer to have the action take place in KeyDown or KeyPress but these events generate problems when you start to edit a cell i.e. handling backspace or delete (where was the caret). For this reason it is a lot less hassle to deal with KeyUp, with this event the Editor content has been established by the time it fires. DBGrid1.Controls[0] is the InplaceEditor and below I check for its existence before trying to use it. As it is, it does not handle pasted text. You might do this by trapping WM_PASTE then testing if the Grid (not the InplaceEditor) is the ActiveControl.

procedure TForm1.DBGrid1KeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
  if DBGrid1.ControlCount > 0 then
    Edit1.Text := TEdit(DBGrid1.Controls[0]).Text;
end;

Not select an item in a TListView

Problem/Question/Abstract:

I have a TListView which contains sequential items which may be grouped together. Users can create a group by left-clicking and dragging the mouse over a series of items. These items are regular, multiselected, highlighted (default) blue items. The user can then right-click to bring up a menu, and select Create Group. Grouped items show up in various colors, and the Data portion of the Item describes the group. I would like users to be able to edit the properties of a group by right-clicking on an item within the group to bring up a menu, then selecting Edit Group. However, whenever I right-click the listview, it highlights the item underneath the cursor, and the Create Group menu selections are enabled. Is there a way to 'turn off' the right-select? Groups are allowed to overlap, so I can't just check to see if the Item underneath is part of a group.

Answer:

You can make a listview descendent that handles the right mouse button differently.

type
  TExlistview = class(TListview)
  private
    procedure WMRButtonDown(var msg: TWMRButtonDown); message WM_RBUTTONDOWN;
    procedure WMRButtonUp(var msg: TWMRButtonUp); message WM_RBUTTONUP;
  end;

procedure TExlistview.WMRButtonDown(var msg: TWMRButtonDown);
begin
  MouseDown(mbRight, KeysToShiftState(msg.Keys), msg.XPos, msg.YPos);
end;

procedure TExlistview.WMRButtonUp(var msg: TWMRButtonUp);
begin
  MouseUp(mbRight, KeysToShiftState(msg.Keys), msg.XPos, msg.YPos);
end;

This will still fire the mouse events for the right button but do nothing of the default processing, like right select or popping up the popup menu. If you still want the menu to pop use:

procedure TExListview.WMRButtonUp(var msg: TWMRButtonUp);

  function SmallpointToScreen(const pt: TSmallpoint): Longint;
  var
    lp: TPoint;
  begin
    lp := ClientToScreen(SmallpointToPoint(pt));
    Result := LongInt(PointToSmallpoint(lp));
  end;

begin
  MouseUp(mbRight, KeysToShiftState(msg.Keys), msg.XPos, msg.YPos);
  Perform(WM_CONTEXTMENU, handle, SmallpointToScreen(msg.Pos));
end;

How to copy a bitmap, picture or metafile from the clipboard?

Problem/Question/Abstract:

How to copy a bitmap, picture or metafile from the clipboard?

Answer:

var
  bmp: TBitmap;
  pic: TPicture;

begin
  bmp := TBitmap.Create;

  // PICTURE OR METAFILE
  if (ClipBoard.HasFormat(CF_PICTURE)) or
    (ClipBoard.HasFormat(CF_METAFILEPICT)) then
  begin
    pic := TPicture.Create;
    pic.Assign(ClipBoard);
    X := pic.Width;
    Y := pic.Height;
    bmp.Width := X;
    bmp.Height := Y;
    bmp.Canvas.Draw(0, 0, pic.Graphic);
    pic.Free;
  end;

  // BITMAP
  if (ClipBoard.HasFormat(CF_BITMAP)) then
  begin
    bmp.Assign(ClipBoard);
  end;
  // Bitmap, picture or metafile is now in bmp
  // When used free bmp!
end;

videocard detection

Problem/Question/Abstract:

This code shows how to detect your videocard (tested on win98 & win2k)

Answer:

First form has a button create another form with a memo

procedure TForm1.button1click(Sender: TObject);
var
  lpDisplayDevice: TDisplayDevice;
  dwFlags: DWORD;
  cc: DWORD;
begin
  form2.memo1.Clear;
  lpDisplayDevice.cb := sizeof(lpDisplayDevice);
  dwFlags := 0;
  cc := 0;
  while EnumDisplayDevices(nil, cc, lpDisplayDevice, dwFlags) do
  begin
    Inc(cc);
    form2.memo1.lines.add(lpDisplayDevice.DeviceString);
      {there is also additional information in lpDisplayDevice}
    form2.show;
  end;
end;

Prevent the BDE from loosing information

Problem/Question/Abstract:

How do I prevent the BDE from loosing information in an application when the PC locks up.

Answer:

Solve 1:

Use the BDE API call DBISavechanges(handle). This will save all data in buffers directly to the database thus preventing a loss of data should anything go wrong in the current database session.

Example

Add BDE to the forms uses clause

procedure TDataform.qryEmployeeAfterPost(DataSet: TDataSet);
begin
  DBISavechanges(qryEmployee.handle);
end;


Solve 2:

unit bdeCommands;
{..
...
..
...}
uses BDE;
{...
... }

function SaveBufferToFile(Dataset: TDataset): Boolean;
begin
  Result := BDESaveChanges(Dataset);
end;

How to get detailed information about the Windows taskbar programmatically

Problem/Question/Abstract:

I'm trying to determine the edge and rectangle of the Windows taskbar, using the SHAppBarMessage API - but how do I get the Windows taskbar handle?

Answer:

I put a procedure together that gets all the information one would want to get about the TaskBar: Pos (Rect), Edge, window handle, and whether it's set to be AutoHide or AlwaysOnTop. I got the parameter and return information by following the parameter value entries within the Win32 Programmers' reference Online Help file. I also used a 1 second timer to fire the ButtonClick, so that I could test dragging and resizing the TaskBar. I'm not sure if the "Edge section" of code (ABM_GETAUTOHIDEBAR) will work properly if there are other AppBars on the system.

procedure GetTaskBarData(var AppBarInfo: TAppBarData; var AutoHide, AlwaysOnTop:
  boolean);
var
  i, RetVal: Cardinal;
begin
  fillchar(AppBarInfo, sizeof(AppBarInfo), 0);
  AppBarInfo.cbSize := sizeof(AppBarInfo);
  RetVal := ShAppBarMessage(ABM_GETSTATE, AppBarInfo);
  AutoHide := RetVal and ABS_AUTOHIDE > 0;
  AlwaysOnTop := RetVal and ABS_ALWAYSONTOP > 0;
  for i := 0 to 3 do
  begin {ask all the edges}
    AppBarInfo.uEdge := i; {then drop the Taskbar Handle into AppBarInfo}
    AppBarInfo.hWnd := ShAppBarMessage(ABM_GETAUTOHIDEBAR, AppBarInfo);
    if AppBarInfo.hWnd <> 0 then
      break;
    {the Taskbar's edge value is left in uEdge by the break}
  end;
  SHAppBarMessage(ABM_GETTASKBARPOS, AppBarInfo);
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  ABI: TAppBarData;
  AHide, AlOnTop: Boolean;
  s: string;
begin
  GetTaskBarData(ABI, AHide, AlOnTop);
  with ABI do
  begin
    caption := format('%d %d %d %d', [rc.left, rc.top, rc.right, rc.bottom]);
    case uEdge of
      ABE_BOTTOM: s := 'Bottom';
      ABE_LEFT: s := 'Left';
      ABE_RIGHT: s := 'Right';
      ABE_TOP: S := 'Top';
    end;
    if AHide then
      s := s + ' AutoHide';
    if AlOnTop then
      s := s + ' AlwaysOnTop';
    caption := caption + ' ' + s;
  end;
end;

Call another form and return multiple values

Problem/Question/Abstract:

I have a main form that will call a second form to use for searching on different criteria. How can I return multiple values retrieved in the second form to the main form?

Answer:

Solve 1:

Well, you need to add the second forms Unit to the first ones Uses clause, so you can call up the form. This gives you access to the forms controls and methods. It is usually bad design to access the forms controls from outside, since this tightly couples the outside code to the form. Any change you make to the form may require a change to the code accessing the form. So decouple them. One way to do that is to add properties (public section of the form) for each data item you may need to access from outside. This way the form controls how the data is fetched from the controls or internal fields of the form, usually via Set and Get methods for the properties. The form is then used like this (assuming it is not autocreated):

with TSearchform.create(application) do
try
  {... assign start values to the forms properties here, if required}
  if ShowModal = mrOK then
  begin
    {... read values from the form properties here}
  end
  else
    {... user aborted, take appropriate action}
finally
  free;
end;

This can be taken a step further to avoid the necessity for public properties in the first place (which exposes a kind of working contract to the outside world, which may reveal too much about the form or limit how you could modify it later too much). For that you create a non-visible class, derived from TPersistent, which holds the data items you need to transfer in and out of the form. The form is given overriden Assign and Assignto methods, which, when fed an instance of this data container, will copy the data between the form and the data container. Now all knowledge of how the forms handles the data is internal to the form, all the outside world needs to know is that it can assign a data container to it and vice versa:

datacontainer := TDataContainer.Create;
{... set up datacontainers data to fed into the form}
searchform := TSearchform.create(application);
try
  searchform.Assign(datacontainer);
  if searchform.ShowModal = mrOK then
    datacontainer.Assign(searchform)
  else
    {... user aborted, take appropriate action}
finally
  searchform.free
end;
{... use datacontainer if user entered data and free it when done}

The TDatacontainer class would reside in its own Unit, which is used by both form units.


Solve 2:

You have a variety of options:

1. Use "var" parameters:

procedure TForm2.DoSomething(var Return1, Return2, Return3: Integer);
begin
  Return1 := 1;
  Return2 := 2;
  Return3 := 3;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  X, Y, Z: Integer;
begin
  Form2.DoSomething(X, Y, Z);
  ShowMessage(IntToStr(X));
end;

2. Declare a record which aggregates your return values:

type
  TReturnRecord = record
    Value1: Integer;
    Value2: Integer;
    Value3: Integer;
  end;

function TForm2.DoSomething: TReturnRecord;
begin
  Result.Value1 := 1;
  Result.Value2 := 2;
  Result.Value3 := 3;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  R: TReturnRecord;
begin
  R := Form2.DoSomething;
  ShowMessage(IntToStr(R.Value1));
end;

3. Declare a class which aggregates your return values:

type
  TReturnClass = class
    Value1: Integer;
    Value2: Integer;
    Value3: Integer;
  end;

function TForm2.DoSomething(AReturn: TReturnClass);
begin
  AReturn.Value1 := 1;
  AReturn.Value2 := 2;
  AReturn.Value3 := 3;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  R: TReturnClass;
begin
  R := TReturnClass.Create;
  try
    Form2.DoSomething(R);
    ShowMessage(R.Value1);
  finally
    R.Free;
  end;
end;

Or you could use a list or array structure, or you could use an open array parameter.

How to convert a *.bmp file to a *.jpg file

Problem/Question/Abstract:

How to convert a *.bmp file to a *.jpg file

Answer:

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Button1: TButton;
    Image1: TImage;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

uses JPEG;

procedure TForm1.Button1Click(Sender: TObject);
var
  JPEG: TJPEGImage;
  Bitmap: TBitmap;
begin
  JPEG := TJPEGImage.Create;
  Bitmap := TBitmap.Create;
  try
    Bitmap.LoadFromFile('C:\Program Files\Common Files\alarm.bmp');
    JPEG.Assign(Bitmap);
    Image1.Picture.Assign(JPEG);
  finally
    JPEG.Free;
    Bitmap.Free;
  end;
end;

end.

How to save/restore the form state in/from the registry

Problem/Question/Abstract:

How to save/restore the form state in/from the registry

Answer:

You may try the following unit. There is one thing you may have to handle separately somehow: the mainform is never actually minimized, so its Windowstate is never wsMinimized, unless you set it in code. When you minimize the main form it is hidden and the Application window is minimized instead. You can check whether it is minimized via

if IsIconic(Application.handle) then
  {... app is minimized}

unit RegWinset;

interface

uses
  Registry, Forms;

procedure SaveWindowstate(ini: TRegInifile; form: TForm);
procedure RestoreWindowstate(ini: TRegInifile; form: TForm);
procedure SaveWindowstateEx(ini: TRegInifile; form: TForm; const section: string);
procedure RestoreWindowstateEx(ini: TRegInifile; form: TForm; const section: string);

implementation

uses
  TypeInfo, Windows;

const
  sSettings = 'Settings';
  sLeft = 'Left';
  sTop = 'Top';
  sWidth = 'Width';
  sHeight = 'Height';
  sState = 'State';

  {Procedure SaveWindowStateEx;

  Parameters:
  ini: inifile to save the settings in
  form: form to save the settings for
  section: section to use for the settings

  Call method: static
  Description: Saves the windows position and size to the INI file.
  Error Conditions: none
  Created: 03.07.97 16:34:34 by P. Below}

procedure SaveWindowstateEx(ini: TRegInifile; form: TForm; const section: string);
var
  wp: TWindowPlacement;
begin
  wp.length := Sizeof(wp);
  GetWindowPlacement(form.handle, @wp);
  with Ini, wp.rcNormalPosition do
  begin
    WriteInteger(section, sLeft, Left);
    WriteInteger(section, sTop, Top);
    WriteInteger(section, sWidth, Right - Left);
    WriteInteger(section, sHeight, Bottom - Top);
    WriteString(section, sState, GetEnumName(TypeInfo(TWindowState),
      Ord(form.WindowState));
  end;
end;

{Procedure RestoreWindowStateEx;

Parameters:
ini: inifile to restore the settings from
form: form to restore the settings for
section: section to use for the settings

Call method: static

Description:
Restores the window position and dimensions from the saved values in the INI file.
If there ain't any, nothing changes.

Error Conditions: none

Created: 03.07.97 16:33:27 by P. Below}

procedure RestoreWindowstateEx(ini: TRegInifile; form: TForm; const section: string);
var
  L, T, W, H: Integer;
begin
  with Ini, form do
  begin
    L := ReadInteger(section, sLeft, Left);
    T := ReadInteger(section, sTop, Top);
    W := ReadInteger(section, sWidth, Width);
    H := ReadInteger(section, sHeight, Height);
    SetBounds(L, T, W, H);
    try
      Windowstate := TWindowState(GetEnumValue(TypeInfo(TWindowState),
        ReadString(section, sState, 'wsNormal')));
    except
    end;
  end;
end;

{ Save state using default settings section }

procedure SaveWindowstate(ini: TRegInifile; form: TForm);
begin
  SaveWindowstateEx(ini, form, sSettings);
end;

{ Restore state using default settings section }

procedure RestoreWindowstate(ini: TRegInifile; form: TForm);
begin
  RestoreWindowStateEx(ini, form, sSettings);
end;

end.

Form scaling and the large fonts/small fonts issue

Problem/Question/Abstract:

The Form of my application displays properly at all screen resolution settings, but if the user selects "Large fonts" in the Windows Display settings, the Form is truncated. How can I handle this better?

Answer:

This is usually a problem of large fonts (120 dpi) vs small fonts (96 dpi) settings. The user can change these settings as part of the display options in control panel. You can check the settings at run-time by looking at Screen.PixelsPerInch.
Different ways have been suggested to create forms that will work well on both settings. The most important one is to use TrueType fonts (like Arial) only in your forms. Ms SansSerif, the default, is TT on NT but not on Win9x!
Option 1:
Design on small fonts, leave the forms Scaled property set to true, set forms AutoScroll to false, leave a little extra space between controls so they can grow a bit under large fonts without colliding with each other. This is said to be the method Borland uses for the Delphi IDE itself. When you test on large fonts *never* save the project there! If you save such a form under large fonts it will become distorted under small fonts!
Option 2:
Design on large fonts and set Scaled to false. Again take care never to save the project under small fonts or the forms will become distorted.
A final issue you may need to take care of is the users screen size (in pixels). If you design your forms to run well on 800*600 the user will have a problem if he is running 640*480. So your forms should check the screen size (Screen.Width, Screen.Height) in their OnCreate handler.
If the screen is too small for the form the form should resize itself to the screen size (or better the work area size, see SystemParametersInfo(SPI_GETWORKAREA) and set its AutoScroll property to true. It will then automatically sprout scrollbars, so the user can at least access all parts of the form. Trying to rescale the form to the smaller screen size will almost never result in a usable form, so I don't consider this an option.

InterBase: Recover uncommitted work

Problem/Question/Abstract:

Is there a way to recover uncommitted work in the event of a power failure?

Answer:

No, uncommitted work is lost. Commit often.

Convert Numbers To Hebrew

Problem/Question/Abstract:

How can i change my 12345 numbers to hebrew numbering style ?

Answer:

Well I have created long ago in the pascal days a function to do this. A few month ago i converted it to Delphi, and created a new function to do it. It's much faster then the old one... but still it is to slow (I hope you can help me to make it even faster).

Note: this is a recorsive function, and also this is the first time i published it, I took it from my String unit, so it might be that there are some functions that apper only in this unit, so I'm sorry from a head :) :

{ Hebrew Numbers }
const
  hZerrowToNine: array[0..9] of char =
  //  0   1   2   3   4   5   6   7   8   9
  (#255, '?', '?', '?', '?', '�', '�', '�', '?', '?');
  //No Zerro in hebrew !!!!

  hTenToNinte: array[1..9] of char =
  // 10  20  30  40  50  60  70  80  90
  ('�', '?', '?', '?', '?', '?', '?', '?', '�');

  hHandredToFour: array[1..4] of char =
  //100 200 300 400
  ('�', '�', '?', '?');

  ///////// Inner function for the "hIntToStrNumber" function \\\\\\\\\

function Single(strNum: string): string;
begin
  result := hZerrowToNineNumbers[strToInt(strNum)];
end;

function Tens(strNum: string): string;
begin
  case strNum[1] of
    '1': if strNum[2] = '0' then
        result := hTenToNinteNumbers[strToInt(strNum[1])]
      else
        result := hZerrowToNineNumbers[StrToInt(strNum[2])] + #32 + hTeen;
    '2'..'9': result := hTenToNinteNumbers[strToInt(strNum[1])];
  else
    result := #255;
  end;
end;

function Hundreds(strNum: string): string;
begin
  case strNum[1] of
    '1', '2': result := hHanderndToNineHandrend[StrToInt(strNum[1])];
    '3'..'9': result := hZerrowToNineNumbers[strToInt(strNum[1])] + #32 + hHundrends;
  else
    result := #255;
  end;
end;

function Thousand(strNum: string): string;
begin
  case strNum[1] of
    '1', '2': result := hOneThousandToNineThousand[strToInt(strNum[1])];
    '3'..'9': result := hZerrowToNineNumbers[strToInt(strNum[1])] + #32 + hThousand;
  else
    result := #255;
  end;
end;

/////////////////////////////////////////////////////////////////////

function hIntToStrNumber(Number: integer): string;
//Thanks for HU-Man for helping to fix a bug that was in this function ...
var
  strNum: string;

begin
  strNum := IntToStr(Number);

  case Length(strNum) of
    1:
      begin // 0 - 9
        result := Single(strNum);
      end;

    2:
      begin // 10 - 99
        result := Tens(strNum);
        if strNum[1] >= '2' then
          if strNum[2] <> '0' then
            result := result + #32 + hAnd + hIntToStrNumber(StrToInt(strNum[2]));
      end;

    3:
      begin // 100 - 999
        result := Hundreds(strNum);
        if strNum[2] <> '0' then
          if strNum[3] = '0' then
            result := result + #32 + hAnd + hIntToStrNumber(StrToInt(strNum[2] +
              strNum[3]))
          else
            result := result + #32 + hIntToStrNumber(StrToInt(strNum[2] + strNum[3]));

        if (strNum[2] = '0') and (strNum[3] <> '0') then
          result := result + #32 + hAnd + hIntToStrNumber(StrToInt(strNum[3]));
      end;

    4:
      begin // 1,000 - 9,999
        result := Thousand(strNum);
        if (strNum[2] <> '0') then
          result := result + #32 + hIntToStrNumber(StrToInt(strNum[2] + strNum[3] +
            strNum[4]));
      end;

  else
    result := '';
  end;

  result := DeleteChar(Result, #255);
end;

How to change the corner size of RoundRect

Problem/Question/Abstract:

The RoundRect shape has too much space missing in the corners. I'd like to specify a smaller corner ellipse. Is there any way to make the rounding of the corners more subtle by using the Delphi shape, or do I have to resort to writing to the WinAPI?

Answer:



Here is one that will let you change the size of the corners.

unit NewShape;

interface

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

type
  TNewShape = class(TShape)
  private
    { Private declarations }
    FCornerSize: Integer;
    procedure SetCornerSize(Value: Integer);
  protected
    { Protected declarations }
    procedure Paint; override;
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
  published
    { Published declarations }
    property CornerSize: Integer read FCornerSize write SetCornerSize default 2;
  end;

procedure Register;

implementation

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

constructor TNewShape.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FCornerSize := 2;
end;

procedure TNewShape.Paint;
var
  X, Y, W, H, S: Integer;
begin
  with Canvas do
  begin
    X := Pen.Width div 2;
    Y := X;
    W := Width - Pen.Width + 1;
    H := Height - Pen.Width + 1;
    if Pen.Width = 0 then
    begin
      Dec(W);
      Dec(H);
    end;
    if W < H then
      S := W
    else
      S := H;
    if Shape in [stSquare, stRoundSquare, stCircle] then
    begin
      Inc(X, (W - S) div 2);
      Inc(Y, (H - S) div 2);
      W := S;
      H := S;
    end;
    case Shape of
      stRectangle, stSquare:
        Rectangle(X, Y, X + W, Y + H);
      stRoundRect, stRoundSquare:
        RoundRect(X, Y, X + W, Y + H, FCornerSize, FCornerSize);
      stCircle, stEllipse:
        Ellipse(X, Y, X + W, Y + H);
    end;
  end;
end;

procedure TNewShape.SetCornerSize(Value: Integer);
begin
  if FCornerSize <> Value then
    FCornerSize := Value;
  Invalidate;
end;

end.

Dynamic arrays an approach

Problem/Question/Abstract:

An approach to do dynamic arrays the easy way

Answer:

type
  TDISIntArray = array of integer;

  TDISFindArrayMode = (famNone, famFirst, famNext, famPrior, famLast);
  TDISSortArrayMode = (samAscending, samDescending);

  EDISArray = class(Exception);

  TDISIntegerArray = class(TObject)
  private
    fLastFindMode: TDISFindArrayMode;
    fComma: Char;
    fArray: TDISIntArray;
    fItemCount: Integer;
    fFindIndex: Integer;
    fDuplicates: Boolean;
    function GetArray(Index: integer): integer;
    procedure SetArray(Index: integer; Value: integer);
    procedure SetDuplicates(Value: Boolean);

    procedure Swap(var a, b: integer);
    procedure QuickSort(Source: TDISIntArray; Mode: TDISSortArrayMode; left, right:
      integer);

    procedure Copy(Source: TDISIntArray; var Dest: TDISIntArray);
  protected
  public
    constructor Create;
    destructor Destroy; override;

    procedure Clear;
    function Add(Value: integer): boolean;
    procedure Delete(Index: integer);
    function Find(Value: integer; Mode: TDISFindArrayMode): integer;

    function Min: integer;
    function Max: integer;
    function Sum: integer;
    function Average: integer;

    function Contains(Value: integer): Boolean;
    function Commatext: string;

    procedure Sort(Mode: TDISSortArrayMode);

    procedure SaveToFile(FileName: string);
    function LoadFromFile(FileName: string): boolean;

    property AddDuplicates: Boolean read fDuplicates write SetDuplicates;
    property Items[Index: integer]: integer read GetArray write SetArray;
    property Count: Integer read fItemCount;

    property CommaSeparator: Char read fComma write fComma;
  end;

implementation

function ReplaceChars(value: string; v1, v2: char): string;
var
  ts: string;
  i: integer;
begin
  ts := value;
  for i := 1 to length(ts) do
    if ts[i] = v1 then
      ts[i] := v2;
  result := ts;
end;

////////////////////////////////////////////////
// TDISIntegerArray
////////////////////////////////////////////////

constructor TDISIntegerArray.Create;
begin
  fItemCount := 0;
  fDuplicates := True;
  fLastFindMode := famNone;
  fComma := ',';
end;

destructor TDISIntegerArray.Destroy;
begin
  inherited Destroy;
end;

function TDISIntegerArray.Min: integer;
var
  TA: TDISIntArray;
begin
  Copy(fArray, Ta);
  QuickSort(Ta, samAscending, low(fArray), high(fArray));
  Result := Ta[0];
end;

function TDISIntegerArray.Max: integer;
var
  TA: TDISIntArray;
begin
  Copy(fArray, Ta);
  QuickSort(Ta, samDescending, low(fArray), high(fArray));
  Result := Ta[0];
end;

function TDISIntegerArray.Sum: integer;
var
  i: integer;
begin
  Result := 0;
  for i := low(fArray) to high(fArray) do
    Result := Result + fArray[i];
end;

function TDISIntegerArray.Average: integer;
begin
  Result := Sum div fItemCount;
end;

procedure TDISIntegerArray.SaveToFile(FileName: string);
var
  Tl: TStringList;
begin
  Tl := TStringList.Create;
  Tl.Text := CommaText;
  Tl.SaveToFile(FileName);
  Tl.Free;
end;

function TDISIntegerArray.LoadFromFile(FileName: string): boolean;
var
  Tl: TStringList;
  Ts: string;
  j: integer;
begin
  Result := False;
  if FileExists(FileName) then
  begin
    Result := True;

    Tl := TStringList.Create;
    Tl.LoadFromFile(FileName);

    Ts := ReplaceChars(Trim(Tl.Text), ';', ',');
    Ts := ReplaceChars(Ts, '|', ',');
    Ts := ReplaceChars(Ts, #9, ',');

    Clear;
    while pos(',', Ts) > 0 do
    begin
      j := StrToIntDef(System.copy(Ts, 1, pos(',', Ts) - 1), 0);
      Add(j);
      System.Delete(Ts, 1, pos(',', Ts));
    end;
    Add(StrToIntDef(Ts, 0));

    Tl.Free;
  end;
end;

procedure TDISIntegerArray.Swap(var a, b: integer);
var
  t: integer;
begin
  t := a;
  a := b;
  b := t;
end;

procedure TDISIntegerArray.QuickSort(Source: TDISIntArray; Mode: TDISSortArrayMode;
  left, right: integer);
var
  pivot: integer;
  lower,
    upper,
    middle: integer;
begin
  lower := left;
  upper := right;
  middle := (left + right) div 2;
  pivot := Source[middle];
  repeat
    case Mode of
      samAscending:
        begin
          while Source[lower] < pivot do
            inc(lower);
          while pivot < Source[upper] do
            dec(upper);
        end;
      samDescending:
        begin
          while Source[lower] > pivot do
            inc(lower);
          while pivot > Source[upper] do
            dec(upper);
        end;
    end;

    if lower <= upper then
    begin
      swap(Source[lower], Source[upper]);
      inc(lower);
      dec(upper);
    end;
  until lower > upper;

  if left < upper then
    QuickSort(Source, Mode, left, upper);
  if lower < right then
    QuickSort(Source, Mode, lower, right);
end;

procedure TDISIntegerArray.Clear;
var
  i: integer;
begin
  for i := low(fArray) to high(fArray) do
    fArray[i] := 0;

  SetLength(fArray, 0);
  fItemCount := 0;
end;

function TDISIntegerArray.Commatext: string;
var
  i: integer;
begin
  Result := '';
  for i := low(fArray) to high(fArray) do
  begin
    Result := Result + IntToStr(fArray[i]);
    Result := Result + fComma;
  end;
  if Length(Result) > 0 then
    System.Delete(Result, length(Result), 1);
end;

procedure TDISIntegerArray.Sort(Mode: TDISSortArrayMode);
begin
  QuickSort(fArray, Mode, low(fArray), high(fArray));
end;

procedure TDISIntegerArray.SetDuplicates(Value: Boolean);
begin
  fDuplicates := Value;
end;

function TDISIntegerArray.Add(Value: integer): boolean;
begin
  Result := True;

if contains(Value) and (fDuplicates = False) then
  begin
    Result := False;
    exit;
  end;

inc(fItemCount);
SetLength(fArray, fItemCount);
fArray[fItemCount - 1] := Value;
end;

function TDISIntegerArray.Contains(Value: integer): Boolean;
var
  i: integer;
begin
  Result := False;
  for i := low(fArray) to high(fArray) do
  begin
    if fArray[i] = Value then
    begin
      Result := True;
      Break;
    end;
  end;
end;

function TDISIntegerArray.Find(Value: integer; Mode: TDISFindArrayMode): integer;
var
  i: integer;
begin
  Result := -1;

  case Mode of
    famNone, famFirst:
      begin
        fLastFindMode := Mode;
        fFindIndex := -1;
        for i := low(fArray) to high(fArray) do
        begin
          if fArray[i] = Value then
          begin
            if Mode = famFirst then
              fFindIndex := i + 1;
            Result := i;
            Break;
          end;
        end;
      end;
    famNext:
      begin

        if fLastFindMode = famPrior then
          inc(fFindIndex, 2);

        fLastFindMode := Mode;

        for i := fFindIndex to high(fArray) do
        begin
          if fArray[i] = Value then
          begin
            fFindIndex := i + 1;
            Result := i;
            Break;
          end;
        end;
      end;
    famPrior:
      begin

        if fLastFindMode = famNext then
          dec(fFindIndex, 2);

        fLastFindMode := Mode;

        for i := fFindIndex downto low(fArray) do
        begin
          if fArray[i] = Value then
          begin

            fFindIndex := i - 1;
            Result := i;
            Break;
          end;
        end;
      end;
    famLast:
      begin
        fFindIndex := -1;
        fLastFindMode := Mode;
        for i := high(fArray) downto low(fArray) do
        begin
          if fArray[i] = Value then
          begin

            fFindIndex := i - 1;
            Result := i;
            Break;
          end;
        end;
      end;
  end;
end;

procedure TDISIntegerArray.Copy(Source: TDISIntArray; var Dest: TDISIntArray);
var
  i: integer;
begin
  SetLength(Dest, 0);
  SetLength(Dest, Length(Source));

  for i := low(Source) to high(Source) do
    Dest[i] := Source[i];

end;

procedure TDISIntegerArray.Delete(Index: integer);
var
  TA: TDISIntArray;
  i: integer;
begin
  if (Index >= Low(fArray)) and (Index <= high(fArray)) then
  begin
    Copy(fArray, Ta);
    Clear;
    for i := low(Ta) to high(Ta) do
    begin
      if i <> Index then
        Add(Ta[i]);
    end;
    dec(fItemCount);
  end;
end;

function TDISIntegerArray.GetArray(Index: integer): integer;
begin
  if (Index >= Low(fArray)) and (Index <= high(fArray)) then
    Result := fArray[index]
  else
    raise EDISArray.Create(format('Index : %d is not valid index %d..%d.', [Index,
      low(fArray), high(fArray)]));
end;

procedure TDISIntegerArray.SetArray(Index: integer; Value: integer);
begin

if contains(Value) and (fDuplicates = False) then
  exit;

if Index < 0 then
  raise EDISArray.Create(format('Index : %d is not valid index.', [Index]))
else
begin
  if Index + 1 > fItemCount then
  begin
    fItemCount := Index + 1;
    SetLength(fArray, fItemCount);
    fArray[fItemCount - 1] := Value;
  end
  else
    fArray[Index] := Value;
end;
end;

How to create a hint for a single cell in a TDrawGrid or TDBGrid

Problem/Question/Abstract:

How can I make a hint for a single cell in a TDBGrid or TDrawGrid? I want to display any text in a grid cell even if it is not placed in the cell completely.

Answer:

Here's an example taken from a working app but simplified a little. OldHintRow and OldHintCol are private variables declared in TStosWin. They store the column and row for which the hint was shown previously.

procedure TStosWin.MyDrawGrid1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
var
  R, C: Integer;
begin
  with MyDrawGrid1 do
  begin
    MouseToCell(X, Y, C, R);
    if (C = OldHintCol) and (R = OldHintRow) then
      exit; {Don't do anything if mouse is in the same cell}
    OldHintCol := C;
    OldHintRow := R;
    Hint := ' Your hint for column C and row R';
    {Force the hint to redisplay}
    PostMessage(Handle, WM_MBUTTONDOWN, MK_LBUTTON, Dword((Y shl 16) + X));
  end;
end;

DateTime String (any format) to TDateTime

Problem/Question/Abstract:

When extracting data from text or other operating systems the format of date strings can vary dramatically. Borland function StrToDateTime() converts a string to a TDateTime value, but it is limited to the fact that the string parameter must be in the format of the current locale&#8217;s date/time format.

eg. "MM/DD/YY HH:MM:SS"

Answer:
This is of little use when extracting dates such as ..

        1) "Friday 18 October 2002 08:34am (45 secs)"  or "Wednesday 15 May 2002 06:12 (22 secs)"
        2) "20020431"
        3) "12.Nov.03"
        4) "14 Hour 31 Minute 25 Second 321 MSecs"

This function will evaluate a DateTime string in accordance to the DateTime specifier format string supplied. The following specifiers are supported ...

  dd                                 the day as a number with a leading zero or space (01-31).  
  ddd                         the day as an abbreviation (Sun-Sat)
  dddd                         the day as a full name (Sunday-Saturday)
  mm                         the month as a number with a leading zero or space (01-12).
  mmm                 the month as an abbreviation (Jan-Dec)
  mmmm                 the month as a full name (January-December)
  yy                                 the year as a two-digit number (00-99).
  yyyy                         the year as a four-digit number (0000-9999).
  hh                                 the hour with a leading zero or space (00-23)
  nn                                 the minute with a leading zero or space (00-59).
  ss                                 the second with a leading zero or space (00-59).
  zzz                                 the millisecond with a leading zero (000-999).
  ampm                 Specifies am or pm flag hours (0..12)
  ap                                 Specifies a or p flag hours (0..12)
  (Any other character corresponds to a literal or delimiter.)

NOTE : One assumption I have to make is that DAYS, MONTHS, HOURS and MINUTES have a leading                       ZERO or SPACE (ie. are 2 chars long) and MILLISECONDS are 3 chars long (ZERO or SPACE                        padded)

Using function
DateTimeStrEval(const DateTimeFormat : string; const DateTimeStr : string) : TDateTime;

The above Examples (1..4) can be evaluated as ... (Assume DT1 to DT4 equals example strings 1..4)

        1)MyDate := DateTimeStrEval('dddd dd mmmm yyyy hh:nnampm (ss xxxx)', DT1);
        2)MyDate := DateTimeStrEval('yyyymmdd', DT2);
        3)MyDate := DateTimeStrEval('dd-mmm-yy', DT3);
        4)MyDate := DateTimeStrEval('hh xxxx nn xxxxxx ss xxxxxx zzz xxxxx', DT4);

uses SysUtils, DateUtils

  // =============================================================================
  // Evaluate a date time string into a TDateTime obeying the
  // rules of the specified DateTimeFormat string
  // eg. DateTimeStrEval('dd-MMM-yyyy hh:nn','23-May-2002 12:34)
  //
  // Delphi 6 Specific in DateUtils can be translated to ....
  //
  // YearOf()
  //
  // function YearOf(const AValue: TDateTime): Word;
  // var LMonth, LDay : word;
  // begin
  //   DecodeDate(AValue,Result,LMonth,LDay);
  // end;
  //
  // TryEncodeDateTime()
  //
  // function TryEncodeDateTime(const AYear,AMonth,ADay,AHour,AMinute,ASecond,
  //                            AMilliSecond : word;
  //                            out AValue : TDateTime): Boolean;
  // var LTime : TDateTime;
  // begin
  //   Result := TryEncodeDate(AYear, AMonth, ADay, AValue);
  //   if Result then begin
  //     Result := TryEncodeTime(AHour, AMinute, ASecond, AMilliSecond, LTime);
  //     if Result then
  //        AValue := AValue + LTime;
  //   end;
  // end;
  //
  // (TryEncodeDate() and TryEncodeTime() is the same as EncodeDate() and
  //  EncodeTime() with error checking and boolean return value)
  //
  // =============================================================================

function DateTimeStrEval(const DateTimeFormat: string;
  const DateTimeStr: string): TDateTime;
var
  i, ii, iii: integer;
  Retvar: TDateTime;
  Tmp,
    Fmt, Data, Mask, Spec: string;
  Year, Month, Day, Hour,
    Minute, Second, MSec: word;
  AmPm: integer;
begin
  Year := 1;
  Month := 1;
  Day := 1;
  Hour := 0;
  Minute := 0;
  Second := 0;
  MSec := 0;
  Fmt := UpperCase(DateTimeFormat);
  Data := UpperCase(DateTimeStr);
  i := 1;
  Mask := '';
  AmPm := 0;

  while i < length(Fmt) do
  begin
    if Fmt[i] in ['A', 'P', 'D', 'M', 'Y', 'H', 'N', 'S', 'Z'] then
    begin
      // Start of a date specifier
      Mask := Fmt[i];
      ii := i + 1;

      // Keep going till not valid specifier
      while true do
      begin
        if ii > length(Fmt) then
          Break; // End of specifier string
        Spec := Mask + Fmt[ii];

        if (Spec = 'DD') or (Spec = 'DDD') or (Spec = 'DDDD') or
          (Spec = 'MM') or (Spec = 'MMM') or (Spec = 'MMMM') or
          (Spec = 'YY') or (Spec = 'YYY') or (Spec = 'YYYY') or
          (Spec = 'HH') or (Spec = 'NN') or (Spec = 'SS') or
          (Spec = 'ZZ') or (Spec = 'ZZZ') or
          (Spec = 'AP') or (Spec = 'AM') or (Spec = 'AMP') or
          (Spec = 'AMPM') then
        begin
          Mask := Spec;
          inc(ii);
        end
        else
        begin
          // End of or Invalid specifier
          Break;
        end;
      end;

      // Got a valid specifier ? - evaluate it from data string
      if (Mask <> '') and (length(Data) > 0) then
      begin
        // Day 1..31
        if (Mask = 'DD') then
        begin
          Day := StrToIntDef(trim(copy(Data, 1, 2)), 0);
          delete(Data, 1, 2);
        end;

        // Day Sun..Sat (Just remove from data string)
        if Mask = 'DDD' then
          delete(Data, 1, 3);

        // Day Sunday..Saturday (Just remove from data string LEN)
        if Mask = 'DDDD' then
        begin
          Tmp := copy(Data, 1, 3);
          for iii := 1 to 7 do
          begin
            if Tmp = Uppercase(copy(LongDayNames[iii], 1, 3)) then
            begin
              delete(Data, 1, length(LongDayNames[iii]));
              Break;
            end;
          end;
        end;

        // Month 1..12
        if (Mask = 'MM') then
        begin
          Month := StrToIntDef(trim(copy(Data, 1, 2)), 0);
          delete(Data, 1, 2);
        end;

        // Month Jan..Dec
        if Mask = 'MMM' then
        begin
          Tmp := copy(Data, 1, 3);
          for iii := 1 to 12 do
          begin
            if Tmp = Uppercase(copy(LongMonthNames[iii], 1, 3)) then
            begin
              Month := iii;
              delete(Data, 1, 3);
              Break;
            end;
          end;
        end;

        // Month January..December
        if Mask = 'MMMM' then
        begin
          Tmp := copy(Data, 1, 3);
          for iii := 1 to 12 do
          begin
            if Tmp = Uppercase(copy(LongMonthNames[iii], 1, 3)) then
            begin
              Month := iii;
              delete(Data, 1, length(LongMonthNames[iii]));
              Break;
            end;
          end;
        end;

        // Year 2 Digit
        if Mask = 'YY' then
        begin
          Year := StrToIntDef(copy(Data, 1, 2), 0);
          delete(Data, 1, 2);
          if Year < TwoDigitYearCenturyWindow then
            Year := (YearOf(Date) div 100) * 100 + Year
          else
            Year := (YearOf(Date) div 100 - 1) * 100 + Year;
        end;

        // Year 4 Digit
        if Mask = 'YYYY' then
        begin
          Year := StrToIntDef(copy(Data, 1, 4), 0);
          delete(Data, 1, 4);
        end;

        // Hours
        if Mask = 'HH' then
        begin
          Hour := StrToIntDef(trim(copy(Data, 1, 2)), 0);
          delete(Data, 1, 2);
        end;

        // Minutes
        if Mask = 'NN' then
        begin
          Minute := StrToIntDef(trim(copy(Data, 1, 2)), 0);
          delete(Data, 1, 2);
        end;

        // Seconds
        if Mask = 'SS' then
        begin
          Second := StrToIntDef(trim(copy(Data, 1, 2)), 0);
          delete(Data, 1, 2);
        end;

        // Milliseconds
        if (Mask = 'ZZ') or (Mask = 'ZZZ') then
        begin
          MSec := StrToIntDef(trim(copy(Data, 1, 3)), 0);
          delete(Data, 1, 3);
        end;

        // AmPm A or P flag
        if (Mask = 'AP') then
        begin
          if Data[1] = 'A' then
            AmPm := -1
          else
            AmPm := 1;
          delete(Data, 1, 1);
        end;

        // AmPm AM or PM flag
        if (Mask = 'AM') or (Mask = 'AMP') or (Mask = 'AMPM') then
        begin
          if copy(Data, 1, 2) = 'AM' then
            AmPm := -1
          else
            AmPm := 1;
          delete(Data, 1, 2);
        end;

        Mask := '';
        i := ii;
      end;
    end
    else
    begin
      // Remove delimiter from data string
      if length(Data) > 1 then
        delete(Data, 1, 1);
      inc(i);
    end;
  end;

  if AmPm = 1 then
    Hour := Hour + 12;
  if not TryEncodeDateTime(Year, Month, Day, Hour, Minute, Second, MSec, Retvar) then
    Retvar := 0.0;
  Result := Retvar;
end;

How to feed rich text chunks to a TRichEdit via the clipboard

Problem/Question/Abstract:

It is possible to feed rich text chunks to the control but it is kind of convoluted. There are three options: the clipboard, the rich edits OLE interface, and the EM_STREAMIN message. We concentrate on the clipboard here.

Answer:

The first step is to register a clipboard format for RTF, since this is not a predefined format:

var
  CF_RTF: Word;

CF_RTF := RegisterClipboardFormat('Rich Text Format');

The format name has to appear as typed above, this is the name used by MS Word for Windows and similar MS products.

Note: The Richedit Unit declares a constant CF_RTF, which is not the clipboard format handle but the string you need to pass to RegisterClipboard format! So you can place Richedit into your uses clause and change the line above to

CF_RTF := RegisterClipboardFormat(Richedit.CF_RTF);

The next step is to build a RTF string with the embedded format information. You will get a shock if you inspect the mess of RTF stuff Wordpad (or much worse: Word) will put into the clipboard if you copy just a few characters ), but you can get away with a lot less. The bare minimum would be something like this (inserts a 12 followed by an underlined 44444):

const
  testtext: PChar = '{\rtf1\ansi\pard\plain 12{\ul 44444}}';

The correct balance of opening and closing braces is extremely important, one mismatch and the target app will not be able to interpret the text correctly. If you want to control the font used for the pasted text you need to add a fonttable (the default font is Tms Rmn, not the active font in the target app!). See example testtext2 below. If you want more info, the full RTF specs can be found on www.microsoft.com, a subset is also described in the Windows help compiler docs (hcw.hlp, comes with Delphi).

procedure TForm1.BtnSetRTFClick(Sender: TObject);
const
  testtext: PChar = '{\rtf1\ansi\pard\plain 12{\ul 44444}}';
  testtext2: PChar = '{\rtf1\ansi' +
  '\deff4\deflang1033{\fonttbl{\f4\froman\fcharset0\fprq2 Times New Roman;}}' +
    '\pard\plain 12{\ul 44444}}';
  flap: Boolean = False;
var
  MemHandle: THandle;
  rtfstring: PChar;
begin
  if flap then
    rtfstring := testtext2
  else
    rtfstring := testtext;
  flap := not flap;
  MemHandle := GlobalAlloc(GHND or GMEM_SHARE, StrLen(rtfstring) + 1);
  if MemHandle <> 0 then
  begin
    StrCopy(GlobalLock(MemHandle), rtfstring);
    GlobalUnlock(MemHandle);
    with Clipboard do
    begin
      Open;
      try
        AsText := '1244444';
        SetAsHandle(CF_RTF, MemHandle);
      finally
        Close;
      end;
    end;
  end
  else
    MessageDlg('Global Alloc failed!', mtError, [mbOK], 0);
end;

Once the text is in the clipboard you can call the richedits PasteFromClipboard method to insert it at the caret.

How to change the page orientation in the middle of a print job

Problem/Question/Abstract:

Is it possible to change the printer orientation from portrait to landscape in the middle of a print job?

Answer:

procedure TForm1.Button2Click(Sender: TObject);
var
  Device: array[0..255] of char;
  Driver: array[0..255] of char;
  Port: array[0..255] of char;
  hDeviceMode: THandle;
  pDevMode: PDeviceMode;
begin
  with Printer do
  begin
    BeginDoc;
    try
      Canvas.font.size := 20;
      Canvas.font.name := 'Arial';
      Canvas.TextOut(50, 50, 'This is portait');
      GetPrinter(Device, Driver, Port, hDeviceMode);
      pDevMode := GlobalLock(hDevicemode);
      with pDevMode^ do
      begin
        dmFields := dmFields or DM_ORIENTATION;
        dmOrientation := DMORIENT_LANDSCAPE;
      end;
      { Cannot use NewPage here since the ResetDc will only work between EndPage
      and StartPage. As a consequence the Printer.PageCount is not updated. }
      Windows.EndPage(Printer.Handle);
      if ResetDC(canvas.Handle, pDevMode^) = 0 then
        ShowMessage('ResetDC failed, ' + SysErrorMessage(GetLastError));
      GlobalUnlock(hDeviceMode);
      Windows.StartPage(Printer.Handle);
      Printer.Canvas.Refresh;
      Canvas.font.size := 20;
      Canvas.font.name := 'Arial';
      Canvas.TextOut(50, 50, 'This is landscape');
    finally
      EndDoc;
    end;
  end;
end;

How to save the position of TCoolBar bands in the registry

Problem/Question/Abstract:

I use a TCoolBar with several TToolbars and some other controls. During runtime a user can automatically reorder and resize the bands on the TCoolbar, is there a easy way of saving the positions and sizes of the different bands and reloading them a next time?

Answer:

You have to save the ID, Break, Width and Index of the bands. Following is a snippet of code that I use to save the Coolbar in the registry.

{ ... }

var
  RegristryFile: TRegIniFile;

const
  Ident = 'ID';
  Brk = 'Break';
  Wdth = 'Width';
  Ndx = 'Index';

  { ... }

procedure SaveCoolBars;
var
  A: Integer;
  IdStr: string;
begin
  with CoolBar, Bands do
  begin
    for A := 0 to Count - 1 do
      with Bands[A] do
      begin
        IdStr := IntToStr(Id);
        with RegristryFile do
        begin
          EraseSection(IdStr);
          WriteBool(IdStr, Brk, Break);
          WriteInteger(IdStr, Wdth, Width);
          WriteInteger(IdStr, Ndx, Index);
        end;
      end;
  end;
end;

procedure LoadCoolBars;
var
  A: Integer;
  B: TCoolBand;
  IdStr: string;
begin
  with CoolBar, Bands do
  begin
    for A := 0 to Count - 1 do
    begin
      B := TCoolband(Bands.FindItemID(A));
      if B = nil then
        Continue;
      with B, RegristryFile do
      begin
        IdStr := IntToStr(Id);
        Break := ReadBool(IdStr, Brk, Break);
        Width := ReadInteger(IdStr, Wdth, Width);
        Index := ReadInteger(IdStr, Ndx, Index);
      end;
    end;
  end;
end;

Make move your forms like WinAMP

Problem/Question/Abstract:

The form remember on what side you put it and returns there when Windows Taskbar is moved!!! Try it out: full source code.

Answer:

unit frmSplashUnit;

interface

uses
  Windows, Messages, SysUtils, Classes,
  Graphics, Controls, Forms, Dialogs,
  ExtCtrls, StdCtrls, ComCtrls, Buttons,
  Menus, ImgList;

const
  MagneticField = 10;

type
  TAlignSide1 = (fasNone, fasTop, fasBottom, fasRight, fasLeft);
  TAlignSide = set of TAlignSide1;
  TfrmSplash =
    class(TForm)
    bvlForm: TBevel;
    lblAction: TLabel;
    lblFile: TLabel;
    bvlTitle: TBevel;
    imgTitle: TImage;
    lblProgress: TLabel;
    pbProgress: TProgressBar;
    bvlLine: TBevel;
    cmdCancel: TSpeedButton;
    popSystemMenu: TPopupMenu;
    mnuRestore: TMenuItem;
    mnuMove: TMenuItem;
    mnuSize: TMenuItem;
    mnuMinimize: TMenuItem;
    mnuMaximize: TMenuItem;
    mnuBar1: TMenuItem;
    mnuClose: TMenuItem;
    ilSystemMenu: TImageList;
    mnuBar2: TMenuItem;
    mnuAbout: TMenuItem;
    cmdAbout: TSpeedButton;
    procedure imgTitleMouseDown(Sender: TObject; Button: TMouseButton; Shift:
      TShiftState; X, Y: Integer);
    procedure imgTitleMouseUp(Sender: TObject; Button: TMouseButton; Shift:
      TShiftState; X, Y: Integer);
    procedure imgTitleMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
    procedure ClientAreaVerify(var Msg: TWMSettingChange); message WM_SETTINGCHANGE;
    procedure FormCreate(Sender: TObject);
    procedure cmdCancelClick(Sender: TObject);
    procedure FormResize(Sender: TObject);
  private
  public
    FSide: TAlignSide;
    FMoving: Boolean;
    FOldX: Integer;
    FOldY: Integer;
    FArea: TRect;
  end;

var
  frmSplash: TfrmSplash;

implementation

{$R *.DFM}

procedure TfrmSplash.imgTitleMouseDown(Sender: TObject; Button: TMouseButton; Shift:
  TShiftState; X, Y: Integer);
begin
  FMoving := True;
  FOldX := X;
  FOldY := Y;
end;

procedure TfrmSplash.imgTitleMouseUp(Sender: TObject; Button: TMouseButton; Shift:
  TShiftState; X, Y: Integer);
begin
  FMoving := False;
end;

procedure TfrmSplash.imgTitleMouseMove(Sender: TObject; Shift: TShiftState; X, Y:
  Integer);
var
  WorkArea: TRect;
begin
  if (SystemParametersInfo(SPI_GETWORKAREA, 0, @WorkArea, 0)) then
    FArea := WorkArea;
  if (FMoving) then
  begin
    FSide := [fasNone];
    if (((frmSplash.Left - (FOldX - X)) > (WorkArea.Left + MagneticField)) and
      ((frmSplash.Left - (FOldX - X) + frmSplash.Width) < (WorkArea.Right -
      MagneticField))) then
      frmSplash.Left := frmSplash.Left - (FOldX - X)
    else if ((frmSplash.Left - (FOldX - X)) <= (WorkArea.Left + MagneticField)) then
    begin
      frmSplash.Left := WorkArea.Left;
      FSide := FSide + [fasLeft];
    end
    else
    begin
      frmSplash.Left := WorkArea.Right - frmSplash.Width;
      FSide := FSide + [fasRight];
    end;
    if (((frmSplash.Top - (FOldY - Y)) > (WorkArea.Top + MagneticField)) and
      ((frmSplash.Top - (FOldY - Y) + frmSplash.Height) < (WorkArea.Bottom -
      MagneticField))) then
    begin
      frmSplash.Top := frmSplash.Top - (FOldY - Y);
      FSide := [fasNone];
    end
    else if ((frmSplash.Top - (FOldY - Y)) <= (WorkArea.Top + MagneticField)) then
    begin
      frmSplash.Top := WorkArea.Top;
      FSide := FSide + [fasTop];
    end
    else
    begin
      frmSplash.Top := WorkArea.Bottom - frmSplash.Height;
      FSide := FSide + [fasBottom];
    end;
    // Removes [fasNone] if anything else is found in FSide.
    if (((fasBottom in FSide) or (fasTop in FSide) or (fasLeft in FSide) or (fasRight
      in FSide)) and (fasNone in FSide)) then
      FSide := FSide - [fasNone];
  end;
end;

procedure TfrmSplash.ClientAreaVerify(var Msg: TWMSettingChange);
var
  WorkArea: TRect;
begin
  if (not (FMoving)) then
    if (SystemParametersInfo(SPI_GETWORKAREA, 0, @WorkArea, 0)) then
    begin
      if (fasLeft in FSide) then
        frmSplash.Left := WorkArea.Left;
      if (fasRight in FSide) then
        frmSplash.Left := WorkArea.Right - frmSplash.Width;
      if (fasTop in FSide) then
        frmSplash.Top := WorkArea.Top;
      if (fasBottom in FSide) then
        frmSplash.Top := WorkArea.Bottom - frmSplash.Height;
    end;
end;

procedure TfrmSplash.FormCreate(Sender: TObject);
begin
  // TO DO: Check if form is on one of the corners.
  FSide := [fasNone];
  FMoving := False;
end;

procedure TfrmSplash.cmdCancelClick(Sender: TObject);
begin
  Application.Terminate;
end;

procedure TfrmSplash.FormResize(Sender: TObject);
begin
  imgTitle.Width := bvlTitle.Width;
  bvlLine.Width := frmSplash.Width - (2 * bvlLine.Left);
  pbProgress.Width := frmSplash.Width - pbProgress.Left - bvlLine.Left;
  cmdCancel.Left := frmSplash.Width - cmdCancel.Width - cmdAbout.Left;
  cmdAbout.Top := frmSplash.Height - cmdAbout.Height - cmdAbout.Left;
  cmdCancel.Top := cmdAbout.Top;
  bvlLine.Top := cmdAbout.Top - bvlLine.Height;
end;

end.