How to read a TMemoField or TBlobField into a string

Problem/Question/Abstract:

I'd like to do something like this (myquery is a TQuery):

myquery.first;
while not myquery.eof do
begin
  writeln(myquery.fieldbyname('description').asstring);
  myquery.next;
end;

But since the field "description" is of type memo, I get this error : "invalid blob handle in record buffer".

Answer:

The contents of complex field types like BLOB and memo are not intended to be retrieved via the TField.AsString property, designed for use with the simple field type CHAR. There are other ways, though, to retrieve the memo data into a String variable.

One way is to use the TMemoField.Text property. For example:

{ ... }
if (Myquery.FieldByName('Description') is TMemoField) then
  StrVar := TMemoField(Myquery.FieldByName('Description')).Text
else
  StrVar := Myquery.FieldByName('Description').AsString;

Another way would be to use the Assign method of a an already-existing string list object. Parse the string list object to get individual lines. After creating a string list object (here named SL):

{ ... }
if (Myquery.FieldByName('Description') is TMemoField) then
begin
  SL.Assign(TMemoField(Myquery.FieldByName('Description')));
  {... parse string list }
end
else
  StrVar := Myquery.FieldByName('Description').AsString;

Still another way would be to extract the memo contents using a TBlobStream object. The TBlobStream.Read method will copy the contents from a memo field into a PChar (or equivalent) buffer, which can then be converted to a String value.

{ ... }
if (Myquery.FieldByName('Description') is TMemoField) then
begin
  BS := TBlobStream.Create(TMemoField(Myquery.FieldByName('Description')), bmRead);
  SizeOfMemoContents := BS.Size;
  YourPCharBuffer := AllocMem(SizeOfMemoContents + 1);
  BS.Read(YourPCharBuffer, SizeOfMemoContents);
  StrVar := StrPas(YourPCharBuffer);
  BS.Free;
  FreeMem(YourPCharBuffer);
  { do something with the retrieved string };
end
else
  { react to a non-memo field };

How to save 32 bit bitmaps in 24 bit bmp format

Problem/Question/Abstract:

How to save 32 bit bitmaps in 24 bit bmp format

Answer:

procedure SaveToFileBMP(const aBmp: TBitmap; aFileName: string);
var
  i, n, m, w: Integer;
  f: file;
  bmfh: BITMAPFILEHEADER;
  bmih: BITMAPINFOHEADER;
  p, p1: Pointer;
  pSrc: PIntArray;
begin
  if ExtractFileExt(aFileName) = '' then
    aFileName := aFileName + '.bmp';
  if GetDeviceCaps(aBmp.Canvas.Handle, BITSPIXEL) <> 32 then
  begin
    aBmp.SaveToFile(aFileName);
    Exit;
  end;
  with bmfh do
  begin
    bfType := Ord('M') shl 8 or Ord('B');
    bfSize := sizeOf(bmfh) + sizeOf(bmih) + aBmp.Width * aBmp.Height * 3;
    bfReserved1 := 0;
    bfReserved2 := 0;
    bfOffBits := sizeOf(bmfh) + sizeOf(bmih);
  end;
  with bmih do
  begin
    biSize := SizeOf(bmih);
    biWidth := aBmp.Width;
    biHeight := aBmp.Height;
    biPlanes := 1;
    biBitCount := 24;
    biCompression := BI_RGB;
    biSizeImage := 0;
    biXPelsPerMeter := 1; {don't care}
    biYPelsPerMeter := 1; {don't care}
    biClrUsed := 0;
    biClrImportant := 0;
  end;
  n := aBmp.Width;
  m := n * 3;
  if m mod 4 <> 0 then
    Inc(m, 4 - (m mod 4));
  GetMem(p, m);
  w := abmp.Width;
  BmpToArray(aBmp, Pointer(pSrc));
  AssignFile(f, aFileName);
  Rewrite(f, 1);
  BlockWrite(f, bmfh, SizeOf(bmfh));
  BlockWrite(f, bmih, SizeOf(bmih));
  for i := aBmp.Height - 1 downto 0 do
    {saving from bottom scanline to top because we set positive height value biHeight := aBmp.Height}
  begin
    p1 := @pSrc[w * i]; {let Delphi calculate necessary address of current scanline}
    asm
      push esi  {we must preserve all registers we use except EAX, EDX, ECX}
      push edi
      mov ecx, n  {ECX = count of colors in a scanline}
      mov esi, p1  {ESI = address of source (32 bit) scanline. Format of color 'ARGB'}
      mov edi, p  {EDI = address of destination (24 bit) scanline. Format of color 'RGB'}
    @L1:
      lodsd  {EAX = source color 'ARGB'}
      stosw  {sending AX register with 'GB' part}
      shr eax, 16  {AX = 'AR'}
      stosb  {sending AL register with 'R' part}
      loop @L1  {decrement counter (ECX) and jump @1 if not zero}
      pop edi  {restoring "spoiled" registers}
      pop esi
    end;
    {while we sent n colors, to file we write m colors, thus doing padding values
    of additional bytes do not matter}
    BlockWrite(f, p^, m);
  end;
  CloseFile(f);
  FreeMem(p);
  FreeMem(pSrc);
end;

Draw rich text transparently onto the canvas of a TBitmap

Problem/Question/Abstract:

I have e.g. a RichEdit that I want to underlay with a grid for character placement. TCanvas does not seem to be available for TRichedit So I draw the grid on the TForm behind the richedit. How can I make the RichEdit transparent or how can I assign a TCanvas to a TRichedit?

Answer:

Solve 1:

procedure OutputRTFtoBmp(RichHolder: TRichEdit; ImageHolder: TBitmap);
var
  Range: TFormatRange;
  TextBoundary: TRect;
begin
  {Setup the Height and Width of our output}
  ImageHolder.width := RichHolder.Width;
  ImageHolder.height := RichHolder.Height;
  if (bkGnd.Width <> 0) and (bkGnd.HEight <> 0) then
    imageholder.canvas.Draw(0, 0, bkGnd)
  else
    with imageholder.canvas do
    begin
      brush.Color := richholder.color;
      fillrect(cliprect);
    end;
  imageholder.canvas.Brush.Style := bsClear;
  {Set the Size of the Rich Edit}
  textboundary := rect(0, 0, RichHolder.Width * screen.Pixelsperinch,
    RichHolder.Height * screen.Pixelsperinch);
  {Set the Range record}
  range.hdc := ImageHolder.Canvas.handle;
  range.hdctarget := ImageHolder.Canvas.handle;
  range.rc := textboundary;
  range.rcpage := textboundary;
  {Start at character zero}
  range.chrg.cpMin := 0;
  {Display all Characters}
  range.chrg.cpMax := -1;
  {Ask RTF to Draw}
  Sendmessage(RichHolder.handle, EM_FORMATRANGE, 1, longint(@range));
  {Cleanup RTF Cache}
  sendmessage(RichHolder.handle, EM_FORMATRANGE, 0, 0);
end;


Solve 2:

This simply copies an RTF document to a canvas:

{ ... }
var
  Bitmap: TBitmap;
  RichEdit: TRichEdit;

function PrintToCanvas(FromChar, ToChar: integer): Longint;
var
  range: TFormatRange;
begin
  FillChar(Range, SizeOf(TFormatRange), 0);
  Range.hdc := Bitmap.Canvas.handle;
  Range.hdcTarget := Bitmap.Canvas.Handle;
  Range.rc.left := 0;
  Range.rc.top := 0;
  Range.rc.right := Bitmap.Width * 1440 div Screen.PixelsPerInch;
  Range.rc.Bottom := Bitmap.Height * 1440 div Screen.PixelsPerInch;
  Range.chrg.cpMax := ToChar;
  Range.chrg.cpMin := FromChar;
  Result := SendMessage(Richedit.Handle, EM_FORMATRANGE, 1, Longint(@Range));
  SendMessage(RichEdit.handle, EM_FORMATRANGE, 0, 0);
end;


Solve 3:

Try following source code:

procedure DrawRTF(Bitmap: TBitmap; X1, Y1, X2, Y2: Integer; RichEdit: TRichEdit);
const
  BitmapPixelsPerInch = 96;
  BitmapTwipsPerPixel = 1440 div BitmapPixelsPerInch;
var
  Range: TFormatRange;
begin
  with Range do
  begin
    {convert the coordinates to twips (1/1440") }
    hDC := Bitmap.Canvas.Handle; {DC handle}
    hdcTarget := Bitmap.Canvas.Handle; {ditto}
    rc := Rect(X1 * BitmapTwipsPerPixel, Y1 * BitmapTwipsPerPixel,
      X2 * BitmapTwipsPerPixel, Y2 * BitmapTwipsPerPixel);
    rcPage := rc;
    chrg.cpMin := 0;
    chrg.cpMax := -1; {RichEdit.GetTextLen;}
    {Free cached information}
    RichEdit.Perform(EM_FORMATRANGE, 0, 0);
    {First measure the text, to find out how high the format rectangle will be.
                The call sets fmtrange.rc.bottom to the actual height required, if all
                characters in the selected
    range will fit into a smaller rectangle.}
    RichEdit.Perform(EM_FORMATRANGE, 0, DWord(@Range));
    {Now render the text}
    RichEdit.Perform(EM_FORMATRANGE, 1, DWord(@Range));
    {Free cached information}
    RichEdit.Perform(EM_FORMATRANGE, 0, 0);
  end;
end;


Solve 4:

PaintTo draws the visible client area of a RichEdit control to the TCanvas. Use the following method to render the complete content to your TCanvas. DestDCHandle is TCanvas.Handle, R is the Rect in relation to your canvas, RichEdit is a TRichEdit instance (can be invisible), PixelsPerInch is the Resolution (for screen e.g. 96).

procedure DrawRTF(DestDCHandle: HDC; const R: TRect;
  RichEdit: TRichEdit; PixelsPerInch: Integer);
var
  TwipsPerPixel: Integer;
  Range: TFormatRange;
begin
  TwipsPerPixel := 1440 div PixelsPerInch;
  with Range do
  begin
    hDC := DestDCHandle; {DC handle}
    hdcTarget := DestDCHandle; {ditto}
    {Convert the coordinates to twips (1/1440")}
    rc.Left := R.Left * TwipsPerPixel;
    rc.Top := R.Top * TwipsPerPixel;
    rc.Right := R.Right * TwipsPerPixel;
    rc.Bottom := R.Bottom * TwipsPerPixel;
    rcPage := rc;
    chrg.cpMin := 0;
    chrg.cpMax := -1; {RichEdit.GetTextLen;}
    {Free cached information}
    RichEdit.Perform(EM_FORMATRANGE, 0, 0);
    {First measure the text, to find out how high the format rectangle will be.
                The call sets fmtrange.rc.bottom to the actual height required, if all
                characters in the selected range will fit into a smaller rectangle}
    RichEdit.Perform(EM_FORMATRANGE, 0, DWord(@Range));
    {Now render the text}
    RichEdit.Perform(EM_FORMATRANGE, 1, DWord(@Range));
    {Free cached information}
    RichEdit.Perform(EM_FORMATRANGE, 0, 0);
  end;
end;

Sample 1:

procedure TForm1.Button1Click(Sender: TObject);
var
  RichEdit: TRichEdit;
  bmp: TBitmap;
  DestDCHandle: HDC;
begin
  RichEdit := TRichEdit.Create(Self);
  try
    RichEdit.Visible := False;
    RichEdit.Parent := Self;
    {Win2k, WinXP}
    RichEdit.Lines.LoadFromFile('filename.rtf');
    bmp := TBitmap.Create;
    try
      bmp.width := 500;
      bmp.height := 500;
      DestDCHandle := bmp.Canvas.Handle;
      DrawRTF(DestDCHandle, Rect(0, 0, bmp.Width, bmp.Height), RichEdit, 96);
      Image1.Picture.Assign(bmp);
    finally
      bmp.Free;
    end;
  finally
    RichEdit.Free;
  end;
end;

Sample 2 (draw transparent):

procedure TForm1.Button1Click(Sender: TObject);
var
  RichEdit: TRichEdit;
  ExStyle: DWord;
  bmp: TBitmap;
  DestDCHandle: HDC;
begin
  RichEdit := TRichEdit.Create(Self);
  try
    RichEdit.Visible := False;
    RichEdit.Parent := Self;
    {Win2k, WinXP}
    ExStyle := GetWindowLong(RichEdit.Handle, GWL_EXSTYLE);
    ExStyle := ExStyle or WS_EX_TRANSPARENT;
    SetWindowLong(RichEdit.Handle, GWL_EXSTYLE, ExStyle);
    RichEdit.Lines.LoadFromFile('filename.rtf');
    bmp := TBitmap.Create;
    try
      bmp.LoadFromFile('filename.bmp');
      DestDCHandle := bmp.Canvas.Handle;
      {Win9x}
      SetBkMode(DestDCHandle, TRANSPARENT);
      DrawRTF(DestDCHandle, Rect(0, 0, bmp.Width, bmp.Height), RichEdit, 96);
      Image1.Picture.Assign(bmp);
    finally
      bmp.Free;
    end;
  finally
    RichEdit.Free;
  end;
end;

How to write on a canvas with a rotated font

Problem/Question/Abstract:

I would like to know how to write in any direction on a canvas : to write vertically or with any angle?

Answer:

Solve 1:

{ ... }
var
  LogRec: TLogFont;
  OldFontHandle, NewFontHandle: hFont;
begin
  with Canvas do
  begin
    Font := Self.Font;
    {create a rotated font based on the font object Font}
    GetObject(Font.Handle, SizeOf(LogRec), Addr(LogRec));
    LogRec.lfEscapement := FAngle * 10;
    LogRec.lfOutPrecision := OUT_DEFAULT_PRECIS;
    NewFontHandle := CreateFontIndirect(LogRec);
    {write text on a canvas}
    TextOut(ARect.Left, ARect.Top, Text)
      NewFontHandle := SelectObject(Canvas.Handle, OldFontHandle);
    DeleteObject(NewFontHandle);
  end;
end;


Solve 2:

Here's a procedure to draw rotated text. To call it, do something like:

{ ... }
Form1.Canvas.Brush.Style := bsClear;
TextRotate(Form1.Canvas, 'Rotated Text', W, H, Angle);

Where W and H are the x, y position at which to draw the text, and Angle is 0 - 359.

procedure TForm1.TextRotate(LocalCanvas: TCanvas; Text: string; X: Integer;
  Y: Integer; RotateAngle: Integer);
var
  LogFont: TLogFont;
begin
  {Get font information}
  GetObject(LocalCanvas.Handle, SizeOf(TLogFont), @LogFont);
  {The angle, in tenths of degrees, between the base line of a character and the x-axis}
  LogFont.lfEscapement := RotateAngle * 10;
  LogFont.lfUnderline := 0;
  LogFont.lfStrikeOut := 0;
  LogFont.lfWidth := 6;
  LogFont.lfHeight := 12;
  LogFont.lfItalic := 0;
  LogFont.lfQuality := PROOF_QUALITY;
  LogFont.lfFaceName := 'Times New Roman';
  LogFont.lfWeight := 400;
  {Assign the new rotated font handle}
  LocalCanvas.Font.Handle := CreateFontIndirect(LogFont);
  {Print the text}
  LocalCanvas.TextOut(X, Y, Text);
  DeleteObject(LocalCanvas.Font.Handle);
end;


Solve 3:

You want to display rotated text? For that you need to use a TrueType font (bitmap fonts cannot be rotated) and a little API to create a rotated font. TFont does not directly support it.

The following example shows how to print rotated text. The same principle works on other canvases.

procedure TForm1.Button3Click(Sender: TObject);
var
  lf: TLogfont;
begin
  with printer do
  begin
    begindoc;
    canvas.font.Name := 'Arial';
    canvas.font.Size := 24;
    canvas.textout(100, 100, 'This is a normal text');
    GetObject(canvas.font.handle, Sizeof(lf), @lf);
    lf.lfescapement := 450;
    lf.lforientation := 450;
    Canvas.Font.handle := CreateFontIndirect(lf);
    canvas.TextOut(100, 1500, 'This is a rotated text');
    EndDoc;
  end;
end;


Solve 4:

procedure TForm1.Button1Click(Sender: TObject);
var
  LogRec: TLogFont;
  OldFont, NewFont: HFont;
  i, X, Y: LongInt;
begin
  if pdPrinter.Execute then
  begin
    with Printer do
    begin
      GetObject(Canvas.Font.Handle, SizeOf(LogRec), @LogRec);
      BeginDoc;
      for i := 0 to 5 do
      begin
        LogRec.lfEscapement := (i * 60) * 10;
        LogRec.lfOutPrecision := OUT_TT_ONLY_PRECIS;
        LogRec.lfFaceName := 'Times New Roman';
        NewFont := CreateFontIndirect(LogRec);
        OldFont := SelectObject(Canvas.Handle, NewFont);
        Canvas.TextOut(100, 100, 'Hello World!');
        NewFont := SelectObject(Canvas.Font.Handle, OldFont);
        DeleteObject(NewFont);
      end;
      EndDoc;
    end;
  end;
end;

end.


Solve 5:

function GetRotatedFont(Canvas: TCanvas; RotationAngle: integer): HFont;
var
  LogFont: TLogFont;
begin
  GetObject(Canvas.Font.Handle, SizeOf(LogFont), @LogFont);
  with LogFont do
  begin
    if (RotationAngle <> lfEscapement) then
    begin
      if RotationAngle = 0 then
        lfOutPrecision := OUT_DEFAULT_PRECIS
      else
        lfOutPrecision := OUT_TT_ONLY_PRECIS;
      lfEscapement := RotationAngle;
      lfOrientation := lfEscapement;
    end;
  end;
  Result := CreateFontIndirect(LogFont);
end;


Solve 6:

{ ... }
var
  LogFont: TLogFont;
  fHandle: HFont;
begin
  try
    Printer.BeginDoc;
    {Create font}
    ZeroMemory(@LogFont, SizeOf(LogFont));
    LogFont.lfFaceName := 'Times New Roman';
    LogFont.lfHeight := 48;
    LogFont.lfWidth := 0; {Have font mapper choose}
    LogFont.lfEscapement := 300; {Angle in 1/10ths of a degree}
    LogFont.lfOrientation := 300; {Angle in 1/10ths of a degree}
    LogFont.lfQuality := DEFAULT_QUALITY;
    {Everything else as default}
    LogFont.lfOutPrecision := OUT_DEFAULT_PRECIS;
    LogFont.lfClipPrecision := CLIP_DEFAULT_PRECIS;
    fHandle := CreateFontIndirect(LogFont);
    {Select new font, print the text and delete font}
    SelectObject(Printer.Canvas.Handle, fHandle);
    Printer.Canvas.TextOut(100, 300, '30 degree text');
    DeleteObject(fHandle);
  finally
    Printer.EndDoc;
  end;
end;


Solve 7:

{ ... }
var
  FontName: string;
  NewFont: Integer;
  OldFont: Integer;
  { ... }
  with Printer.Canvas do
  begin
    FontName := Font.Name + #0;
    NewFont := CreateFont(Font.Height - 1, 0, 900, 0, FW_NORMAL, 0, 0, 0, DEFAULT_CHARSET, OUT_TT_PRECIS, CLIP_DEFAULT_PRECIS, PROOF_QUALITY, 4, @fontname[1]);
    OldFont := SelectObject(Handle, NewFont);
    TextOut(X, Y, Text);
    SelectObject(Handle, OldFont);
    DeleteObject(NewFont);
  end;
  { ... }

The value '900' is tenths of degrees.

Load a Unicode file into a TMemo

Problem/Question/Abstract:

Load a Unicode file into a TMemo

Answer:

procedure LoadUnicodeFile(const filename: string; strings: TStrings);

  procedure SwapWideChars(p: PWideChar);
  begin
    while p^ <> #0000 do
    begin
      p^ := WideChar(Swap(Word(p^)));
      Inc(p);
    end;
  end;

var
  ms: TMemoryStream;
  wc: WideChar;
  pWc: PWideChar;
begin
  ms := TMemoryStream.Create;
  try
    ms.LoadFromFile(filename);
    ms.Seek(0, soFromend);
    wc := #0000;
    ms.Write(wc, sizeof(wc));
    pWC := ms.Memory;
    if pWc^ = #$FEFF then {normal byte order mark}
      Inc(pWc)
    else if pWc^ = #$FFFE then
    begin {byte order is big-endian}
      SwapWideChars(pWc);
      Inc(pWc);
    end
    else
      ; {no byte order mark}
    strings.Text := WideChartoString(pWc);
  finally
    ms.free;
  end;
end;

Used like this:

LoadUnicodeFile(filename, memo1.lines);

How to change the colour luminance or brightness

Problem/Question/Abstract:

I am trying to write a routine that paints a box on the screen, but the edges of the box should be either lighter or darker then the color of the box. I want the routine to take a color, say clBlue, then paint the box in blue, and the top area in light blue and the bottom in dark blue, i.e. the same of clYellow, etc.. The brightness would change say 20%-40% each way. Using the Win32 Standard Color dialog, it is possible to set a custom color to say blue, then manipulate a scroll bar to see all the different brightness's (luminosity) of that color. Is it possible to write a routine in Delphi that takes two parameters, a color parameter, and a brightness % change, and returns a new color?

Answer:

It's possible. The HSL system that Windows uses is imperfect in that different colors having the same L value aren't all of the same perceived brightness. This makes it difficult to do brightness matching. I've put together some code that uses the CIE's L*,a*,b* system to provide a color coordinate system that does a much better job of matching the response of the human visual system.

To use the code, take your original RGB value, then divide each value by 255 so that the resulting numbers range from 0.0 to 1.0. Now feed these values to the RgbToLab function. This converts the RGB coordinates to LAB coordinates, where the first coordinate (L) is scaled from 0 to 100. So now you can modify that L value to change the brightness of the color, then feed the new LAB values to LabToRgb to convert back to RGB. Finally, multiply each of the final result values by 255 and round to the nearest integer.

unit uLabRgb;

interface

type
  TVector3 = array[1..3] of Double;

function LabToRgb(Lab: TVector3): TVector3;
function RgbToLab(Rgb: TVector3): TVector3;

implementation

type
  TMatrix3 = array[1..3, 1..3] of Double;

const
  RgbXyz: TMatrix3 = ((1, 0, 0), (0, 1, 0), (0, 0, 1));
  XyzRgb: TMatrix3 = ((1, 0, 0), (0, 1, 0), (0, 0, 1));
  { CCIR recommended values }
  PhosphorX: TVector3 = (0.64, 0.30, 0.15);
  PhosphorY: TVector3 = (0.33, 0.60, 0.06);
  WhitePoint: TVector3 = (0.95, 1.0000, 1.09);
  Gamma: Double = 1 / 0.45;

function MultiplyMatrix3ByVector3(const M: TMatrix3; const V: TVector3): TVector3;
var
  I: Integer;
  J: Integer;
begin
  for I := 1 to 3 do
  begin
    Result[I] := 0.0;
    for J := 1 to 3 do
      Result[I] := Result[I] + M[I, J] * V[J]
  end;
end;

function MultiplyMatrix3ByMatrix3(const M1, M2: TMatrix3): TMatrix3;
var
  I: Integer;
  J: Integer;
  K: Integer;
begin
  for I := 1 to 3 do
    for J := 1 to 3 do
    begin
      Result[I, J] := 0.0;
      for K := 1 to 3 do
        Result[I, J] := Result[I, J] + M1[I, K] * M2[K, J]
    end;
end;

function InvertMatrix3(const M: TMatrix3): TMatrix3;
var
  I: Integer;
  J: Integer;
  D: Double;

  function Next(I: Integer): Integer;
  begin
    Result := I + 1;
    if Result > 3 then
      Result := Result - 3
  end;

  function Prev(I: Integer): Integer;
  begin
    Result := I - 1;
    if Result < 1 then
      Result := Result + 3
  end;

begin
  D := 0;
  for I := 1 to 3 do
    D := D + M[1, I] * (M[2, Next(I)] * M[3, Prev(I)] - M[2, Prev(I)] * M[3, Next(I)]);
  FillChar(Result, SizeOf(Result), 0);
  for I := 1 to 3 do
    for J := 1 to 3 do
      Result[J, I] := (M[Next(I), Next(J)] * M[Prev(I), Prev(J)] - M[Next(I), Prev(J)] * M[Prev(I), Next(J)]) / D;
end;

function LabToXyz(const Lab: TVector3): TVector3;
var
  LL: Double;

  function Cube(X: Double): Double;
  begin
    if X >= (6 / 29) then
      Result := X * X * X
    else
      Result := (108 / 841) * (X - (4 / 29))
  end;

begin
  LL := (Lab[1] + 16) / 116;
  Result[1] := WhitePoint[1] * Cube(LL + Lab[2] / 500);
  Result[2] := WhitePoint[2] * Cube(LL);
  Result[3] := WhitePoint[3] * Cube(LL - Lab[3] / 200)
end;

function XyzToRgb(const Xyz: TVector3): TVector3;
var
  I: Integer;
begin
  Result := MultiplyMatrix3ByVector3(XyzRgb, Xyz);
  for I := 1 to 3 do
    if Result[I] <= 0.0 then
      Result[I] := 0
    else
      Result[I] := Exp(Ln(Result[I]) / Gamma)
end;

function LabToRgb(Lab: TVector3): TVector3;
begin
  Result := XyzToRgb(LabToXyz(Lab))
end;

function RgbToXyz(const Rgb: TVector3): TVector3;
var
  I: Integer;
begin
  Result := Rgb;
  for I := 1 to 3 do
    if Result[I] <= 0.0 then
      Result[I] := 0
    else
      Result[I] := Exp(Ln(Result[I]) * Gamma);
  Result := MultiplyMatrix3ByVector3(RgbXyz, Result)
end;

function XyzToLab(const Xyz: TVector3): TVector3;
var
  YY: Double;

  function CubeRoot(X: Double): Double;
  begin
    if X >= (216 / 24389) then
      Result := Exp(Ln(X) / 3)
    else
      Result := (841 / 108) * X + (4 / 29)
  end;

begin
  YY := CubeRoot(Xyz[2] / WhitePoint[2]);
  Result[1] := 116 * YY - 16;
  Result[2] := 500 * (CubeRoot(Xyz[1] / WhitePoint[1]) - YY);
  Result[3] := 200 * (YY - CubeRoot(Xyz[3] / WhitePoint[3]))
end;

function RgbToLab(Rgb: TVector3): TVector3;
begin
  Result := XyzToLab(RgbToXyz(Rgb))
end;

procedure InitTransformationMatrices;
var
  I: Integer;
  J: Integer;
  PhosphorZ: TVector3;
  C: TVector3;
  CToXyz: TMatrix3;
  XyzToC: TMatrix3;
begin
  for I := 1 to 3 do
  begin
    CToXyz[1, I] := PhosphorX[I];
    CToXyz[2, I] := PhosphorY[I];
    CToXyz[3, I] := 1 - PhosphorX[I] - PhosphorY[I]
  end;
  XyzToC := InvertMatrix3(CToXyz);
  C := MultiplyMatrix3ByVector3(XyzToC, WhitePoint);
  for I := 1 to 3 do
    for J := 1 to 3 do
      RgbXyz[I, J] := CToXyz[I, J] * C[J];
  XyzRgb := InvertMatrix3(RgbXyz)
end;

initialization
  InitTransformationMatrices;

end.

Align cells in a TStringGrid (2)

Problem/Question/Abstract:

I need to right-align text in certain cells of a TStringGrid. How can I do that?

Answer:

Solve 1:

procedure TForm1.StringGrid1DrawCell(Sender: TObject; ACol, ARow: Integer;
  Rect: TRect; State: TGridDrawState);
var
  dx: integer;
  Text: string;
begin
  if aCol in [1..2] then {If column is 1 or 2, then right-align text}
    with StringGrid1.Canvas do
    begin
      FillRect(Rect);
      Text := StringGrid1.cells[aCol, aRow];
      dx := TextWidth(Text) + 2;
      TextOut(Rect.Right - dx, Rect.Top, Text);
    end;
end;


Solve 2:

procedure TForm1.StringGrid1DrawCell(Sender: TObject; ACol, ARow: Integer;
  Rect: TRect; State: TGridDrawState);
const
  CharOffset = 3;
var
  fLeft: Integer;
begin
  {Right justify column 3}
  if (ACol = 3) then
  begin
    with TStringGrid(Sender) do
    begin
      Canvas.FillRect(Rect);
      fLeft := Rect.Right - Canvas.TextWidth(Cells[ACol, ARow]);
      Canvas.TextOut(fleft - CharOffset, Rect.Top + CharOffset, Cells[ACol, ARow]);
    end;
  end;
end;


Solve 3:

The following code aligns the strings of the first column in a TStringGrid to the right:

procedure DrawTheText(ACanvas: TCanvas; ARect: TRect;
  AValue: string; AAlign: TAlignment);
var
  horzOffset: integer;
  options: integer;
  vertOffset: integer;
begin
  {Note: The Handle property of TCanvas is the handle of its DC.}
  with ACanvas do
  begin
    vertOffset := ARect.Top + (((ARect.Bottom - ARect.Top) -
                        TextExtent(AValue).CY) div 2);
    horzOffset := TextExtent('Mi').CX div 4;
      {Yields rougly the width of an "average" character}
    options := ETO_CLIPPED or ETO_OPAQUE;
    case AAlign of
      taLeftJustify:
        begin
          SetTextAlign(Handle, TA_LEFT or TA_TOP or TA_NOUPDATECP);
          ExtTextOut(Handle, ARect.Left + horzOffset, vertOffset, options,
            @ARect, PChar(AValue), Length(AValue), nil);
        end;
      taRightJustify:
        begin
          SetTextAlign(Handle, TA_RIGHT or TA_TOP or TA_NOUPDATECP);
          ExtTextOut(Handle, ARect.Right - horzOffset, vertOffset, options,
            @ARect, PChar(AValue), Length(AValue), nil);
        end;
      taCenter:
        begin
          horzOffset := ((ARect.Right - ARect.Left) - TextExtent(AValue).CX) div 2;
          SetTextAlign(Handle, TA_LEFT or TA_TOP or TA_NOUPDATECP);
          ExtTextOut(Handle, ARect.Left + horzOffset, vertOffset, options,
            @ARect, PChar(AValue), Length(AValue), nil);
        end;
    end;
  end;
end;

procedure TFrmAlignText.StringGridDrawCell(Sender: TObject; Col, Row: Integer;
  Rect: TRect; State: TGridDrawState);
var
  align: TAlignment;
  theText: string;
  thisRect: TRect;
begin
  {Assumes that DefaultDrawing := true}
  theText := IntToStr(Col) + ':' + IntToStr(Row);
  align := taLeftJustify;
  {Select background color}
  if gdSelected in State then
    StringGrid.Canvas.Brush.Color := clHighlight
  else if gdFixed in State then
    StringGrid.Canvas.Brush.Color := clBtnFace
  else
    StringGrid.Canvas.Brush.Color := clWindow;
  {Determine font/text attributes}
  StringGrid.Canvas.Font.Color := clBlack;
  StringGrid.Canvas.Font.Style := StringGrid.Canvas.Font.Style - [fsBold];
  if Col = 1 then
  begin
    align := taRightJustify;
    StringGrid.Canvas.Font.Style := StringGrid.Canvas.Font.Style + [fsBold];
    StringGrid.Canvas.Font.Color := clRed;
    StringGrid.Canvas.Font.Name := 'Courier New';
  end
  else if Col = 2 then
  begin
    align := taCenter;
    StringGrid.Canvas.Font.Style := StringGrid.Canvas.Font.Style + [fsBold]
  end
  else if (Row = 0) and (Col = 0) then
  begin
    StringGrid.Canvas.Draw(Rect.Left + 2, Rect.Top + 2, Image.Picture.Graphic);
  end;
  if not ((Row = 0) and (Col = 0)) then
    DrawTheText(StringGrid.Canvas, Rect, theText, align);
  {Draw focus rectangle}
  if gdFocused in State then
    StringGrid.Canvas.DrawFocusRect(Rect);
  if gdFixed in State then
    Frame3D(StringGrid.Canvas, Rect, clWindow, clHighlight, 1);
end;

Form design for different screen resolutions

Problem/Question/Abstract:

I'm designing my forms for multiple screen resolutions and I'm going through a major problem. I'm designing at 800x600 and when the screen resolution increases the form looks Ok, but when it decreases (640x480) some of my components get wild. They don't seem to follow the same pattern when they get smaller.

Answer:

Solve 1:

I think you are using the wrong approach. If you just proportionally resize your form and anything on it you do not usually meet the users requirements. If he uses a higher screen resolution he usually wants to see more information on the screen, not just the same information displayed larger.

I design forms always in large font mode (120 dpi), use only true-type fonts (Arial 8 or 9 pt as form default) and set the forms Scaled property to false. If the form has controls that can benefit from being resized larger to show more information (memos and grids mostly) I use the bsSizeable border style and set the controls Anchors (or use Align) to make them track changes in the form size automatically. If the controls cannot be resized with any benefit the form gets the bsDialog border style. If the form is larger than 600x400 I conduct a test for the workarea size (SystemParametersInfo(SPI_GETWORKAREA ...)) and if it is smaller than the form the form is resized to the workarea size, its AutoScroll property is set to True so it sprouts scrollbars. This may not look too great but it makes all of the controls accessible to the user and is far better than proportionally shrinking the form and end up with a font size that is practically unreadable. The Windows font mapper also deviates from strict proportionality for smaller font sizes, these are rendered a bit larger than one would expect to improve legibility. And if you use non-truetype fonts the mapper may even substitute a larger font since the one you require is not available in the requested size. This totally screws up the form layout if you use controls with Autosize true (edit control standard, for example).


Solve 2:

From Borland (issues to bear in mind when scaling Delphi forms on different screen resolutions):

Decide early in the form design stage whether you're going to allow the form to be scaled or not. The advantage of not scaling is that nothing changes at runtime. The disadvantage of not scaling is that nothing changes at runtime (your form may be far too small or too large to read on some systems if it is not scaled).
If you're NOT going to scale the form, set Scaled to False. Otherwise, set the Form's Scaled property to True.
Set AutoScroll to False. AutoScroll = True means 'don't change the form's frame size at runtime' which doesn't look good when the form's contents do change size.
Set the form's font to a scaleable TrueType font, like Arial. Only Arial will give you a font within a pixel of the desired height. NOTE: If the font used in an application is not installed on the target computer, then Windows will select an alternative font within the same font family to use instead.
Set the form's Position property to something other than poDesigned. poDesigned leaves the form where you left it at design time, which for me always winds up way off to the left on my 1280 x 1024 screen - and completely off the 640 x 480 screen.
Don't crowd controls on the form - leave at least 4 pixels between controls, so that a one pixel change in border locations (due to scaling) won't show up as ugly overlapping controls.
For single line labels that are alLeft or alRight aligned, set AutoSize to True. Otherwise, set AutoSize to False.
Make sure there is enough blank space in a label component to allow for font width changes - a blank space that is 25% of the length of the current string display length is a little too much, but safe. (You'll need at least 30% expansion space for string labels if you plan to translate your app into other languages) If AutoSize is False, make sure you actually set the label width appropriately. If AutoSize is True, make sure there is enough room for the label to grow on its own.
In multi-line, word-wrapped labels, leave at least one line of blank space at the bottom. You'll need this to catch the overflow when the text wraps differently when the font width changes with scaling. Don't assume that because you're using large fonts, you don't have to allow for text overflow - somebody else's large fonts may be larger than yours!
Be careful about opening a project in the IDE at different resolutions. The form's PixelsPerInch property will be modified as soon as the form is opened, and will be saved to the DFM if you save the project. It's best to test the app by running it standalone, and edit the form at only one resolution. Editing at varying resolutions and font sizes invites component drift and sizing problems. Make sure that you set your PixelsPerInch for all your forms to 120. It defaults at 96, which causes scaling problems at a lower resolution.
Speaking of component drift, don't rescale a form multiple times, at design time or a runtime. Each rescaling introduces roundoff errors which accumulate very quickly since coordinates are strictly integral. As fractional amounts are truncated off control's origins and sizes with each successive rescaling, the controls will appear to creep northwest and get smaller. If you want to allow your users to rescale the form any number of times, start with a freshly loaded/created form before each scaling, so that scaling errors do not accumulate.
In general, it is not necessary to design forms at any particular resolution, but it is crucial that you review their appearance at 640x480 with small fonts and large, and at a high-resolution with small fonts and large before releasing your app. This should be part of your regular system compatibility testing checklist.
Pay close attention to any components that are essentially single-line TMemos - things like TDBLookupCombo. The Windows multi-line edit control always shows only whole lines of text - if the control is too short for its font, a TMemo will show nothing at all (a TEdit will show clipped text). For such components, it's better to make them a few pixels too large than to be one pixel too small and show not text at all.
Keep in mind that all scaling is proportional to the difference in the font height between runtime and design time, NOT the pixel resolution or screen size. Remember also that the origins of your controls will be changed when the form is scaled - you can't very well make components bigger without also moving them over a bit.


Solve 3:

To ensure that your projects will work with both large and small fonts you want to do exactly this: Develop using small font with TForm.AutoScroll = False. This is how we develop the IDE itself and have so for years


Solve 4:

On form scaling and the large fonts/ small fonts issue:

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 runtime 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 propery 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. This is my favourite since large fonts is my default setting (I am myopic). 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 800x600 the user will have a problem if he is running 640x480. 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 shoulds resize itself to the screen size (or better the workarea 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.

How to retrieve selected rows in a TDBGrid

Problem/Question/Abstract:

How can I retrieve the text displayed in selected rows? Whenever I inspect the TDBGrid - SelectedRows property I find:
1) TDBGrid - SelectedRows - Count as the number of rows selected in the grid.
2) Iterating through the TDBGrid - SelectedRows - Items[i] property I get blank strings.
What should I get when I read a Bookmark?

Answer:

You try to inspect a bookmark, not the record the bookmark points to. Try this:


{ ... }
var
  i: integer;
begin
  for i := 0 to DBGrid1.SelectedRows.Count - 1 do
  begin
    Table1.GoToBookmark(TBookmark(DBGrid1.SelectedRows[i]));
    Memo1.Lines.Add(Table1.Fields[0].AsString); {process the record}
  end;
end;

Performing Custom Actions on WebBroser.Document's OnClick Event

Problem/Question/Abstract:

The TWebBrowser-object is a great way to display offline html-files within your application. Sometimes it would be nice to react within your delphi-application when the user clicks on a link in the html-view...

Answer:

An onclick event occurs on every HTMLElement on HTMLDocument object whenever a left mouse button pressed and released. This event does not apply for just 'A' tag only. It then bubbled, traversing to its parent. This eases us a bit to accomplish the task by intercepting onclick event on HTMLDocument instead of attaching our handler to each of HTML anchor element (IHTMLAnchorElement). We then can examine on what HTML element the event actually occur.

Using JavaScript to interact with IE DOM, you'll probably write your code like this:

<script language="JavaScript"><!--
function DocumentClicked()
{
  var e = /* window. */event.srcElement;
  // do something with e
  alert(e.tagName);
  return false;
}
//--></script>
<body ... onclick="DocumentClicked()">

Returning false for that function tells IE not to bubble this event and don't perform any of its default action.

When using OLE Automation to control a separately running instance of an application, you will need to create a mechanism to respond to events triggered by that ActiveX object. To create this mechanism, commonly referred to as an event sink.

To achieve the same result with Delphi, it is obvious that we need to capture COM events from Internet Explorer object. Fortunately there is excellent utility made by Binh Ly called EventSinkImp. EventSinkImp is a free utility (comes with full source code for enthusiasts) that imports COM connection point-based event interfaces for ease of use in Delphi applications. EventSinkImp creates stub classes/components that publishes event methods as native Delphi events so that you can easily build applications that need to capture COM-based events from Delphi, Visual Basic, or Visual C++ server COM components.

Actually I quoted the above phrase from EventSinkImp help file:). You can download it from http://www.techvanguards.com/products/eventsinkimp.

Use EventSinkImp utility to generate the Pascal unit file for "Microsoft HTML Object Library" (exposed from %SYSTEM%\mshtml.tlb). With its default options, it will create "MSHTMLEvents.pas" stored in $(DELPHI)\Imports folder. This unit wraps Sink events into TComponent descendant objects and creates RegisterComponents procedure for them so they can appear in ActiveX component palette.

Now let's start Sink something. First we must instantiate a SinkComponent. Drop a TMSHTMLHTMLDocumentEvents component on the Form, or create it at run-time. Here I do the later:

uses...
  , MSHTMLEvents { generated by EventSinkImp utility }
  , SHDocVw { or SHDocVW_TLB                    }
  , mshtml { or MSHTML_TLB                     }
  ;
type
  TForm1 = class(TForm)
    WebBrowser1: TWebBrowser;
    ...
    private
    FSinkComponent: TMSHTMLHTMLDocumentEvents;
    function DocumentOnClick(Sender: TObject): WordBool;
  end;
  {  ... }

procedure TForm1.FormCreate(Sender: TObject);
begin
  FSinkComponent := TMSHTMLHTMLDocumentEvents.Create(Self);
end;

Then we must hook up this event sink to an object which HTMLElements (objects which implements IHTMLElement) reside. It is WebBroser1.Document and it implements IHTMLDocument2 interface. We start to hook up using the following syntax:

FSinkComponent.Connect(WebBrowser1.Document as IHTMLDocument2);
FSinkComponent.onclick := DocumentOnClick;

To unhook, use the following syntax:

FSinkComponent.Disconnect;

Remember that WebBrowser1.Document must contain a valid document prior to calling FSinkComponent.Connect(). WebBrowser1.Document is nil by default and this is not valid parameter for FSinkComponent.Connect() method which expecting an IUnknown object. You can open an URL or just load 'about:blank' page to make the Document valid. My suggestion is call Connect() from WebBrowser1.OnNavigateComplete2 event and optionally call Disconnect() from WebBrowser1.BeforeNavigate2 event.

From this point we can perform a special action whenever an onclick event occurs in WebBrowser1.Document. In the sample above, DocumentOnClick() method will be called. Remember to assign False for its Result unless you want IE to perform the default action for this event.

function TForm1.DocumentOnClick(Sender: TObject): WordBool;
begin
  // do whatever necessary here
  Result := False;
end;

To make something meaningful, let's create a special HTML tag for our HTML document. This tag is special because it contains custom attributes. Later we can retrieve these attributes value to perform an appropriate action. Any HTML tag will do fine as long as IE able to render it visible. I picked the 'A' tag for this purpose because everyone already know that an underlined HTML text is clickable. Here is the sample of our special tags with just one custom attribute:

  <a href="#SomeBogusURL" ActionID="3">Click here!!!</a>
  <br>
  <a href="#SomeBogusURL" ActionID="23">And also here!!!</a>

The custom attribute name is "ActionID". Actually we can also use the "HREF" attribute for this purpose, but I decided not to mess with the standard attributes. We need to adjust the onclick handler. It now looks like this:

function TForm1.DocumentOnClick(Sender: TObject): WordBool;
var
  Element: IHTMLElement;
  ActionID: OleVariant;
begin
  Result := True;
  // find out on what element this event occured
  Element := (TMSHTMLHTMLDocumentEvents(Sender).Source as
    IHTMLDocument2).parentWindow.event.srcElement;
  // We are interesting for elements with 'A' tag, but quite often
  // there are other elements (HTML tags) between <a> and </a>
  // tags which are actually receive the click.
  // Thus we cannot simply check with syntax:
  //    if AnchorElement.tagName = 'A' then ...
  // ... needs a bit more effort to check and we'll traverse if
  // necessary.

  while (Element <> nil) and (Element.tagName <> 'A') do
    Element := Element.Get_parentElement;

  if Element <> nil then
  begin
    // Element is a valid HTMLElement and it is an anchor element.
    // It also implements IHTMLAnchorElement interface in case you need
    // something with that interface.
    // Now we need to examine the value for 'ActionID' attribute
    ActionID := Element.getAttribute('ActionID', 0);
    if TVarData(ActionID).VType = varOleStr then
    begin
      PerformAnActionBasedOnActionID(StrToInt(ActionID));
      Result := False;
    end
    else
      // Attribute ActionID does not exist
      ;
  end;
end;

Hope you got the picture. You can put as many custom attributes as necessary to feed the Delphi code. For example:

  <a href="#" ActionStr="ShowForm" FormName="fmDlg1"
    ShowModal="True">Preference Options</a><br>
  <a href="#" ActionStr="ShowForm" FormName="fmDlg2"
    ShowModal="False">Preview</a><br>
  <a href="#" ActionStr="MessageBox" MsgStr="Hello&#13;World!"
    MsgCaption="A DlgBox" MsgIcon="1">bla bla</a>

And here is the sample custom HTML tags other than 'A' tag.

  <div align="center" ActionID="3" style="cursor:hand">Click me</div>
  <ul>
    <li ActionID="13" style="cursor:hand">Item 1</li>
    <li ActionID="14" style="cursor:hand">Item 2</li>
  </ul>

Go imagine yourself what to do with those attribute values!

I highlight 2 important properties and methods of IHTMLElement object to retrieve the HTML Tag name and attribute value. They are tagName and getAttribute(). The tagName property is already self-explained. I'll give a summarized description of getAttribute() method, quoted from MS Internet Development SDK:

IHTMLElement.getAttribute(
  const strAttributeName: WideString; // specifies the name of the
  // attribute
  lFlags: Integer // specifies one or more of the following flags:
  // 0: Default. Performs a property search that is not
  //    case-sensitive, and returns an interpolated
  //    value if the property is found.
  // 1: Performs a case-sensitive property search.
  //    To find a match, the uppercase and lowercase
  //    letters in strAttributeName must exactly
  //    match those in the attribute name. If the
  //    lFlags parameter for IHTMLStyle::getAttribute
  //    is set to 1 and this option is set to 0
  //    i(default), the specified property name
  //    might not be found.
  // 2: Returns the value exactly as it was set in
  //    script or in the source document.
  ): OleVariant;

Result is OleVariant type. It is a pointer to a VARIANT that returns  a BSTR, number, or VARIANT_BOOL value as defined by the attribute.  If the attribute is not present, this method returns nil.

One more question, how touse this example with frame set?

Basically, all you need to do is hook the SinkComponent to the document within the frame instead of WebBrowser.Document.

Suppose you interest in document within frameset's frame named 'frame1', your code will look like this:

procedure TForm1.WebBrowser1NavigateComplete2(Sender: TObject;
  const pDisp: IDispatch; var URL: OleVariant);
var
  MainDoc, DocumentInFrame: IHTMLDocument2;
  FrameName: OleVariant;
begin
  MainDoc := WebBrowser1.Document as IHTMLDocument2;
  FrameName := 'frame1';
  DocumentInFrame := (IDispatch(MainDoc.Get_frames.item(FrameName)) as
    IHTMLWindow2).document;
  FSinkComponent.Connect(DocumentInFrame);
  {  ... }
end;

This article comes with a downloadable demo source code. This demo shows you how the click on HTML anchors will interact with Delphi's TForm.

It will help a lot if you know some MS Internet Explorer Document Object Model (IE DOM) basic. That topic does not covered here or in demo source code. The complete coverage is available at MSDN online. To learn about COM/OLE Automation/Event Sink stuff in Delphi/BCB environment, please visit Binh Ly website. There are excellent articles, tutorials, sample codes, and load of downloadable goodies.


Component Download: WBOnClickEventSink.zip

Highlighting a Row in a DBGrid

Problem/Question/Abstract:

How do I highlight a row in a TDBGrid based on the value of field?

Answer:

This question begs for a short bit of a philosophical discourse before I actually answer the question. Really, I'm not just tooting my horn... it's actually valid <G>

Cue It Up

Providing visual cues for users in your applications is an important part of good interface design. Visual cues allow the user to immediately identify and differentiate special circumstances that may occur within the course of an application&#8217;s session. For instance, in a column of numbers, it&#8217;s easier to tell the difference between positive and negative values at first glance if the negative numbers are either a different color or enclosed in parentheses. In the table below, the left column contains positive and negative numbers with the negative number merely represented by their negative sign. The right column represents negative numbers in red boldface text. Let's take a look.

10015
15486
-54862
54846
78948
40594
-45945
78945
10015
15486
-54862
54846
78948
40594
-45945
78945


As you can see, it is far easier to discern the negative values in the right column than it is to discern them in the left column.

The point to all this is that if you build programs or interfaces which will be viewed by a lot of people, it's a good idea to do the extra bit of work to make the job of interpreting what's in your interface that much easier.

Let's Get Down to Business
See? I told you it wasn't going to take a long time... In any case, let's get back to the topic... Highlighting a row in a TDBGrid based on the value of a particular field is a perfect example of providing visual cues for your users. But with this particular operation, it's not as intuitive as you might think; not that it's hard, but I had to do a bit of digging to get the answer for this one.

At first glance, I thought why not just put some code in the OnCalcFields event. Okay, okay... bad thought. So lo and behold I saw the OnDrawDataCell event. Unfortunately, I found out that OnDrawColumnCell replaced it in the 32-bit versions of Delphi, so I had to turn that way. No problem. I found a bit of code in Neil Rubenking's book, "Delphi Programming Problem Solver," and that got me started. Let's talk concepts first...

Behind the Scenes
I didn't know much detail information about the TDBGrid component until I studied the VCL source code in DBGrids.PAS. And what I discovered was rather interesting. To draw itself, TDBGrid performs a lot of canvas manipulation. And while it happens rather fast, each cell in the grid is drawn individually. Essentially, the grid gets the dimensions of each cell and feeds that information into a TRect structure. Then that is passed to various drawing functions to display the text. Yikes! You ought to see the DrawCell method - it's big! Good for us that it's pretty fast at executing...

Drawing the Cell
As it turns out, the way painting occurs is pretty straight forward. Delphi progresses through the grid row-by-row. In each row, it then iterates through each cell, drawing the background and text within the cell's bounding rectangle. So, to highlight a row, we actually have to highlight each cell of the row, and that's handled through the OnDrawColumnCell event and a little code.

Study the code sample below, and we'll discuss it immediately after the listing:

procedure TForm1.DBGrid1DrawColumnCell(Sender: TObject;
  const Rect: TRect; DataCol: Integer; Column: TColumn;
  State: TGridDrawState);
begin
  with Sender as TDBGrid, DataSource.DataSet do
    if (FieldByName('AmountPaid').AsFloat > 15000) then
      DrawField(Column.Field.DisplayText, Rect, Canvas,
        Column.Font, Column.Alignment, [fsBold],
        clYellow, clRed);
end;

{This is the workhorse routine that does the drawing.}

procedure TForm1.DrawField(const Value: string;
  const Rect: TRect;
  vCanvas: TCanvas;
  vFont: TFont;
  vAlignment: TAlignment;
  FontStyle: TFontStyles;
  FontColor: TColor;
  BGColor: TColor);
var
  I: Integer;
begin
  I := 0;

  //First, fill in the background color of the cell
  vCanvas.Brush.Color := BGColor;
  vCanvas.FillRect(Rect);
  //SetBkMode ensures that the background is transparent
  SetBkMode(Canvas.Handle, TRANSPARENT);

  //Set the passed font properties
  vCanvas.Font := vFont;
  vCanvas.Font.Color := FontColor;
  vCanvas.Font.Style := vCanvas.Font.Style + FontStyle;

  //Set Text Alignment
  case vAlignment of
    taRightJustify:
      begin
        SetTextAlign(vCanvas.Handle, TA_RIGHT);
        I := Rect.Right - 2;
      end;

    taLeftJustify:
      begin
        SetTextAlign(vCanvas.Handle, TA_LEFT);
        I := Rect.Left + 2;
      end;

    taCenter:
      begin
        SetTextAlign(vCanvas.Handle, TA_CENTER);
        I := (Rect.Right + Rect.Left) div 2;
      end;
  end; { case }

  //Draw the text
  vCanvas.TextRect(Rect, I, Rect.Top + 2, Value);
  SetTextAlign(vCanvas.Handle, TA_LEFT);
end;

The code above is an excerpt from a form unit that I created. On the form, I've got a TTable, TDataSource, and a TDBGrid dropped onto it. The TTable points to the DBDEMOS alias, and is linked to the ORDERS.DB table. It's really simple.

Anyway, what's going in the code? What we're doing in the event handler code is merely adding a little functionality to the default cell drawing methodology by calling the DrawField method of the Form1. Since we're riding on the assumption that the DBGrid iterates row-by-row, while at the same time checking and refreshing its datalinks, we can use that to check the value of a field as DBGrid iterates - in this case, the AmountPaid field - to see if we need to highlight the row. I won't go into specific details about the DataField method. It's pretty straight-forward. However, I will point out the most important thing, and that's the first part of the method:

//First, fill in the background color of the cell
vCanvas.Brush.Color := BGColor;
vCanvas.FillRect(Rect);
//SetBkMode ensures that the background is transparent
SetBkMode(Canvas.Handle, TRANSPARENT);

Here, I'm filling in the background of the cell. If I didn't call SetBkMode immediately after the FillRect method, the row would show up completely solid with no text displayed. In any case, try this out and see how it works for you. Well... we're actually not done yet....

I Just Can't Get No Satisfaction

After I wrote this code, I just wasn't satisfied with it. Why? The reason is because I take object-oriented programming seriously, and I realized that the proper way to introduce this type of functionality into a DBGrid would be to actually make a component that had the capability built into it. That way, I wouldn't have to rewrite the code each time I wanted to have this functionality. So that's what I did...

The code listing below is the complete listing of TEnhDBGrid. I'll talk particulars after I give you the listing.

unit EnhDBGrid;

interface

uses
  Windows, Classes, Graphics, Grids, DBGrids;

type
  TEnhDBGrid = class(TCustomDBGrid)
  private
    FHighlightBGColor: TColor;
    FHighlightFont: TFont;
    FDoRowHighlight: Boolean;
    procedure DrawField(const Value: string;
      const Rect: TRect;
      vCanvas: TCanvas;
      const vFont: TFont;
      vAlignment: TAlignment;
      const FontStyle: TFontStyles;
      const FontColor: TColor;
      const BGColor: TColor);
  protected
    procedure DrawColumnCell(const Rect: TRect;
      DataCol: Integer;
      Column: TColumn;
      State: TGridDrawState); override;
    procedure SetHighlightFont(Value: TFont);
  public
    constructor Create(AOwner: TComponent); override;
    property Canvas;
    property SelectedRows;
    property DoRowHighLight: Boolean read FDoRowHighLight
      write FDoRowHighlight
      default False;
  published
    property Align;
    property BorderStyle;
    property Color;
    property Columns stored False; //StoreColumns;
    property Ctl3D;
    property DataSource;
    property DefaultDrawing;
    property DragCursor;
    property DragMode;
    property Enabled;
    property FixedColor;
    property Font;
    property HighlightBGColor: TColor read FHighlightBGColor
      write FHighlightBGColor;
    property HighlightFont: TFont read FHighlightFont
      write SetHighlightFont;
    property ImeMode;
    property ImeName;
    property Options;
    property ParentColor;
    property ParentCtl3D;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ReadOnly;
    property ShowHint;
    property TabOrder;
    property TabStop;
    property TitleFont;
    property Visible;
    property OnCellClick;
    property OnColEnter;
    property OnColExit;
    property OnColumnMoved;
    property OnDrawDataCell; { obsolete }
    property OnDrawColumnCell;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEditButtonClick;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
    property OnStartDrag;
    property OnTitleClick;
  end;

procedure Register;

implementation

constructor TEnhDBGrid.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  //Give the highlight font a default value
  FHighlightFont := TFont.Create;
end;

procedure TEnhDBGrid.DrawField(const Value: string;
  const Rect: TRect;
  vCanvas: TCanvas;
  const vFont: TFont;
  vAlignment: TAlignment;
  const FontStyle: TFontStyles;
  const FontColor: TColor;
  const BGColor: TColor);
var
  I: Integer;
begin
  I := 0;

  //First, fill in the background color of the cell
  vCanvas.Brush.Color := BGColor;
  vCanvas.FillRect(Rect);
  //SetBkMode ensures that the background is transparent
  SetBkMode(Canvas.Handle, TRANSPARENT);

  //Now draw out the text in the cell
  vCanvas.Font := vFont;
  vCanvas.Font.Color := FontColor;
  vCanvas.Font.Style := vCanvas.Font.Style + FontStyle;

  //Now set the text alignment
  case vAlignment of {  }
    taRightJustify:
      begin
        SetTextAlign(vCanvas.Handle, TA_RIGHT);
        I := Rect.Right - 2;
      end;

    taLeftJustify:
      begin
        SetTextAlign(vCanvas.Handle, TA_LEFT);
        I := Rect.Left + 2;
      end;

    taCenter:
      begin
        SetTextAlign(vCanvas.Handle, TA_CENTER);
        I := (Rect.Right + Rect.Left) div 2;
      end;
  end; { case }
  //Write the text!!!
  vCanvas.TextRect(Rect, I, Rect.Top + 2, Value);
  //Necessary step to align rest of the text in the DBGrid
  SetTextAlign(vCanvas.Handle, TA_LEFT);
end;

procedure TEnhDBGrid.DrawColumnCell(const Rect: TRect;
  DataCol: Integer; Column: TColumn;
  State: TGridDrawState);
begin
  //Do the inherited method
  inherited DrawColumnCell(Rect, DataCol, Column, State);

  //If user wants row highlighted, then call DrawField
  if DoRowHighLight then
    DrawField(Column.Field.DisplayText, Rect, Canvas,
      FHighlightFont, Column.Alignment,
      FHighlightFont.Style,
      FHighlightFont.Color, FHighlightBGColor);
end;

procedure TEnhDBGrid.SetHighlightFont(Value: TFont);
begin
  //Assign the font
  FHighlightFont.Assign(Value);
end;

procedure Register;
begin
  RegisterComponents('BD', [TEnhDBGrid]);
end;

end.

The component is merely a functionality wrapper for the form code above, so I won't discuss it in any meaningful detail. What I will discuss, however are the properties that I introduced into the component. First off is the public property DoRowHighlight. This is a Boolean property that you set at runtime to activate the functionality of the component. You use it in the OnDrawColumnCell method as follows:

procedure TForm1.EnhDBGrid1DrawColumnCell(Sender: TObject;
  const Rect: TRect; DataCol: Integer; Column: TColumn;
  State: TGridDrawState);
begin
  //Turns highlighting on or off depending on the row
  with Sender as TEnhDBGrid, DataSource.DataSet do
    if FieldByName('AmountPaid').AsFloat > 15000 then
      DoRowHighlight := True
    else
      DoRowHighlight := False;
end;

This is similar to what I did in the example above, but in this case, depending upon the AmountPaid field's value, I turn the functionality on or off. Admittedly, it's rather crude, but hey! it works!

The other two properties are HighlightFont and HighlightBGColor. The first property merely sets the highlighted cells' font properties and the second sets the color of the background you want to paint. With respect to the HighlightFont property, notice in the Create constructor, I actually create an instance of a TFont and assign it to FHighlightFont. This is necessary, otherwise at runtime, you won't be able to set the font to anything. It's possible to assign the font to the default font of the DBGrid, but you won't be able to change the font. So, creating an instance that can be changed is the way to go.

Those of you who are pros at component writing may notice something in the code. The DrawField method is declared as virtual. The reason for this is that just in case someone wanted to add functionality to what I already created, they wouldn't have to rewrite the code - it's adding a bit of an OOP twist to the component.

Also, notice that I didn't descend from TDBGrid; rather, I descended directly from TDBGrid. My reasoning behind this was that TDBGrid merely exposes the protected properties of TCustomDBGrid. I felt it was a waste to branch off of a component that didn't really add any new functionality. Also, while I exposed the same properties as TDBGrid does, I could have just as easily limited the exposure. In other words, descending from the ancestor above TDBGrid gives me a lot more control over what I want to expose and not expose.

Well, thanks for bearing with me. Have fun with the code!

Play an AVI file at full screen

Problem/Question/Abstract:

Using the TMediaPlayer to play AVI is rather slow. When I play the same movies in the Windows mediaplayer everything works fine. I tried to import the TActiveMovie ActiveX control in Delphi 5 but then I get an error message when I want to compile my program. I can't even delete the control from my form. Is there another "easy" way to play AVI from Delphi without the delays from MCI?

Answer:

This code plays an AVI movie (in full screen). It links directly to the MCI devices of Windows.So it should be as fast as possible.

procedure TForm1.Button1Click(Sender: TObject);
const
  longName: PChar = 'f:\media\ANIM1.MPG'; {Your complete FileName}
var
  ret, shortName: PChar;
  err: DWord;
begin
  {Getting the short Name (8:3) of selected file}
  shortName := strAlloc(521);
  GetShortPathName(longName, shortname, 512);
  {Sending a close Command to the MCI}
  ret := strAlloc(255);
  err := mciSendString(pchar('close movie'), 0, 0, 0);
  {No error check because at the first call there is no MCI device to close}
  {Open a new MCI Device with the selected movie file}
  err := mciSendString(pchar('open ' + shortName + ' alias movie'), 0, 0, 0);
  shortName := nil;
  {If an Error was traced then display a MessageBox with the mciError string}
  if err <> 0 then
  begin
    mciGetErrorString(err, ret, 255);
    messageDlg(ret, mtInformation, [mbOk], 0);
  end;
  {Sending the "play fullscreen command to the Windows MCI}
  err := mciSendString(pchar('play movie fullscreen'), 0, 0, 0);
  {Use the following line instead of the above one if you want to play
        it in screen mode}
  err := mciSendString(pchar('play movie'), 0, 0, 0);
  {If an Error was traced then display a MessageBox with the mciError string}
  if err <> 0 then
  begin
    mciGetErrorString(err, ret, 255);
    messageDlg(ret, mtInformation, [mbOk], 0);
  end;
  ret := nil;
end;

How to autosize a TDBGrid

Problem/Question/Abstract:

When placing a DBGrid on a form, it is difficult to know exactly how large it needs to be to accomodate the datafields and the number of records that are displayed. There is always a white border at the bottom under the last record and to the right of the rightmost field. There must be a simple way to tell the DBgrid (and the non data-aware grid, too) to always and automatically resize itself according to what it needs to display. Any ideas?

Answer:

Solve 1:

I use the following code to size my DBGrid and my form:

procedure TListDlg.FormCreate(Sender: TObject);
var
  W, i: Integer;
begin
  DataSet.Active := True {Make sure that your dataset is active}
  W := 0;
  for i := 0 to DBGrid.Columns.Count - 1 do
    W := W + DBGrid.Columns[i].Width + 1;
  DBGrid.ClientWidth := W;
  Self.ClientWidth := (DBGrid.Left * 2) + DBGrid.Width;
end;

Now your DBGrid is centered in your form and shows all Columns. To avoid the "white border" you can use the following code:

procedure TDBGrid.WMSize(var Msg: TWMSize);
var
  RowHeight: Integer;
  VisibleRows: Integer;
begin
  if Align <> alClient then
  begin
    if not (csDesigning in ComponentState) then
      ShowScrollBar(Handle, SB_VERT, False);
    {There is a problem in scaling a grid because the VCL includes the scrollbar}
    RowHeight := DefaultRowHeight;
    if dgRowLines in Options then
      RowHeight := RowHeight + GridLineWidth;
    VisibleRows := ClientHeight div RowHeight;
    if VisibleRows < 1 then
      VisibleRows := 1;
    if HandleAllocated then
      ClientHeight := (VisibleRows * RowHeight);
    Msg.Result := 0;
  end
  else
    inherited;
end;


Solve 2:

If you need to actually calculate the width of the entire TDBGrid, use the following:

function NewTextWidth(fntFont: TFont; const sString: OpenString): integer;
var
  fntSave: TFont;
begin
  result := 0;
  fntSave := Application.MainForm.Font;
  Application.MainForm.Font := fntFont;
  try
    result := Application.MainForm.Canvas.TextWidth(sString);
  finally
    Application.MainForm.Font := fntSave;
  end;
end;

{Calculate the width of the grid needed to exactly display with no horizontal scrollbar and with no extra space between the last column and the vertical scrollbar. The grid's datasource must be properly set and the datasource's dataset must be properly set, though it need not be open. Note: this width includes the width of the vertical scrollbar, which changes based on screen resolution. These changes are compensated for.}

function iCalcGridWidth(dbg: TDBGrid): integer;
const
  cMEASURE_CHAR = '0';
  iEXTRA_COL_PIX = 4;
  iINDICATOR_WIDE = 11;
var
  i, iColumns, iColWidth, iTitleWidth, iCharWidth: integer;
begin
  iColumns := 0;
  result := GetSystemMetrics(SM_CXVSCROLL);
  iCharWidth := NewTextWidth(dbg.Font, cMEASURE_CHAR);
  with dbg.dataSource.dataSet do
    for i := 0 to FieldCount - 1 do
      with Fields[i] do
        if visible then
        begin
          iColWidth := iCharWidth * DisplayWidth;
          if dgTitles in dbg.Options then
          begin
            iTitleWidth := NewTextWidth(dbg.TitleFont, DisplayLabel);
            if iColWidth < iTitleWidth then
              iColWidth := iTitleWidth;
          end;
          inc(iColumns, 1);
          inc(result, iColWidth + iEXTRA_COL_PIX);
        end;
  if dgIndicator in dbg.Options then
  begin
    inc(iColumns, 1);
    inc(result, iINDICATOR_WIDE);
  end;
  if dgColLines in dbg.Options then
    inc(result, iColumns)
  else
    inc(result, 1);
end;

I had to use the function NewTextWidth, rather than the Grid's Canvas.TextWith as the Canvas of the Grid may not initialized when you need to call iCalcGridWidth.

What's DelphiScript ?

Problem/Question/Abstract:

There are tools which support DelphiScript. Or other tools are interpreter which implement sort of pascal-scripting. What's the aim of these tools and where you can find it.

Answer:

Maybe you have noticed, that I put the article in the OLE category. So in a short way, DelphiScript is an OLE scripting language, like VBScript or JScript. Depending on the history, the language root is Standard Pascal and not ObjectPascal.

Extensions

There are extensions which supports OLE objects and the OLE variant type. It then deals with all Standard Pascal types as OLEVariant, or it does support them, e.g. not supported are pointers (of course), files, set operators (replaced with procedures), records (but records are replaced by untyped arrays). Therfore you can declare the type of a variable or parameter, it is allowed, but has no effect. Another extension supports exception handling the same way as OPascal does.
Bref, all variables are of the OleVariant type.

Comparison

Delphi Script and VBScript are case insensitive while JavaScript is case sensitive.
Delphi Script is strongly typed while VBScript and JavaScript is loosely typed. This means variable declaration is mandatory in Delphi Script, but variable declaration is not needed in VBScript and JavaScript.
Delphi Script uses square brackets to access data property and round brackets for function calls. VBScripts and JavaScript do not make this distinction. For example, the following statements are equivalent:
(Delphi Script) sum := Data1.Value[0] + tq_min(Data2.Value[0],0);
(VBScript) sum = Data1.Value(0) + tq_min(Data2.Value(0),0)
(JavaScript) sum = Data1.value(0) + tq_min(Data2.Value(0),0);

A Tool Example

The easiest way to begin scripting is to use a recorder. Later you can edit the script and so on. For example DelphiScript support is built into AQTest: www.automatedqa.com
It's a highly recommended tool that comes out of the box with 19 profilers.  The two that we are interested in most, is "listing unused units", and "identifying who calls what method" are included. (The method call profiler display its info through a diagram. fantastic cool.;)
So let's get back to DelphiScript(DS). DS code can be read by Delphi.
DS supports almost all Standard Pascal operators and routines, minus those that deal with type conversion or I/O, type conversion are always implicit.
Interesting is, there are units. But as DS is meant for scripting and selfstanding routines, units are simply groupings of scripts in one file. That means, no unit structure (interface, implementation etc.) is possible.
  
1. Concrete Implementation Dream Scripter

Dream Scripter supports Delphi Script language - the subset of Object Pascal. Before execution the script is compiled to native processor code and that's why Delphi Script is much faster than other scripting languages. Another cool feature - you don't need to have any scripting engine or extra DLLs on the user computer to use Delphi Script.  

Dream Scripter is written entirely with Delphi. You don't need any extra DLLs or OCXs. Source is compatible and tested with Delphi 3, Delphi 4, Delphi 5, C++ Builder 3, C++ Builder 4, and C++ Builder 5
http://www.dream-com.com/scripter.html

2. Conrete Implementation PasScript

PasScript is an interpreter of a vast subset of the OP (ObjectPascal) language which supports all OP data types except interfaces.
This subset was extended by the Poly data type that allows you to operate with dynamic data structures (lists, trees, and more) without using pointers and apply Pascal language in the Artificial Intelligence data domain with the same success.
But what are differences between PasScript and another Pascal scripting engines?
PasScript supports more wide subset of the OP language. You can use such concepts as units, default parameters, overloaded routines, open arrays, records, sets, pointers, classes, objects, class references, events, exceptions, and more in a script. PasScript syntax is 100% compatible
with OP.
All calling conventions register, pascal, stdcall, cdecl, safecall are supported Script-defined handlers for Windows messages Script-defined callback functions.
For example, you can define WindowProc function directly in a script More flexible importing Delphi classes. You can use instances of any Delphi class in a script create new instances of a Delphi class in a script and destroy them create new PasScript class in a script which inherits a Delphi class. More wide possibilities regarding the event handlers. You can create script-defined event handler for Delphi defined event and vice versa. You can pause, resume and terminate scripts and PasScript allows you to control an OLE Automation server.
The TPasScript component allows you to embed the interpreter into your Delphi, Kylix or C++ Builder application, so you can extend and customize the application without having to recompile it. http://users.ints.net/virtlabor/

One of the latest invention is to use OP as a script language for ASP.NET:
Recognizing Delphi as a script language works like this:
The first step in getting support for ASP.NET is making sure it recognizes Delphi as a scripting language, and knows how to invoke the Delphi for .NET compiler for the various ASP file types.

ASP.NET will look for a web.config file in the root of whatever virtual directories you set up for IIS. Here are the contents of this file for using Delphi as a scripting language with ASP.NET.

The first step in getting support for ASP.NET is making sure it recognizes Delphi as a scripting language, and knows how to invoke the Delphi for .NET compiler for the various ASP file types.
ASP.NET will look for a web.config file in the root of whatever virtual directories you set up for IIS. Here are the contents of this file for using Delphi as a scripting language with ASP.NET.


configuration>
  system.web>                            
    compilation debug="true">
       assemblies>
          add assembly="DelphiProvider" />
       assemblies>
       compilers>
          compiler language="Delphi" extension=".pas"
            type="Borland.Delphi.DelphiCodeProvider,DelphiProvider" />  
       compilers>
    compilation>
  system.web>
configuration>

more on that on: http://bdn.borland.com/article/0,1410,28974,00.html

How to make a TOpenDialog display folders only

Problem/Question/Abstract:

Delphi has a TOpenDialog to choose files, but I need an open dialog to choose folders only.

Answer:

function DirectorySelect: string;
var
  dir_name: string;
  Options: TSelectDirOpts;
begin
  options := [];
  if SelectDirectory(dir_name, Options, 0) then
    Result := dir_name
  else
    Result := '';
end;

ASCII Made Easy

Problem/Question/Abstract:

Manipulating ASCII Files with the Table Component

Answer:

ASCII files, the veritable antitheses of database server-based data, are nonetheless important files for receiving data from a wide range of sources, as well as an effective medium for sharing data with others. This installation of "DBNavigator" takes a look at several mechanisms that Delphi provides for reading and writing ASCII files using the TTable class.

Using tables to read and write ASCII files is not the only solution provided for by Delphi. For example, you can use typed or untyped files and perform basic file input/output (I/O) using functions and procedures of the System unit, e.g. AssignFile, ReadLn, WriteBuffer, etc. An advantage to this approach is that applications created using only these techniques do not require the Borland Database Engine (BDE). However, for the database developer whose applications must use the BDE already, the TTable class provides a number of handy and relatively easy to use methods for using and creating ASCII data.

Overview of ASCII Files

ASCII, which stands for the American Standard Code for Information Interchange, uses 8-bit integers to represent the characters and control codes commonly encountered in data. Each ASCII character or control code has a decimal equivalent. For example, the decimal value 65 represents an uppercase A, 97 represents a lowercase a, and 10 represents a line feed.

An ASCII file is a file that contains only ASCII characters, and is normally considered to hold only text. What makes ASCII files so interesting is that they can be created from almost any source, from "big iron" mainframes to the very earliest personal computers. This makes them a convenient format for importing data from another source, and well as exporting data to be used by some non-database program, such as a spreadsheet or word processor.

In this article, I will limit my discussion to three types of ASCII files: delimited, fixed-length, and simple text. Delimited ASCII files contain two or more data fields. A single character, called a separator, separates these fields. The most common character used for this purpose is the comma. The string data within a delimited file is identified by being preceded and followed by a delimiting character (or delimiter), most often the double quotation mark. The following is an example of what a delimited file may look like:

"Plumber","Mark",1000,5.2,3/4/95
"Ramerez","Pablo",1050,16.75,8/15/97
"Johannson","Christina",998,-25.25,9/1/98

Fixed-length files don't use separators or delimiters. Instead, the data fields are defined by their position within a record. While the records in a delimited file are of a variable length, in a fixed-length file each record is the same length. The following is an example of a fixed-length file:

Plumber        Mark 1000 5.23/4/95
Ramerez        Pablo 1050 16.758/15/97
Johannson      Christina   998 -25.259/1/98

Simple text files do not have individual fields, but are instead composed of a sequence of characters. An HTML file is a good example. The following is an example of a portion of a simple text file:

***********************************************************
                DELPHI 4 RELEASE NOTES
***********************************************************

This file contains last-minute information about Delphi
4 and additional information that enhances the
usability of Delphi. We recommend you read this entire
file before using Delphi 4.

Simple text files are the easiest to work with, and therefore are discussed first.

Reading Simple Text Files

To read a simple text file using a Table component, set the Table's TableName property to the name of the text file and open the Table. The TableName property can either include the fully qualified path, or you can enter the path in the DatabaseName property and only the file name in the TableName property. Figure 1 shows the Table and DBGrid page of the example TEXTFILE project with Delphi's README.TXT file loaded into a Table. (The projects discussed in this article are available for download; see the end of this article for details.)


Figure 1: Any text file can be opened using a table and displayed in a DBGrid.

While using a Table component to access a text file is simple, it's generally used only when your code is going to work with the text in the text file line-by-line. As you can see in Figure 1, the DBGrid, although capable of displaying the text in the Table as a single field, doesn't provide a view of the data suitable for an end user. If you merely want to display text from a simple text file, a Memo component (or other control that encapsulates TStrings) is better. This can be seen in Figure 2, which shows a Memo component from the Memo page of the TEXTFILE project.


Figure 2: A memo is often the best control for displaying a simple text file to your users.

All the code associated with the TEXTFILE project can be found in the OnClick event handler for the Select Text File to View button:

procedure TForm1.Button1Click(Sender: TObject);
begin
  if OpenDialog1.Execute then
  begin
    Memo1.Lines.Clear;
    Memo1.Lines.LoadFromFile(OpenDialog1.Filename);
    Table1.Close;
    Table1.Tablename := OpenDialog1.Filename;
    Table1.Open;
  end;
end;

The Table and Memo components in the TEXTFILE project are configured to be read-only. It's possible, however, to make changes to the data in a simple text file using a Table or a TStrings object. Changes made to a Table are posted on a line-by-line basis (unless CachedUpdates is used), while changes made to the text in a TStrings must be saved by calling the SaveToFile method.

Using Fixed-length ASCII Files

The use of a fixed-length ASCII file requires a schema file. A schema file contains a description of your ASCII file's metadata, including field names, field types, and field sizes. The following is an example:

[FIXED]
Filetype=Fixed
CharSet=ASCII
Field1=LastName,Char,20,00,00
Field2=FirstName,Char,20,00,20
Field3=IDNumber,LongInt,11,00,40
Field4=SomeReal,Float,20,02,51
Field5=SomeDate,Date,11,00,71

You will immediately recognize this file as being in the same format as an INI file. The file begins with the name of the file that it describes. Delphi assumes the file extension of this file is .TXT. Furthermore, the schema file must use the same file name as your ASCII file, but have the file extension .SCH.

On the line following the ASCII file name is the entry FileType=, which is followed by the type of ASCII file. This type can either be the value Fixed or Varying (the value is not case-sensitive). Next, you must identify the character set. In the US this value is almost always ASCII.

The remainder of the schema file contains descriptions of each of the fields in the ASCII file. Each field is described on a separate line that begins FieldN=, where N is the ordinal position of the field in the table structure. Consequently, the first field is defined by a line that begins Field1, the second field by a line that begins Field2, and so forth.

The definition of each field includes five parts: the field name, the field type, the maximum size of the field, the number of decimal places (this applies only to floating point value fields), and the column in which the field begins. The acceptable field type values are shown in Figure 3.

Field Type
Use for
Char
Strings
Float
64-bit floating point numbers
Number
16-bit integer
Bool
Boolean values
LongInt
32-bit long integers
Date
Date fields
Time
Time fields
TimeStamp
Date + Time fields

Figure 3: The values for the field type part of the field definition.

In the preceding schema file example, the first field is declared to have the name LastName, be a string field, contain a maximum of 20 characters, include a meaningless 00 in the decimal part, and finally be found with 0 columns offset from the start of the record. The fourth field, by comparison, is declared to have the name SomeReal, be a floating point number, have a maximum of 20 characters in its value, include 2 decimal places in its display, and whose value can be found starting at column 52 (offset 51 characters from the beginning of the record).

You can create your fixed-length schema file manually, or you can have Delphi generate it for you. Creating a schema file manually involves entering the properly formatted file definition using any text editor, such as Notepad or WordPad. Just make sure you save the file as a text file using the same name as your data file, but with the extension .SCH.

To have Delphi create your fixed-length schema file, you use BatchMove (either a BatchMove component, or the BatchMove method of the TTable class.). This requires that you already have a BDE-supported file type that contains the data from which you want to create a fixed-length ASCII file. If such a file does not already exist, you can create one using the Database Desktop application that ships with Delphi. From the Database Desktop select File | New | Table, select Paradox (or any other file type you are familiar with), and then enter the structure of your table in the Create dialog box, as shown in Figure 4.


Figure 4: The Create dialog box in the Database Desktop.

Once you have a table with the desired structure, use the following steps to create your schema file:

In Delphi, create a new application.
Place two Table components on your form.
Using the DatabaseName and TableName properties of Table1, select the data file that contains the structure from which you want to create a schema file. For example, set DatabaseName to DBDEMOS and TableName to CUSTOMER.DB.
Select Table2, and set its TableName property to the fully-qualified file name of the ASCII file for which you want to create a schema file. Include the entire file path as well as the .TXT file extension. For example, set TableName to C:\Program Files\Borland\Delphi4\Projects\CUSTOMER.TXT. Also set the TableType property of Table2 to ttASCII.
Now place a Button component on your main form, and double-click it to create an OnClick event handler. Add one statement to the event handler created by Delphi:

procedure TForm1.Button1Click(Sender: TObject);
begin
  Table2.BatchMove(Table1, batCopy);
end;

Run your application and click the button.

That's it; you've created a schema file. If you perform the preceding steps using the CUSTOMER.DB table in the DBDEMOS database, you'll find the following schema file in the directory you entered for your TableName:

[CUSTOMER]
Filetype=Fixed
CharSet=ascii
Field1=CustNo,Float,20,02,00
Field2=Company,Char,30,00,20
Field3=Addr1,Char,30,00,50
Field4=Addr2,Char,30,00,80
Field5=City,Char,15,00,110
Field6=State,Char,20,00,125
Field7=Zip,Char,10,00,145
Field8=Country,Char,20,00,155
Field9=Phone,Char,15,00,175
Field10=FAX,Char,15,00,190
Field11=TaxRate,Float,20,02,205
Field12=Contact,Char,20,00,225
Field13=LastInvoiceDate,TimeStamp,30,00,245

Unlike simple text files, which cannot be edited very easily in data-aware controls such as the DBGrid, fixed-length ASCII files can easily be used in any data-aware control. The only limitation is that the files have no indexes, and therefore cannot be sorted. All records you add are appended to the end of the file. Also, because there are no indexes, you cannot define record uniqueness based on a unique key. Finally, these files cannot be shared because they have no native locking mechanism.

Using Delimited ASCII Files

Delimited ASCII files are only slightly more difficult to use than fixed-length ASCII files, in part because Delphi will not generate a schema file for you. Instead, you must write the schema file for a delimited ASCII file yourself.

There are only three differences between schema files created for delimited ASCII files and those you use for fixed-length files. The first, and most obvious, is the FileType entry. While you set this entry to Fixed for a fixed-length file, you set it to Varying for a delimited file.

The other two differences involve defining the field separator and the string delimiter. The schema file for a delimited ASCII file contains two additional lines immediately following the FileType= entry. The first of these is the Separator= entry. You use this to define the character used to separate the fields. As mentioned earlier, this character is often the comma. The second entry is Delimiter=, which you use to define the character used to enclose strings. In most cases this will be the double quote character. The following is an example of a schema file for a delimited ASCII file:

[DELIMIT]
FileType=Varying
Separator=,
Delimiter="
CharSet=ascii
Field1=LastName,Char,20,00,00
Field2=FirstName,Char,20,00,20
Field3=IDNumber,LongInt,11,00,40
Field4=SomeReal,Float,11,02,51
Field5=SomeDate,Date,11,00,62

While Delphi won't generate a delimited schema file for you, the similarity between the two schema file types provides you with some assistance. Specifically, using the steps given earlier you can create a fixed-length schema file for your delimited table structure, and then make the three modifications just described to the Delphi-generated schema file.

The use of both a fixed-length ASCII file and a delimited ASCII file is demonstrated in the SCHEMA project, shown in Figure 5.


Figure 5: The SCHEMA project main form.

When you view the FIXED.TXT table, the FIXED.SCH schema file permits Delphi to read the following ASCII file:

Plumber        Mark 1000       5.203/4/1995
Ramerez        Pablo 1050 16.758/15/1997
Johannson      Christina   998 -25.259/1/1998

When you view the DELIMIT.TXT ASCII file, the DELIMIT.SCH schema file permits you to view this file:

"Plumber","Mark",1000,5.2,3/4/95
"Ramerez","Pablo",1050,16.75,8/15/97
"Johannson","Christina",998,-25.25,9/1/98

Final Notes

By default, the BDE is configured to display two-digit years in dates. So, if you write a date field to an ASCII file, only the last two digits of the year are stored. In most cases, you will want to make sure that Delphi writes all four-year digits of your date data. To do this you must update the Date format setting using the BDE Administrator located in your system's Control Panel (see Figure 6).


Figure 6: Setting the Date format in the BDE Administrator.

Also, to display the four-digit year in a date field associated with an ASCII file, you must instantiate the TFields associated with your Table component, and set the DisplayFormat property of your Date fields. For example, setting the DisplayFormat of a TDateField object to "m/d/yyyy" causes all four digits of the year to be displayed.

Another peculiarity of using ASCII tables is that (at least with my copy of Delphi 4) the Table's Active property must be set to False at application startup. While you may want to set the Active property to True during design time - so that you can see your data as you work - you should set Active to False before running your application. Use the OnCreate event handler, or some other similar event handler, to set the Active property to True for your tables that use ASCII data. This code may look something like the following:

procedure TForm1.FormCreate(Sender: TObject);
begin
  Table1.Open;
end;

Conclusion

ASCII files, while not used in day-to-day database applications, provide an effective medium for passing data to and from Delphi and other applications. Not only can a Table component be used to read simple text files, but with the addition of a schema file, the Table component can read, display, and write delimited or fixed-length ASCII files.


Component Download: ASCII_Made_Easy.zip

Collection Dataset an object oriented database

Problem/Question/Abstract:

Incapsulating a collection in a TDataset decendant. Enabling to save and load diferent datasets bij loading and saving component resources.

Answer:

I have writen a TDataset descendant that allows a collection to be set as property so it will do the deletes inserts and updates for you with a little help from the Data aware controls in delphi.

I made an example that saves some master detail data .

In my example i'll show you how i use the dataset in design time so i can set the fields displaylength and it's displayLabel

For those cracks that do not need an example here's the compleet code of the object.

For those who do just download the sample .

And of course do not forget to vote or leave a message :) ..

Greatings all and keep up the good work.

unit CollectionDataSet;

interface

uses
  DB, Classes, typinfo, dialogs;

type
  PRecInfo = ^TRecInfo;
  TRecInfo = packed record
    Bookmark: Integer;
    BookmarkFlag: TBookmarkFlag;
  end;

  { TCollectionDataSet }

  TCollectionDataSet = class(TDataSet)
  private
    FRecBufSize: Integer;
    FRecInfoOfs: Integer;
    FCurRec: Integer;
    FFileName: string;
    FLastBookmark: Integer;
    FCollection: TCollection;
    FCollectionCount: Integer;
    procedure SetCollection(const Value: TCollection);
  protected
    function AllocRecordBuffer: PChar; override;
    procedure FreeRecordBuffer(var Buffer: PChar); override;
    procedure GetBookmarkData(Buffer: PChar; Data: Pointer); override;
    function GetBookmarkFlag(Buffer: PChar): TBookmarkFlag; override;
    function GetRecord(Buffer: PChar; GetMode: TGetMode; DoCheck: Boolean): TGetResult; override;
    function GetRecordSize: Word; override;
    procedure InternalAddRecord(Buffer: Pointer; Append: Boolean); override;
    procedure InternalClose; override;
    procedure InternalCancel; override;
    procedure InternalDelete; override;
    procedure InternalFirst; override;
    procedure InternalGotoBookmark(Bookmark: Pointer); override;
    procedure InternalHandleException; override;
    procedure InternalInitFieldDefs; override;
    procedure InternalInitRecord(Buffer: PChar); override;
    procedure InternalLast; override;
    procedure InternalOpen; override;
    procedure InternalPost; override;
    procedure InternalSetToRecord(Buffer: PChar); override;
    function IsCursorOpen: Boolean; override;
    procedure SetBookmarkFlag(Buffer: PChar; Value: TBookmarkFlag); override;
    procedure SetBookmarkData(Buffer: PChar; Data: Pointer); override;
    procedure SetFieldData(Field: TField; Buffer: Pointer); override;
    function GetRecordCount: Integer; override;
    function GetRecNo: Integer; override;
    procedure SetRecNo(Value: Integer); override;
  public
    function GetFieldData(Field: TField; Buffer: Pointer): Boolean; override;
    property Collection: TCollection read FCollection write SetCollection;
  published
    property FileName: string read FFileName write FFileName;
    property Active;
    property AutoCalcFields;
    property BeforeOpen;
    property AfterOpen;
    property BeforeClose;
    property AfterClose;
    property BeforeInsert;
    property AfterInsert;
    property BeforeEdit;
    property AfterEdit;
    property BeforePost;
    property AfterPost;
    property BeforeCancel;
    property AfterCancel;
    property BeforeDelete;
    property AfterDelete;
    property BeforeScroll;
    property AfterScroll;
    property BeforeRefresh;
    property AfterRefresh;
    property OnCalcFields;
    property OnDeleteError;
    property OnEditError;
    property OnFilterRecord;
    property OnNewRecord;
    property OnPostError;

  end;

procedure Register;

implementation

uses Windows, SysUtils, Forms;

{ TCollectionDataSet }

procedure TCollectionDataSet.InternalOpen;

begin
  if Collection = nil then
    raise EDatabaseError.Create('Collection is niet gevult !');

  FCurRec := -1;

  FCollectionCount := Collection.Count;
  FLastBookmark := Collection.Count;
  FRecInfoOfs := SizeOf(Integer);

  FRecBufSize := SizeOf(TRecInfo) + FRecInfoOfs;
  BookmarkSize := SizeOf(Integer);

  InternalInitFieldDefs;

  if DefaultFields then
    CreateFields;

  BindFields(True);
end;

procedure TCollectionDataSet.InternalClose;
begin

  if DefaultFields then
    DestroyFields;
  FLastBookmark := 0;
  FCurRec := -1;
end;

function TCollectionDataSet.IsCursorOpen: Boolean;
begin
  Result := Assigned(collection);
end;

procedure TCollectionDataSet.InternalInitFieldDefs;
var
  PropList: PPropList;
  PropCount: Integer;
  ClassTypeInfo: PTypeInfo;
  ClassTypeData: PTypeData;
  i: integer;
begin
  FieldDefs.Clear;
  if Collection = nil then
    raise EInvalidPointer.create('Collection is nil');
  ClassTypeInfo := Collection.ItemClass.ClassInfo;
  ClassTypeData := GetTypeData(ClassTypeInfo);
  PropCount := ClassTypeData.PropCount - 1;
  //  reserveer geheugen
  GetMem(PropList, SizeOf(PPropInfo) * ClassTypeData.PropCount);
  // Error trap
  try
    // Vul de prop list
    GetPropList(Collection.ItemClass.ClassInfo, tkAny, PropList);
    for i := 0 to PropCount do
    begin
      try
        case PropList[i]^.PropType^.Kind of
          tkString, tkLString,
            tkWString, tkWChar,
            tkChar:
            begin
              FieldDefs.Add(PropList[i]^.Name, ftString, 255, False);
            end;

          tkInteger,
            tkEnumeration:
            begin
              FieldDefs.Add(PropList[i]^.Name, ftInteger, 0, False);
            end;
          tkFloat:
            begin
              FieldDefs.Add(PropList[i]^.Name, ftFloat, 0, False);
            end;
          tkClass:
            begin
            end;
          tkArray:
            begin
            end;
        end; // end case
      except
        on e: Exception do

      end;

    end;
  finally
    FreeMem(PropList, SizeOf(PPropInfo) * ClassTypeData.PropCount);
  end;

end;

procedure TCollectionDataSet.InternalHandleException;
begin
  Application.HandleException(Self);
end;

procedure TCollectionDataSet.InternalGotoBookmark(Bookmark: Pointer);
var
  Index: Integer;
begin
  Index := PInteger(Bookmark)^ - 1;
  if Index > -1 then
    FCurRec := Index
  else
    DatabaseError('Bookmark not found');
end;

procedure TCollectionDataSet.InternalSetToRecord(Buffer: PChar);
begin
  InternalGotoBookmark(@PRecInfo(Buffer + FRecInfoOfs).Bookmark);
end;

function TCollectionDataSet.GetBookmarkFlag(Buffer: PChar): TBookmarkFlag;
begin
  Result := PRecInfo(Buffer + FRecInfoOfs).BookmarkFlag;
end;

procedure TCollectionDataSet.SetBookmarkFlag(Buffer: PChar; Value: TBookmarkFlag);
begin
  PRecInfo(Buffer + FRecInfoOfs).BookmarkFlag := Value;
end;

procedure TCollectionDataSet.GetBookmarkData(Buffer: PChar; Data: Pointer);
begin
  PInteger(Data)^ := PRecInfo(Buffer + FRecInfoOfs).Bookmark;
end;

procedure TCollectionDataSet.SetBookmarkData(Buffer: PChar; Data: Pointer);
begin
  PRecInfo(Buffer + FRecInfoOfs).Bookmark := PInteger(Data)^;
end;

function TCollectionDataSet.GetRecordSize: Word;
begin
  Result := SizeOf(Integer); //MaxStrLen;
end;

function TCollectionDataSet.AllocRecordBuffer: PChar;
begin
  GetMem(Result, FRecBufSize);
end;

procedure TCollectionDataSet.FreeRecordBuffer(var Buffer: PChar);
begin
  FreeMem(Buffer, FRecBufSize);
end;

function TCollectionDataSet.GetRecord(Buffer: PChar; GetMode: TGetMode;
  DoCheck: Boolean): TGetResult;
begin
  if Collection.Count < 1 then
    Result := grEOF
  else
  begin
    Result := grOK;
    case GetMode of
      gmNext:
        if FCurRec >= RecordCount - 1 then
          Result := grEOF
        else
          Inc(FCurRec);
      gmPrior:
        if FCurRec <= 0 then
          Result := grBOF
        else
          Dec(FCurRec);
      gmCurrent:
        if (FCurRec < 0) or (FCurRec >= RecordCount) then
          Result := grError;
    end;
    if Result = grOK then
    begin
      PInteger(Buffer)^ := Integer(FCollection.Items[FCurRec]);
      with PRecInfo(Buffer + FRecInfoOfs)^ do
      begin
        BookmarkFlag := bfCurrent;
        Bookmark := FCurRec + 1;
      end;
    end
    else if (Result = grError) and DoCheck then
      DatabaseError('No Records');
  end;
end;

procedure TCollectionDataSet.InternalInitRecord(Buffer: PChar);
begin
  PInteger(Buffer)^ := Integer(FCollection.Add);
end;

function TCollectionDataSet.GetFieldData(Field: TField; Buffer: Pointer): Boolean;

var
  Apropinfo: PPropinfo;
  AString: string;
  AInteger: Integer;
  AFloat: Double;
  AItem: TCollectionItem;
begin
  Result := False;
  if Collection.Count = 0 then
    exit;
  AItem := TCollectionItem(PInteger(ActiveBuffer)^);
  Apropinfo := typinfo.GetPropInfo(AItem, Field.FullName);
  case Apropinfo.PropType^.Kind of
    tkString, tkLString,
      tkWString, tkWChar,
      tkChar:
      begin
        AString := GetStrProp(AItem, Apropinfo);
        StrLCopy(Buffer, PChar(AString), Length(AString));
        Result := PChar(Buffer)^ <> #0;
      end;

    tkInteger,
      tkEnumeration:
      begin
        AInteger := GetOrdProp(AItem, Apropinfo);
        PInteger(Buffer)^ := AInteger;
        Result := true;
      end;
    tkFloat:
      begin
        AFloat := GetFloatProp(AItem, Apropinfo);
        PDouble(Buffer)^ := AFloat;
        Result := true;
      end;
  end; // end case
end;

procedure TCollectionDataSet.SetFieldData(Field: TField; Buffer: Pointer);
var
  Apropinfo: PPropinfo;
  AString: string;
  AInteger: Integer;
  AFloat: Double;
  AItem: TCollectionItem;
begin
  AItem := TCollectionItem(PInteger(ActiveBuffer)^);
  Apropinfo := typinfo.GetPropInfo(AItem, Field.FullName);
  case Apropinfo.PropType^.Kind of
    tkString, tkLString,
      tkWString, tkWChar,
      tkChar:
      begin
        AString := PChar(Buffer);
        SetStrProp(AItem, Apropinfo, AString);
      end;

    tkInteger,
      tkEnumeration:
      begin
        AInteger := 0;
        if Buffer <> nil then
          AInteger := PInteger(Buffer)^;
        SetOrdProp(AItem, Apropinfo, AInteger);
      end;
    tkFloat:
      begin

        AFloat := 0;
        if Buffer <> nil then
          AFloat := PDouble(Buffer)^;
        SetFloatProp(AItem, Apropinfo, AFloat);
      end;
  end; // end case

  DataEvent(deFieldChange, Longint(Field));
end;

procedure TCollectionDataSet.InternalFirst;
begin
  FCurRec := -1;
end;

procedure TCollectionDataSet.InternalLast;
begin
  FCurRec := FCollectionCount;
end;

procedure TCollectionDataSet.InternalPost;
begin
  if State = dsinsert then
  begin
    Inc(FCollectionCount);
    Inc(FLastBookmark);
    if FCurRec <> -1 then
      TCollectionItem(PInteger(ActiveBuffer)^).Index := FCurRec;
  end;

end;

procedure TCollectionDataSet.InternalAddRecord(Buffer: Pointer; Append: Boolean);
begin
  Inc(FLastBookmark);
  if Append then
    InternalLast;
  Inc(FCollectionCount);

end;

procedure TCollectionDataSet.InternalDelete;
begin
  Collection.Delete(FCurRec);
  Dec(FCollectionCount);
  if FCurRec >= Collection.Count then
    Dec(FCurRec);
end;

function TCollectionDataSet.GetRecordCount: Longint;
begin
  Result := FCollectionCount;
end;

function TCollectionDataSet.GetRecNo: Longint;
begin
  UpdateCursorPos;
  if (FCurRec <= -1) and (RecordCount > 0) then
    Result := 0
  else
    Result := FCurRec + 1;
end;

procedure TCollectionDataSet.SetRecNo(Value: Integer);
begin
  if (Value >= 0) and (Value < FCollectionCount) then
  begin
    FCurRec := Value - 1;
    Resync([]);
  end;
end;

procedure TCollectionDataSet.SetCollection(const Value: TCollection);
begin
  FCollection := Value;
end;

procedure TCollectionDataSet.InternalCancel;
begin
  Collection.Delete(Collection.Count - 1);
end;

end.