1. Technology

{
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/ ******************************************** }

©2014 About.com. All rights reserved.