Search for a keyword in a help file

Problem/Question/Abstract:

How to search for a keyword in a help file

Answer:

const
  EmptyString: PChar = '';
begin
  Application.HelpCommand(HELP_PARTIALKEY, LongInt(EmptyString));
end;

Generic File Importer Base Class

Problem/Question/Abstract:

Here is a useful base class to create derived classes to import data from any flat file format you can think of...

Answer:

{-----------------------------------------------------------------------------
Unit Name:     classParentDataManipulator
Author:        StewartM (Stewart Moss)

Documentation Date: 23, 08, 2002  (14:39,)

Version 1.0
-----------------------------------------------------------------------------

Compiler Directives:

Purpose:

Dependancies:

Description:

Parent Class for data manipulation
Creates the basic skelton for adding data manipulation sub-classes

Each of the inherited classes must override the ProcessData method and provide
  their own properties specific to the class (ie Invoice Number etc...)

Very useful class.

inheritance Diagram

  + -- TParentDataProcessor    // base class
       +
       |
       + --- TDerivedImporter  // sub class

Notes:

History:

Copyright 2002 by Stewart Moss.
All rights reserved.
-----------------------------------------------------------------------------}

unit classParentDataManipulator;

interface

uses Sysutils, Classes;

type
  TParentDataProcessor = class(TObject)
  private
    StringIn: string;
    LineCounter: Integer;

  public
    FieldNames,
      FieldValues,
      MultiFieldNames,
      MultiFieldValues: TStringList;

    FormName,
      FileName: string;
    Delimiters: string;
    // A list of delimiters (ie ',/[];:') used in inherited ProcessData()

    constructor create;
    destructor Destroy; override;
    procedure ProcessFile;

    function DataAtPos(S: string; StartP, EndP: Integer): string;
    // Returns the data from "StartP" to "EndP" in String "S"

    function ExpandTabs(s: string): string;
    // ExpandTabs to 8 Spaces

    procedure ProcessData(StrIn: string; LineNumber: Integer); virtual;
    // Virtual method for override in sub-classes

    procedure FieldAdd(FieldName, Data: string; GenException: Boolean);
    // Adds FieldName and FieldValue to Strings and can generate exception if
    // string is empty when required

    procedure MultiFieldAdd(FieldName, Data: string; GenException: Boolean);
    // Adds FieldName and FieldValue to Multi Field Strings and can generate exception
    // if string is empty when required

  end;

  TProcessException = Exception;

implementation

var
  F: text;
  //  Exception: TProcessException;

  { TDataProcessor }

constructor TParentDataProcessor.create;
begin
  inherited create;
  FieldNames := TStringList.Create;
  FieldValues := TStringList.Create;
  MultiFieldNames := TStringList.Create;
  MultiFieldValues := TStringList.Create;
  FieldNames.Clear;
  FieldValues.Clear;
  MultiFieldNames.Clear;
  MultiFieldValues.Clear;
end;

procedure TParentDataProcessor.ProcessFile;
begin
  if Filename = '' then
    raise Exception.Create('No Filename specified');

  try
    AssignFile(F, Filename);
    Reset(f);
  except
    try
      CloseFile(F);
    except
    end;
    raise Exception.Create('Could not open file ' + FileName);
  end;

  LineCounter := 0;

  while not eof(f) do
  begin
    Inc(LineCounter);

    try
      Readln(f, StringIn);
    except
      try
        CloseFile(f);
      except // swallow CloseFile errors
      end;

      raise Exception.Create('Could not read from file. Line number ' +
        IntToStr(LineCounter));
    end;

    StringIn := ExpandTabs(StringIn);
    // Exapnd Tabs to 8 Spaces

    ProcessData(StringIn, LineCounter);
    // Execute virutal method in sub-classes passing current line and LineNumber
  end;

  try
    closefile(f);
  except
    raise Exception.Create('Could not close file ' + FileName);
  end;
end;

procedure TParentDataProcessor.ProcessData(StrIn: string; LineNumber: Integer);
// Virtual method for override in sub-classes
begin
  //
end;

destructor TParentDataProcessor.Destroy;
begin
  FieldNames.Free;
  FieldValues.Free;
  MultiFieldNames.Free;
  MultiFieldValues.Free;
end;

function TParentDataProcessor.DataAtPos(S: string; StartP,
  EndP: Integer): string;
begin
  // Returns the data from "StartP" to "EndP" in String "S"
  Result := trim(Copy(S, StartP, EndP - StartP));
end;

function TParentDataProcessor.ExpandTabs(s: string): string;
begin
  // ExpandTabs to 8 Spaces
  Result := StringReplace(S, #09, '        ', [rfReplaceAll]);
end;

procedure TParentDataProcessor.FieldAdd(FieldName, Data: string;
  GenException: Boolean);
begin
  // Adds FieldName and FieldValue to Strings and can generate exception if
  // string is empty
  if (GenException) and (Data = '') then
    raise Exception.create('-- No ' + FieldName + ' Specified --');
  Fieldnames.add(FieldName);
  FieldValues.add(Data);
end;

procedure TParentDataProcessor.MultiFieldAdd(FieldName, Data: string;
  GenException: Boolean);

var
  loop: integer;
  flag: Boolean;
begin
  // Adds FieldName and FieldValue to Multi Field Strings and can generate exception
  // if string is empty

  if (GenException) and (Data = '') then
    raise Exception.create('-- No Multiple Field - ' + FieldName + ' Specified --');

  flag := false;
  loop := 0;
  while (loop < MultiFieldNames.count) and not flag do
  begin
    if MultiFieldNames.Strings[loop] = FieldName then
      flag := true;
    inc(Loop);
  end;

  dec(loop);

  if Flag then
    MultiFieldValues.Strings[loop] := MultiFieldValues.Strings[loop] + ';' + Data
  else
  begin
    MultiFieldNames.add(FieldName);
    MultiFieldValues.add(Data);
  end;
end;

end.

How to give the scrollbars of a TRichEdit a flat look

Problem/Question/Abstract:

Does anyone know of a way to change the scroll bars in the RichEdit to obtain the flat look?

Answer:

Start with this one and do not forget to put CommCtrl in your uses clause:

procedure TForm1.FormCreate(Sender: TObject);
var
  XVerScrollInfo, XHorScrollInfo: TScrollInfo;
begin
  InitializeFlatSB(RichEdit1.Handle);
  GetScrollInfo(RichEdit1.Handle, SB_VERT, XVerScrollInfo);
  GetScrollInfo(RichEdit1.Handle, SB_HORZ, XHorScrollInfo);
  FlatSB_SetScrollProp(RichEdit1.Handle, WSB_PROP_VSTYLE, FSB_ENCARTA_MODE, True);
  FlatSB_SetScrollProp(RichEdit1.Handle, WSB_PROP_HSTYLE, FSB_ENCARTA_MODE, True);
end;

Easily use HTML Help files in your programs

Problem/Question/Abstract:

Do you long to move from WinHelp to HTML Help in your programs? The unit below converts all WinHelp calls to HTML Help enabling you to upgrade with the minimum of effort.

Answer:

Save this unit to a directory on your Environment Options|Library|Library Path and add to your project uses clause, all WinHelp requests will now be translated to HTML Help. Specify your *.chm file in the Project Options|Application|Help file setting. Context sensitive help will work as normal, use TApplication.HelpCommand to send help commands. eg. Application.HelpCommand(HELP_KEY, DWORD(keyData))

unit dmHTMLHelp;
{Unit to translate WinHelp requests into HTML Help and call the API.}
{Written by Dave Murray, October 2001. dmurray@worldmark.com}
{NOTES:
This unit assigns its own handler to the Application.OnHelp event.
DO NOT assign your own handler to Application.OnHelp.
Also, this unit ignores any form's HelpFile property. (Delphi 4+)}

interface

uses
  Windows, Messages, SysUtils, Forms;

const
  {commands to pass to HtmlHelp(), see HTML Help API Reference}
  HH_DISPLAY_TOPIC = $0000; {open help topic}
  HH_HELP_FINDER = $0000; {backwards compatibility,use HH_DISPLAY_TOPIC instead}
  HH_DISPLAY_TOC = $0001; {select Contents tab in nav pane}
  HH_DISPLAY_INDEX = $0002; {select Index tab + search for keyword}
  HH_DISPLAY_SEARCH = $0003; {select Search tab in nav pane}
  HH_SET_WIN_TYPE = $0004;
  HH_GET_WIN_TYPE = $0005;
  HH_GET_WIN_HANDLE = $0006;
  HH_ENUM_INFO_TYPE = $0007;
  HH_SET_INFO_TYPE = $0008;
  HH_SYNC = $0009;
  HH_RESERVED1 = $000A; {not currently implemented}
  HH_RESERVED2 = $000B; {not currently implemented}
  HH_RESERVED3 = $000C; {not currently implemented}
  HH_KEYWORD_LOOKUP = $000D;
  HH_DISPLAY_TEXT_POPUP = $000E; {display string resource/text in a popup}
  HH_HELP_CONTEXT = $000F; {display topic for context number}
  HH_TP_HELP_CONTEXTMENU = $0010; {text popup help, same as HELP_CONTEXTMENU}
  HH_TP_HELP_WM_HELP = $0011; {text popup help, same as HELP_WM_HELP}
  HH_CLOSE_ALL = $0012; {close all windows opened by caller}
  HH_ALINK_LOOKUP = $0013; {ALink version of HH_KEYWORD_LOOKUP}
  HH_GET_LAST_ERROR = $0014; {not currently implemented}
  HH_ENUM_CATEGORY = $0015;
  HH_ENUM_CATEGORY_IT = $0016;
  HH_RESET_IT_FILTER = $0017;
  HH_SET_INCLUSIVE_FILTER = $0018;
  HH_SET_EXCLUSIVE_FILTER = $0019;
  HH_INITIALIZE = $001C;
  HH_UNINITIALIZE = $001D;
  HH_PRETRANSLATEMESSAGE = $00FD;
  HH_SET_GLOBAL_PROPERTY = $00FC;

function HtmlHelp(hwndCaller: THandle; pszFile: PChar; uCommand: cardinal; dwData:
  longint): THandle; stdcall;

implementation

function HtmlHelp(hwndCaller: THandle; pszFile: PChar; uCommand: cardinal; dwData:
  longint): THandle; stdcall; external 'hhctrl.ocx' name 'HtmlHelpA'; {external API call}

type
  TdmHTMLHelp = class(TObject) {encapsulates function}
    function ApplicationHelp(Command: Word; Data: Longint; var CallHelp: Boolean):
      Boolean;
  end; {TdmHTMLHelp..}

function TdmHTMLHelp.ApplicationHelp(Command: Word; Data: Longint; var CallHelp:
  Boolean): Boolean;
{translates WinHelp commands to HTMLHelp commands + calls API}
var
  HCommand: word;
begin
  {make sure VCL doesn't activate WinHelp + function succeeds}
  CallHelp := false;
  result := true;
  {translate WinHelp > HTMLHelp}
  case Command of
    HELP_CONTENTS:
      begin
        HCommand := HH_DISPLAY_TOC;
        Data := 0;
      end; {HELP_CONTENTS..}
    HELP_CONTEXT: HCommand := HH_HELP_CONTEXT;
    HELP_CONTEXTPOPUP: HCommand := HH_HELP_CONTEXT;
    HELP_FINDER: HCommand := HH_DISPLAY_TOPIC;
    HELP_KEY: HCommand := HH_DISPLAY_INDEX;
    HELP_QUIT:
      begin
        HCommand := HH_CLOSE_ALL;
        Data := 0;
      end; {HELP_QUIT..}
  else
    begin {default}
      HCommand := HH_DISPLAY_TOPIC;
      Data := 0;
    end; {default..}
  end; {case Command..}
  {call HTML Help API}
  HtmlHelp(Application.MainForm.Handle, PChar(Application.HelpFile), HCommand, Data);
end; {function TdmHTMLHelp.ApplicationHelp}

var
  HTMLHelper: TdmHTMLHelp;

initialization
  {create object + assign event handler}
  HTMLHelper := TdmHTMLHelp.Create;
  Application.OnHelp := HTMLHelper.ApplicationHelp;
finalization
  {free event handler + object}
  Application.OnHelp := nil;
  HTMLHelper.Free;
end.

Two ways to change the default project options

Problem/Question/Abstract:

Two ways to change the default project options

Answer:

You can change the default project options (which is being used by every new project you create) from Delphi GUI:

Create a new project (File | New Application)
Go to "Project | Options" and change the options as you wish.
Check "Default" checkbox in the tabs which you changed options in.

If you rather change the options "manually," you can do so using a simple text editor:

Edit defproj.dof file located in your Delphi's BIN directory (C:\Program Files\Borland\Delphi 2.0\Bin for example) using Notepad or any other text editor. If you don't see the defproj.dof, create one using your favorite text editor in the Delphi's BIN directory using the following format:

[Compiler]
A=1
B=0
C=0
D=1
E=0
F=0
G=1
H=1
I=1
J=1
K=0
L=1
M=0
N=1
O=1
P=1
Q=0
R=0
S=0
T=0
U=0
V=1
W=0
X=1
Y=0
Z=1
ShowHints=0
ShowWarnings=0
UnitAliases=WinTypes=Windows;<cont.>
WinProcs=Windows;DbiTypes=BDE;<cont.>
DbiProcs=BDE;DbiErrs=BDE;

[Linker]
MapFile=0
OutputObjs=0
ConsoleApp=1
DebugInfo=0
MinStackSize=16384
MaxStackSize=1048576
ImageBase=4194304
ExeDescription=

[Directories]
OutputDir=
SearchPath=
Conditionals=

[Parameters]
RunParams=

How to display a help file on top of a form with style fsStayOnTop

Problem/Question/Abstract:

I have a form with its formstyle set to fsStayOnTop. If I display the help for this form, the help windows is opened behind my form. Even if I click on the help window it stays behind. How can I display the help windows in front of any form?

Answer:

You can do this by sending a macro to WinHelp.


procedure TForm1.Button1Click(Sender: TObject);
begin
  with Application do
  begin
    Helpfile := 'C:\Programme\Borland\Delphi5\Help\TOOLS\HCW.HLP';
    HelpCommand(HELP_CONTENTS, 0);
    HelpCommand(HELP_COMMAND, Integer(PChar('Generate(' + IntToStr(WM_COMMAND)
      + ', 1471, 0)')));
  end;
end;


This macro call fakes a menu action for the "keep on top" menu item. Use 1472 to deactivate the on top state. Help macros are documented in the helpfile I used above. The HelpOnTop macro gives the menu IDs to use for Generate in this case. HelponTop itself may be useful if you simply want to change the current on-top default for the window (it is a toggle).

How to make a TButton flee from the mouse cursor

Problem/Question/Abstract:

As a joke, I am trying to have a button on a form move around the form to avoid the mouse pointer. I was trying to use the OnMouseMove event of the form to accomplish this, but have not had any success. Does anybody know a quick way of doing this?

Answer:

procedure TMainForm.Button1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
var
  NewPoint: TPoint;
begin
  Randomize;
  NewPoint.X := X;
  NewPoint.Y := Y;
  repeat
    NewPoint.X := NewPoint.X + Random((Sender as TButton).Width div 2);
    NewPoint.Y := NewPoint.Y + Random((Sender as TButton).Height div 2);
  until
    PtInRect(ClientRect, NewPoint) and not PtInRect((Sender as TButton).ClientRect, NewPoint);
  (Sender as TButton).Left := NewPoint.X;
  (Sender as TButton).Top := NewPoint.Y;
end;

How to store several bitmaps into a single file

Problem/Question/Abstract:

Is there a simple way to write a TBitmap object to a file and read it back? I want to store bitmaps and other data all in one file (much like word processors are capable of doing).

Answer:

If you wish to store multiple things into a file, you'll need to implement some sort of file structure so you can know what and where things are in the file. For example, if you wished to store several bitmaps to a file, you could structure your file like this:

file header
bitmap count

bitmap header
bitmap size
bitmap stream
bitmap trailer
...

file trailer

Where "file header" contains information such as the version of the file and a unique file structure identifier, "bitmap count" is the number of bitmaps saved to the file, "bitmap header" is a unique identifier which indicates the start of a bitmap entry in the file, "bitmap size" is the size of the bitmap stream, "bitmap stream" is the bitmap's stream (from SaveToStream), "bitmap trailer" is a trailer identifier which indicates the end of the bitmap entry, and "file trailer" is a unique identifier which indicates the end of the file, and optionally contains the size of the file and a CRC of the file (for error detection). Of course, you'd iterate the "bitmap header"..."bitmap trailer" structure once per bitmap saved to the file.

You can use a TFileStream to read / write this structure. You'll need to write a number of methods which read and interpret each section. You'll also want to create a TBitmap instance each time you encounter a "bitmap header" structure. Here's a quick example of how to implement the "bitmap header"..."bitmap trailer" section:

const
  BITMAP_HEADER = 100;
  BITMAP_TRAILER = 200;

procedure SaveBitmap(Bitmap: TBitmap; Stream: TStream);
var
  Buffer: TMemoryStream;
  Identifier: LongInt;
  Size: LongInt;
begin
  Buffer := TMemoryStream.Create;
  try
    Bitmap.SaveToStream(Buffer);
    Identifier := BITMAP_HEADER;
    Stream.Write(Identifier, SizeOf(Identifier));
    Size := Buffer.Size;
    Stream.Write(Size, SizeOf(Size));
    Buffer.Position := 0;
    Stream.CopyFrom(Buffer, Size);
    Identifier := BITMAP_TRAILER;
    Stream.Write(Identifier, SizeOf(Identifier));
  finally
    Buffer.Free;
  end;
end;

procedure ReadBitmap(Bitmap: TBitmap; Stream: TStream);
var
  Buffer: TMemoryStream;
  Identifier: LongInt;
  Size: LongInt;
begin
  Buffer := TMemoryStream.Create;
  try
    Stream.Read(Identifier, SizeOf(Identifier));
    if Identifier <> BITMAP_HEADER then
      raise Exception.Create('Bitmap header expected');
    Stream.Read(Size, SizeOf(Size));
    Buffer.CopyFrom(Stream, Size);
    Bitmap.LoadFromStream(Buffer);
    Stream.Read(Identifier, SizeOf(Identifier));
    if Identifier <> BITMAP_TRAILER then
      raise Exception.Create('Bitmap trailer expected');
  finally
    Buffer.Free;
  end;
end;

Of course, you'll need to write other methods to read the other file sections, and you'll need to call ReadBitmap the correct number of times (specified in "bitmap count") with a TBitmap instance.

Simple HTML parsing and painting

Problem/Question/Abstract:

How to do simple HTML parsing and painting

Answer:

This morning a friend asked me how to do a simple HTML parsing. He wanted to implement a hint box with formatting possibilities.

So I developed a very simple procedure which draws the contents of a string to a rectangle on a canvas. It only understands the HTML tags b, i and u, and it moves to the next line when it finds a new line code. (This is not HTML conform, but in this case really useful)

The parsing itself is extremely simple, but you need to work  with pointers and not with strings since they make it more difficult to get each individual character.

The following procedure is just a little example. If you need HTML editing/painting please try out WPTools.

// Draw simple HTML text to any canvas
// 3/16/2000 by Julian Ziersch, http://www.ziersch.com/
// Products: WPTools, WPReporter, WPForm
// wPDF: PDF Export for WPTools

procedure DrawHTML(r: TRect; aCanvas: TCanvas; const text: string);
var
  p: PChar;
  c: Char;
  x, y, w, wc, hc: Integer;
  code: string;
begin
  p := PChar(text);
  x := r.Left;
  y := r.Top;
  hc := aCanvas.TextHeight('Ag');
  if p <> nil then
    while p^ <> #0 do
    begin
      c := p^;
      if c = '<' then
      begin
        code := '';
        inc(p);
        while (p^ <> '>') and (p^ <> #0) do
        begin
          code := code + uppercase(p^);
          inc(p);
        end;
        if code = 'B' then
          aCanvas.Font.Style :=
            aCanvas.Font.Style + [fsBold]
        else if code = 'I' then
          aCanvas.Font.Style :=
            aCanvas.Font.Style + [fsItalic]
        else if code = 'U' then
          aCanvas.Font.Style :=
            aCanvas.Font.Style + [fsUnderline]
        else if code = '/B' then
          aCanvas.Font.Style :=
            aCanvas.Font.Style - [fsBold]
        else if code = '/I' then
          aCanvas.Font.Style :=
            aCanvas.Font.Style - [fsItalic]
        else if code = '/U' then
          aCanvas.Font.Style :=
            aCanvas.Font.Style - [fsUnderline];
      end
      else if c = #10 then
      begin
        x := r.Left;
        inc(y, hc);
      end
      else if c >= #32 then
      begin
        wc := aCanvas.TextWidth(c);
        if x + wc > r.Right then
        begin
          x := r.Left;
          inc(y, hc);
        end;
        if y + hc < r.Bottom then
          aCanvas.TextOut(x, y, c);
        inc(x, wc);
      end;
      if p^ > #0 then
        inc(p);
    end;
end;

How to use the Win95 Help (What's this?) button

Problem/Question/Abstract:

How to use the Win95 Help (What's this?) button

Answer:

The help button is supposed to be used only with dialogs, Borderstyle := bsDialog. This is a Microsoft thingy, for a main window you are supposed to provide either a menu item or a speedbutton that does a SendMessage(windowhandle, WM_SYSCOMMAND, SC_CONTEXTHELP, 0) to get the window into the context help mode.

The help button is only available if biMinimize and biMaximize is not set. Furthermore, sometimes you have to override the CreateParams method and set the style accordingly.


interface

type
  TfrmMain = class(TForm)
  public
    procedure CreateParams(var Params: TCreateParams); override;
  end;

implementation

procedure TfrmMain.CreateParams(var Params: TCreateParams);
begin
  inherited;
  Params.Style := Params.Style or DS_CONTEXTHELP;
  Params.ExStyle := Params.ExStyle or WS_EX_CONTEXTHELP;
end;

How to create a non-rectangular TPanel

Problem/Question/Abstract:

How to create a non-rectangular TPanel

Answer:

unit ShapedPanel;

interface

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

type
  TShapedPanel = class(TCustomControl)
  private
    { Private declarations }
    FBorderColor: TColor;
    IsLoaded: Boolean;
    FBorderWidth: Integer;
    FRgn, FRgn2: HRGN;
    RgnBrush: TBrush;
    FFIlLColor: TColor;
    procedure SetFillColor(const Value: TColor);
    function GetFillColor: TColor;
    procedure MakeRegion;
    procedure SetBorderColor(Value: TColor);
    procedure WMSize(var Message: TMessage); message WM_SIZE;
  protected
    { Protected declarations }
    procedure Paint; override;
    procedure CreateWnd; override;
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    { Published declarations }
    property BorderColor: TColor read FBorderColor write SetBorderColor default clBlack;
    property BorderWidth: Integer read FBorderWidth write FBorderWidth default 2;
    property FillColor: TColor read GetFillColor write SetFillColor;
    property Height default 200;
    property Width default 200;
    property OnClick;
    property OnContextPopup;
    property OnDblClick;
    property OnEndDock;
    property OnEndDrag;

    property OnEnter;
    property OnExit;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnResize;
    property OnStartDrag;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('EXS', [TShapedPanel]);
end;

constructor TShapedPanel.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ControlStyle := [csCaptureMouse, csClickEvents, csOpaque, csDoubleClicks];
  Width := 200;
  Height := 200;
  RgnBrush := TBrush.Create;
  RgnBrush.Color := clBlack;
  FFillColor := clWhite;
  IsLoaded := False;
  FBorderWidth := 2;
  FBorderColor := clBlack;
  FRgn := 0;
  FRgn2 := 0;
end;

destructor TShapedPanel.Destroy;
begin
  DeleteObject(FRgn);
  DeleteObject(FRgn2);
  inherited;
end;

procedure TShapedPanel.CreateWnd;
begin
  inherited;
  MakeRegion;
  IsLoaded := True;
  {IsLoaded is to make sure MakeRegion is not called before there is a
  Handle for this control, but it may not be nessary}
end;

procedure TShapedPanel.MakeRegion;
var
  x4, y2: Integer;
  FPoints: array[0..5] of TPoint;
begin
  {I moved the Region creation to this procedure so it can be called for WM_SIZE}
  SetWindowRgn(Handle, 0, False);
  {this clears the window region}
  if FRgn <> 0 then
  begin
    {Make sure to Always DeleteObject for a Region}
    DeleteObject(FRgn);
    DeleteObject(FRgn2);
    FRgn := 0;
    FRgn2 := 0;
  end;
  x4 := Width div 4;
  y2 := Height div 2;
  FPoints[0] := Point(x4, 0);
  FPoints[1] := Point(Width - x4, 0);
  FPoints[2] := Point(Width, y2);
  FPoints[3] := Point(Width - x4, Height);
  FPoints[4] := Point(x4, Height);
  FPoints[5] := Point(0, y2);
  FRgn := CreatePolygonRgn(FPoints, 6, WINDING);
  SetWindowRGN(Handle, FRgn, True);
  FRgn2 := CreatePolygonRgn(FPoints, 6, WINDING);
  {FRgn2 is used for FrameRgn in Paint}
end;

procedure TShapedPanel.WMSize(var Message: TMessage);
var
  TmpClr: TColor;
begin
  inherited;
  if IsLoaded then
  begin
    TmpClr := Canvas.Brush.Color;
    Canvas.Brush.Color := FFillColor;
    MakeRegion;
    FillRgn(Canvas.Handle, FRgn2, Canvas.Brush.Handle);
    Paint;
    Canvas.Brush.Color := TmpClr;
  end;
end;

procedure TShapedPanel.Paint;
var
  TmpClr: TColor;
begin
  inherited;
  if IsLoaded then
  begin
    TmpClr := Canvas.Brush.Color;
    Canvas.Brush.Color := FFillColor;
    MakeRegion;
    FillRgn(Canvas.Handle, FRgn2, Canvas.Brush.Handle);
    FrameRgn(Canvas.Handle, FRgn2, RgnBrush.Handle, FBorderWidth, FBorderWidth);
    Canvas.Brush.Color := TmpClr;
  end;
end;

procedure TShapedPanel.SetBorderColor(Value: TColor);
begin
  if FBorderColor <> Value then
  begin
    FBorderColor := Value;
    RgnBrush.Color := FBorderColor;
    Paint;
  end;
end;

procedure TShapedPanel.SetFillColor(const Value: TColor);
begin
  if FFillColor <> Value then
  begin
    FFillColor := Value;
    Paint;
  end
end;

function TShapedPanel.GetFillColor: TColor;
begin
  Result := FFillColor;
end;

end.

How to randomly select records from a TTable

Problem/Question/Abstract:

How to randomly select records from a TTable

Answer:

procedure TForm1.FormCreate(Sender: TObject);
begin
  randomize; {call only once}
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  table1.first;
  table1.MoveBy(Random(table1.recordcount));
end;

Retrieving POST data in a TWebBrowser

Problem/Question/Abstract:

How do I get the POST data in a TWebBrowser event?

Answer:

In the BeforeNavigate2 event of TWebBrowser, you receive the PostData and Header data as OleVariant.  If you simply assign the OleVariant type to a string, you may get part of the data or garbage.  

You can convert the OleVariant to String using this function:

function VariantToString(AVar: OleVariant): string;
var
  i: integer;
  V: olevariant;
begin
  Result := '';
  if VarType(AVar) = (varVariant or varByRef) then
    V := Variant(TVarData(AVar).VPointer^)
  else
    V := AVar;

  if VarType(V) = (varByte or varArray) then
  try
    for i := VarArrayLowBound(V, 1) to VarArrayHighBound(V, 1) do
      Result := Result + Chr(Byte(V[i]));
  except;
  end
  else
    Result := V;
end;

How to call Windows system dialogs from code

Problem/Question/Abstract:

How to call Windows system dialogs from code

Answer:

{ ... }

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

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

var
  Form1: TForm1;
  oShell: OleVariant;

implementation

{$R *.DFM}

procedure TForm1.Shell(sMethod: Integer);
begin
  case sMethod of
    0: {Minimizes all windows on the desktop}
      begin
        oShell.MinimizeAll;
        Button1.Tag := Button1.Tag + 1;
      end;
    1: {Displays the Run dialog}
      begin
        oShell.FileRun;
        Button1.Tag := Button1.Tag + 1;
      end;
    2: {Displays the Shut Down Windows dialog}
      begin
        oShell.ShutdownWindows;
        Button1.Tag := Button1.Tag + 1;
      end;
    3: {Displays the Find dialog}
      begin
        oShell.FindFiles;
        Button1.Tag := Button1.Tag + 1;
      end;
    4: {Displays the Date/ Time dialog}
      begin
        oShell.SetTime;
        Button1.Tag := Button1.Tag + 1;
      end;
    5: {Displays the Internet Properties dialog}
      begin
        oShell.ControlPanelItem('INETCPL.cpl');
        Button1.Tag := Button1.Tag + 1;
      end;
    6: {Enables user to select folder from Program Files}
      begin
        oShell.BrowseForFolder(0, 'My Programs', 0, 'C:\Program Files');
        Button1.Tag := Button1.Tag + 1;
      end;
    7: {Displays the Taskbar Properties dialog}
      begin
        oShell.TrayProperties;
        Button1.Tag := Button1.Tag + 1;
      end;
    8: {Un-Minimizes all windows on the desktop}
      begin
        oShell.UndoMinimizeAll;
        Button1.Tag := 0;
      end;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  oShell := CreateOleObject('Shell.Application');
  Shell(Button1.Tag);
  oShell := VarNull;
end;