Delphi Developer's Kit 1996/Delphi Developer's Kit 1996.iso/power/dbmemox/dbmemox.pas

Pascal/Delphi Source File | 1995-12-22 | 7.8 KB | 322 lines

{$D- $L-  $Y-}

{$IFDEF NEVER}

TDBMemoXpld:

The TDBMemoXpld Control inherits most of its functionality
from the TDBMemo Control, except that, when it does not have
focus, it takes up minimal real estate and it 'explodes' when
it receives focus.  Browse the properties and it should become
clear how to use this control.

In the compressed state, it will display as much text as
possible on one line followed by '...'.

If the control is parented by a TPanel (or descendant), the
expanded version will explode beyond the boundaries of the TPanel.

As a default, this control will install on the samples page.  If
you want it somewhere else create an ini file named dbmemox.ini.
Include the following:

   [Install]
   Page=pagename

Or, you can change the source (not recommended).

To install: copy dbmemox.dcr and dbmemox.dcu to a directory
            in your install components search path.

            add dbmemox to your component list, and rebuild.



Version: 0.99

Date: 6/5/95

Author: Wm. Rubenstein, 76675,2251 (Compuserve)

Disclaimer:  All the usual about liability.
             All the usual about who owns this code.
             This is freeware.


################################################################

{$ENDIF}

unit Dbmemox;

interface
uses
  SysUtils, WinTypes, WinProcs, Classes, Graphics, Controls,
  StdCtrls, DBCtrls, ExtCtrls, IniFiles;

type
  TDBMemoXpld = class(TDBMemo)
  private
    { Private declarations }
    FCanvas: TControlCanvas;  {used to measure text}
    FExploded: Boolean;
    FWidthExpld: Integer;
    FHeightExpld: Integer;
    FWidth: integer;
    FHeight: integer;
    FEdit: TEdit; {this is a second control--used to display
                  the compressed version of the data}
    FOnExit: TNotifyEvent;
    procedure SetExploded(Value: boolean);
    procedure SetWidthExpld(Value: integer);
    procedure SetHeightExpld(Value: integer);
    procedure CreateEdit;
    procedure FEditMouseDown(Sender: TObject; Button: TMouseButton;
                Shift: TShiftState; X, Y: Integer);
    procedure FEditOnEnter(Sender: TObject);
    procedure MemoOnExit(Sender: TObject);
  protected
    { Protected declarations }
    procedure change; override;
    procedure loaded; override;

  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    property Exploded: Boolean read FExploded write SetExploded;

  published
    { Published declarations }
    property WidthExpld: Integer read FWidthExpld
                         write SetWidthExpld;
    property HeightExpld: Integer read FHeightExpld
                          write SetHeightExpld;
end;

procedure Register;

implementation

constructor TDBMemoXpld.Create(AOwner: TComponent);
begin
   inherited Create(AOwner);
   FCanvas := TControlCanvas.Create;
   FCanvas.Control := Self;
   FExploded := false;
   Height := 25;
   Width := 90;
   FheightExpld := 185;
   FWidthExpld := 90;
   WordWrap := true;
end;

destructor TDBMemoXpld.Destroy;
begin
   FCanvas.Free;
   inherited Destroy;
end;

procedure TDBMemoXpld.Loaded;
begin
   inherited loaded;
   FWidth := Width;
   FHeight := Height;
end;

procedure TDBMemoXpld.SetExploded(Value: boolean);
begin;
   if FExploded <> Value then
   begin
      FExploded := Value;
      Change;
   end;
end;

procedure TDBMemoXpld.SetWidthExpld(Value: integer);
begin
   FWidthExpld := Value;
end;

procedure TDBMemoXpld.SetHeightExpld(Value: integer);
begin
   FHeightExpld := Value;
end;

procedure TDBMemoXpld.Change;
var
   s: string;
   DC: HDC;
   WindowHandle: THandle;
   Width, AvailWidth, i: integer;
   ellipse: string;
begin
   if (csDesigning in ComponentState) or
      (csLoading in ComponentState) then
      exit;

   if FEdit = nil then CreateEdit;

   if FExploded then
   begin
      FEdit.Hide;
      BringToFront;
      Show;
      inherited Change;
      exit;
   end;
   {compressed so get some text.}
   try
      Hide;
      FEdit.Show;
      ellipse := '...';
      AvailWidth := FEdit.clientWidth - 5;
      WindowHandle := FEdit.Handle;
      DC := GetDC(WindowHandle);
      FCanvas.Handle := DC;
      FCanvas.Font := Font;

      i := 0;
      s := '';
      {Accumulate enought lines to fill the
      control, if possible}
      while i < Lines.Count do
      begin
         s := s + Lines.Strings[i];
         if FCanvas.TextWidth(s) >= AvailWidth then
            break;
         INC(i);
      end;

      if i >= Lines.Count then
         ellipse := ''; {We have it all}
      i := length(s);
      while true do
      begin
         {Backscan for non-space char}
         while (i > 0) and (s[i] = ' ') do
            DEC(i);
         s[0] := Char(i);
         if FCanvas.TextWidth(s + ellipse) < AvailWidth then
            break; {What we have will fit}
         {It won't fit, so backscan for space
         and go again}
         while (i > 0) and (s[i] <> ' ') do
            DEC(i);
         s[0] := Char(i);
         ellipse := '...';
      end;
      s := s + ellipse + char(0);
      SetWindowText(FEdit.Handle, Addr(s[1]));
      inherited Change;
   finally
      ReleaseDC(WindowHandle, DC);
      FCanvas.Handle := 0;
   end;
end;

procedure TDBMemoXpld.FEditMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
   if Button = mbLeft then
      Exploded := true;
   {Execute mousedown for the real control}
   MouseDown(Button, Shift, X, Y);
end;

procedure TDBMemoXpld.FEditOnEnter(Sender: TObject);
begin
   Exploded := true;
   SetFocus; {to the real control}
end;

procedure TDBMemoXpld.MemoOnExit(Sender: TObject);
begin;
   Exploded := False;
   if Assigned(FOnExit) then
      FOnExit(Sender);
end;

procedure TDBMemoXpld.CreateEdit;
{Create the new compressed control}
var
   T: TComponent;
   P: TLabel;
   i: integer;
begin
   if Parent is TPanel then
   begin
      FEdit := TEdit.Create(Parent.Parent);
      FEdit.SetBounds(Left + Parent.Left, Top + Parent.Top,
         FWidth, FHeight);
      FEdit.Parent := Parent.Parent;
   end
   else
   begin
      FEdit := TEdit.Create(Parent);
      FEdit.SetBounds(Left, Top, FWidth, FHeight);
      FEdit.Parent := Parent;
   end;
   FEdit.Font := Font;
   FEdit.BorderStyle := BorderStyle;
   FEdit.Color := Color;
   FEdit.Ctl3D := Ctl3D;
   FEdit.Cursor := Cursor;
   FEdit.HelpContext := HelpContext;
   FEdit.Hint := Hint;
   FEdit.ParentColor := ParentColor;
   FEdit.ParentCtl3D := ParentCtl3D;
   FEdit.ParentFont := ParentFont;
   FEdit.ParentShowHint := ParentShowHint;
   FEdit.ShowHint := ShowHint;
   FEdit.TabOrder := TabOrder;
   FEdit.TabStop := TabStop;
   FEdit.Enabled := Enabled;
   FEdit.OnEnter := FEditOnEnter;
   FEdit.OnMouseDown := FEditMouseDown;

   FOnExit := OnExit;
   Self.OnExit := MemoOnExit;

   self.SetBounds(Left, Top, FWidthExpld, FHeightExpld);

   {We need to retarget the focusControl Component of any
   TLabel which points to us.}
   T := parent;
   for i := 0 to T.ComponentCount - 1 do
   begin
      if T.Components[i] is TLabel then
      begin
         P := T.Components[i] as TLabel;
         if P.FocusControl = self then
            P.FocusControl := FEdit;
      end;
   end;


end;

function GetInstallPage: string;
var
   IniFile: TIniFile;
begin
   try
      IniFile := TIniFile.Create('dbmemox.ini');
      Result := IniFile.ReadString('Install', 'Page', 'Samples');
      IniFile.Free;
   except
      on exception do
      begin
         Result := 'Samples';
         IniFile.Free;
      end;
   end;
end;

procedure Register;
begin
  RegisterComponents(GetInstallPage, [TDBMemoXpld]);
end;

end.