How to detect a CR / LF in a TRichEdit

Problem/Question/Abstract:

I need to determine where there are CR/LF's in a TRichEdit. Here's the problem. I need to use the TRichEdit to take pretty much just plain text. I am using the TRichEdit instead of the TMemo because it handles end-of-line spaces much better. When I save the text, I need to save it in a proprietary text format. So when I encounter a CRLF, I need to place a "/p" combination at the end of the text line.

Answer:

procedure SaveTextWithParagraphMarkers(const filename, Text, marker: string);
var
  fs: TFilestream;
  S: string;
begin
  S := Stringreplace(text, #13#10, marker, [srReplaceAll]);
  fs := TFilestream.Create(filename, fmCreate);
  try
    fs.WriteBuffer(S[1], Length(S));
  finally
    fs.Free
  end;
end;

SaveTextWithParagraphMakers(filename, richedit1.text, '/p'#13#10);

Set the selected block to upper case/lower case

Problem/Question/Abstract:

Set the selected block to upper case/lower case

Answer:

I constantly forget this shortcut, particularly the one how to set the selected block to lower case.
Since it is hard to find in the online help, here it is as a reminder for myself:

press Ctrl+K then release and press  O   block lower case
press Ctrl+K then release and press  N   block upper case

(I don't know whether this works in editor layouts other than IDE classic.)

Looking for text in any part of a field

Problem/Question/Abstract:

A function to search text in part of a field of any dataset

Answer:

The following function searches for text in any part of a field of any dataset (it can be for example a TTable, TQuery, TADOTable, TADOQuery, TIBTable, TIBQuery, etc.)

type
  TLocateStrOption = (loCaseSensitive, loContinue);
  TLocateStrOptions = set of TLocateStrOption;

function LocateStr(Dataset: TDataset; Field: TField; Str: string;
  LocateOptions: TLocateStrOptions): boolean;
// Searches text in any part of a dataset field. The search can be
// case sensitive (option loCaseSensitive) and can start from the
// beginning or from the current record (option loContinue).
//
// Returns True if the string was found (the dataset is positioned
// in that record) and False otherwise (the dataset is left in EOF)
var
  ControlsDisabled: boolean;
begin
  ControlsDisabled := Dataset.ControlsDisabled;
  if not ControlsDisabled then
    Dataset.DisableControls;
  try
    if loContinue in LocateOptions then
    begin
      if not Dataset.Eof then
        Dataset.Next;
    end
    else
      Dataset.First; // Start from the beginning
    if not (loCaseSensitive in LocateOptions) then
      Str := UpperCase(Str);
    while not Dataset.Eof do
    begin
      if loCaseSensitive in LocateOptions then
      begin
        if Pos(Str, Field.AsString) <> 0 then
          break;
      end
      else
      begin
        if Pos(Str, UpperCase(Field.AsString)) <> 0 then
          break;
      end;
      Dataset.Next;
    end;
    Result := Dataset.Eof;
  finally
    if not ControlsDisabled then
      Dataset.EnableControls;
  end;
end;


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

Sort a TListView by numerical values

Problem/Question/Abstract:

My TListView is populated with file names in the first column and their sizes in the second column. To sort the data in the columns I use certain code. Now I would like the second column sorted not by Ansi values, where 822 is greater than 1000, but by numerical values. The second column must behave like the first, which means that the first click sorts the values ascending and the next click sorts them descending. Can anyone help me?

Answer:

Start a new project, and drop a ListView on the form. Replace all of the unit's code with code listed below. Set the ListView1's OnColumnClick Event to point to the ListView1ColumnClick in the code and link the form's OnCreate to the FormCreate. Run the program. Every time you click on the "Column 2" header, the column will sort in the opposite order. Note, if you click too quick, it'll be considered a double click, and it's not set up for that. Also, if you click on Column 1's header, it'll sort alphabetically.

unit Unit1;

{$O-}

interface

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

type
  TForm1 = class(TForm)
    ListView1: TListView;
    procedure FormCreate(Sender: TObject);
    procedure ListView1ColumnClick(Sender: TObject; Column: TListColumn);
  private
    NameSortOrder, SizeSortOrder: integer;
  public
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
var
  i: Integer;
  ListItem: TListItem;
begin
  Randomize;
  NameSortOrder := -1;
  SizeSortOrder := -1;
  with ListView1 do
  begin
    Align := alClient;
    ViewStyle := vsReport;
    with Columns.Add do
    begin
      Caption := 'Column 1';
      width := 90;
    end;
    with Columns.Add do
    begin
      Caption := 'Column 2';
      width := 90;
      Alignment := taRightJustify;
    end;
    for i := 1 to 20 do
    begin
      ListItem := ListView1.Items.Add;
      with ListItem do
      begin
        caption := format('FileName %2d', [i]);
        SubItems.add(Format('%3.6n', [random]));
      end;
    end;
  end;
end;

function SizeCustomSort(Item1, Item2: TListItem; ParamSort: integer): integer;
  stdcall;
var
  R1, R2: real;
  code: Integer;
begin
  val(Item1.SubItems.Strings[0], R1, code); {ignore code}
  val(Item2.SubItems.Strings[0], R2, code);
  if R1 > R2 then
    result := ParamSort
  else if R1 < R2 then
    result := -ParamSort
  else
    result := 0;
end;

procedure TForm1.ListView1ColumnClick(Sender: TObject; Column: TListColumn);
begin
  if Column.Index = 1 then
  begin
    ListView1.CustomSort(@SizeCustomSort, SizeSortOrder);
    SizeSortOrder := SizeSortOrder * -1; {reverse the next sort order}
  end
  else
  begin
    ListView1.SortType := stText;
    ListView1.AlphaSort;
  end;
end;

end.

Another option to execute system commands

Problem/Question/Abstract:

When you want to execute some command you just call WinExec. But if you want to execute some system command like 'dir *.*' or even execute an old DOS application, WinExec by itself just doesn't give all you want.

Answer:

The solution here it's by running your commands trought the COMSPEC. This is, COMPSPEC it's an environment variable that on Windows NT and 2000 returns the path to CMD.EXE and on Windows 9x returns the path to COMMAND.COM.

While I tested all this article code with Windows 2000 it can probably run also in Windows 9x (I think).
If you go to 'Command Prompt' and write the following you'll get a description of a various number of options that you can use to run a command (or a batch of commands in a single command line):

Starts a new instance of the Windows 2000 command interpreter

CMD [/A | /U] [/Q] [/D] [/E:ON | /E:OFF] [/F:ON | /F:OFF] [/V:ON | /V:OFF]
    [[/S] [/C | /K] string]

/C      Carries out the command specified by string and then terminates
/K      Carries out the command specified by string but remains
/S      Modifies the treatment of string after /C or /K (see below)
/Q      Turns echo off
/D      Disable execution of AutoRun commands from registry (see below)
/A      Causes the output of internal commands to a pipe or file to be ANSI
/U      Causes the output of internal commands to a pipe or file to be
        Unicode
/T:fg   Sets the foreground/background colors (see COLOR /? for more info)
/E:ON   Enable command extensions (see below)
/E:OFF  Disable command extensions (see below)
/F:ON   Enable file and directory name completion characters (see below)
/F:OFF  Disable file and directory name completion characters (see below)
/V:ON   Enable delayed environment variable expansion using c as the
        delimiter. For example, /V:ON would allow !var! to expand the
        variable var at execution time.  The var syntax expands variables
        at input time, which is quite a different thing when inside of a FOR
        loop.
/V:OFF  Disable delayed environment expansion.

Note that multiple commands separated by the command separator '&&' are accepted for string if surrounded by quotes.  Also, for compatibility reasons, /X is the same as /E:ON, /Y is the same as /E:OFF and /R is the same as /C.  Any other switches are ignored.

If /C or /K is specified, then the remainder of the command line after the switch is processed as a command line, where the following logic is used to process quote (") characters:

    1.  If all of the following conditions are met, then quote characters
        on the command line are preserved:

        - no /S switch
        - exactly two quote characters
        - no special characters between the two quote characters,
          where special is one of: &<>()@^|
        - there are one or more whitespace characters between the
          the two quote characters
        - the string between the two quote characters is the name
          of an executable file.

    2.  Otherwise, old behavior is to see if the first character is
        a quote character and if so, strip the leading character and
        remove the last quote character on the command line, preserving
        any text after the last quote character.

If /D was NOT specified on the command line, then when CMD.EXE starts, it
looks for the following REG_SZ/REG_EXPAND_SZ registry variables, and if
either or both are present, they are executed first.

    HKEY_LOCAL_MACHINE\Software\Microsoft\Command Processor\AutoRun

        and/or

    HKEY_CURRENT_USER\Software\Microsoft\Command Processor\AutoRun

Command Extensions are enabled by default.  You may also disable extensions for a particular invocation by using the /E:OFF switch.  You can enable or disable extensions for all invocations of CMD.EXE on a machine and/or user logon session by setting either or both of the following REG_DWORD values in the registry using REGEDT32.EXE:

    HKEY_LOCAL_MACHINE\Software\Microsoft\Command Processor\EnableExtensions

        and/or

    HKEY_CURRENT_USER\Software\Microsoft\Command Processor\EnableExtensions

to either 0x1 or 0x0.  The user specific setting takes precedence over the machine setting.  The command line switches take precedence over the registry settings.

The command extensions involve changes and/or additions to the following
commands:

    DEL or ERASE
    COLOR
    CD or CHDIR
    MD or MKDIR
    PROMPT
    PUSHD
    POPD
    SET
    SETLOCAL
    ENDLOCAL
    IF
    FOR
    CALL
    SHIFT
    GOTO
    START (also includes changes to external command invocation)
    ASSOC
    FTYPE

To get specific details, type commandname /? to view the specifics.

Delayed environment variable expansion is NOT enabled by default.  You can enable or disable delayed environment variable expansion for a particular invocation of CMD.EXE with the /V:ON or /V:OFF switch.  You can enable or disable completion for all invocations of CMD.EXE on a machine and/or user logon session by setting either or both of the following REG_DWORD values in the registry using REGEDT32.EXE:

    HKEY_LOCAL_MACHINE\Software\Microsoft\Command Processor\DelayedExpansion

        and/or

    HKEY_CURRENT_USER\Software\Microsoft\Command Processor\DelayedExpansion

to either 0x1 or 0x0.  The user specific setting takes precedence over the machine setting.  The command line switches take precedence over the registry settings.

If delayed environment variable expansion is enabled, then the exclamation
character can be used to substitute the value of an environment variable
at execution time.

File and Directory name completion is NOT enabled by default.  You can enable or disable file name completion for a particular invocation of CMD.EXE with the /F:ON or /F:OFF switch.  You can enable or disable completion for all invocations of CMD.EXE on a machine and/or user logon session by setting either or both of the following REG_DWORD values in the registry using REGEDT32.EXE:

    HKEY_LOCAL_MACHINE\Software\Microsoft\Command Processor\CompletionChar
    HKEY_LOCAL_MACHINE\Software\Microsoft\Command Processor\PathCompletionChar

        and/or

    HKEY_CURRENT_USER\Software\Microsoft\Command Processor\CompletionChar
    HKEY_CURRENT_USER\Software\Microsoft\Command Processor\PathCompletionChar

with the hex value of a control character to use for a particular function (e.g.  0x4 is Ctrl-D and 0x6 is Ctrl-F).  The user specific settings take precedence over the machine settings.  The command line switches take precedence over the registry settings.

If completion is enabled with the /F:ON switch, the two control characters used are Ctrl-D for directory name completion and Ctrl-F for file name completion.  To disable a particular completion character in the registry, use the value for space (0x20) as it is not a valid control character.

Completion is invoked when you type either of the two control characters.  The completion function takes the path string to the left of the cursor appends a wild card character to it if none is already present and builds up a list of paths that match.  It then displays the first matching path.  If no paths match, it just beeps and leaves the display alone.  Thereafter, repeated pressing of the same control character will cycle through the list of matching paths.  Pressing the Shift key with the control character will move through the list backwards.  If you edit the line in any way and press the control character again, the saved list of matching paths is discarded and a new one generated.  The same occurs if you switch between file and directory name completion.  The only difference between the two control characters is the file completion character matches both file and directory names, while the directory completion character only matches directory names.
If file completion is used on any of the built in directory commands (CD, MD or RD) then directory completion is assumed.

The completion code deals correctly with file names that contain spaces or other special characters by placing quotes around the matching path.
Also, if you back up, then invoke completion from within a line, the text to the right of the cursor at the point completion was invoked is discarded.

and it's this option that will let you run commands without the disadvantage of using batch files.

With this article you'll also have an attached project sample containing an unit (SysCommand.pas) that implements a small component. The best thing you can do it's look at the attached sample, anyway here it is a small test sample:

var
  FSysCommand: TSysCommand;

begin
  FSysCommand := TSysCommand.Create(Self);
  FSysCommand.WhenDone := cwdRemain;
  FSysCommand.WindowTitle := 'This is a test';
  FSysCommand.BkColor := cclBtWhite;
  FSysCommand.FgColor := cclLtRed;
  FSysCommand.CmdsList.Add('echo Now I will list your windows directory files.');
  FSysCommand.CmdsList.Add('pause');
  FSysCommand.CmdsList.Add('dir "c:\windows\*.*" /s');
  FSysCommand.Execute;

  as you can see, it's easy and simple to run a batch of commands throught the
    Command Prompt.

  = = SysCommand.pas = =

unit SysCommand;
// by Fernando J.A. Silva (magico@galaxycorp.com)   2001/08/24

interface
uses
  Classes;

type
  TCmdWhenDone = (
    cwdClose { /C or /R },
      // Carries out the command specified by string and then terminates
    cwdRemain { /K } // Carries out the command specified by string but remains
    );

  TCmdAutoRunCmds = (
    carDefault,
    carDisable { /D } // Disable execution of AutoRun commands from registry
    );
  // if carDisable was NOT specified, then when the command is launched, it
  //    looks for the following REG_SZ/REG_EXPAND_SZ registry variables, and if
  //    either or both are present, they are executed first.
  //
  //  HKEY_LOCAL_MACHINE\Software\Microsoft\Command Processor\AutoRun
  //     and/or
  //  HKEY_CURRENT_USER\Software\Microsoft\Command Processor\AutoRun

  TCmdOutputType = (
    cotANSI { /A },
      // Causes the output of internal commands to a pipe or file to be ANSI
    cotUnicode { /U } // Causes the output of internal commands to a pipe or file to be Unicode
    );

  TCmdColor = (cclNone, cclBlack {0}, cclBlue {1}, cclGreen {2}, cclAqua {3}, cclRed
    {4},
    cclPurple {5}, cclYellow {6}, cclWhite {7}, cclGray {8}, cclLtBlue {9},
    cclLtGreen {A}, cclLtAqua {B}, cclLtRed {C}, cclLtPurple {D}, cclLtYellow {E},
    cclBtWhite {F});

  TCmdExtensions = (
    cexDefault,
    cexON, {/E:ON or /X } // Enable command extensions
    cexOFF {/E:OFF or /Y } // Disable command extensions
    );
  // Command Extensions are enabled by default.  You may also disable extensions
  //    for a particular invocation by using the cexOFF. You can enable or disable
  //    extensions for all invocations of CMD.EXE on a machine and/or user logon
  //    session by setting either or both of the following REG_DWORD values in the
  //    registry using REGEDT32.EXE:
  //
  //  HKEY_LOCAL_MACHINE\Software\Microsoft\Command Processor\EnableExtensions
  //     and/or
  //  HKEY_CURRENT_USER\Software\Microsoft\Command Processor\EnableExtensions
  //
  //    to either 0x1 or 0x0.  The user specific setting takes precedence over
  //    the machine setting.  The command line switches take precedence over the
  //    registry settings.

  TSysCommand = class(TComponent)
  private
    FOutputType: TCmdOutputType;
    FAutoRunCmds: TCmdAutoRunCmds;
    FCmdExtensions: TCmdExtensions;
    FWhenDone: TCmdWhenDone;
    FBkColor: TCmdColor;
    FFgColor: TCmdColor;
    FWindowTitle: string;

    FCmdsList: TStringList;

    function GetParamsString: string;
    procedure GetInternalCmdsList(var AList: TStringList);
    function GetCommandsString: string;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function Execute: Boolean;
  published
    property OutputType: TCmdOutputType read FOutputType write FOutputType;
    property AutoRunCmds: TCmdAutoRunCmds read FAutoRunCmds write FAutoRunCmds;
    property CmdExtensions: TCmdExtensions read FCmdExtensions write FCmdExtensions;
    property WhenDone: TCmdWhenDone read FWhenDone write FWhenDone;
    property BkColor: TCmdColor read FBkColor write FBkColor;
    property FgColor: TCmdColor read FFgColor write FFgColor;
    property WindowTitle: string read FWindowTitle write FWindowTitle;

    property CmdsList: TStringList read FCmdsList write FCmdsList;
  end;

implementation

uses
  Windows,
  SysUtils;

const
  FStrWhenDone: array[0..1] of string = (' /C', ' /K');
  FStrAutoRun: array[0..1] of string = ('', ' /D');
  FStrOutType: array[0..1] of string = (' /A', ' /U');
  FStrColors: array[0..16] of string = ('', '0', '1', '2', '3', '4', '5', '6', '7',
    '8', '9', 'A', 'B', 'C', 'D', 'E', 'F');
  FStrUseExt: array[0..2] of string = ('', ' /E:ON', ' /E:OFF');

constructor TSysCommand.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FOutputType := cotANSI;
  FAutoRunCmds := carDefault;
  FCmdExtensions := cexDefault;
  FWhenDone := cwdClose;
  FBkColor := cclNone;
  FFgColor := cclNone;
  WindowTitle := '';
  FCmdsList := TStringList.Create;
end;

destructor TSysCommand.Destroy;
begin
  inherited Destroy;
  FCmdsList.Destroy;
end;

function TSysCommand.GetParamsString: string;
// Returns a string containing the parameters to be passed to 'COMSPEC'
begin
  Result := '';
  Result := Result + FStrOutType[Ord(FOutputType)];
  Result := Result + FStrAutoRun[Ord(FAutoRunCmds)];
  Result := Result + FStrUseExt[Ord(FCmdExtensions)];
  Result := Result + FStrWhenDone[Ord(FWhenDone)];
end;

procedure TSysCommand.GetInternalCmdsList(var AList: TStringList);
begin
  // Clean string list
  AList.Clear;
  // Insert all commands
  if FWindowTitle <> '' then
    AList.Add('TITLE ' + FWindowTitle);
  if (FBkColor <> cclNone) and (FFgColor <> cclNone) then
    AList.Add('COLOR ' + FStrColors[Ord(FBkColor)] + FStrColors[Ord(FFgColor)]);
end;

function TSysCommand.GetCommandsString: string;
// Return a string with internal commands and user commands
var
  FList: TStringList;
  idx: Integer;
  s: string;

begin
  s := '';

  // Get internal command list as string
  FList := TStringList.Create;
  GetInternalCmdsList(FList);
  for idx := 0 to FList.Count - 1 do
    s := s + FList.Strings[idx] + ' && ';
  // Concat with user commands list
  for idx := 0 to FCmdsList.Count - 1 do
    s := s + FCmdsList.Strings[idx] + ' && ';
  // Delete last &&
  Delete(s, Length(s) - 3, 4);

  // Return commands string
  Result := '"' + s + '"';
end;

function TSysCommand.Execute: Boolean;
var
  FCmd: string;
  FExec: string;

begin
  // get name and path of command processor
  FCmd := GetEnvironmentVariable('COMSPEC');

  FExec := FCmd + ' ' + GetParamsString + ' ' + GetCommandsString;
  Result := WinExec(PChar(FExec), SW_SHOWNORMAL) > 31;
end;

end.

Note: The TSysCommand probably can be extended to support Linux Terminal Mode.
It would be a fine addition and a good reason to use this component in a application.

How to search a TRichEdit for lines with a special pattern and change their colour

Problem/Question/Abstract:

How do I scan a TRichEdit from top to bottom and check for lines with a special pattern to change color? I only know SelStart and SelLength, but how do I select a line at a time?

Answer:

var
  S: string;
  i: Integer;

{ ... }
with richedit1 do
begin
  lines.beginupdate;
  try
    for i := 0 to lines.count - 1 do
    begin
      S := Lines[i];
      if LineShouldBeColored(S) then
      begin
        SelStart := Perform(EM_LINEINDEX, i, 0);
        SelLength := Length(S);
        SelAttributes.Color := clRed;
      end;
    end;
  finally
    SelStart := 0;
    Perform(EM_SCROLLCARET, 0, 0);
    lines.endupdate;
  end;
end;

How to refresh the client rectangle

Problem/Question/Abstract:

A config form allows the user to change the background, but I can't refresh the complete client area when coming back from the config form. Only the config form area is refreshed.

Answer:

procedure TMainWin.InvalidateClient;
var
  R: TRect;
begin
  R := Classes.Rect(0, 0, ClientWidth, ClientHeight);
  InvalidateRect(ClientHandle, @R, true);
end;

How to save several TBitmaps into one file

Problem/Question/Abstract:

Does anybody know whether it is possible to write some small TBitmaps with different widths and heights into one file?

Answer:

Saving the TBitmap to a Stream, and appending other TBitmaps to that stream, then saving the stream to disk would be the method.

procedure SaveBitmapToStream(aBitmap: TBitmap; aStream: TStream);
var
  ms: TMemoryStream;
  size: Integer;
begin
  Assert(Assigned(aBitmap));
  Assert(Assigned(aStream));
  ms := TMemoryStream.Create;
  try
    aBitmap.SaveToStream(ms);
    ms.position := 0;
    size := ms.Size;
    aStream.WriteBuffer(size, Sizeof(size));
    aStream.CopyFrom(ms, size);
  finally
    ms.free
  end;
end;

then

aStream.SaveToFile('FileName');

to read then first off do:

aStream.LoadFromFile('FileName');

then

procedure LoadBitmapFromStream(aBitmap: TBitmap; aStream: TStream);
var
  ms: TMemoryStream;
  size: Integer;
begin
  Assert(Assigned(aBitmap));
  Assert(Assigned(aStream));
  ms := TMemoryStream.Create;
  try
    aStream.ReadBuffer(size, Sizeof(size));
    ms.CopyFrom(aStream, size);
    ms.position := 0;
    aBitmap.LoadfromStream(ms);
  finally
    ms.free
  end;
end;

How to get the RGB value of a pixel under the mouse cursor

Problem/Question/Abstract:

How can I get the hex RGB value of the pixel under the cursor? I want to be able to do this when the cursor is over an image.

Answer:

Solve 1:

Mouse movement:


procedure TForm1.ImageMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
begin
  ColNumb := Image.Canvas.Pixels[X, Y]; {The image can't be a JPG}
  GetRGB(ColNumb, R, G, B);
  {Here are the RGB values you need}
end;


The GetRGB procedure:


procedure GetRGB(Col: TColor; var R, G, B: Byte);
var
  Color: $0..$FFFFFFFF;
begin
  Color := ColorToRGB(Col);
  R := ($000000FF and Color);
  G := ($0000FF00 and Color) shr 8;
  B := ($00FF0000 and Color) shr 16;
end;


Solve 2:

var
  MyColor: TColor;
begin
  MyColor := Image1.Canvas.Pixels[x, y];
  Label1.Caption := format('Red: %d; Green: %d; Blue:%d',
    [GetRValue(MyColor), GetGValue(MyColor), GetBValue(MyColor)]);
end;


Solve 3:

function DesktopColor(const x, y: integer): TColor;
var
  c: TCanvas;
begin
  c := TCanvas.create;
  c.handle := GetWindowDC(GetDesktopWindow);
  result := getpixel(c.handle, x, y);
  c.free;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  pos: TPoint;
begin
  GetCursorPos(Pos);
  Panel1.Color := DesktopColor(pos.x, pos.y);
end;

How to draw on the Desktop

Problem/Question/Abstract:

I'd like to draw on the screen, and not necessarily in the application form. Example: When the application is running but the form is minimized, I'd like to be able to draw a circle on the desktop.

Answer:

procedure THovedForm.Tegn1ButtonClick(Sender: TObject);
var
  DesktopDC: HDC;
  Rectangle: TRect;
  pcTekst: PChar;
begin
  DesktopDC := GetWindowDC(GetDesktopWindow);
  MoveToEx(DesktopDC, 0, 0, nil);
  LineTo(DesktopDC, Screen.Width, Screen.Height);
  MoveToEx(DesktopDC, 0, Screen.Height, nil);
  LineTo(DesktopDC, Screen.Width, 0);
  pcTekst := 'Finn Tolderlund';
  SetTextColor(DesktopDC, clBlue);
  Rectangle.Left := 150;
  Rectangle.Top := 250;
  Rectangle.Right := 150 + 100;
  Rectangle.Bottom := 250 + 100;
  SetBkMode(DesktopDC, Transparent);
  DrawTextEx(DesktopDC, pcTekst, -1, Rectangle, DT_CENTER or DT_NOCLIP, nil);
  ReleaseDC(GetDesktopWindow, DesktopDC);
end;

How to get a list of Parallel ports on a PC

Problem/Question/Abstract:

How to get a list of Parallel ports on a PC

Answer:

function PortExists(const PortName: string): Boolean;
var
  hPort: HWND;
begin
  Result := False;
  hPort := CreateFile(PChar(PortName), {name}
    GENERIC_READ or GENERIC_WRITE, {access attributes}
    0, {no sharing}
    nil, {no security}
    OPEN_EXISTING, {creation action}
    FILE_ATTRIBUTE_NORMAL or
    FILE_FLAG_OVERLAPPED, {attributes}
    0); {no template}
  if hPort <> INVALID_HANDLE_VALUE then
  begin
    CloseHandle(hPort);
    Result := True;
  end;
end;

{Parallel Ports}
for i := 1 to 9 do
begin
  if PortExists('LPT' + IntToStr(i)) then
    List.Append('Ports: Printer Port (LPT' + IntTostr(i) + ')');
end;

Inside Delphi's Classes and Interfaces Part II

Problem/Question/Abstract:

You've probably used classes & interfaces more than once in your delphi programs. Did you ever dtop to think how delphi implements this creatures ?

Answer:

Inorder to understand this article, you must read the previous article (Inside Delphi's Classes and Interfaces Part I).
In this article we'll finish covering Delphi's implementation of Interfaces, and review a few usefull conclusions.

Let's start with an indepth example :

type

  IInterface1 = interface
    procedure ActA;
    procedure ActB;
  end;

  IInterface2 = interface(IInterface1)
    procedure ActC;
    procedure ActD; stdcall;
  end;

  TSampleClass = class(TInterfacedObject, IInterface1, IInterface2)
    procedure ActA;
    procedure ActB;
    procedure ActC;
    procedure ActD; stdcall;
  end;

var
  Interface1: IInterface1;
  Interface2: IInterface2;
  Sample: TSampleClass;
begin
  Sample := TSampleClass.Create;
  Interface1 := Sample;
  Interface2 := Sample;
  Interface1.ActA;
  Interface1.ActB;
  Interface2.ActA;
  Interface2.ActB;
  Interface2.ActC;
  Interface2.ActD;
end;

Instead of looking at the compiled code for this example, I'll simlpy note the interesting aspects of it. First, when assigning a value to Interface1, we'd expect delphi to take the value of  what 'Sample' points to and add a specific amount ($10) and be done with it. When assigning a value to Interface2, we'd expect delphi to do the same, just add a smaller amount ($0C) because the interfaces are stored in memory from the last to the first.
But delphi doesn't do that. It assignes both Interface1 AND Interface2 the value that 'Sample' points to plus $0C. That's because IInterface2 inherites from IInterface1. Therefor,  IInterface2 includes IInterface1. Hence, any call to Interface1, will actually be executed through IInterface2's method list.

Second, when we call Interface1.ActA, it calles the 4th (every interface inherites from IUnknown) method on IInterface2's method list (because IInterface2 inherites from IInterface1). When we call Interface1.ActB it calles the 5th method on IInterface2's method list. When we call Interface2.ActA it calles the 4th method on IInterface2's method list, just the same as Interface1.ActA. That's because IInterface2 inherites from IInterface1.

Third, when we call Interface2.ActD delphi addes one additional instruction before calling the 7th method of IInterface2. That's because we've declared a different convention call to the method (stdcall). Notice that all of IUnknown's methods are defined with the stdcall directive.

The structor of an interface's method list always follows the following rule :

First Method
.
.
Last Method
The parent's interface's method list

In our case, IInterface2's method list is as follows :
  
ActC
ActD
// IInterface1's method list
   ActA
   ActB
   // IUnknown's method List
      QueryInterface
     _AddRef
     _Release

NOTE : The structor above is how the methods' code is organized in memory. The first entry in any interface's method list will belong to QueryInterface (the first method of IUnknown) but it will point to a place in memory (the implementation of that specific interface's QueryItnerface method) that is higher than the interfaces' own methods' implementation - as shown in the structor above. In our case, IInterface2's QueryInterface's implementation is higher in memory than IInterface2's ActB's implementation, which is higher in memory than ActD's implementation. Thou ActD is the 7th entry, ActB is the 5th entry and QueryInterface is the 1st entry in IInterface2's method list.

To fully understand what happens when delphi calls an interface's method, lets have a look at the compiled method list of IInterface2 in the example above. The following code is an exact copy of the compiled code (except for the comments) :

// ActC
add eax, -$0C
jmp TSampleClass.ActC
// ActD
add dword ptr[esp + $04], -$0C
jmp TSampleClass.ActD
// ActA
add eax, -$0C
jmp TSampleClass.ActA
// ActB
add eax, -$0C
jmp TSampleClass.ActB
// QueryInterface
add dword ptr[esp + $04], -$0C
jmp TInterfacedObject.QueryInterface
// _AddRef
add dword ptr[esp + $04], -$0C
jmp TInterfacedObject._AddRef
// _Release
add dword ptr[esp + $04], -$0C
jmp TInterfacedObject._Release

As you remember, an object's method is actually a regular function/procedure that accepts as a parameter an instance of the method's class. As you can notice, before each call to the real method ('TSampleClass.ActD' for example) there is one line of code that changes the value of either 'eax', or 'dword ptr [esp + $04]', depending on the calling convention. As you can notice, in all cases we subtract $0C form a variable. But, why 12 ($0C = 12) ? That's because this interface (IInterface2) is in the 3rd (FRefcount, IUnknown are before it) place after the pointer to VMT of the clasS TSampleClass. Therefore, the value of any instance of IInterface2 of TSampleClass (Interface2 for example) is actually the value of the pointer to that class' instance plus 12.

Here is another example that will help understand the section above. The following code continues the defenitions from the above code :

type

  IAnotherInterface = interface
    procedure ActE;
  end;

  TAnotherSample = class(TInterfacedObject, IInterface2, IAnotherInterface)
    procedure ActA;
    procedure ActB;
    procedure ActC;
    procedure ActD; stdcall;
    procedure ActE;
  end;

var
  Interface2: IInterface2;
begin
  Interface2 := TAnotherSample.Create;
  Interface2.ActC;
end;

Now, let's compare the entry for this example's IInterface2 and the previous' one :

IInterface2 of TAnotherSample:
add eax, -$10
jmp TAnotherSample.ActC

IInterface2 of TSampleClass:
add eax, -$0C
jmp TSampleClass.ActC

There are two obvious changes :

The actuall function that is called (either TAnotherSample.ActC or TSampleClass.ActC)  
The amount that 'eax' is changed by. Notice that when calling IInterface2 of TAnotherSample, 'eax' is changed by 16 ($10 = 16) as opposed to being changed by 12. That's because on TAnotherSample, the IInterface2 is the second interface in the instance's structor in memory, and therefor it is "farther away" from the instance itself and needs to be changed by additional 4 bytes.

And now to some usefull sutff :

First, if you want to check if 2 (or more) interface variables are of the same instance, you cannot simply compare them, even if they are of the same type. You must QueryInterface them to a single interface type, and then compare. As a general rule, if you want to compare interfaces, QueryInterface them to IUnknown and then compare.

Example :

type

  IBooA = interface
  end;

  IBooB = interface
  end;

  TBoo = class(TInterfacedObject, IBooA, IBooB)
  end;

var
  Boo: TBoo;
  BooA: IBooA;
  BooB: IBooB;
begin
  Boo := TBoo.create;
  BooA := Boo;
  BooB := Boo;

  // This won't complie
  if BooA = BooB then
  begin
    Beep;
  end;

  if Integer(BooA) = Integer(BooB) then
  begin
    // will never get here
    Beep;
  end;

  if IUnknown(BooA) = IUnknown(BooB) then
  begin
    // will never get here
    Beep;
  end;

  // the 'as' word is the same as QueryInterface when acting on interfaces
  if (BooA as IUnknown) = (BooB as IUnknown) then
  begin
    // Will always get here
    Beep;
  end;
end;

Explaination : The first comparing won't complie, becuase BooA and BooB are of 2 different types. The Second and third comparings will complie but never return true. That's because type casting doesn't change the value of the variable that's being type casted. It only allows the complier to complie the code though there are two different types involved. Hence, if BooA is different from BooB, comparing them will never return true, no matter what type casting is done to them.
But why do BooA and BooB have different values ? They were both assigned using the ":= Boo;" statment. The answer is simple. Remeber that I said that an interface's variable's value is actually the value of the instance itself (or at least the value of the pointer to the instance) plus a different number for each interface ? In our case, BooA is the same as what Boo points to, added 16. And BooB is the same as what Boo points to, added 12. That's why BooA and BooB are not that same.
The Forth comparing actually works. That's because if an interface is from the same type, then comparing it to an interface of that type will always return the expected result (if both interfaces were aquired via QueryInterface, not by type casting). That's because if they are of the same type, then the difference between them and the instance is the same. And if they are of the same instance, then they must be equal.
That is, each interface is equal to it's instance + a specific Delta (the Delta depeneds on the interface). In other words, Interface = Instace + Delta. If 'Instance' is the same for both interfaces, and the 'Delta' is the same (cause they are of the same interface type), then both interfaces must be equal.

Note : This is the way delphi works, for good and for bad. You should take this in mind when writing code for propertys of interface type. The following code wouldn't work properly :

TSample = class
private
  FData: IUnknown;
  procedure SetData(Value: IUnknown);
protected
  procedure Changed; virtual; abstract;
public
  property Data: IUnknown read FData write SetData;
end;

procedure TSample.SetData(Value: IUnknown);
begin
  // This is incorrect.
  if Value <> FData then
  begin
    FData := Value;
    Changed;
  end;
end;

It might seem that this code should work, but it might not work when someone would assgin the property 'Data' with an IUnknown retreived by a type cast. The correct code should be :

procedure TSample.SetData(Value: IUnknown);
begin
  if (Value as IUnknown) <> (FData as IUnknown) then
  begin
    FData := Value;
    Changed;
  end;
end;

Second, each interface you declare that a class implements (with exception of interfaces that inherite from other interfaces) means that each instance of that class will take up 4 more byte of memory. That might seem like nothing (and probably is) except for one case. Consider the following code :

IInterfaceA = interface
end;

IInterfaceB = interface
end;

TSampleClass1 = class(TInterfacedObject, IInterfaceA)
end;

TSampleClass2 = class(TSampleClass1, IInterfaceA, IInterfaceB)
end;

It would seem that each instance of TSampleClass1 should take up 16 bytes, and each instance of TSampleClass2 should take up 20 bytes (4 bytes more, because it supports one more interface). That is not true. Each instance of TSampleClass1 does take up 16 byte. But, each instance of TSampleClass2 takes up 24 bytes ! That's because delphi creates an interface entry even for interfaces that are already implemented by parent classes.
The solution to this is simple. Just remove the decleration of IInterfaceA from TSampleClass2. This will not change the fact that TSampleClass2 implements IInterfaceA, cause TSamlpeClass2 inherites from TSamlpeClass1, which implements IInterface1. This wouldn't have happened if IInterfaceB was a decendant of IInterfaceA.
  
This might add up to quit alot if you do your inheritence improporely. For example :

TSampleClass1 = class(TInterfacedObject, IUnknown)
end;

TSampleClass2 = class(TSampleClass1, IUnknown)
end;

TSampleClass3 = class(TSampleClass2, IUnknown)
end;

TSampleClass4 = class(TSampleClass3, IUnknown)
end;

TSampleClass5 = class(TSampleClass4, IUnknown)
end;

Each instance of TSampleClass5 takes up 32 bytes of memory, though it has no real data (except for FRefCount of TItnerfacedObject).

How to assign multiple TEdit fields to variables

Problem/Question/Abstract:

Is there an easier way to assign multiple Edit fields to variables without individually setting each one? Here is a sample code.

type
  testrec = record
    fees: array[1..10] of string[65];
  end;

var
  dat: testrec;

procedure FormToDat;
begin
  fees[1] := Edit1.Text;
  fees[2] := Edit2.Text;
  fees[3] := Edit3.Text;
  fees[4] := Edit4.Text;
  { ... }
end;

This sample code seems inefficient and I'm thinking there might be an easier way to do this.

Answer:

There are a wide variety of ways to do this in Delphi, here's one:

var
  I: Integer;
  C: TComponent;
begin
  for I := 1 to 10 do
  begin
    C := FindComponent('Edit' + IntToStr(I));
    if C is TEdit then
      TEdit(C).Text := Fees[1];
  end;
end;

You could also store references to the edits in a TList or an array, or you could also iterate through the Controls or Components properties.

Enabling a horizontal scrollbar in a TListBox

Problem/Question/Abstract:

Enabling a horizontal scrollbar in a TListBox

Answer:

Solve 1:

There is no such property in TListBox. To force a listbox to have horizontal scrollbars, use the message LB_SETHORIZONTALEXTENT.

// e.g. in FormCreate(..)
begin
  ListBox1.Width := 300;
  // listbox can be scrolled by 100 pixels horizontally now:
  SendMessage(ListBox1.Handle, LB_SETHORIZONTALEXTENT, 400, 0);
end;


Solve 2:

MaxWidth := 0;
for i := 0 to ListBox1.Items.Count - 1 do
  if MaxWidth < ListBox1.Canvas.TextWidth(ListBox1.Items.Strings[i]) then
    MaxWidth := ListBox1.Canvas.TextWidth(ListBox1.Items.Strings[i]);
SendMessage(ListBox1.Handle, LB_SETHORIZONTALEXTENT, MaxWidth + 100, 0);

It uses the Messages .dcu.