lina-components/Source/uAdvCtrls.pas

unit uAdvCtrls;

//////////////////////////////////////
///  Lina Advanced Controls Unit   ///
///  ****************************  ///
///  (c) 2014 Dennis Göhlert a.o.  ///
//////////////////////////////////////

  {$IFNDEF MSWINDOWS}
    {$IFDEF WARN_INCOMPATIBLEOS}
      {$MESSAGE ERROR 'The "uAdvCtrls" unit is only available under MS-Windows OS'}
    {$ENDIF}
  {$ENDIF}

interface

uses
  { Standard-Units }
  SysUtils, Classes, StdCtrls, Windows, Messages, Graphics, Controls, Printers,
  { Andere Package-Units }
  uBase;

type
  { Hilfsklassen }
  TMemoCaptionMode = (mcmAnyState,mcmUnfocusedOnly);

type
  { Ereignisse }
  TPaintMemoPaintEvent = procedure(Sender: TObject) of object;

type
  TCommandButton = class(TButton)
  private
    { Private-Deklarationen }
    FAbout: TComponentAbout;
    FNote: WideString;
    FShield: Boolean;
    FIcon: TIcon;
    { Methoden }
    procedure SetNote(Value: WideString);
    procedure SetShield(Value: Boolean);
    procedure SetIcon(Value: TIcon);
    procedure FIconChange(Sender: TObject);
  public
    { Public-Deklarationen }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    { Published-Deklarationen }
    property About: TComponentAbout read FAbout;
    property Note: WideString read FNote write SetNote;
    property Shield: Boolean read FShield write SetShield default False;
    property Icon: TIcon read FIcon write SetIcon;
  end;

  TScrollListBox = class(TListBox)
  private
    { Private-Deklarationen }
    FAbout: TComponentAbout;
    FHorizontalScrollBar: Boolean;
    FHorizontalScrollWidth: Integer;
    { Methoden }
    procedure SetHorizontalScrollBar(Value: Boolean);
  public
    { Public-Deklarationen }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure ScrollTo(Index: Integer);
  published
    { Published-Deklarationen }
    property About: TComponentAbout read FAbout;
    property HorizontalScrollBar: Boolean read FHorizontalScrollBar write SetHorizontalScrollBar default False;
    property HorizontalScrollWidth: Integer read FHorizontalScrollWidth write FHorizontalScrollWidth default 48;
  end;

  TPaintMemo = class(TMemo)
  private
    { Private-Deklarationen }
    FAbout: TComponentAbout;
    FShowCaption: Boolean;
    FCaption: TCaption;
    FCaptionFont: TFont;
    FCaptionMode: TMemoCaptionMode;
    FCaptionVisible: Boolean;
    FCaptionPosition: TPoint;
    { Ereignisse }
    FPaintEvent: TPaintMemoPaintEvent;
    { Methoden }
    procedure SetShowCaption(Value: Boolean);
    procedure SetCaptionFont(Value: TFont);
    procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
  public
    { Public-Deklarationen }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    property CaptionVisible: Boolean read FCaptionVisible default False;
  published
    { Ereignisse}
    property OnPaint: TPaintMemoPaintEvent read FPaintEvent write FPaintEvent;
    { Published-Deklarationen }
    property About: TComponentAbout read FAbout;
    property ShowCaption: Boolean read FShowCaption write SetShowCaption default True;
    property Caption: TCaption read FCaption write FCaption;
    property CaptionFont: TFont read FCaptionFont write SetCaptionFont;
    property CaptionMode: TMemoCaptionMode read FCaptionMode write FCaptionMode default mcmUnfocusedOnly;
    property CaptionPosition: TPoint read FCaptionPosition write FCaptionPosition;
  end;

  procedure Register;

  function BmpToIco(Bitmap: TBitmap): TIcon;

const
  { Meta-Daten }
  CommandButtonComponent_Name = 'CommandButton';
  CommandButtonComponent_Version = 1.0;
  CommandButtonComponent_Copyright = 'Copyright © 2014';
  CommandButtonComponent_Author = 'Dennis Göhlert a.o.';

  ScrollListBoxComponent_Name = 'ScrollListBox';
  ScrollListBoxComponent_Version = 1.0;
  ScrollListBoxComponent_Copyright = 'Copyright © 2014';
  ScrollListBoxComponent_Author = 'Dennis Göhlert a.o.';

  PaintMemoComponent_Name = 'PaintMemo';
  PaintMemoComponent_Version = 1.0;
  PaintMemoComponent_Copyright = 'Copyright © 2014';
  PaintMemoComponent_Author = 'Dennis Göhlert a.o.';
  { Messages }
  BS_COMMANDLINK = $0000000E;
  BM_SETIMAGE = $00F7;
  BCM_SETNOTE = $00001609;
  BCM_FIRST = $1600;
  BCM_SETSHIELD = BCM_FIRST + $000C;

implementation

procedure Register;
begin
  RegisterComponents(ComponentsPage,[TCommandButton,TScrollListBox,TPaintMemo]);
end;

function BmpToIco(Bitmap: TBitmap): TIcon;
begin
  with TImageList.CreateSize(Bitmap.Width,Bitmap.Height) do
  begin
    try
      AddMasked(Bitmap,Bitmap.TransparentColor);
      Result := TIcon.Create;
      GetIcon(0,Result);
    finally
      Free;
    end;
  end;
end;

{ ----------------------------------------------------------------------------
  TAdvancedButton
  ---------------------------------------------------------------------------- }

constructor TCommandButton.Create(AOwner: TComponent);
begin
  inherited;
  FAbout := TComponentAbout.Create(CommandButtonComponent_Name,CommandButtonComponent_Version,CommandButtonComponent_Copyright,CommandButtonComponent_Author);
  FShield := False;
  FIcon := TIcon.Create;
  FIcon.OnChange := FIconChange;
end;

destructor TCommandButton.Destroy;
begin
  FAbout.Free;
  FIcon.Free;
  inherited;
end;

procedure TCommandButton.SetNote(Value: WideString);
begin
  SendMessage(Handle,BCM_SETNOTE,0,LParam(Pointer(Value)));
  fNote := Value;
end;

procedure TCommandButton.SetShield(Value: Boolean);
begin
  SendMessage(Handle,BCM_SETSHIELD,0,LParam(Value));
  fShield := Value;
end;

procedure TCommandButton.SetIcon(Value: TIcon);
begin
  SendMessage(Handle,BM_SETIMAGE,1,LParam(Value.Handle));
  fIcon.Assign(Value);
end;

procedure TCommandButton.FIconChange(Sender: TObject);
begin
  SendMessage(Handle,BM_SETIMAGE,1,LParam(FIcon.Handle));
end;

{ ----------------------------------------------------------------------------
  TScrollListBox
  ---------------------------------------------------------------------------- }

constructor TScrollListBox.Create(AOwner: TComponent);
begin
  inherited;
  FAbout := TComponentAbout.Create(ScrollListBoxComponent_Name,ScrollListBoxComponent_Version,ScrollListBoxComponent_Copyright,ScrollListBoxComponent_Author);
  FHorizontalScrollBar := False;
  FHorizontalScrollWidth := 48;
end;

destructor TScrollListBox.Destroy;
begin
  FAbout.Free;
  inherited;
end;

procedure TScrollListBox.SetHorizontalScrollBar(Value: Boolean);
begin
  if Value = True then
  begin
    Perform(LB_SETHORIZONTALEXTENT,FHorizontalScrollWidth,Longint(0));
  end else
  begin
    Perform(LB_SETHORIZONTALEXTENT,0,0);
  end;
  FHorizontalScrollBar := Value;
end;

procedure TScrollListBox.ScrollTo(Index: Integer);
begin
  Perform(LB_SETTOPINDEX,Index,0);
end;

{ ----------------------------------------------------------------------------
  TPaintMemo
  ---------------------------------------------------------------------------- }

constructor TPaintMemo.Create(AOwner: TComponent);
begin
  inherited;
  FAbout := TComponentAbout.Create(PaintMemoComponent_Name,PaintMemoComponent_Version,PaintMemoComponent_Copyright,PaintMemoComponent_Author);
  FShowCaption := True;
  FCaptionFont := TFont.Create;
  FCaptionFont.Assign(Font);
  FCaptionFont.Color := clGray;
  FCaptionFont.Style := [fsItalic];
  FCaptionMode := mcmUnfocusedOnly;
  FCaptionVisible := False;
  FCaptionPosition.X := 5;
  FCaptionPosition.Y := 0;
end;

destructor TPaintMemo.Destroy;
begin
  FAbout.Free;
  FCaptionFont.Free;
  inherited;
end;

procedure TPaintMemo.SetShowCaption(Value: Boolean);
begin
  FShowCaption := Value;
  Repaint;
end;

procedure TPaintMemo.SetCaptionFont(Value: TFont);
begin
  FCaptionFont.Assign(Value);
end;

procedure TPaintMemo.WMPaint(var Message: TWMPaint);
var
  CCanvas: TControlCanvas;
  CRect: TRect;
begin
  inherited;
  FCaptionVisible := False;
  if FShowCaption = True then
  begin
    if ((Focused = False) or (CaptionMode = mcmAnyState)) and (Length(Text) < 1) then
    begin
      CCanvas := TControlCanvas.Create;
      try
        CCanvas.Control := Self;
        CCanvas.Brush.Color := Color;
        CRect := ClientRect;
        InflateRect(CRect,3,3);
        CCanvas.FillRect(CRect);
        CCanvas.Font.Assign(FCaptionFont);
        CCanvas.TextOut(FCaptionPosition.X,FCaptionPosition.Y,FCaption);
      finally
        CCanvas.Free;
      end;
      FCaptionVisible := True;
    end;
  end;
  if Assigned(OnPaint) = True then
  begin
    OnPaint(Self);
  end;
end;

end.