{
Article: 

TMemoBar - T(Custom)Memo extender

http://delphi.about.com/library/weekly/aa083005a.htm

Full source code of a MemoBar Delphi component.
MemoBar can be attached to a T(Custom)Memo component to
provide additional info/functionality for a Memo component.
TMemoBar displays: current line and column number,
position of the textual cursor and the total number of characters.
MemoBar adds "GoTo Line" and "overwrite" features to a Memo control. 
}

MemoBar.pas

Download MemoBar.pas

interface

uses
  SysUtils, StdCtrls, Classes, Controls, ExtCtrls, Windows, Messages, QDialogs;

type
  TInsertState = (isInsert, isOverwrite);

  TMemoBar = class(TPanel)
  private
    fCharsPanel : TPanel;
    fInsertStatePanel : TPanel;
    fLocationPanel : TPanel;
    fMemo: TMemo;
    fInsertState: TInsertState;
    fOverwriteCaretHeight: integer;
    fOverwriteCaretWidth: integer;

    function GetLocationPanel: TPanel;
    procedure SetMemo(const Value: TMemo);
    function GetInsertStatePanel: TPanel;
    function GetCharsPanel: TPanel;
  protected
    procedure CreateWnd; override;
  private
    OldMemoWindowProc : TWndMethod;
    procedure MemoWindowProc(var Message : TMessage);

    procedure UpdateChars;
    procedure UpdateInsert;
    procedure UpdateLocation;
    procedure ToogleInsert;

    procedure ApplyOverwriteCaret;

    procedure LocationClick(Sender : TObject);

    property LocationPanel : TPanel read GetLocationPanel;
    property InsertStatePanel : TPanel read GetInsertStatePanel;
    property CharsPanel : TPanel read GetCharsPanel;
  public
    constructor Create(AOwner: TComponent);override;
    destructor Destroy; override;
  published
    property Memo : TMemo read fMemo write SetMemo;
    property InsertState : TInsertState read fInsertState write fInsertState default isInsert;
    property OverwriteCaretWidth : integer read fOverwriteCaretWidth write fOverwriteCaretWidth;
    property OverwriteCaretHeight : integer read fOverwriteCaretHeight write fOverwriteCaretHeight;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('delphi.about.com', [TMemoBar]);
end;

{ TMemoBar }

procedure TMemoBar.ApplyOverwriteCaret;
begin
  if Memo = nil then Exit;
  DestroyCaret;
  CreateCaret(Memo.handle,0,OverwriteCaretWidth,OverwriteCaretHeight) ;
  ShowCaret(Memo.Handle);
end; (* ApplyOverwriteCaret *)

constructor TMemoBar.Create(AOwner: TComponent);
begin
  inherited;

  Caption := '';
  Height := 21;
  Width := 233;

  fInsertState := isInsert; //default for TCustomMemo
  fOverwriteCaretWidth := 12;
  fOverwriteCaretHeight := 16;
end; (* Create *)

procedure TMemoBar.CreateWnd;
begin
  inherited;

  CharsPanel.Refresh;
  InsertStatePanel.Refresh;
  LocationPanel.Refresh;
end; (* CreateWnd *)

destructor TMemoBar.Destroy;
 function SameMethod(Proc1, Proc2: TWndMethod): Boolean;
 begin
   Result := (TMethod(Proc1).Code = TMethod(Proc2).Code) and (TMethod(Proc1).Data = TMethod(Proc2).Data);
 end;
begin
  if Assigned(Memo) then
  begin
    if SameMethod(memo.WindowProc, MemoWindowProc) then
    begin
      Memo.WindowProc := OldMemoWindowProc;
    end;
  end;

  inherited; //Destroy
end; (* Destroy *)

function TMemoBar.GetCharsPanel: TPanel;
var
  txt : string;
begin
  if fCharsPanel = nil then
  begin
    fCharsPanel := TPanel.Create(self);
    fCharsPanel.Parent := Self;
    fCharsPanel.Align := alLeft;
    fCharsPanel.BevelOuter := bvLowered;

    txt := ' 1000/1000 '; //set min width
    fCharsPanel.Width := Self.Canvas.TextWidth(txt);

    fCharsPanel.Visible := true;
  end;

  result := fCharsPanel;
end; (* GetCharsPanel *)

function TMemoBar.GetInsertStatePanel: TPanel;
var
  txt : string;
begin
  if fInsertStatePanel = nil then
  begin
    fInsertStatePanel := TPanel.Create(self);
    fInsertStatePanel.Parent := Self;
    fInsertStatePanel.Align := alLeft;
    fInsertStatePanel.BevelOuter := bvLowered;

    txt := '  OVERWRITE  ';
    fInsertStatePanel.Width := Self.Canvas.TextWidth(txt);

    fInsertStatePanel.Visible := true;
  end;

  result := fInsertStatePanel;
end; (* GetInsertStatePanel *)

function TMemoBar.GetLocationPanel: TPanel;
var
  txt : string;
begin
  if fLocationPanel = nil then
  begin
    fLocationPanel := TPanel.Create(self);
    fLocationPanel.Parent := Self;
    fLocationPanel.Align := alLeft;
    fLocationPanel.BevelOuter := bvLowered;
    fLocationPanel.Cursor := crHandPoint;
    fLocationPanel.ShowHint := true;
    fLocationPanel.Hint := 'Click: GoTO Line ...';

    txt := Format('Ln: %d Col: %d',[1000,1000]);
    fLocationPanel.Width := Self.Canvas.TextWidth(txt);

    fLocationPanel.Visible := true;

  end;
  result := fLocationPanel;
end; (* GetLocationPanel *)

procedure TMemoBar.LocationClick(Sender: TObject);
var
  newLine : integer;
  minLines : integer;
  maxLines : integer;
  prompt : string;
begin
  newLine := Perform(EM_LINEFROMCHAR, Memo.SelStart, 0) ;
  minLines := 1;
  maxLines := Memo.Lines.Count;
  prompt := Format('Line number (1 - %d)',[maxLines]);
  if InputQuery('Go To line',prompt,newLine,minLines,maxLines) then
  begin
    Memo.SelStart := Memo.Perform(EM_LINEINDEX, newLine, 0);
    Memo.Perform(EM_SCROLLCARET,0,0);
  end;
end; (* LocationClick *)

procedure TMemoBar.MemoWindowProc(var Message: TMessage);
begin
  if Message.Msg = WM_LBUTTONUP then
  begin
    UpdateLocation;
  end;

  if Message.Msg = WM_CHAR then
  begin
    if ((Memo.SelLength = 0) and (InsertState = isOverwrite)) then
    begin
      Memo.SelLength := 1;
    end;
  end;

  OldMemoWindowProc(Message);

  if Message.Msg = WM_KEYUP then
  begin
    UpdateChars;
    UpdateLocation;
    if Message.WParam = Ord(VK_INSERT) then
    begin
      ToogleInsert;
    end;
  end;

  if Message.Msg = WM_KILLFOCUS then
  begin
    DestroyCaret;
  end;

  if Message.Msg = WM_SETFOCUS then
  begin
    if InsertState = isOverwrite then ApplyOverwriteCaret;
  end;
end; (* MemoWindowProc *)

procedure TMemoBar.SetMemo(const Value: TMemo);
begin
  if fMemo <> Value then
  begin
    if Assigned(fMemo) then fMemo.WindowProc := OldMemoWindowProc;

    if Value <> nil then
    begin
      fMemo := Value;
      OldMemoWindowProc := fMemo.WindowProc;
      fMemo.WindowProc := MemoWindowProc;
    end;

    LocationPanel.OnClick := LocationClick;
  end;

  if Value = nil then
  begin
    fMemo := nil; 
    LocationPanel.OnClick := nil;
  end;

  UpdateChars;
  UpdateInsert;
  UpdateLocation;
end; (* SetMemo *)

procedure TMemoBar.ToogleInsert;
begin
  if InsertState = isInsert then
  begin
    InsertState := isOverwrite;

    ApplyOverwriteCaret;
  end
  else
  begin
    InsertState := isInsert;

    //trick to recreate default caret
    Memo.Perform(WM_KILLFOCUS,Memo.Handle,0);
    Memo.Perform(WM_SETFOCUS,Memo.Handle,0);
  end;

  UpdateInsert;
end; (* ToogleInsert *)

procedure TMemoBar.UpdateChars;
var
  chars : string;
begin
  if NOT Assigned(Memo) then
  begin
    chars := '0/0';
  end
  else
  begin
    chars := Format('%d/%d',[Memo.SelStart,Length(Memo.Text)]);
  end;

  CharsPanel.Caption := chars;
end; (* UpdateChars *)

procedure TMemoBar.UpdateInsert;
var
  state : string;
begin
  if NOT Assigned(Memo) then
  begin
    state := '?';
  end
  else
  begin
    if InsertState = isInsert then
      state := 'INSERT'
    else
      state := 'OVERWRITE';
  end;

  InsertStatePanel.Caption := state;
end; (* UpdateInsert *)

procedure TMemoBar.UpdateLocation;
var
  caretLocation : string;
  l,c : integer;
begin
  if NOT Assigned(Memo) then
  begin
    l := 0; c:= 0;
  end
  else
  begin
    with Memo do
    begin
      l := 1 + Perform(EM_LINEFROMCHAR, SelStart, 0) ;
      c := SelStart - Perform(EM_LINEINDEX, l - 1, 0);
    end;
  end;

  caretLocation := Format('Ln: %d Col: %d',[l,c]);
  LocationPanel.Caption := caretLocation;
end; (* UpdateLocation *)

end.


{
********************************************
Zarko Gajic
About.com Guide to Delphi Programming
http://delphi.about.com
email: delphi@aboutguide.com
free newsletter: http://delphi.about.com/library/blnewsletter.htm
forum: http://forums.about.com/ab-delphi/start/
********************************************
}