highlightedmemo.pas

常用数学计算工具

unit HighlightedMemo;
{------张秀达修改于2001.7-------CryptGetProvParam }
//增加HightLightLineNum属性
{ ********************** Nic Hollinworth June 1998 *********************** }

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, ComCtrls, RichEdit;

type
  THighlightedMemo = class(TMemo)
  private
    fCanvas:TCanvas;
    FHighlightedLine: integer; // Line number of text in memo
    fHLLNum:Integer;           //HightlightLine Number
    FHighLightColor: TColor;   // HighLight Colour
    FInvertColor: boolean;     // Invert the text within the highlighted bar
    FColIncrement: integer;    // Row offset added when scrolling
    FRowIncrement: integer;    // Col offset added when scrolling
    procedure SetHighLightColor (Value: TColor);
    procedure SetInvertColor (Value: boolean);
    procedure SetLine (LineNumber: integer);
    procedure SetHLLNum(HLLNum:Integer);
    function  GetVSPos:Integer;
    procedure SetVSPos(Pos:Integer);
    procedure WMPAINT (var Message: TMessage); message WM_PAINT;
    procedure WMHSCROLL (var Message: TMessage); message WM_HSCROLL;
    procedure WMVSCROLL (var Message: TMessage); message WM_VSCROLL;
    procedure WMKeyDown (var Message: TMessage); message WM_KeyDown;
    procedure WMResize  (Var Message: TMessage); message WM_Size;
  protected
    procedure Change; override;
  public
    constructor Create (AOwner: TComponent); override;
    destructor  Destroy; override;
    function GetFirstVisibleLine:Integer;
    function GetMaxVisibleLine:Integer;
    function GetVisibleLine:Integer;
    function LineToPos(x,y:Integer):Integer;
    function CurrentY:Integer;
    function CurrentX:Integer;
    function FindText(const SearchStr: string;
                     StartPos, Length: Integer; Options: TSearchTypes): Integer;
  published
    property HighLightColor: TColor read FHighLightColor write SetHighLightColor default clHighLight;
    property HighLightedLine: integer read FHighLightedLine write SetLine default -1;
    property HighLightedLineNum: Integer read fHLLNum write SetHLLNum default 1;
    property InvertTextColor: boolean read FInvertColor write SetInvertColor default false;
    property VScrollPos:Integer read GetVSPos write SetVSPos;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('Additional', [THighlightedMemo]);
end;

{ **************************************************************************** }

constructor THighLightedMemo.Create (AOwner: TComponent);
begin
  inherited Create (AOwner);
  FHighlightedLine := -1;
  fHLLNum:=1;
  FHighLightColor  := clHighLight;
  FRowIncrement := 0;
  FInvertColor := false;
  fCanvas:=TControlCanvas.Create;
  TControlCanvas(fCanvas).control:=Self;
  MaxLength:=1024*1024;
  WantTabs:=True;
  ControlStyle:=ControlStyle - [csOpaque];
 // PlainText:=True;
 // HideScrollBars:=False;
end;

destructor THighLightedMemo.Destroy;
begin
 inherited;
 fCanvas.Free;
end;
{ **************************************************************************** }

procedure THighLightedMemo.Change;
// When the text changes adjust the highlighted line, if
// necessary, and repaint the control.
begin
  inherited Change;
  if HandleAllocated then begin
    FRowIncrement := -GetScrollPos (Handle, SB_VERT);
    FColIncrement := -GetScrollPos (Handle, SB_HORZ);
  end;
  if FHighLightedLine >=0 then Refresh;
end;

{ **************************************************************************** }

procedure THighlightedMemo.WMPAINT (var Message: TMessage);
// Repaint the control ...
var
  i:Integer;
  HighLightedRow: integer;
  RowHeight: integer;
  TextString: string;
  TextMargin: integer;
  ps:TPAINTSTRUCT;
begin
  Brush.Style:=bsClear;
  inherited;
  Brush.Style:=bsSolid;

  if FHighLightedLine < 0 then exit;
  if (FHighLightedLine+fHLLNum<GetFirstVisibleLine )
     or( FHighLightedLine>GetFirstVisibleLine+GetVisibleLine-1)then exit;

  FRowIncrement := -GetScrollPos (Handle, SB_VERT);
  FColIncrement := -GetScrollPos (Handle, SB_HORZ);
  fCanvas.Font:=Font;
  if FInvertColor then                                   // $02 value of high order byte is used to
      fCanvas.Font.Color := ColorToRGB(FHighLightColor) xor $02FFFFFF;

  beginPaint(handle,ps);
  for i:=1 to   fHLLNum do
   begin
    TextString := Lines[FHighLightedLine+i-1];
    HighLightedRow := FHighLightedLine + FRowIncrement+i-1;
   // Paint the highlighted bar
     with fCanvas do begin
       RowHeight := TextHeight('A'); // Get the height of the text
       TextMargin := Integer(Perform (EM_GETMARGINS, 0, 0)); // Offset from left edge of client area
       Brush.Color := FHighlightColor;
       FillRect (Rect (1, HighLightedRow*RowHeight+1, ClientWidth-2, (HighLightedRow + 1)*RowHeight+1));
       TextOut (TextMargin + FColIncrement + 1, HighLightedRow*RowHeight + 1, TextString);
     end;//with end
  end;  //for end;
  EndPaint(Handle,ps);
end;

{ **************************************************************************** }

procedure THighLightedMemo.SetHighLightColor (Value: TColor);
// Set the colour of the highlighted bar
begin
  if FHighLightColor = Value then exit;
  FHighLightColor := Value;
  Refresh;
end;

{ **************************************************************************** }

procedure THighLightedMemo.SetLine (LineNumber: integer);
// Set the highlighted bar to the 'LineNumber' given
begin
  if FHighLightedLine = LineNumber then exit;
  FHighLightedLine := LineNumber;
  Refresh;
end;

procedure THighLightedMemo.SetHLLNum(HLLNum:Integer);
begin
 if fHLLNum=HLLNum then exit;
 fHLLNum:=HLLNum;
 Refresh;
end;
{ **************************************************************************** }

procedure THighLightedMemo.WMVSCROLL (var Message: TMessage);
// Set the row increment according to the scroll bar position
begin
  inherited;
  FRowIncrement := -GetScrollPos (Handle, SB_VERT);
  if FHighLightedLine < 0 then exit;
  Refresh;
end;

{ **************************************************************************** }

procedure THighLightedMemo.WMHSCROLL (var Message: TMessage);
// Set the column increment according to the scroll bar position
begin
  inherited;
  FColIncrement := -GetScrollPos (Handle, SB_HORZ);
  if FHighLightedLine < 0 then exit;
  Refresh;
end;

{ **************************************************************************** }

procedure THighLightedMemo.WMKeyDown (var Message: TMessage);
begin
 inherited;
 if FHighLightedLine <0 then exit;
 Refresh; 
end;
procedure THighLightedMemo.SetInvertColor (Value: boolean);
// Set boolean value to true to invert text colour
begin
  if FInvertColor=Value then exit;
  FInvertColor := Value;
  Refresh;
end;
procedure THighLightedMemo.WMResize;
begin
 inherited; Refresh;
end;
///////////////
function  THighLightedMemo.LineToPos;
begin
 Result:=SendMessage(Handle, EM_LINEINDEX, Y, 0)+X;
end;
function  THighLightedMemo.GetVSPos;
begin
 Result:=SendMessage(Handle, EM_LINEFROMCHAR, SelStart, 0);
 //Result:=GetScrollPos (Handle, SB_VERT);
end;
procedure THighLightedMemo.SetVSPos;
var
 curLine:Integer;
begin
 curline := Pos;
 if curline < 0 then  curline := 0;
 if curline > Lines.Count - 1
    then curline := Lines.Count - 1;
 SelStart := SendMessage(Handle, EM_LINEINDEX, curline, 0);
 SelLength := 1; SelLength:=0;
end;
function THighLightedMemo.CurrentY;
begin
 Result:=CaretPos.x;
end;
function THighLightedMemo.CurrentX;
begin
 Result:=CaretPos.x;
end;
/////////可见的行数
function THighLightedMemo.GetFirstVisibleLine:Integer;
begin
 Result:=SendMessage(Handle, EM_GETFIRSTVISIBLELINE, 0, 0)
end;
function THighLightedMemo.GetMaxVisibleLine;
var
 RowHeight:Integer;
begin
 fCanvas.Font:=Font; RowHeight:=fCanvas.TextHeight('A');
 if Visible
  then Result:=ClientHeight div RowHeight
  else Result:=0;
end;
function THighLightedMemo.GetVisibleLine;
var
   c: integer;
   n: integer;
begin
 n := GetMaxVisibleLine;
 c := Lines.Count - SendMessage(Handle, EM_GETFIRSTVISIBLELINE, 0, 0);
 if c < n then  result := c
          else  result := n;
end;
/////////////////////////
function THighLightedMemo.FindText(const SearchStr: string;
  StartPos, Length: Integer; Options: TSearchTypes): Integer;
var
  Find: TFindText;
  Flags: Integer;
begin
  with Find.chrg do
  begin
    cpMin := StartPos;
    cpMax := cpMin + Length;
  end;
  Flags := 0;
  if stWholeWord in Options then Flags := Flags or FT_WHOLEWORD;
  if stMatchCase in Options then Flags := Flags or FT_MATCHCASE;
  Find.lpstrText := PChar(SearchStr);
  Result := SendMessage(Handle, EM_FINDTEXT, Flags, LongInt(@Find));
end;

/////

end.