source: cprs/branches/HealthSevak-CPRS/VA/VA2006Utils.pas@ 1721

unit VA2006Utils;

interface

uses
  Windows, Messages, SysUtils, Classes, Controls, ComCtrls, CommCtrl,
  Forms;

type

  //This class exists to workaround TFrame tabstop set to True
  //Known defect with Delphi 2006: http://qc.embarcadero.com/wc/qcmain.aspx?d=12257
  TfraTabStopFalse = class(TFrame)
  private
    function GetTabStop: Boolean;
    procedure SetTabStop(const Value: Boolean);
  published
    property TabStop: Boolean read GetTabStop write SetTabStop stored False;
  end;

// Fixes bug in Delphi 2006, where clicking on a header control section after
// any other section have been added or deleted could cause access violations
procedure FixHeaderControlDelphi2006Bug(HeaderControl: THeaderControl);

implementation

uses
  VAUtils;

type

  THeaderControl2006BugFixer = class(TComponent)
  private
    FHeaderControl: THeaderControl;
    procedure HeaderControlMessageHandler(var Msg: TMessage; var Handled: Boolean);
  protected
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
  public
    constructor CreateWrapper(HeaderControl: THeaderControl);
  end;

procedure THeaderControl2006BugFixer.HeaderControlMessageHandler
                      (var Msg: TMessage; var Handled: Boolean);
var
  OnSectionClick: TSectionNotifyEvent;
begin
  if (Msg.Msg = CN_NOTIFY) and (PHDNotify(Msg.LParam)^.Hdr.code = HDN_ITEMCLICK) then
  begin
    Handled := TRUE;
    Msg.Result := 0;
    OnSectionClick := FHeaderControl.OnSectionClick;
    if assigned(OnSectionClick) then
      OnSectionClick(FHeaderControl, FHeaderControl.Sections[PHDNotify(Msg.lParam)^.Item]);
  end;
end;

procedure THeaderControl2006BugFixer.Notification(AComponent: TComponent;
  Operation: TOperation);
begin
  inherited;
  if (Operation = opRemove) and (AComponent = FHeaderControl) then
  begin
    RemoveMessageHandler(FHeaderControl, HeaderControlMessageHandler);
    Self.Free;
  end;
end;

constructor THeaderControl2006BugFixer.CreateWrapper(HeaderControl: THeaderControl);
begin
  inherited Create(nil);
  FHeaderControl := HeaderControl;
  FHeaderControl.FreeNotification(HeaderControl);
  AddMessageHandler(HeaderControl, HeaderControlMessageHandler);
end;

procedure FixHeaderControlDelphi2006Bug(HeaderControl: THeaderControl);
begin
  THeaderControl2006BugFixer.CreateWrapper(HeaderControl);
end;

{ TfraTabStopFalse }

function TfraTabStopFalse.GetTabStop: Boolean;
begin
  Result := False;
end;

procedure TfraTabStopFalse.SetTabStop(const Value: Boolean);
begin
 //Do nothing here, just ignore the Value
end;

end.