Use PBM_SETMARQUEE and PBS_MARQUEE in Delphi

Problem/Question/Abstract:

According to Microsoft you could use a progress bar with style set to PBS_MARQUEE if you don't know the final value. It will show a progress bar with only a gradient going from left to right. I find no other references to these constants except from MSDN. Anyone know how to use them in Delphi?

Answer:

It's defined in CommCtrl.h:

#if (_WIN32_WINNT >= 0x0501)
#define PBS_MARQUEE             0x08
#define PBM_SETMARQUEE          (WM_USER+10)
#endif      // _WIN32_WINNT >= 0x0501

In Delphi (untested):

{ ... }
const
  PBS_MARQUEE = $08;
  PBM_SETMARQUEE = (WM_USER + 10);

You set this style by subclassing the TProgressBar.CreateParams methods and setting PBS_MARQUEE:

procedure TMyProgressBar.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  Params.Style := Params.Style or PBS_MARQUEE;
end;

You can now turn on the marquee:

SendMessage(MyProgressBar1.Handle, PBS_SETMARQUEE, 1, 200);

and off:

SendMessage(MyProgressBar1.Handle, PBS_SETMARQUEE, 0, 200);

The 200 is the number of milliseconds between animation updates.

A Simple Notepad with Delphi 6

Problem/Question/Abstract:

A Simple Notepad with Delphi (though reinventing the wheel)

Answer:

All the functions available in the normal notepad will be available with this and also I have added two more things in the Options menu (Want Tabs and Want Returns); by default, it’s been checked. And you can change the background color of the notepad, though you cannot save. Some functions like find text, replace have to be revisited though. If you people have any ideas on that, please feel free to share/update the code.

The following is the entire code:

Project Code:  DelphiNotepad.dpr

program DelphiNotepad;

uses
  Forms,
  NotePad1 in 'NotePad1.pas' {Form1},
  GoToForm in 'GoToForm.pas' {frmGoTo};

{$R *.res}

begin
  Application.Initialize;
  Application.Title := 'Delphi Notepad';
  Application.CreateForm(TForm1, Form1);
  Application.CreateForm(TfrmGoTo, frmGoTo);
  Application.Run;
end.

Unit One Code: Notepad1.pas

unit NotePad1;
{
Unit Name : NotePad1.pas
Developed By : S S B Magesh Puvananthiran
Description : A simple notepad developed with Delphi 6
}
interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ConvUtils, Menus, ComCtrls, StrUtils, ExtDlgs;

type
  TForm1 = class(TForm)
    Memo1: TMemo;
    MainMenu1: TMainMenu;
    FileMenu: TMenuItem;
    FileNew: TMenuItem;
    FileOpen: TMenuItem;
    EditMenu: TMenuItem;
    Undo: TMenuItem;
    N1: TMenuItem;
    Cut: TMenuItem;
    Copy: TMenuItem;
    Paste: TMenuItem;
    SelectAll1: TMenuItem;
    FormatMenu: TMenuItem;
    WordWrap: TMenuItem;
    FileSave: TMenuItem;
    Exit2: TMenuItem;
    FileExit: TMenuItem;
    SelectAll: TMenuItem;
    Font: TMenuItem;
    HelpMenu: TMenuItem;
    AboutNotepad: TMenuItem;
    TimeDate: TMenuItem;
    OpenDialog1: TOpenDialog;
    SaveDialog1: TSaveDialog;
    StatusBar1: TStatusBar;
    FontDialog1: TFontDialog;
    SaveAs1: TMenuItem;
    FilePrint: TMenuItem;
    N2: TMenuItem;
    PrintDialog1: TPrintDialog;
    PrinterSetupDialog1: TPrinterSetupDialog;
    FindDialog1: TFindDialog;
    N3: TMenuItem;
    Find: TMenuItem;
    FindNext: TMenuItem;
    Replace: TMenuItem;
    GoTo1: TMenuItem;
    ReplaceDialog1: TReplaceDialog;
    BackgroundColor: TMenuItem;
    ColorDialog1: TColorDialog;
    Options1: TMenuItem;
    WantTabs1: TMenuItem;
    WantReturns1: TMenuItem;
    procedure FileExitClick(Sender: TObject);
    procedure AboutNotepadClick(Sender: TObject);
    procedure FileOpenClick(Sender: TObject);
    procedure FileSaveClick(Sender: TObject);
    procedure FileNewClick(Sender: TObject);
    procedure WordWrapClick(Sender: TObject);
    procedure FontClick(Sender: TObject);
    procedure UndoClick(Sender: TObject);
    procedure CutClick(Sender: TObject);
    procedure CopyClick(Sender: TObject);
    procedure PasteClick(Sender: TObject);
    procedure SelectAllClick(Sender: TObject);
    procedure TimeDateClick(Sender: TObject);
    procedure Memo1Change(Sender: TObject);
    procedure Memo1MouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure Memo1KeyUp(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure FormCreate(Sender: TObject);
    procedure SaveAs1Click(Sender: TObject);
    procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
    procedure FilePrintClick(Sender: TObject);
    procedure PageSetupClick(Sender: TObject);
    procedure FindDialog1Find(Sender: TObject);
    procedure FindClick(Sender: TObject);
    procedure FindNextClick(Sender: TObject);
    procedure ReplaceClick(Sender: TObject);
    procedure ReplaceDialog1Replace(Sender: TObject);
    procedure ReplaceDialog1Find(Sender: TObject);
    procedure GoTo1Click(Sender: TObject);
    procedure BackgroundColorClick(Sender: TObject);
    procedure WantTabs1Click(Sender: TObject);
    procedure WantReturns1Click(Sender: TObject);
  private
    procedure OpenTheFile;
    function SaveChanges: Boolean;
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

uses GoToForm;

{$R *.dfm}

procedure TForm1.AboutNotepadClick(Sender: TObject);
begin
  ShowMessage('   Delphi Notepad ' + #13 +
    '   Developed with Borland Delphi 6 Enterprise Trial Edition');
end;

procedure TForm1.FileExitClick(Sender: TObject);
begin
  Close;
end;

procedure TForm1.FileOpenClick(Sender: TObject);
begin
  if not (Memo1.Modified) then
    OpenTheFile
  else if (Memo1.Modified) then
  begin
    ModalResult := MessageDlg('Save Changes?', mtConfirmation, [mbYes, mbNo,
      mbCancel], 0);
    if ((ModalResult = mrYes) and (SaveChanges)) or (ModalResult = mrNo) then
    begin
      OpenTheFile;
      Memo1.Modified := False;
    end;
  end;
end;

procedure TForm1.FileSaveClick(Sender: TObject);
begin
  if SaveChanges then
    Memo1.Modified := False;
end;

procedure TForm1.FileNewClick(Sender: TObject);
begin
  if not (Memo1.Modified) then
  begin
    Memo1.Clear;
    Form1.Caption := 'UnNamed - Delphi Notepad';
    OpenDialog1.FileName := '';
    SaveDialog1.FileName := '';
  end
  else if (Memo1.Modified) then
  begin
    ModalResult := MessageDlg('Save Changes?', mtConfirmation, [mbYes, mbNo,
      mbCancel], 0);
    if (ModalResult = mrYes) and (SaveChanges) then
    begin
      Memo1.Clear;
      Form1.Caption := 'UnNamed - Delphi Notepad';
      Memo1.Modified := False;
      OpenDialog1.FileName := '';
      SaveDialog1.FileName := '';
    end
    else if ModalResult = mrNo then
    begin
      Memo1.Clear;
      Form1.Caption := 'UnNamed - Delphi Notepad';
      OpenDialog1.FileName := '';
      SaveDialog1.FileName := '';
      Memo1.Modified := False;
    end;
  end;
end;

procedure TForm1.OpenTheFile;
begin
  if OpenDialog1.Execute then
  begin
    Memo1.Lines.LoadFromFile(OpenDialog1.FileName);
    Form1.Caption := OpenDialog1.FileName + ' - ' + 'Delphi Notepad';
  end;
end;

function TForm1.SaveChanges: Boolean;
begin
  Result := False;
  if (OpenDialog1.FileName = '') and (SaveDialog1.FileName = '') then
  begin
    if SaveDialog1.Execute then
    begin
      Screen.Cursor := crHourGlass;
      StatusBar1.SimpleText := 'Saving...';
      Memo1.Lines.SaveToFile(SaveDialog1.FileName);
      Form1.Caption := SaveDialog1.FileName + ' - ' + 'Delphi Notepad';
      StatusBar1.SimpleText := 'Ready';
      Screen.Cursor := crDefault;
      Result := True;
    end;
  end
  else
  begin
    Screen.Cursor := crHourGlass;
    StatusBar1.SimpleText := 'Saving...';
    if OpenDialog1.FileName <> '' then
    begin
      Memo1.Lines.SaveToFile(OpenDialog1.FileName);
      Form1.Caption := OpenDialog1.FileName + ' - ' + 'Delphi Notepad';
    end
    else if SaveDialog1.FileName <> '' then
    begin
      Memo1.Lines.SaveToFile(SaveDialog1.FileName);
      Form1.Caption := SaveDialog1.FileName + ' - ' + 'Delphi Notepad';
    end;

    StatusBar1.SimpleText := 'Ready';
    Screen.Cursor := crDefault;
    Result := True;
  end;
end;

procedure TForm1.WordWrapClick(Sender: TObject);
begin
  if WordWrap.Checked then
  begin
    Memo1.WordWrap := True;
    Memo1.ScrollBars := ssVertical;
  end
  else
  begin
    Memo1.WordWrap := False;
    Memo1.ScrollBars := ssBoth;
  end;
end;

procedure TForm1.FontClick(Sender: TObject);
begin
  if FontDialog1.Execute then
  begin
    Memo1.Font := FontDialog1.Font;
    Memo1.Font.Color := FontDialog1.Font.Color;
  end;
end;

procedure TForm1.UndoClick(Sender: TObject);
begin
  if (Memo1.Modified) and (Memo1.CanUndo) then
    Memo1.Undo;
end;

procedure TForm1.CutClick(Sender: TObject);
begin
  Memo1.CutToClipboard;
end;

procedure TForm1.CopyClick(Sender: TObject);
begin
  Memo1.CopyToClipboard;
end;

procedure TForm1.PasteClick(Sender: TObject);
begin
  Memo1.PasteFromClipboard;
end;

procedure TForm1.SelectAllClick(Sender: TObject);
begin
  Memo1.SelectAll;
end;

procedure TForm1.TimeDateClick(Sender: TObject);
begin
  Memo1.SelText := DateToStr(Now) + TimeToStr(Time);
end;

procedure TForm1.Memo1Change(Sender: TObject);
begin
  if (Memo1.Modified) and (Memo1.CanUndo) then
    Undo.Enabled := True
  else
    Undo.Enabled := False;
end;

procedure TForm1.Memo1MouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  if Memo1.SelText <> '' then
  begin
    Cut.Enabled := True;
    Copy.Enabled := True;
  end
  else
  begin
    Cut.Enabled := False;
    Copy.Enabled := False;
  end;
end;

procedure TForm1.Memo1KeyUp(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
  if Memo1.SelText <> '' then
  begin
    Cut.Enabled := True;
    Copy.Enabled := True;
  end
  else
  begin
    Cut.Enabled := False;
    Copy.Enabled := False;
  end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  Form1.Caption := 'UnNamed - Delphi Notepad';
end;

procedure TForm1.SaveAs1Click(Sender: TObject);
begin
  if SaveDialog1.Execute then
  begin
    Memo1.Lines.SaveToFile(SaveDialog1.FileName);
    Form1.Caption := SaveDialog1.FileName + ' - Delphi Notepad';
    Memo1.Clear;
    Memo1.Lines.LoadFromFile(SaveDialog1.FileName);
  end;
end;

procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
  if (Memo1.Modified) then
  begin
    ModalResult := MessageDlg('Save Changes?', mtConfirmation, [mbYes, mbNo,
      mbCancel], 0);
    if ((ModalResult = mrYes) and (SaveChanges)) or (ModalResult = mrNo) then
      CanClose := True
    else
      CanClose := False;
  end
  else if not (Memo1.Modified) then
    CanClose := True;
end;

procedure TForm1.FilePrintClick(Sender: TObject);
begin
  if PrintDialog1.Execute then
    Print
  else
    PrinterSetupDialog1.Execute;
end;

procedure TForm1.PageSetupClick(Sender: TObject);
begin
  PrinterSetupDialog1.Execute;
end;

procedure TForm1.FindDialog1Find(Sender: TObject);
var
  I, J, PosReturn, SkipChars: Integer;
  CursorPos: TPoint;
begin
  CursorPos := Memo1.CaretPos;
  if frDown in FindDialog1.Options then
  begin
    for I := CursorPos.Y + 1 to Memo1.Lines.Count do
    begin
      PosReturn := Pos(FindDialog1.FindText, Memo1.Lines[I]);
      if (PosReturn <> 0) then
      begin
        SkipChars := 0;
        for J := 0 to I - 1 do
          SkipChars := SkipChars + Length(Memo1.Lines[J]);
        SkipChars := SkipChars + (I * 2);
        SkipChars := SkipChars + PosReturn - 1;

        Memo1.SelStart := SkipChars;
        Memo1.SelLength := Length(FindDialog1.FindText);
        Break;
      end;
    end;
  end
  else
  begin
    for I := CursorPos.Y - 1 downto 0 do
    begin
      PosReturn := Pos(FindDialog1.FindText, Memo1.Lines[I]);
      if PosReturn <> 0 then
      begin
        SkipChars := 0;
        for J := 0 to I - 1 do
          SkipChars := SkipChars + Length(Memo1.Lines[J]);
        SkipChars := SkipChars + (I * 2);
        SkipChars := SkipChars + PosReturn - 1;

        Memo1.SelStart := SkipChars;
        Memo1.SelLength := Length(FindDialog1.FindText);
        Break;
      end;
    end;
  end;
end;

procedure TForm1.FindClick(Sender: TObject);
begin
  FindDialog1.Execute;
end;

procedure TForm1.FindNextClick(Sender: TObject);
begin
  FindDialog1Find(nil);
end;

procedure TForm1.ReplaceClick(Sender: TObject);
begin
  ReplaceDialog1.Execute;
end;

procedure TForm1.ReplaceDialog1Replace(Sender: TObject);
var
  CursorPos: TPoint;
  I, J, SkipChars, PosReturn: integer;
begin
  if frReplace in ReplaceDialog1.Options then
    Memo1.SelText := ReplaceDialog1.ReplaceText
  else if frReplaceAll in ReplaceDialog1.Options then
  begin
    CursorPos := Memo1.CaretPos;
    for I := CursorPos.Y + 1 to Memo1.Lines.Count do
    begin
      PosReturn := Pos(ReplaceDialog1.FindText, Memo1.Lines[I]);
      if PosReturn <> 0 then
      begin
        SkipChars := 0;
        for J := 0 to I - 1 do
          SkipChars := SkipChars + Length(Memo1.Lines[J]);
        SkipChars := SkipChars + (I * 2);
        SkipChars := SkipChars + PosReturn - 1;

        Memo1.SelStart := SkipChars;
        Memo1.SelLength := Length(ReplaceDialog1.FindText);
        Memo1.SelText := ReplaceDialog1.ReplaceText;
      end;
    end;
  end;
end;

procedure TForm1.ReplaceDialog1Find(Sender: TObject);
var
  I, J, PosReturn, SkipChars: Integer;
  CursorPos: TPoint;
begin
  CursorPos := Memo1.CaretPos;
  for I := CursorPos.Y + 1 to Memo1.Lines.Count do
  begin
    PosReturn := Pos(ReplaceDialog1.FindText, Memo1.Lines[I]);
    if PosReturn <> 0 then
    begin
      SkipChars := 0;
      for J := 0 to I - 1 do
        SkipChars := SkipChars + Length(Memo1.Lines[J]);
      SkipChars := SkipChars + (I * 2);
      SkipChars := SkipChars + PosReturn - 1;

      Memo1.SelStart := SkipChars;
      Memo1.SelLength := Length(ReplaceDialog1.FindText);
      Break;
    end;
  end;
end;

procedure TForm1.GoTo1Click(Sender: TObject);
begin
  frmGoTo.ShowModal;
end;

procedure TForm1.BackgroundColorClick(Sender: TObject);
begin
  if ColorDialog1.Execute then
    Memo1.Color := ColorDialog1.Color;
end;

procedure TForm1.WantTabs1Click(Sender: TObject);
begin
  if WantTabs1.Checked then
    Memo1.WantTabs := True
  else
    Memo1.WantTabs := False;
end;

procedure TForm1.WantReturns1Click(Sender: TObject);
begin
  if WantReturns1.Checked then
    Memo1.WantReturns := True
  else
    Memo1.WantReturns := False;
end;

end.

Unit One Form File : Notepad1.dfm

object Form1: TForm1
  Left = 160
    Top = 107
    Width = 579
    Height = 414
    ActiveControl = Memo1
    Caption = 'Delphi Notepad'
    Color = clBtnFace
    Font.Charset = DEFAULT_CHARSET
    Font.Color = clWindowText
    Font.Height = -11
    Font.Name = 'MS Sans Serif'
    Font.Style = []
    Menu = MainMenu1
    OldCreateOrder = False
    Position = poScreenCenter
    OnCloseQuery = FormCloseQuery
    OnCreate = FormCreate
    PixelsPerInch = 96
    TextHeight = 13
    object Memo1: TMemo
    Left = 0
      Top = 0
      Width = 571
      Height = 349
      Align = alClient
      BevelInner = bvNone
      Color = clWhite
      HideSelection = False
      ScrollBars = ssBoth
      TabOrder = 0
      WantTabs = True
      WordWrap = False
      OnChange = Memo1Change
      OnKeyUp = Memo1KeyUp
      OnMouseUp = Memo1MouseUp
  end
  object StatusBar1: TStatusBar
    Left = 0
      Top = 349
      Width = 571
      Height = 19
      Panels = <>
      SimplePanel = True
      SimpleText = 'Ready'
  end
  object MainMenu1: TMainMenu
    Left = 256
      Top = 176
      object FileMenu: TMenuItem
      Caption = '&File'
        object FileNew: TMenuItem
        Caption = '&New'
          ShortCut = 16462
          OnClick = FileNewClick
      end
      object FileOpen: TMenuItem
        Caption = '&Open...'
          ShortCut = 16463
          OnClick = FileOpenClick
      end
      object FileSave: TMenuItem
        Caption = '&Save'
          ShortCut = 16467
          OnClick = FileSaveClick
      end
      object SaveAs1: TMenuItem
        Caption = 'Save &As...'
          OnClick = SaveAs1Click
      end
      object Exit2: TMenuItem
        Caption = '-'
      end
      object FilePrint: TMenuItem
        Caption = '&Print...'
          ShortCut = 16464
          OnClick = FilePrintClick
      end
      object N2: TMenuItem
        Caption = '-'
      end
      object FileExit: TMenuItem
        Caption = 'E&xit'
          OnClick = FileExitClick
      end
    end
    object EditMenu: TMenuItem
      Caption = '&Edit'
        object Undo: TMenuItem
        Caption = '&Undo'
          Enabled = False
          ShortCut = 16474
          OnClick = UndoClick
      end
      object N1: TMenuItem
        Caption = '-'
      end
      object Cut: TMenuItem
        Caption = 'C&ut'
          Enabled = False
          ShortCut = 16472
          OnClick = CutClick
      end
      object Copy: TMenuItem
        Caption = '&Copy'
          Enabled = False
          ShortCut = 16451
          OnClick = CopyClick
      end
      object Paste: TMenuItem
        Caption = '&Paste'
          ShortCut = 16470
          OnClick = PasteClick
      end
      object SelectAll1: TMenuItem
        Caption = '-'
      end
      object Find: TMenuItem
        Caption = '&Find...'
          ShortCut = 16454
          OnClick = FindClick
      end
      object FindNext: TMenuItem
        Caption = 'Find &Next...'
          ShortCut = 114
          OnClick = FindNextClick
      end
      object Replace: TMenuItem
        Caption = '&Replace'
          ShortCut = 16456
          OnClick = ReplaceClick
      end
      object GoTo1: TMenuItem
        Caption = '&Go To...'
          ShortCut = 16455
          OnClick = GoTo1Click
      end
      object N3: TMenuItem
        Caption = '-'
      end
      object SelectAll: TMenuItem
        Caption = 'Select &All'
          ShortCut = 16449
          OnClick = SelectAllClick
      end
      object TimeDate: TMenuItem
        Caption = 'Time/Date'
          ShortCut = 116
          OnClick = TimeDateClick
      end
    end
    object Options1: TMenuItem
      Caption = '&Options'
        object WantTabs1: TMenuItem
        AutoCheck = True
          Caption = '&Want Tabs'
          Checked = True
          OnClick = WantTabs1Click
      end
      object WantReturns1: TMenuItem
        AutoCheck = True
          Caption = 'Want &Returns'
          Checked = True
          OnClick = WantReturns1Click
      end
    end
    object FormatMenu: TMenuItem
      Caption = '&Format'
        object WordWrap: TMenuItem
        AutoCheck = True
          Caption = '&WordWrap'
          OnClick = WordWrapClick
      end
      object Font: TMenuItem
        Caption = '&Font...'
          OnClick = FontClick
      end
      object BackgroundColor: TMenuItem
        Caption = '&Background Color...'
          OnClick = BackgroundColorClick
      end
    end
    object HelpMenu: TMenuItem
      Caption = '&Help'
        object AboutNotepad: TMenuItem
        Caption = '&About Delphi Notepad'
          OnClick = AboutNotepadClick
      end
    end
  end
  object OpenDialog1: TOpenDialog
    DefaultExt = '*.txt'
      Filter = 'Text Files|*.txt|All Files|*.*'
      InitialDir = 'C:\MyDocuments'
      Title = 'Open File...'
      Left = 328
      Top = 192
  end
  object SaveDialog1: TSaveDialog
    DefaultExt = '*.txt'
      Filter = 'Text Files|*.txt|All Files|*.*'
      InitialDir = 'C:\'
      Options = [ofOverwritePrompt, ofHideReadOnly, ofEnableSizing]
      Title = 'Save File...'
      Left = 312
      Top = 136
  end
  object FontDialog1: TFontDialog
    Font.Charset = DEFAULT_CHARSET
      Font.Color = clWindowText
      Font.Height = -11
      Font.Name = 'MS Sans Serif'
      Font.Style = []
      MinFontSize = 0
      MaxFontSize = 0
      Left = 272
      Top = 192
  end
  object PrintDialog1: TPrintDialog
    Options = [poPrintToFile, poPageNums, poSelection, poWarning, poHelp,
      poDisablePrintToFile]
      Left = 272
      Top = 192
  end
  object PrinterSetupDialog1: TPrinterSetupDialog
    Left = 216
      Top = 72
  end
  object FindDialog1: TFindDialog
    Options = [frDisableMatchCase, frDisableWholeWord]
      OnFind = FindDialog1Find
      Left = 152
      Top = 192
  end
  object ReplaceDialog1: TReplaceDialog
    Options = [frDisableMatchCase, frDisableWholeWord]
      OnFind = ReplaceDialog1Find
      OnReplace = ReplaceDialog1Replace
      Left = 272
      Top = 192
  end
  object ColorDialog1: TColorDialog
    Ctl3D = True
      Left = 240
      Top = 224
  end
end

Unit Two Code:  GoToForm.pas

unit GoToForm;
{
Unit Name : GoToForm.pas
Developed By : S S B Magesh Puvananthiran
Description : A simple form to enter the line number.
}
interface

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

type
  TfrmGoTo = class(TForm)
    Edit1: TEdit;
    BitBtn1: TBitBtn;
    BitBtn2: TBitBtn;
    procedure BitBtn1Click(Sender: TObject);
    procedure FormShow(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  frmGoTo: TfrmGoTo;

implementation

uses NotePad1;

{$R *.dfm}

procedure TfrmGoTo.BitBtn1Click(Sender: TObject);
var
  LineNum, PosReturn, i, SkipChars: integer;
begin
  try
    PosReturn := 0;
    LineNum := StrToInt(Edit1.Text) - 1;
    if (LineNum >= 1) and (LineNum + 1 <= Form1.Memo1.Lines.Count - 1) then
    begin
      SkipChars := 0;
      for i := 0 to LineNum - 1 do
      begin
        SkipChars := SkipChars + Length(Form1.Memo1.Lines[i]);
        PosReturn := Pos(Form1.Memo1.Lines.Strings[0], Form1.Memo1.Lines[i]);
      end;
      Close;
      Form1.Memo1.SetFocus;
      SkipChars := SkipChars + PosReturn;
      Form1.Memo1.SelStart := SkipChars + (LineNum * 2);
      Form1.Memo1.SelLength := 1;
    end
    else
    begin
      MessageDlg('Line Number Out of Range', mtWarning, [mbOk], 0);
      Edit1.Text := IntToStr(Form1.Memo1.Lines.Count);
      Edit1.SelectAll;
    end;
  except
    MessageDlg('''' + Edit1.Text + '''' + ' is Not a valid integer value', mtError,
      [mbOk], 0);
  end;
end;

procedure TfrmGoTo.FormShow(Sender: TObject);
begin
  Edit1.Text := '1';
  Edit1.SelectAll;
end;

end.

Unit Two Form File: GoToForm.dfm

object frmGoTo: TfrmGoTo
  Left = 100
    Top = 108
    Width = 211
    Height = 88
    ActiveControl = Edit1
    BorderIcons = [biSystemMenu]
    Caption = 'Go To Line'
    Color = clBtnFace
    Font.Charset = DEFAULT_CHARSET
    Font.Color = clWindowText
    Font.Height = -11
    Font.Name = 'MS Sans Serif'
    Font.Style = []
    OldCreateOrder = False
    Position = poScreenCenter
    OnShow = FormShow
    PixelsPerInch = 96
    TextHeight = 13
    object Edit1: TEdit
    Left = 2
      Top = 3
      Width = 121
      Height = 21
      TabOrder = 0
      Text = '1'
  end
  object BitBtn1: TBitBtn
    Left = 126
      Top = 3
      Width = 75
      Height = 25
      TabOrder = 1
      OnClick = BitBtn1Click
      Kind = bkOK
  end
  object BitBtn2: TBitBtn
    Left = 126
      Top = 35
      Width = 75
      Height = 25
      TabOrder = 2
      Kind = bkCancel
  end
end


Component Download: DelphiNotepad.zip

Sql Server External Stored Procedures in Delphi

Problem/Question/Abstract:

When stored procedures aren't enough and you want to create functionality within a query, external procedures may be helpful

Answer:

Writing MS SQL Server Extended Stored Procedures with Delphi

Microsoft SQL Server 6.5 and 7 have the powerful capability to make functions in DLL's available as stored procedures. Microsoft calls them Extended Stored Procedures. If you've read this article, you know what Extended Stored Procedures are, what you can do with them, and how to install them on a SQL Server. You should also be able to use the object-oriented framework I wrote, which makes writing Extended Stored Procedures with Delphi extremely easy.

I assume you are familiar with SQL Server and with the concept of stored procedures. The code and examples in this article apply both to SQL Server 6.5 and SQL Server 7.

What are Extended Stored Procedures?

Extended Stored Procedures (called xp's afterwards) are part of Microsoft's Open Data Services (ODS) for SQL Server. With ODS you can do three things:

Making routines in a DLL available as stored procedures to any SQL Server user.
Write procedure server applications. They are similar to xp's, however they run as a separate network server application and could even be running on a different machine (3-tier).
Writing gateways to non-SQL Server based environments.

In the following figure a graphical overview of the ODS architecture is given.



In this article I discuss the art of writing stored procedures with Delphi. Technically this DLL is part of SQL server, therefore programmer errors may corrupt your SQL Server, so it's not an art without danger.

Making parts of your application available on the server has some advantages, for example:

Some things are easy to write in Delphi, but difficult or impossible using Transact SQL. For example you might use some routines written in a language you don't understand or don't have the source code for, so you can't translate it to Transact SQL (with the possibility of errors creeping in during this translation).
Delphi routines run much faster than Transact SQL. Take for example numerical calculations.
You can interface with other programs, databases and such. For example you could write an xp that accepts the name of a paradox table and returns the contents of this table as a SQL Server result set.

Xp's live in DLL's and can therefore be written in any language which can produce DLL's like Delphi can. Before going into detail about how to write xp's, first some examples from a user's point of view. Let's assume we have an xp called xp_incbyone1 which increments a given number by one. We can call xp_incbyone1 as followings:

        declare
          @mynumber integer

        select @mynumber = 1

        exec master..xp_incbyone1 @mynumber output

        select @mynumber

The declare statement declares a variable @mynumber of type integer. Next we set it to one, pass it to the xp and allow the xp to modify it by appending output to the parameter. Finally we display the number with a select statement to see if it has been updated. The result should be 2 of course.

In this example we have an xp which returns an output parameter. Xp's can also return a result set. The example xp_incbyone2 returns the number as a result set. The code to call it would be:

        declare
         @mynumber integer

        select @mynumber = 1

        exec master..xp_incbyone2 @mynumber

xp_incbyone2 will return a table of just one column and one row containing the value 1.

Both xp_incbyone1 and xp_incbyone2 are described in detail in the next section where I present the framework.

As you see, for users extended stored procedures work exactly like stored procedures. Just like stored procedures, extended stored procedures can return parameters and/or result sets.

Each implementation of an xp needs to do the same things:

Check that the caller of the procedure has provided all of the required parameters and that each parameter is of the appropriate data type. Return an appropriate message if not.
Define the columns for returning a result set.
Create each record for returning to the caller.
Set up any output parameters and return statuses used by the procedure.
When finished returning results, send the results completion message using srv_senddone with the SRV_DONE_MORE status flag.
Return from the procedure with the desired Transact-SQL return status.

Step 1 is necessary because, unless normal stored procedures, it is up to the programmer to validate any user-specified parameters for xp's. Step 2 and 3 are optional, and are applicable only if you return a result set. Step 4 is also optional, and applies only if you return output parameters.

Writing xp's with Delphi

The C programmer who wants to develop xp's has to install the SQL Server 7 development tools. This option can be turned on when installing SQL Server 7. In the directory \MSSQL7\devtools\ you will find all the required header files and demo-programs. Unfortunately, Inprise did not supply a translation of these header files with Delphi. Therefore I had to translate the most important parts by hand to Delphi. This means that you don't need to install the SQL Server 7 development tools if you use this framework to write xp's. If you want to add more pieces you will need this resource kit though. Or you can ask me if I've time to expand the framework a bit to cover the missing pieces. Note: in previous version of SQL Server the development tools were part of the the BackOffice resource kit.

In the previous paragraph 6 steps were mentioned each xp has to do. The framework makes step 1 through 4 easier by taking care of details. You also can use Delphi types, because the framework does type translation between SQL Server types and Delphi types. The framework takes entirely care off step 5 and 6.

You use this framework as follows:

Create an object of class TSQLXProc and implement its Execute method.
Write a procedure that allocates this object, calls it's Run method and frees the object. The name of this procedure should be equal to the name of your extended stored procedure. It's calling method should be stdcall.

To make this more concrete, let's implement the xp_incbyone1 stored procedure. The 1st step is to create a new object based on TSQLXProc and implement its Execute method. It's header looks like this:

type
  TXPIncByOne1 = class(TSQLXProc)
    function Execute: Boolean; override;
  end;

The Execute method looks like this:

function TXPIncByOne1.Execute: Boolean;
begin
  Params[1] := Params[1] + 1;
  Result := True;
end;

The 2nd step is to write a procedure that calls this object. This is the procedure that SQL Server is actually calling. For xp_incbyone1 it looks like this:

function xp_incbyone1(srvproc: PSRV_PROC): SRVRETCODE; stdcall;
const
  ExpectedParams = 1;
var
  xp: TSQLXProc;
begin
  xp := TXPIncByOne1.Create(srvproc, ExpectedParams);
  Result := xp.Run;
  xp.Free;
end;

It's that easy!

Let's look in more detail to the first step. The only thing you'll ever need to do is to implement the Execute method. This function returns True or False. If False is returned, an error is returned to the calling application or user. Exceptions are caught by the code that calls your Execute method and a similar error is returned to the calling application or user.

You have access to the parameters of a stored procedure by using the variant array Params. Parameters are numbered from one onwards. As noted earlier SQL Server does no type checking on xp parameters. The framework returns parameters as variants, so it's a bit more robust against different parameters, but variant conversion errors may occur if a parameter type mismatches. You might want to use the ODS API call srv_paramtype to explicitly retrieve and check parameter types, but so far I've not found a need this. Another solution for checking parameter types is to use the VarType function. See Table 1 for a list of Transact-SQL data types and corresponding Delphi data types.

If a parameter is Null, the Params property returns the variant type Null. Equally, if you want to return Null, set the corresponding parameter in Params to Null.

Let's look in more detail to the second step. This step will probably always be the same except for the value of the ExpectedParams const and the particular object to instantiate. This procedure is called by SQL Server with one parameter: srvproc. We pass this parameter to the instantiated object and we pass it the number of parameters to expect. If the actual number of parameters is different from this an error message will be send back to the calling application/user. Pass zero if you don't want to check for the number of parameters, for example to support a variable number of parameters.

Next we call the Run method of the instantiated object, which in turn will call our Execute method (surrounded by for example a try..except block). Finally we free the object.

Now let's tackle an xp which returns a result set. It's header is this:

type
  TXPIncByOne2 = class(TSQLXProc)
    function Execute: Boolean; override;
  end;

It's body is this:

function TXPIncByOne2.Execute: Boolean;
var
  myint: integer;
begin
  DescribeColumn('my column name', SRVINT4, 4, SRVINT4, 4, @myint);
  Myint := Params[1] + 1;
  SendRow;
  Result := True;
end;

And the procedure to call this object is this:

function xp_incbyone2(srvproc: PSRV_PROC): SRVRETCODE; stdcall;
const
  ExpectedParams = 1;
var
  xp: TSQLXProc;
begin
  xp := TXPIncByOne2.Create(srvproc, ExpectedParams);
  Result := xp.Run;
  xp.Free;
end;

We now have a bit more complicated Execute method. In case we want to return a result set, we need to describe every row in the resulting table: its column name, its destination type, its destination length, its source type, its source length and a pointer to the source data. You should call DescribeColumn for every column in the result table. The next step is to fill the source data, that's the assignment to myint. The row is now complete, so we can send it to SQL Server using SendRow. You should prepare source data and call SendRow for every row in the result table. And finally just return True and exit. After that SQL Server will send the entire result table to the client.

The xp_incbyone2 procedure is still a simple call the object and exit. In the remaining examples I will omit this procedure.

Table 1: supported types for use with DescribeColumn.

ODS constant  
TSQL data type(s)
Delhi data type(s)
SRVVARCHAR
varchar
string
SRVCHAR
char  
string
SRVINTN
tinyint, smallint, int
shortint,smallint,integer
SRVBIT  
bit
Boolean
SRVDECIMAL
numeric/decimal
n/a (string)
SRVNUMERIC
numeric/decimal
n/a (string)
SRVFLTN
real, float
single, double
SRVMONEYN
smallmoney, money
n/a (integer, DBMONEY)
SRVDATETIMN
smalldatetime, datetime
TDateTime


I implemented two xp's from the sample xp's which Microsoft implemented in xp.c. The first one simply copies the contents of the first parameter to the second parameter. The second one returns the free space from every drive available on the SQL Server computer.

To avoid name clashes I called the first xp xp_delphiecho instead of xp_echo. The second one is called xp_delphidisklist instead of xp_disklist. Especially xp_echo looks ways more elegant than the Microsoft's sample program. You really should have a look at xp.c!

The code for xp_delphiecho is:

function TXPEcho.Execute: Boolean;
begin
  Params[2] := Params[1];
  Result := True;
end;

The code for xp_delphidisklist is:

function TXPDiskList.Execute: Boolean;
var
  drivename: char;
  space_remaining: Int32;
  drivenums: Int32;
  rootname: string;
  SectorsPerCluster,
    BytesPerSector,
    NumberOfFreeClusters,
    TotalNumberOfClusters: dword;

  function IsDrive(drive: char): Boolean;
  begin
    IsDrive := (drivenums and (1 shl (Ord(drive) - Ord('A')))) <> 0;
  end;

begin
  DescribeColumn('drive', SRVCHAR, 1, SRVCHAR, 1, @drivename);
  DescribeColumn('bytes free', SRVINT4, 4, SRVINT4, 4, @space_remaining);
  drivenums := GetLogicalDrives;
  for drivename := 'C' to 'Z' do
  begin
    if IsDrive(drivename) then
    begin
      rootname := drivename + ':\';
      GetDiskFreeSpace(
        PChar(rootname),
        SectorsPerCluster,
        BytesPerSector,
        NumberOfFreeClusters,
        TotalNumberOfClusters);
      space_remaining := SectorsPerCluster * NumberOfFreeClusters * BytesPerSector;
      SendRow;
    end;
  end;
  Result := True;
end;

In the first two lines the description of the result table is given. The result table consists of two columns 'drive' and 'bytes free'. Next for every drive we fill the variables drivename and space_remaining and send back the row using SendRow.

The framework in more detail

The framework itself is in the unit odsxp.pas. In the following figure you see how this framework fits within the ODS architecture.  



SQL Server loads and calls the DLL. You have written a simple method which creates an object of type TSQLXProc. You call its Run method.

The Run method does some checks and calls you back on a method you have written, the Execute method. When you are finished, you return to Run, which in return sends the results back to SQL Server.

Installing xp's on SQL Server

All of the material in this section can also be found in the Microsoft SQL Programmers Toolkit or in the Microsoft Transact-SQL reference.

Installing xp's differs between SQL Server 6.5 and SQL Server 7.0. Everything that works under SQL Server 6.5 also works under SQL Server 7.

Installing xp's on SQL Server 7

Installing an extended stored procedure on SQL Server 7 can be done using the SQL Enterprise manager:

Open a server.
Go to item `Databases'.
Select the master database.
Right click it and choose `New Extended Stored Procedure', see figure below
Give the name of a function in the DLL and the location and name of the DLL itself.




Installing xp's on SQL Server 6.5

When you have compiled your DLL you have to install it in the appropriate directory. Copy the file to the same directory as the standard SQL Server DLL files. Usually this directory is something like c:\mssql\binn, note binn with two n's not the bin directory with a single n which also exists! As with other DLL's, once the extended stored procedure DLL is placed in the appropriate directory and the appropriate paths are set, you can make its functions available to users immediately. It is not necessary to restart the server.

For each function provided in an extended stored procedure DLL, a SQL Server system administrator must run the sp_addextendedproc system procedure, specifying the name of the function and the name of the DLL in which that function resides. For example:

sp_addextendedproc 'xp_delphiecho', 'xpdelphi.dll'

This command registers the function xp_delphiecho, located in the file xpdelphi.dll, as a SQL Server extended stored procedure. You must run sp_addextendedproc in the master database.

To drop individual extended stored procedures, a system administrator uses the system procedure sp_dropextendedproc.

Once a system administrator has added an extended stored procedure, users can find out what new functions are available by using the system procedure sp_helpextendedproc. When used without an argument, sp_helpextendedproc displays all extended stored procedures that are currently registered with the master database. If you specify an extended stored procedure name as an argument, sp_helpextendedproc verifies whether that function is currently available.

Extended Stored Procedures are subject to the same security mechanisms as regular stored procedure. For example to give every right on the xp_delphiecho xp, run the following command in the master database:

        grant exec on xp_delphiecho to public

Calling extended stored procedures

Every user can now call xp_delphiecho from every database by prefixing xp_delphiecho with 'master..'. For example to call xp_delphiecho from the pubs database you say:

        exec master..xp_delphiecho @paramin, @paramout output

Unloading extended stored procedures

SQL Server loads an extended stored procedure DLL as soon as a call is made to one of the DLL's functions. The DLL remains loaded until the server is shut down or until the system administrator uses the DBCC command to unload it. For example:

DBCC xpdelphi(FREE)

This command unloads xpdelphi.dll, allowing the system administrator to copy in a newer version of this file without shutting down the server. You probably will need this command quite a lot to debug your xp's!

Files

The following source files are provided:

xpdelphi.dpr: sample DLL with all discussed xp's.
xpdelphi.sql: script to add all xp's in xpdelphi.dll to the master database.
odsxp.pas: the unit with the discussed framework.
compileit.bat: compile the example program.

Further reading

You can find more information about Extended Stored Procedures in the SQL Server manuals. Also you can consult the following Microsoft Knowledge Base articles:

Q190987: "Extended Stored Procedures: What Everyone Should Know".
Q194661: "SQL Server COM Object Persistence Model".

These knowledge base articles discuss some internals you definitively have to know when writing more advanced xp's.

Conclusions

A framework has been presented which makes writing Microsoft SQL Server Extended Stored Procedures a breeze. Four sample xp's have been shown and discussed. Let me know which interesting applications you have developed using this package!


Component Download: 1293_C.zip

Component Serialization

Problem/Question/Abstract:

Serialization is the process of saving a component state (To a file of stream). Delphi provides a nice infrastructure for serialization of components (The DFM Way). But how do we utilize this infrastructure to the fullest? What are the limitations?

Answer:

Introduction

In order to understand serialization, we need to define what serialization is, what we want to save (the component state) and how do we use the mechanism if it exists. Only after understanding those concepts, we can continue to learn how to write components to use this infrastructure.

Serialization: I define serialization components as the process of taking a component, saving the component state, so we can reconstruct another component later that is identical to the original component. I do not know if there is a formal definition to serialization, and my definition my not be the best, but for this article, it is enough. An object that can be serialized is sometimes called persistent object. In Delphi, all components are by default persistent (with some limitations I&#8217;ll talk about later in this article).

Component State: A Component state is what distinguishes a component from another component of the same type. If two components have the same state, we can replace one with the other without any change in the application. One can say that the state of a component is the algebraic sum of it&#8217;s properties.

Serializing a component in Delphi is a simple process, using the stream classes. To save a component to some media, all we need to do is create the appropriate stream, and save the component to the stream. In order to load the component, we need only to create the stream object, and then read the component.

Example of saving a component to file:

procedure TForm1.SaveComponent;
var
  Stream: TFileStream;
begin
  Stream := TFileStream.Create('c:\temp\mycomponent.dat', fmCreate);
  try
    Stream.WriteComponent(MyComponent);
  finally
    Stream.Free;
  end;
end;

Example of loading a component from the file:

procedure TForm1.F;
var
  Stream: TFileStream;
  MyComponent: TComponent;
begin
  Stream := TFileStream.Create('c:\temp\mycomponent.dat', fmOpenRead);
  try
    Stream.ReadComponent(MyComponent);
  finally
    Stream.Free;
  end;
end;

Special conversion functions

Two special functions must be mentioned. ObjectBinaryToText and ObjectTextToBinary. Those two functions manipulate streams; can convert the stream content between the binary representation and a text (DFM like) representation. Those functions are very useful to debug streaming of object, and to provide readable streams.

Example of saving a component to a text file:

procedure TForm1.SaveComponent;
var
  Stream2: TFileStream;
  Stream1: TMemoryStream;
begin
  Stream1 := TMemoryStream.Create;
  Stream2 := TFileStream.Create('c:\temp\mycomponent.dat', fmCreate);
  try
    Stream1.WriteComponent(MyComponent);
    Stream1.position := 0;
    ObjectBinaryToText(Stream1, Stream2);
  finally
    Stream1.Free;
    Stream2.Free;
  end;
end;

Component Support for serialization

We tend to think that components are serialization ready. In general, that is true. A Component will know how to serialize all of it&#8217;s published properties (unless they are of type TComponent, I&#8217;ll explain later why). Moreover, 3rd-party components we use normally are serialization ready, hiding the messy stuff. However, if you are a component writer, and you need to create a serialization ready component, you need to go into a partially documented area. In the rest of this article, this is what I will discuss.

Components know how to serialize all published properties that are of atom types (string, char, integer and the such), TPersistent descendent objects (but not components). TComponent also defines a vast infrastructure to serialize more types of data. I know of 5 methods, each with its uses, advantages and disadvantages (There may be more methods in the VCL that I have overlooked).

Extending components using TPersistent.
Extending components using TCollection.
Extending components using DefineProperties Override.
Extending components using Child Components (Component Composition).
Extending components using Component Aggregation.

Note: The names I gave to those methods are not taken from Borland Documentation or any other source. Those names are the names I use to identify the various serialization methods, and you are welcome to disagree with the names    

1. Extending components using TPersistent.

This method of is useful for composition relation between a TComponent object and one TPersistent object. This method is available in both Delphi 5 and 6.
A Component will stream by default any property of type TPersistent that is not a TComponent. Our TPersistent property is streamed just like a component, and it may have other TPersistent properties that will get streamed.

The VCL makes the assumption that the property always has an object created. If we do not initialize the TPersistent object before we try to read the parent component, we will get an error.

Advantage:

The simplest method to support compositions.

Disadvantages:

Cannot stream TComponent derived properties.
Cannot be used in a polymorph property (a property that the object is points to may be of different classes in different situations).
The TPersistent object must be created in the constructor of the parent TComponent.

Example:

See TpersistentExampleXX Unit in the example code.

type
  TPersistentExampleRoot = class(TComponent)
  private
    FBranch: TPersistentExampleChild;
    FC: string;
    procedure SeTPersistentExampleChild(const Value: TPersistentExampleChild);
    procedure SetC(const Value: string);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property Branch: TPersistentExampleChild read FBranch write
      SeTPersistentExampleChild;
    property C: string read FC write SetC;
  end;

  TPersistentExampleChild = class(TPersistent)
  private
    FB: string;
    procedure SetB(const Value: string);
  public
  published
    property B: string read FB write SetB;
  end;

I define two classes, one a TComponent, another as a TPersistent. I Set the TComponent to reference the TPersistent. That&#8217;s all.

2. Extending components using TCollection.

This method is useful for composition relation between a TComponent and one or more TPersistent objects. This method is available in both Delphi 5 and 6.
A TComponent will stream any published property that is a TCollection. The great thing, is that with almost no work you can serialize a list of objects.

I am not going to provide a full explanation of this method, as it is documented well in the Delphi help files.

Advantages:

Provides a simple method to stream a list of TPersistent objects.

Disadvantages:

All the objects must be of a single class, derived from TCollectionItem.
Cannot stream TComponent derived objects.

Example:

See CollectionExampleXX Unit in the example code.

3. Extending components using DefineProperties Override.

This method allows the definition of semi-properties. Semi-properties are not real properties, but are treated as properties by the Delphi streaming system. This method applies to both Delphi 5 and 6.

DefineProperties has two major uses &#8211; when you need to stream properties that are not normally supported by Delphi (like array properties), or when you need to customize the method a property is streamed.

How does it work:

You must override the DefineProperties method (defined in the TPersistent class), and in the derived function you need to call the DefineProperty or DefineBinaryProperty of the Filer parameter.
You need to pass two methods to the DefineXXX functions, one for reading the property value, the other to write the value.
In those two functions, you get a TReader and TWriter objects as parameters, and you are free to read and write whatever you want. The only limitation is that the reader and the writer will traverse the same number of bytes.

Advantage:

Allows more control over streaming properties.
Allows streaming of any type of data.

Disadvantages:

Requires more work &#8211; for each sub-property we must write two methods.
When saving some types of data (like TComponents), ObjectBinaryToText fails.
When saving TComponents, references from the saved TComponent to other objects may not be restored (referenced from within the saved component properties tree to objects outside it will not be restored).

Example:

See the DefinePropertiesExampleXX Unit in the example code.
In this example, I define an object who streams two outrival properties &#8211; An array and a TComponent.
The Class declaration is:

type
  TDefinePropertiesExample = class(TComponent)
  private
    FIntegers: array of Integer;
    FChild: TComponent;
    procedure ReadIntegers(Reader: TReader);
    procedure ReadChild(Reader: TReader);
    procedure WriteIntegers(Writer: TWriter);
    procedure WriteChild(Writer: TWriter);
    function GetIntegers(Index: Integer): Integer;
    procedure SetIntegers(Index: Integer; const Value: Integer);
  protected
    procedure DefineProperties(Filer: TFiler); override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    property Integers[Index: Integer]: Integer read GetIntegers write SetIntegers;
    property Child: TComponent read FChild write FChild;
  end;

Take special notice to the DefineProperties Function override, and to the Read&#8230; and Write&#8230; Functions.
The DefineProperties function:

procedure TDefinePropertiesExample.DefineProperties(Filer: TFiler);
begin
  inherited;
  Filer.DefineProperty('Integers', ReadIntegers, WriteIntegers, True);
  Filer.DefineProperty('IntegersCount', ReadIntegerCount, WriteIntegerCount, True);
  // If we do not reference a child component, do not save any. (If we
  // try, we will get an error).
  Filer.DefineProperty('Child', ReadChild, WriteChild, FChild <> nil);
end;

And the write / read functions:

procedure TDefinePropertiesExample.ReadChild(Reader: TReader);
begin
  Reader.ReadComponent(FChild);
end;

procedure TDefinePropertiesExample.ReadIntegerCount(Reader: TReader);
begin
  // read the length of the array.
  SetLength(FIntegers, Reader.ReadInteger);
end;

procedure TDefinePropertiesExample.ReadIntegers(Reader: TReader);
var
  I: Integer;
begin
  // write the integers in the array.
  Reader.ReadListBegin;
  I := Low(FIntegers);
  while not Reader.EndOfList do
  begin
    FIntegers[i] := Reader.ReadInteger;
    Inc(I);
  end;
  Reader.ReadListEnd;
end;

procedure TDefinePropertiesExample.WriteChild(Writer: TWriter);
begin
  Writer.WriteComponent(FChild);
end;

procedure TDefinePropertiesExample.WriteIntegerCount(Writer: TWriter);
begin
  // write the length of the array.
  Writer.WriteInteger(Length(FIntegers));
end;

procedure TDefinePropertiesExample.WriteIntegers(Writer: TWriter);
var
  I: Integer;
begin
  // write the integers in the array.
  Writer.WriteListBegin;
  for I := Low(FIntegers) to High(FIntegers) do
    Writer.WriteInteger(FIntegers[i]);
  Writer.WriteListEnd;
end;

4. Extending components using Child Components (Component Composition).

This method is available only in Delphi 6.
The method allows to stream child components that have a composition relation with the parent component. The method is very similar to method 1 (TPersisent), and is in fact an extension of that method.
Don&#8217;t get confused &#8211; In Delphi 5 you cannot serialize a child TComponent easily.  You will have to use DefineProperties (method 3), or by Component Aggregation (method 5).

How does it work:

Each TComponent has a property ComponentStyle of type TComponentStyle. This type is a set of some flags. One of those flags is csSubComponent. A Component who has this flag set will be serialized by this method.

The method has the same advantages and disadvantages as the TPersistent method (1).

Example:

See the SubComponentExampleXX Unit in the example code.
First, we must create the SubComponent in the constructor of the parent component.

constructor TSubComponentExRoot.Create(AOwner: TComponent);
begin
  inherited;
  FSomeString := 'This is the root component';
  FChild := TSubComponentExChild.Create(Self);
end;

Then, we need to tell the SubComponent that it is a SubComponent (when we want it serialized).

procedure TSubComponentExRoot.SetChildComponentFlag(Value: Boolean);
begin
  FChild.SetSubComponent(Value);
end;


5. Extending components using Component Aggregation.

This method is available both in Delphi 5 and 6.
The method allows streaming any number of child components, without the limitation that we need to know the number in advance or the limitation that we need to create the child components in the constructor of the root component. This is what makes this method different then the others &#8211; it serializes child components and not sub-components. Delphi Forms, DataModules and Frames are using this method to save their state to the DFM files.
This method has some variations between Delphi 5 and 6 (primarily in the fixup stage.

How does it work?

Saving the child components:

In the TComponent class we have the GetChildren function. A component we wishes to serialize it&#8217;s child components needs to override this function, and call the proc parameter function for each child component.

Reading the child components:

When reading the root components, all of the child components will be read, and added to it&#8217;s components array. The root component will be the owner of all the components read, regardless of who where their owner before we wrote them. You are assures that the components will be read completely with all the data you wish, BUT there is a tricky part .

References between the components read and from the components read to other components are another matter. In Delphi documentation and sources this is called the fixup stage &#8211; fixing the references between the read components. There are two types of fixups &#8211; local and global.

Local fixup is restoring references between components read at the same time (two components on the same form, for example). The trick here is that both components have to be owned by the root component before we saved them. Take a good look at the example application and play with the owners of the child components, to see when those references are restored and when they are not.

Global fixups is the process of restoring references between the read components and some other components already existing. Delphi has a method to locate those other existing component in the classes unit that changed between Delphi 5 and 6.

In Delphi 5, the global fixup process uses a function pointer called FindGlobalComponent. In the forms unit, This pointer is set to point to a function called FindGlobalComponent. This function uses a global list of all forms and datamodules to find those components. In order to extend the global fixup to support our objects, we need to replace this function and restore it, and it is a messy code.

In Delphi 6, Borland fixed this spaghetti, by replacing the FindGlobalComponent function pointer with a function, that it using a list of Find Component function. We can now register out own find component function to co-exist with the Delphi 6 &#8216;forms unit&#8217; function. The register functions are RegisterFindGlobalComponentProc and UnRegisterFindGlobalComponentProc.
There is a lot more to say on the fixup subject, and I hope someone will take the time to explain it better.

Advantage:

Allows streaming of full dynamic component trees.
Allows restoring complicated referenced between saved components and to other components in the application.

Disadvantages:

Complicated and easily broken (normally we do not mind who the owner of a component is, but here is has a strong affect).
The fixup process is verry complicated and I find it hard to use.

Example Code:

See the ComponentAggregationExampleXX Unit in the example code.

The GetChildren Function:

procedure TComponentFirstChild.GetChildren(Proc: TGetChildProc;
  Root: TComponent);
begin
  inherited;
  if (FSecondChild <> nil) and SaveChild then
    Proc(FSecondChild);
end;

How to read CSV files with TStringList.CommaText when the value between commas contains a space

Problem/Question/Abstract:

When reading comma separated files with TStringList.CommaText, there is a problem, if the value between commas contains a space it is broken up to two separate values. Any suggestion on how to avoid this?

Answer:

Solve 1:

I had a similar problem and wrote a function that replaces all commas (,) with carriage returns (#13). So you can do:

StringList1.Text := CommaSeparate(TheCSVString);

function CommaSeparate(const szString: string): string;
var
  iLength: integer;
  i: integer;
  bDoubleQuotesActive: boolean;
  szOutput: string;
begin
  iLength := Length(szString);
  bDoubleQuotesActive := False;
  for i := 1 to iLength do
  begin
    if szString[i] = ',' then
    begin
      if not bDoubleQuotesActive then
        szOutput := szOutput + Chr(13);
    end
    else if szString[i] = '"' then
    begin
      if bDoubleQuotesActive then
        bDoubleQuotesActive := False
      else
        bDoubleQuotesActive := True;
    end
    else
      szOutput := szOutput + szString[i];
  end;
  Result := szOutput;
end;


Solve 2:

{ ... }
interface
{So CommaText will have the same meaning as CSV}
TCommaStrings = class(TStringList)
private
  function GetCommaText: string;
  procedure SetCommaText(const Value: string);
public
  property CommaText: string read GetCommaText write SetCommaText;
end;

implementation

function TCommaStrings.GetCommaText: string;
var
  S: string;
  P: PChar;
  I, Count: Integer;
begin
  Count := GetCount;
  if (Count = 1) and (Get(0) = '') then
    Result := '""'
  else
  begin
    Result := '';
    for I := 0 to Count - 1 do
    begin
      S := Get(I);
      P := PChar(S);
      while not (P^ in [#0..' ', '"', ',']) do
        P := CharNext(P);
      if (P^ <> #0) then
        S := AnsiQuotedStr(S, '"');
      Result := Result + S + ',';
    end;
    System.Delete(Result, Length(Result), 1);
  end;
end;

procedure TCommaStrings.SetCommaText(const Value: string);
var
  P, P1: PChar;
  S: string;
begin
  BeginUpdate;
  try
    Clear;
    P := PChar(Value);
    while P^ in [#1..' '] do
      P := CharNext(P);
    while P^ <> #0 do
    begin
      if P^ = '"' then
        S := AnsiExtractQuotedStr(P, '"')
      else
      begin
        P1 := P;
        while (P^ >= ' ') and (P^ <> ',') do
          P := CharNext(P);
        SetString(S, P1, P - P1);
      end;
      Add(S);
      while P^ in [#1..' '] do
        P := CharNext(P);
      if P^ = ',' then
      begin
        repeat
          P := CharNext(P);
        until
          not (P^ in [#1..' ']);
        if P^ = #0 then
          Add('') {Trailing commas ARE another field!}
      end;
    end;
  finally
    EndUpdate;
  end;
end;

A Delphi translation of the IAutoComplete interface

Problem/Question/Abstract:

I'm looking for a Delphi translation of the IAutoComplete interface in Microsofts shldisp.h. Can anyone point me in the right direction, please?

Answer:

Here is the translation and a TEdit decendant I wrote a while back:

unit uAutoComplete;

interface

uses
  Windows, SysUtils, Controls, Classes, ActiveX, ComObj, stdctrls, Forms, Messages;

const
  IID_IAutoComplete: TGUID = '{00bb2762-6a77-11d0-a535-00c04fd7d062}';
  IID_IAutoComplete2: TGUID = '{EAC04BC0-3791-11d2-BB95-0060977B464C}';
  CLSID_IAutoComplete: TGUID = '{00BB2763-6A77-11D0-A535-00C04FD7D062}';
  IID_IACList: TGUID = '{77A130B0-94FD-11D0-A544-00C04FD7d062}';
  IID_IACList2: TGUID = '{470141a0-5186-11d2-bbb6-0060977b464c}';
  CLSID_ACLHistory: TGUID = '{00BB2764-6A77-11D0-A535-00C04FD7D062}';
  CLSID_ACListISF: TGUID = '{03C036F1-A186-11D0-824A-00AA005B4383}';
  CLSID_ACLMRU: TGUID = '{6756a641-de71-11d0-831b-00aa005b4383}';

type
  IACList = interface(IUnknown)
    ['{77A130B0-94FD-11D0-A544-00C04FD7d062}']
    function Expand(pszExpand: POLESTR): HResult; stdcall;
  end;

const
  {Options for IACList2}
  ACLO_NONE = 0; {don't enumerate anything}
  ACLO_CURRENTDIR = 1; {enumerate current directory}
  ACLO_MYCOMPUTER = 2; {enumerate MyComputer}
  ACLO_DESKTOP = 4; {enumerate Desktop Folder}
  ACLO_FAVORITES = 8; {enumerate Favorites Folder}
  ACLO_FILESYSONLY = 16; {enumerate only the file system}

type

  IACList2 = interface(IACList)
    ['{470141a0-5186-11d2-bbb6-0060977b464c}']
    function SetOptions(dwFlag: DWORD): HResult; stdcall;
    function GetOptions(var pdwFlag: DWORD): HResult; stdcall;
  end;

  IAutoComplete = interface(IUnknown)
    ['{00bb2762-6a77-11d0-a535-00c04fd7d062}']
    function Init(hwndEdit: HWND; const punkACL: IUnknown; pwszRegKeyPath,
      pwszQuickComplete: POLESTR): HResult; stdcall;
    function Enable(fEnable: BOOL): HResult; stdcall;
  end;

const
  {Options for IAutoComplete2}
  ACO_NONE = 0;
  ACO_AUTOSUGGEST = $1;
  ACO_AUTOAPPEND = $2;
  ACO_SEARCH = $4;
  ACO_FILTERPREFIXES = $8;
  ACO_USETAB = $10;
  ACO_UPDOWNKEYDROPSLIST = $20;
  ACO_RTLREADING = $40;

type

  IAutoComplete2 = interface(IAutoComplete)
    ['{EAC04BC0-3791-11d2-BB95-0060977B464C}']
    function SetOptions(dwFlag: DWORD): HResult; stdcall;
    function GetOptions(out pdwFlag: DWORD): HResult; stdcall;
  end;

  TEnumString = class(TInterfacedObject, IEnumString)
  private
    FStrings: TStringList;
    FCurrIndex: integer;
  public
    {IEnumString}
    function Next(celt: Longint; out elt; pceltFetched: PLongint): HResult; stdcall;
    function Skip(celt: Longint): HResult; stdcall;
    function Reset: HResult; stdcall;
    function Clone(out enm: IEnumString): HResult; stdcall;
    {VCL}
    constructor Create;
    destructor Destroy; override;
  end;

  TACOption = (acAutoAppend, acAutoSuggest, acUseArrowKey);
  TACOptions = set of TACOption;

  TACSource = (acsList, acsHistory, acsMRU, acsShell);

  TACEdit = class(TEdit)
  private
    FACList: TEnumString;
    FAutoComplete: IAutoComplete;
    FACEnabled: boolean;
    FACOptions: TACOptions;
    FACSource: TACSource;
    function GetACStrings: TStringList;
    procedure SetACEnabled(const Value: boolean);
    procedure SetACOptions(const Value: TACOptions);
    procedure SetACSource(const Value: TACSource);
  protected
    procedure CreateWnd; override;
    procedure DestroyWnd; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property ACStrings: TStringList read GetACStrings;
    property ACEnabled: boolean read FACEnabled write SetACEnabled;
    property ACOptions: TACOptions read FACOptions write SetACOptions;
    property ACSource: TACSource read FACSource write SetACSource;
  end;

implementation

{ IUnknownInt }

function TEnumString.Clone(out enm: IEnumString): HResult;
begin
  Result := E_NOTIMPL;
  pointer(enm) := nil;
end;

constructor TEnumString.Create;
begin
  inherited Create;
  FStrings := TStringList.Create;
  FCurrIndex := 0;
end;

destructor TEnumString.Destroy;
begin
  FStrings.Free;
  inherited;
end;

function TEnumString.Next(celt: Integer; out elt; pceltFetched: PLongint): HResult;
var
  I: Integer;
  wStr: WideString;
begin
  I := 0;
  while (I < celt) and (FCurrIndex < FStrings.Count) do
  begin
    wStr := FStrings[FCurrIndex];
    TPointerList(elt)[I] := CoTaskMemAlloc(2 * (Length(wStr) + 1));
    StringToWideChar(wStr, TPointerList(elt)[I], 2 * (Length(wStr) + 1));
    Inc(I);
    Inc(FCurrIndex);
  end;
  if pceltFetched <> nil then
    pceltFetched^ := I;
  if I = celt then
    Result := S_OK
  else
    Result := S_FALSE;
end;

function TEnumString.Reset: HResult;
begin
  FCurrIndex := 0;
  Result := S_OK;
end;

function TEnumString.Skip(celt: Integer): HResult;
begin
  if (FCurrIndex + celt) <= FStrings.Count then
  begin
    Inc(FCurrIndex, celt);
    Result := S_OK;
  end
  else
  begin
    FCurrIndex := FStrings.Count;
    Result := S_FALSE;
  end;
end;

{ TACEdit }

constructor TACEdit.Create(AOwner: TComponent);
begin
  inherited;
  FACList := TEnumString.Create;
  FACEnabled := true;
  FACOptions := [acAutoAppend, acAutoSuggest, acUseArrowKey];
end;

procedure TACEdit.CreateWnd;
var
  Dummy: IUnknown;
  Strings: IEnumString;
begin
  inherited;
  if HandleAllocated then
  begin
    try
      Dummy := CreateComObject(CLSID_IAutoComplete);
      if (Dummy <> nil) and (Dummy.QueryInterface(IID_IAutoComplete, FAutoComplete) =
        S_OK) then
      begin
        case FACSource of
          acsHistory:
            Strings := CreateComObject(CLSID_ACLHistory) as IEnumString;
          acsMRU:
            Strings := CreateComObject(CLSID_ACLMRU) as IEnumString;
          acsShell:
            Strings := CreateComObject(CLSID_ACListISF) as IEnumString;
        else
          Strings := FACList as IEnumString;
        end;
        if S_OK = FAutoComplete.Init(Handle, Strings, nil, nil) then
        begin
          SetACEnabled(FACEnabled);
          SetACOptions(FACOptions);
        end;
      end;
    except
      {CLSID_IAutoComplete is not available}
    end;
  end;
end;

destructor TACEdit.Destroy;
begin
  FACList := nil;
  inherited;
end;

procedure TACEdit.DestroyWnd;
begin
  if (FAutoComplete <> nil) then
  begin
    FAutoComplete.Enable(false);
    FAutoComplete := nil;
  end;
  inherited;
end;

function TACEdit.GetACStrings: TStringList;
begin
  Result := FACList.FStrings;
end;

procedure TACEdit.SetACEnabled(const Value: boolean);
begin
  if (FAutoComplete <> nil) then
  begin
    FAutoComplete.Enable(FACEnabled);
  end;
  FACEnabled := Value;
end;

procedure TACEdit.SetACOptions(const Value: TACOptions);
const
  Options: array[TACOption] of integer = (ACO_AUTOAPPEND, ACO_AUTOSUGGEST,
    ACO_UPDOWNKEYDROPSLIST);
var
  Option: TACOption;
  Opt: DWORD;
  AC2: IAutoComplete2;
begin
  if (FAutoComplete <> nil) then
  begin
    if S_OK = FAutoComplete.QueryInterface(IID_IAutoComplete2, AC2) then
    begin
      Opt := ACO_NONE;
      for Option := Low(Options) to High(Options) do
      begin
        if (Option in FACOptions) then
          Opt := Opt or DWORD(Options[Option]);
      end;
      AC2.SetOptions(Opt);
    end;
  end;
  FACOptions := Value;
end;

procedure TACEdit.SetACSource(const Value: TACSource);
begin
  if FACSource <> Value then
  begin
    FACSource := Value;
    RecreateWnd;
  end;
end;

initialization
finalization
end.

Screen capture of the desktop when multiple monitors are present

Problem/Question/Abstract:

I currently use DC := GetDC(GetDesktopWindow) to get a screen capture. What do I need to do do to capture the desktop when multiple monitors are present instead of just the primary monitor?

Answer:

Solve 1:

On multi-monitor systems the desktop is one big bitmap. On my dual-monitor system the following captures both desktops into one big bitmap. If you just wanted the second monitor you could adjust the left setting of the TRect to be captured. Keep in mind, however, that some people might arrange monitors other than side by side with monitor 1 on the left and monitor 2 on the right.

procedure GrabScreen(const SourceRect: TRect; Bitmap: TBitmap);
var
  ScreenCanvas: TCanvas;
begin
  ScreenCanvas := TCanvas.Create;
  try
    ScreenCanvas.Handle := GetDC(0);
    try
      Bitmap.Width := SourceRect.Right - SourceRect.Left;
      Bitmap.Height := SourceRect.Bottom - SourceRect.Top;
      Bitmap.Canvas.CopyRect(Rect(0, 0, Bitmap.Width, Bitmap.Height), ScreenCanvas,
        SourceRect);
    finally
      ReleaseDC(0, ScreenCanvas.Handle);
      ScreenCanvas.Handle := 0;
    end;
  finally
    ScreenCanvas.Free;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  GrabScreen(Rect(0, 0, Screen.Monitors[0].Width + Screen.Monitors[1].Width,
    Screen.Height),
    Image1.Picture.Bitmap);
  Caption := Format('Width %d Height %d', [Image1.Width, Image1.Height]);
end;


Solve 2:

Referring to Answer 1: Finally, I went through and used the debugger to check out all of the Screen variable fields at runtime and found what I needed:

{ ... }
DC := GetDC(GetDesktopWindow);
BMPImage := TBitmap.Create;
try
  BMPImage.Width := Screen.DesktopWidth;
  BMPImage.Height := Screen.DesktopHeight;
  BitBlt(BMPImage.Canvas.Handle, 0, 0, BMPImage.Width, BMPImage.Height,
    DC, Screen.DesktopLeft, Screen.DesktopTop, SRCCOPY);
finally
  ReleaseDC(GetDesktopWindow, DC);
end;
{ ... }

Set the character format in a TRichEdit to subscript or superscript

Problem/Question/Abstract:

I need to set the character format in a RichEdit control to subscript or superscipt. When I produce an RTF file including this formatting, the Delphi TRichEdit shows it correctly. But I cannot set the formatting by code. I tried to send a EM_SETCHARFORMAT message to the TRichEdit with dwEffects set to CFE_SUBSCRIPT but this doesn't have the desired effect.

Answer:

Solve 1:

You have to use a little API here since the TTextAttributes class used to implement DefAttributes does not surface this ability (since it was designed to be compatible to TFont). You should be able to set sub/ superscripts by sending an EM_SETCHARFORMAT message to a TRichedit. Something like this:

var
  format: TCharFormat; {defined in Unit RichEdit}

FillChar(format, sizeof(format), 0);
with format do
begin
  cbSize := Sizeof(format);
  dwMask := CFM_OFFSET;
  yOffset := 60; {superscript by 60 twips, negative values give subscripts}
end;
richedit1.Perform(EM_SETCHARFORMAT, SCF_SELECTION, LongInt(@format));

The message affects the current selection. If there is none it will affect new text inserted via seltext.

The problem with this is that the rich edit common control version 1 does not properly adjust the line spacing in lines containing super- or subscripted text. So if you don't reduce the font size as well, the text may be cut off at top or bottom. This version of the control also has no way to manually adjust the linespacing. There are wrappers for version 2 and 3 of the control around, e.g. the TRxrichEdit component in RXLib. These versions handle sub/superscripted text correctly but they require riched20.dll on the target system and it may not be present on all of them.


Solve 2:

Pressing the Up arrow sets to SuperScript, the down arrow to SubScript and the Left arrow back to normal.

procedure TForm1.RichEdit1KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
var
  ref: TCharFormat;
begin
  FillChar(ref, sizeof(ref), 0);
  if ssAlt in Shift then
    case Key of
      VK_UP:
        begin
          with ref do
          begin
            cbSize := Sizeof(ref);
            dwMask := CFM_OFFSET;
            yOffset := 60;
          end;
        end;
      VK_DOWN:
        begin
          with ref do
          begin
            cbSize := Sizeof(ref);
            dwMask := CFM_OFFSET;
            yOffset := -60;
          end;
        end;
      VK_LEFT:
        begin
          with ref do
          begin
            cbSize := Sizeof(ref);
            dwMask := CFM_OFFSET;
            yOffset := 0;
          end;
        end;
    end;
  (Sender as TRichEdit).Perform(EM_SETCHARFORMAT, SCF_SELECTION, LongInt(@ref));
end;


Solve 3:

{ ... }
type
  TCharacterFormat = (CFM_Superscript, CFM_Subscript, CFM_Normal);

procedure RE_SetCharFormat(RichEdit: TRichEdit; CharacterFormat: TCharacterFormat);
var
  {The CHARFORMAT structure contains information about character formatting
  in a rich edit control}
  Format: TCharFormat;
begin
  FillChar(Format, SizeOf(Format), 0);
  with Format do
  begin
    cbSize := SizeOf(Format);
    dwMask := CFM_OFFSET;
    {Character offset, in twips, from the baseline. If the value of this member
                is positive, the character is a superscript; if it is negative, the
                character is a subscript}
    case CharacterFormat of
      CFM_Superscript: yOffset := 60;
      CFM_Subscript: yOffset := -60;
      CFM_Normal: yOffset := 0;
    end;
  end;
  {The EM_SETCHARFORMAT message sets character formatting in a rich edit control.
  SCF_SELECTION: Applies the formatting to the current selection}
  Richedit.Perform(EM_SETCHARFORMAT, SCF_SELECTION, Longint(@Format));
end;

Examples:

{Apply Subscript to the current selection}

procedure TForm1.Button1Click(Sender: TObject);
begin
  RE_SetCharFormat(RichEdit1, CFM_Superscript);
end;

{Apply subscript to the current selection}

procedure TForm1.Button2Click(Sender: TObject);
begin
  RE_SetCharFormat(RichEdit1, CFM_Subscript);
end;

Load a stream containing HTML code into a TWebBrowser

Problem/Question/Abstract:

How to load a stream containing HTML code into a TWebBrowser

Answer:

Solve 1:

Imagine, you want to load a html document into the browser, that is not available as a file on your hard disk, but linked as a resource into your application.

You can use TResourceStream to make the data accessible for Delphi. But how to get the data into your WebBrowser? HTML documents implement the IPersistentStreamInit - interface, what means they support standard methods to accept data from any kind of stream or write data to any kind of stream.

uses ActiveX;

{Loads the contents of the "Stream" into the "WebBrowser"
"Stream" should contain HTML code}

procedure LoadStream(WebBrowser: TWebBrowser; Stream: TStream);
var
  PersistStreamInit: IPersistStreamInit;
  StreamAdapter: IStream;
  MemoryStream: TMemoryStream;
begin
  {Load empty HTML document into Webbrowser to make "Document" a valid HTML document}
  WebBrowser.Navigate('about:blank');
  {wait until finished loading}
  repeat
    Application.ProcessMessages;
    Sleep(0);
  until
    WebBrowser.ReadyState = READYSTATE_COMPLETE;
  {Get IPersistStreamInit - Interface}
  if WebBrowser.Document.QueryInterface(IPersistStreamInit, PersistStreamInit) = S_OK then
  begin
    {Clear document}
    if PersistStreamInit.InitNew = S_OK then
    begin
      {Make local copy of the contents of Stream if you want to use Stream directly,
                        you have to consider, that StreamAdapter will destroy it automatically}
      MemoryStream := TMemoryStream.Create;
      try
        MemoryStream.CopyFrom(Stream, 0);
        MemoryStream.Position := 0;
      except
        MemoryStream.Free;
        raise;
      end;
      {Use Stream-Adapter to get IStream Interface to our stream}
      StreamAdapter := TStreamAdapter.Create(MemoryStream, soOwned);
      {Load data from Stream into WebBrowser}
      PersistStreamInit.Load(StreamAdapter);
    end;
  end;
end;

{Let's test. You could also create a TResourceStream or TFileStream etc. here.}

procedure TForm1.Button2Click(Sender: TObject);
var
  S: TStringStream;
begin
  {To use this code, replace [ ] brackets with <> ones in the following two lines !}
  S := TStringStream.Create('[html][h1]Stream Test[/h1][p]This HTML content ' +
    'is being loaded from a stream.[/html]');
  try
    LoadStream(WebBrowser1, S);
  finally
    S.Free;
  end;
end;


Solve 2:

///////Begin Source
uses ActiveX;

function ShowHtml(mWebBrowser: TWebBrowser; mStrings: TStrings): Boolean;
var
  vMemoryStream: TMemoryStream;
begin
  Result := False;
  if not (Assigned(mStrings) and Assigned(mWebBrowser)) then
    Exit;
  mWebBrowser.Navigate('about:blank');
  if not Assigned(mWebBrowser.Document) then
    Exit;
  vMemoryStream := TMemoryStream.Create;
  try
    mStrings.SaveToStream(vMemoryStream);
    try
      vMemoryStream.Position := 0;
      Application.ProcessMessages; // :)
      (mWebBrowser.Document as IPersistStreamInit).Load(
        TStreamAdapter.Create(vMemoryStream));
    except
      Exit;
    end;
  finally
    vMemoryStream.Free;
  end;
  Result := True;
end; { ShowHtml }
///////End Source

///////Begin Demo

procedure TForm1.Button1Click(Sender: TObject);
begin
  ShowHtml(WebBrowser1, Memo1.Lines);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  Memo1.Text :=
    ''#13#10 +
    'Hello Worlds!'#13#10 +
    ''#13#10;
end;
///////End Demo


Solve 3:

procedure AssignDocument(Browser: TWebBrowser; Text: string);
var
  Document: OleVariant;
{$IFDEF PERSIST_STREAM}
  InStream: TStream;
  Persist: IPersistStreamInit; {Declared in ActiveX}
{$ENDIF}
begin
{$IFDEF WRITE_FILE}
  Document := LocalServerPath('temp.html');
  WriteTextFile(Document, Text); {utility function}
  Browser.Navigate2(Document);
{$ENDIF}
{$IFDEF PERSIST_STREAM}
  Document := 'about:blank';
  Browser.Navigate2(Document);
  InStream := TStringStream.Create(Text);
  try
    Persist := (Browser.Document as IPersistStreamInit);
    Persist.Load(TStreamAdapter.Create(InStream));
  finally
    InStream.Free;
  end;
{$ENDIF}
{$IFDEF DISPATCH_DOC}
  Document := 'about:blank';
  Browser.Navigate2(Document);
  Document := Browser.Document as IDispatch;
  Document.Open;
  try
    Document.Write(Text);
  finally
    Document.Close;
  end;
{$ENDIF}
end;

BitmapToRegion (Delphi-like version - very fast)

Problem/Question/Abstract:

How to convert Windows Bitmaps to Windows Regions very fast. This is the Delphi-like replacement for the BitmapToRegion function. This version is much cleaner, smaller and educational mantaining a high performance. You will also find many interesting comments and techniques inside.

Answer:

Overview

The function BitmapToRegion creates a Windows Region (HRGN) from a Windows Bitmap (HBITMAP) which is used as a mask. You choose one color to be made "transparent", meaning that areas of the bitmap with this color will be left out of the resulting region. This region will take the shape of the "non-transparent" pixels from the original bitmap, which may or may not have a regular shape. You can later apply this region to any window (all windowed controls including the form) using the SetWindowRgn API call. Using this method you can create non-rectangular forms or controls easily. The function also accepts a color tolerance for red, green, and blue values which means that a color range could be specified rather than only one color.

How it works?

The function iterates over all the bitmap scanlines searching for contiguous non-transparent pixels on a row-by-row basis.

It keeps record of the last visible pixel position on the row and loops until a transparent pixel is found or the end of the row reached. Variable "x0" holds the last visible pixel position and "x" holds the current pixel position. If x0 = x it means that the current pixel is transparent and must be ignored, if x > x0 then we have at least one visible pixel.

We then add a rect containing the pixels (x0,y) to (x,y+1) to a windows structure RGNDATA which is passed to the function ExtCreateRegion, later used to create the desired region (the RGNDATA is explained later on this article). The variable y holds the current row being scanned. If we aren't yet at the end of the row we will make x0 = x and will restart looping until another transparent pixel is found or the end of the row reached (doing the same procedures again). If the end of the row is finally reached we will jump to the next bitmap row, starting with x0 = x = 0.

By doing this to the entire bitmap we will end up with the desired visible region.

Problems found

** Windows 98 Limitations
Using this function on Windows 98 could fail with very complex masks (bitmaps). That is due to a limitation on ExtCreateRegion under this OS: the function fails if the number of rects is too large. To workaround this, every time the number of rects reachs 2000, we call ExtCreateRegion and store it in Result (if it is the first region created) or we combine this region with the one already created.

** Accessing the RGNDATA rects by index
The region data is made up of a RGNDATAHEADER which specifies the type and size of the region plus a buffer of arbitrary size called Buffer (brilliant!). The problem is that we need to access Buffer as if it was an Array of Rects, but it is defined as:

Buffer: array[0..0] of CHAR;

This is a very commom C construct actually denoting a char pointer (char *), but Pascal is a far more strong typed language preventing us from accessing this array directly. The easiest way to access the rects on this buffer is by typecasting it to a more convenient structure like:

TRectArray = array[0..(MaxInt div SizeOf(TRect)) - 1] of TRect;

This creates the largest possible array of TRect elements. Do not attempt to create a variable of this type because you will certainly exhaust system resources. It is meant to be used for typecasting variables only (or a pointer contents: TRectArrat(MyPrt^)[x] not TRectArray(MyPtr)[x]!). If we did declare a pointer to this structure, we will be able to typecast another pointer without having to dereference it:

PRectArray = ^TRectArray;

Now the following statement is correct: PRectArray(MyPtr)[x]. We can make a variable of type PRectArray (let's say pr) point to Buffer with the simple statement: pr := @RgnData.Buffer; This technique can be used to simplify and clarify your code the same way it is used here.

** Bitmap Orientation and Scanline Access
The code:

ScanLinePtr := bmp.ScanLine[0];
ScanLineInc := Integer(bmp.ScanLine[1]) - Integer(ScanLinePtr);

is very tricky. The first line gets a pointer to the first bitmap scanline. The second line gets the (signed) distance in bytes that separates the bitmap scanlines in memory (scanlines need not to be contiguos in memory). If the bitmap is bottom-up the distance will be negative. When we make Inc(Integer(ScanLinePtr),ScanLineInc) we are already taking into account this possibility (Inc with negative values actually decrements).

The access to individual pixels are made using the techniques shown earlier on "Accessing the RGNDATA rects by index". We find the value of the xth character by typecasting ScanLinePrt to PByteArray at the index [x*SizeOf(TRGBQuad)]. TRGBQuad is an structure of red, green, blue, plus an extra byte that represents a pixel for a 32-bit RGB image. We then make b point to this element of the array. Since b is itself a PByteArray, we can access its individual bytes by index where the first (0) is red, the second is green, and the last (2) is blue (we do not use the fourth byte). The code is as follows:

b := @PByteArray(ScanLinePtr)[x * SizeOf(TRGBQuad)];
if (b[0] >= lr) and (b[0] <= hr) and
  (b[1] >= lg) and (b[1] <= hg) and
  (b[2] >= lb) and (b[2] <= hb) then
  ...

Rationales

** Use of RGNDATA and ExtCreateRegion:
Speed! Speed is one of the main concerns of this algorithm. We could have made the code much simpler if we used CreateRectRgn for every rect found and combined them one-by-one with CombineRgn instead of adding rects to a RGNDATA and later calling ExtCreateRegion to create the region at once, but ExtCreateRegion is much faster than the combined use of CreateRectRgn and ComineRgn.

** Use of AllocUnit
Performance again is the factor of choice of this added complexity. We could allocate memory as needed, one rect at a time, but it is much faster to allocate a chunk of rects (even if we ended up with unused memory) and only do memory reallocation (expansion) when we run out of space (we catch this when we test if RgnData^.rdh.nCount >= maxRects). In the end all data (even unused) is freed.

** Use of Scanline Instead of Pixels property Scanline is a hundred times faster than Pixels property for accessing the pixels of a bitmap.

** 32-bit Depth Conversion
I have chosen to convert every bitmap to pf32bit first to be able to deal uniformly with the bitmap data, no need to have a special case for every pixel format and since the algorithm is meant to be used only with RGB images (not palette indexed) it was a matter of choosing between pf24bit and pf32bit. Second because Windows being a 32-Bit environment is faster when dealing with 32-bit per pixel bitmaps.

Conclusion

This article provided a very fast Delphi friendly routine to convert bitmaps into windows regions. These regions could be used to apply astonishing effects to your forms simply by making them non-rectangular and decorated art painted over the visible areas (if you ever saw the Quintessential CD player or the new apple Quicktime interface you know what I mean).

You will also find inside a discussion on some Windows 98 limitations regarding complex region creation and the best (fastest) method to use the TBitmap Scanline property to access the pixels of an image. There's also some comments on how to access arbitrary sizeable structs often found in C/C++ code from within Delphi.

Final Comments

This function is used by a component which I wrote called TFormShapper to apply persintent non-regular shapes to forms. The component has a mask property of type TPicture that stores the picture along with the form. This picture can be any valid TGraphic descendant (including my own TPNGImage or TTGAImage implementations). All I did to use it as a bitmap was to create a temporary bitmap and draw the stored graphic over it with: tmpBMP.Canvas.Draw(0, 0, TheGraphic); then I passed this tmpBMP to the function, freeing it later to release memory and system resources. You can use this technique if you have any image that is not a TBitmap, but that could be drawn over one.

My next post will regard the techniques used to extend the graphics capabilities of Delphi, adding new image file formats and creating a new derived TGraphic class. Stay tuned.

--- CODE STARTS HERE ---

function BitmapToRegion(bmp: TBitmap; TransparentColor: TColor = clBlack;
  RedTol: Byte = 1; GreenTol: Byte = 1; BlueTol: Byte = 1): HRGN;
const
  AllocUnit = 100;
type
  PRectArray = ^TRectArray;
  TRectArray = array[0..(MaxInt div SizeOf(TRect)) - 1] of TRect;
var
  pr: PRectArray; // used to access the rects array of RgnData by index
  h: HRGN; // Handles to regions
  RgnData: PRgnData; // Pointer to structure RGNDATA used to create regions
  lr, lg, lb, hr, hg, hb: Byte; // values for lowest and hightest trans. colors
  x, y, x0: Integer; // coordinates of current rect of visible pixels
  b: PByteArray; // used to easy the task of testing the byte pixels (R,G,B)
  ScanLinePtr: Pointer; // Pointer to current ScanLine being scanned
  ScanLineInc: Integer; // Offset to next bitmap scanline (can be negative)
  maxRects: Cardinal; // Number of rects to realloc memory by chunks of AllocUnit
begin
  Result := 0;
  { Keep on hand lowest and highest values for the "transparent" pixels }
  lr := GetRValue(TransparentColor);
  lg := GetGValue(TransparentColor);
  lb := GetBValue(TransparentColor);
  hr := Min($FF, lr + RedTol);
  hg := Min($FF, lg + GreenTol);
  hb := Min($FF, lb + BlueTol);
  { ensures that the pixel format is 32-bits per pixel }
  bmp.PixelFormat := pf32bit;
  { alloc initial region data }
  maxRects := AllocUnit;
  GetMem(RgnData, SizeOf(RGNDATAHEADER) + (SizeOf(TRect) * maxRects));
  try
    with RgnData^.rdh do
    begin
      dwSize := SizeOf(RGNDATAHEADER);
      iType := RDH_RECTANGLES;
      nCount := 0;
      nRgnSize := 0;
      SetRect(rcBound, MAXLONG, MAXLONG, 0, 0);
    end;
    { scan each bitmap row - the orientation doesn't matter (Bottom-up or not) }
    ScanLinePtr := bmp.ScanLine[0];
    ScanLineInc := Integer(bmp.ScanLine[1]) - Integer(ScanLinePtr);
    for y := 0 to bmp.Height - 1 do
    begin
      x := 0;
      while x < bmp.Width do
      begin
        x0 := x;
        while x < bmp.Width do
        begin
          b := @PByteArray(ScanLinePtr)[x * SizeOf(TRGBQuad)];
          // BGR-RGB: Windows 32bpp BMPs are made of BGRa quads (not RGBa)
          if (b[2] >= lr) and (b[2] <= hr) and
            (b[1] >= lg) and (b[1] <= hg) and
            (b[0] >= lb) and (b[0] <= hb) then
            Break; // pixel is transparent
          Inc(x);
        end;
        { test to see if we have a non-transparent area in the image }
        if x > x0 then
        begin
          { increase RgnData by AllocUnit rects if we exceeds maxRects }
          if RgnData^.rdh.nCount >= maxRects then
          begin
            Inc(maxRects, AllocUnit);
            ReallocMem(RgnData, SizeOf(RGNDATAHEADER) + (SizeOf(TRect) * MaxRects));
          end;
          { Add the rect (x0, y)-(x, y+1) as a new visible area in the region }
          pr := @RgnData^.Buffer; // Buffer is an array of rects
          with RgnData^.rdh do
          begin
            SetRect(pr[nCount], x0, y, x, y + 1);
            { adjust the bound rectangle of the region if we are "out-of-bounds" }
            if x0 < rcBound.Left then
              rcBound.Left := x0;
            if y < rcBound.Top then
              rcBound.Top := y;
            if x > rcBound.Right then
              rcBound.Right := x;
            if y + 1 > rcBound.Bottom then
              rcBound.Bottom := y + 1;
            Inc(nCount);
          end;
        end; // if x > x0
        { Need to create the region by muliple calls to ExtCreateRegion, 'cause }
        { it will fail on Windows 98 if the number of rectangles is too large   }
        if RgnData^.rdh.nCount = 2000 then
        begin
          h := ExtCreateRegion(nil, SizeOf(RGNDATAHEADER) + (SizeOf(TRect) *
            maxRects), RgnData^);
          if Result > 0 then
          begin // Expand the current region
            CombineRgn(Result, Result, h, RGN_OR);
            DeleteObject(h);
          end
          else // First region, assign it to Result
            Result := h;
          RgnData^.rdh.nCount := 0;
          SetRect(RgnData^.rdh.rcBound, MAXLONG, MAXLONG, 0, 0);
        end;
        Inc(x);
      end; // scan every sample byte of the image
      Inc(Integer(ScanLinePtr), ScanLineInc);
    end;
    { need to call ExCreateRegion one more time because we could have left    }
    { a RgnData with less than 2000 rects, so it wasn't yet created/combined  }
    h := ExtCreateRegion(nil, SizeOf(RGNDATAHEADER) + (SizeOf(TRect) * MaxRects),
      RgnData^);
    if Result > 0 then
    begin
      CombineRgn(Result, Result, h, RGN_OR);
      DeleteObject(h);
    end
    else
      Result := h;
  finally
    FreeMem(RgnData, SizeOf(RGNDATAHEADER) + (SizeOf(TRect) * MaxRects));
  end;
end;

I've supplied a couple of simple examples of using this function for beginners:

{This first example sets the region of a TForm}

procedure TForm1.Button1Click(Sender: TObject);
var
  ARgn: HRGN;
  ABitmap: TBitmap;
begin
  ABitmap := TBitmap.Create;
  try
    ABitmap.LoadFromFile('C:\MyImage.bmp');
    ARgn := BitmapToRegion(ABitmap, clFuchsia);
    SetWindowRgn(Form1.Handle, ARgn, True);
  finally
    ABitmap.Free;
  end;
end;

{This second example sets the region of a TPanel}

procedure TForm1.Button1Click(Sender: TObject);
var
  ARgn: HRGN;
  ABitmap: TBitmap;
begin
  ABitmap := TBitmap.Create;
  try
    ABitmap.LoadFromFile('C:\MyImage.bmp');
    ARgn := BitmapToRegion(ABitmap, clFuchsia);
    SetWindowRgn(Panel1.Handle, ARgn, True);
  finally
    ABitmap.Free;
  end;
end;

From both examples, you can see how simple it is to simply specify the Handle of the window control that you wish to set the region of. Be it a TForm, TPanel, TMemo, etc.