{-----------------------------------------------------------
  ColorMemo v2.x
  © 1997 - 2002 Baltic Solutions
 -----------------------------------------------------------
  ColorMemo component

  TColorRule, TDrawRules, THotSpot,
  TMemoMark, TColorMemo definitions
 -----------------------------------------------------------
  Last revision date: 2002.02.27
 -----------------------------------------------------------}

unit ColMemo;
{$O-}
{$J+}  // writeable typed constants on
{$INCLUDE versiondef.inc}

// defining this uses DrawText instead of ExtTextOut
{$DEFINE CM_DT1}

interface

uses
   Windows, Graphics, SysUtils, Messages, Classes,
   Controls, StdCtrls, Forms, CMParamFile, shellAPI,
   Printers;

const


  BEG_END_SZ  = 6;   { The maximum size of one Begin or End marker }
  HandCursor  = 1;
  ColorValues: array[1..16] of TColor =
     (clBLACK, clMAROON, clGREEN, clOLIVE, clNAVY, clPURPLE, clTEAL, clGRAY,
      clSILVER, clRED, clLIME, clYELLOW, clBLUE, clFUCHSIA, clAQUA, clWHITE);

  Colors: array[1..16] of string[7] =
     ('BLACK', 'MAROON', 'GREEN', 'OLIVE', 'NAVY', 'PURPLE', 'TEAL', 'GRAY',
      'SILVER', 'RED', 'LIME', 'YELLOW', 'BLUE', 'FUCHSIA', 'AQUA', 'WHITE');

  CM_DEF_KEYWORD_CHARS = ['A'..'Z', 'a'..'z', '_', '0'..'9'];
  CM_HOTSPOT_Z = 252;
  CM_HOTSPOT_CHAR_Z = 253;


 type
   // pre-definitions
   TColorMemo = class;


   TKeyDrawingType = ( dtKeyShow, dtEventDraw, dtBeginEnd, dtBeginLineEnd);
   TColorMemoOption = ( cmoAcceptFiles, cmoAllowCutCopy, cmoCalcFullBegEnds, cmoDragText);
   TColorMemoOptions = set of TColorMemoOption;

// TKeyDescr describes area to be colored. Used in component itself and in TDrawEvent
   PKeyDescr = ^TKeyDescr;
   TKeyDescr = record
     Left, Right: Integer;
     KeyColor: TColor;
     BGColor: TColor;
     ZOrder: Byte;
     DrawKey: Boolean;
     FontSt: TFontStyles;
     IgnoreOthers: Boolean; //completely ignores other keys that are inside
   end;

// This record is used to describe Begin/End markers.
// The KeyBegEndLst and KeyLineEndLst lists are used only to specify parameters,
// and are transformed to array of type TBeginEndDescr.
// The size of array is specified in BEG_END_CNT.
   PBeginEndDescr = ^TBeginEndDescr;
   TBeginEndDescr = record
     CBegin, CEnd: Array[0..BEG_END_SZ] of Char;
     KeyColor: TColor;
     BGColor: TColor;
     Pos: PChar;
   end;



// Export to RTF/HTML
 TColBufferEntry = record
   col: TColor;
   ZOrder: TColor;
 end;

 PColBuff = ^TColBuff;
 TColBuff = array[0..MaxListSize] of TColBufferEntry;

// Keywords as hotspots
 TcmHotKeyword = record
   left, right: integer;
 end;
 TcmHotKeywordListArr = array[0..MaxListSize] of TcmHotKeyword;
 PcmHotKeywordListArr = ^TcmHotKeywordListArr;



TWMContextMenu = packed record
  Msg: Cardinal;
  hWnd: HWND;
  case Integer of
    0: (XPos: Smallint;YPos: Smallint);
    1: (Pos: TSmallPoint; Result: Longint);
end;

THotSpotEvent = procedure( Sender: TObject; const SRC: String) of object;
THotSpotClickEvent = procedure( Sender: TObject; const SRC: String; MButton: TMouseButton; Shift: TShiftState) of object;
TDrawEvent = procedure( Sender: tObject; FromPos: PChar; var A: array of tKeyDescr; var ItemsCount: Integer) of object;
TDrawExEvent = procedure (Sender: TObject; ABuff, AFromPos: PChar; ALength: integer) of object;
TKeyDrawEvent = procedure( Canvas: TCanvas; const PKey: String; Rect: TRect; KColor: TColor) of object;
TDropFileEvent = procedure (Sender: TObject; const AFile: TFileName) of object;
TIsKeywordCharEvent = procedure (Sender: TObject; Achar: Char; var IsKeywordChar: boolean) of object;
TCMContextPopupEvent = procedure (Sender: TObject; X, Y: integer; var Handled: boolean) of object;


TcmHotKeywordList = class
  private
    FList: PcmHotKeywordListArr;
    FActLength: integer;  // number of allocated records
    FCount: integer; // number of used records
    FMemo: TColorMemo;
  public
    procedure Add(left, right: integer);
    procedure Clear;
    constructor Create(const AMemo: TColorMemo);
    destructor Destroy; override;
    function GetHotspot(const APosition: integer): string;
end;

// This list collects all TKeyDescr data from all types of coloring rules
// It's CalcColors method that does this. Overlapings, ... are regulated
// in a Paint method of component

// list is "fat"; everytime a new item is requested with AddNew,
// function either returns existing instance or expands a list;
// actual number of valid items is ValidItemsCount
// paintstart points to keys to be painted.
TKeyDescrList = Class( TList)
  private
    FValidItemsCount: integer;
    FColMemo: TColorMemo;
    FPaintStart: integer;
   public
     constructor Create(AMemo: TColorMemo);
     destructor Destroy; override;
     procedure Reset;
     property ValidItemsCount: integer read FValidItemsCount; // number of valid items in list
     procedure CalcMinMax;
     procedure ParseMultilines; // divides all multiline descriptions into separate ones
     function AddNew: PKeyDescr;
     procedure MarkPaintStart;
     property PaintStart: integer read FPaintStart;
   end;

EMemoLost = class(Exception)
    constructor Create;
  end;

TCMStringList = class(TStringList)
  public
    procedure AddColored(Astring: string; AColor: TColor);
end;

TBegEndList = class(TList)
  private
    FValidItems: integer;
  public
   property ValidItemsCount: integer read FValidItems;
   procedure Reset;
   function AddNew: PBeginEndDescr;
    destructor Destroy; override;
end;


TColorRule = Class( TCollectionItem)
  private
    FColorMemo    : TColorMemo;
    FRuleType     : TKeyDrawingType;
    FKeywords     : TCMStringList;
    FKeyBegEnd    : TCMStringList;
    FKeyLineEnd   : TCMStringList;
    FKeyCase      : Boolean;
    FEnabled      : Boolean;
    FPartWord     : Boolean;
    FKeyDefColor  : TColor;
    FKeySelColor  : TColor;
    FKeyBrushColor: TColor;
    FKeyMaxLines  : Integer;
    FZOrder       : Byte;
    FIntChar      : String;
    FMaxBegEndDscr: Integer;

    FBegEnd       : TBegEndList;
    FKeyList      : TStringList;

    CaseBuf       : PChar;
    CaseBufLen    : Integer;


    FResultList: TStringList;
    FName: String;
    FIsHotspot: boolean;
    FBold: boolean;
    FItalic: boolean;
    FUnderline: boolean;
    FIgnoreOtherRules: boolean;

    procedure SetKeywords( Value: TCMStringList);
    procedure SetKeyBegEnd( Value: TCMStringList);
    procedure SetKeyLineEnd( Value: TCMStringList);
    procedure SetKeyCase( Value: Boolean);

    procedure  CalcKeywordColors(EBUF, PFrom: PChar; PCount: Integer);
    procedure  CalcBegEndColors(EBUF, PFrom: PChar; PCount: Integer; ACompleteBuff, AIncEnd: boolean);
    procedure CalcFullBegEnds (EBUF, PFrom: PChar; PCount: Integer;
                              ABeg, AEnd: PChar; MaxLines: integer;
                              ACol, ABGCol: TColor; ACompleteBuff, AIncEnd: boolean);
    function NewKeyDescr: PKeyDescr;
  protected
    function GetDisplayName: string; override;
    procedure ReadFromParam (const AParam: TCMParamList); virtual;
    procedure WriteToParam (const AParam: TCMParamList); virtual;
  public
    constructor Create(Collection: TCollection); override;
    destructor Destroy; override;
    procedure AssignTo( Dest: TPersistent); override;

    procedure  CalcColors( EBUF, PFrom: PChar; PCount: Integer);
    function UpdateKeyParams: Boolean;
    property CMemo: TColorMemo read FColorMemo;

  published
    property ZOrder: Byte read FZOrder write FZOrder default 0;
    property IntChar: String read FIntChar write FIntChar;
    property Keywords: TCMStringList read FKeywords write SetKeywords;
    property KeyBegEndLst: TCMStringList read FKeyBegEnd write SetKeyBegEnd;
    property KeyLineEndLst: TCMStringList read FKeyLineEnd write SetKeyLineEnd;
    property KeyMaxHeight: Integer read FKeyMaxLines write FKeyMaxLines default 1;
    property KeyDrawingType: TKeyDrawingType read FRuleType write FRuleType default dtBeginEnd;
    property KeyCase: Boolean read FKeyCase write SetKeyCase default False;
    property Enabled: Boolean read FEnabled write FEnabled default True;

    property Bold: boolean read FBold write FBold default False;
    property Italic: boolean read FItalic write FItalic default False;
    property Underline: boolean read FUnderline write FUnderline default False;

    property PartWord: Boolean read FPartWord write FPartWord default False;
    property DefKeyColor: TColor read FKeyDefColor write FKeyDefColor default clRed;
    property KeySelColor: TColor read FKeySelColor write FKeySelColor default clYellow;
    property KeyBrushColor: TColor read FKeyBrushColor write FKeyBrushColor default clWindow;
    property IsHotspot: boolean read FIsHotspot write FIsHotspot;
    property IgnoreOtherRules: boolean read FIgnoreOtherRules write FIgnoreOtherRules;

    property Name: String read FName write FName;
end; { TColorRule }

TDrawRules = class( TCollection)
  private
    FColorMemo: TColorMemo;
    FRUpdate: Boolean;

    function GetRule(Index: Integer): TColorRule;
    procedure SetRule(Index: Integer; Value: TColorRule);
    procedure UpdRules;

  protected
    function  GetOwner: TPersistent; override;
    function GetAttrCount: Integer; override;
    function GetAttr(Index: Integer): String; override;
    function GetItemAttr(Index: Integer; ItemIndex: Integer): String;
      override;
  public
    constructor Create( CLMM: TColorMemo);
    function  Add: TColorRule;
    property CMemo: TColorMemo read FColorMemo;
    property UpdateRules: Boolean read FRUpdate write FRUpdate;
    property Items[ Index: Integer]: TColorRule read GetRule write SetRule; default;

    procedure ReadFromParam (const AParam: TCMParamList);
    procedure WriteToParam (const AParam: TCMParamList);
    procedure SaveToFile (const AFileName: string);
    procedure LoadFromFile (const AFileName: string);
end;

THotSpot = class(TPersistent)
  private
    FHSBegChar    : Char;
    FHSEndChar    : Char;
    FHotSpotColor : TColor;
    FHotSpotMarkerColor: TColor;
    FHotSpotActive: Boolean;
    FHotSpotUnderlined: Boolean;
  public
    constructor Create;
    procedure AssignTo( Dest: TPersistent); override;
  published
    property BeginChar: Char read FHSBegChar write FHSBegChar default #30;
    property EndChar: Char read FHSEndChar write FHSEndChar default #31;
    property Color: TColor read FHotSpotColor write FHotSpotColor default clBlue;
    property MarkerColor: TColor read FHotSpotMarkerColor  write FHotSpotMarkerColor default clWindow;
    property Active: Boolean read FHotSpotActive write FHotSpotActive default False;
    property Underlined: Boolean read FHotSpotUnderlined write FHotSpotUnderlined default True;
end;

TCMGutterOptions = class (TPersistent)
  private
    FColMemo: TColorMemo;
    FShowLineNumbers: boolean;
    FAlignment: TAlignment;
    FStartCount: Integer;
    FIs3D: Boolean;
    FSize: Integer;
    FNumColor: TColor;
    FColor: TColor;
    procedure Changed;
    procedure SetAlignment(const Value: TAlignment);
    procedure SetNumColor(const Value: TColor);
    procedure SetShowLineNumbers(const Value: boolean);
    procedure SetStartCount(const Value: Integer);
    procedure SetColor(const Value: TColor);
    procedure SetIs3D(const Value: Boolean);
    procedure SetSize(const Value: Integer);
  protected
    procedure AssignTo(Dest: TPersistent); override;
  public
    constructor Create(AMemo: TColorMemo);
  published
    property ShowLineNumbers: boolean read FShowLineNumbers write SetShowLineNumbers;
    property Alignment: TAlignment read FAlignment write SetAlignment default taLeftJustify;
    property NumColor: TColor read FNumColor write SetNumColor;
    property StartCountAt: Integer read FStartCount write SetStartCount default 1;
    property Size: Integer read FSize write SetSize default 0;
    property Is3D: Boolean read FIs3D write SetIs3D default false;
    property Color: TColor read FColor write SetColor default clBtnFace;
end;

{ TMemoMark - smth like bookmark in Datasets }
TMemoMark = class
  private
    FStartPos, FEndPos: integer;
    FMemo: TColorMemo;
    function GetLength: Integer;
    function GetStartLine: integer;
    function GetEndLine: Integer;
    function GetText: string;
  public
    constructor Create;
    destructor Destroy; override;
    property StartPos: integer read FStartPos write FStartPos;
    property EndPos: integer read FEndPos write FEndPos;
    property StartLine: integer read GetStartLine;
    property EndLine: integer read GetEndLine;
    property Text: string read GetText;
    property Length: integer read GetLength;
    property Memo: TColorMemo read FMemo;
    procedure ShowMark;
end;

TCMPrintMargins = class(TPersistent)
  private
    FTop: integer;
    FBottom: integer;
    FRight: integer;
    FLeft: integer;
  protected
    procedure AssignTo(Dest: TPersistent); override;
  published
    property Top: integer read FTop write FTop;
    property Bottom: integer read FBottom write FBottom;
    property Left: integer read FLeft write FLeft;
    property Right: integer read FRight write FRight;
end;

TCMPrintOptions = class(TPersistent)
  private
    FHeader: string;
    FFooter: string;
    FHeaderAlignment: TAlignment;
    FFooterAlignment: TAlignment;
    FMargins: TCMPrintMargins;
  protected
    procedure AssignTo(Dest: TPersistent); override;
  public
    constructor Create;
    destructor Destroy; override;
  published
    property Margins: TCMPrintMargins read FMargins write FMargins;
    property Header: string read FHeader write FHeader;
    property Footer: string read FFooter write FFooter;
    property HeaderAlignment: TAlignment read FHeaderAlignment write FHeaderAlignment;
    property FooterAlignment: TAlignment read FFooterAlignment write FFooterAlignment;
end;


TColorMemo = class(TMemo)
  private
    FCanvas: TCanvas;
    FRules: TDrawRules;
    FFullRedraw: Boolean;

    FHotSpotProp: THotSpot;

    FCurLine : Integer;
    FCurPosn : Integer;
    FCurTop  : Integer;
    FMaxLines: Integer;
    FMemLnCnt: Integer;
    FMemChCnt: Integer;
    VER95   : Boolean;
    CLAR    : Pointer;
    CLAR_SIZ: Integer;
    FKeyDescr : TKeyDescrList;
    FCurrBuff : Pchar;
    FCurrBuffLen: integer;

    MINLEFT : LongInt;
    MAXRIGHT: LongInt;
    FAcceptFiles: boolean;

    FOldCursorPos: integer;  { stores the prev. cursor position }
    FOldSelLength: integer;  { stores selection length }
    FOldLength: integer;     { prev. selection length }
    FPosDiff: integer;
    FLengthDiff: integer;
    FDragSelLength: Integer;
    FDragSelStart: Integer;
    FMemoMarks: TList;
    FCreated: boolean;
    LineDC: THandle;
    DragLineX: integer;
    DragLineY: integer;
    FDragText: boolean;
    FDownX: integer;
    FDownY: integer;

    FTextArea: TRect;
    FTextRgn: HRGN;

    FLastSpot: string; // last hovered hotspot

    Fcursor: TCursor;  // actual cursor of memo
    FGutterOpts: TCMGutterOptions;
    FPrintOptions: TCMPrintOptions;

    FHotKeywords: TcmHotKeywordList;
    FAllowCutCopy: boolean;
    FCalcFullBegEnds: boolean;

    FOnIsKeywordChar: TIsKeywordCharEvent;
    FOnHotSpotClick: THotSpotClickEvent;
    FOnVScroll: TNotifyEvent;
    FOnHScroll: TNotifyEvent;
    FOnDraw: TDrawEvent;
    FOnKeyDraw: TKeyDrawEvent;
    FOnDropFile: TDropFileEvent;
    FOnHoverHotSpot: THotSpotEvent;
    FOnHotSpotExit: THotSpotEvent;
    FOnContextPopup: TCMContextPopupEvent;
    FOnDrawEx: TDrawExEvent;
    FOnSelectionChange: TNotifyEvent;

    FLastTabStopWidth: Integer;

    procedure UpdateBookmarks;
    procedure Edited;

    function  GetCurrentLine: Integer;
    function  GetCurrentPosition: Integer;
    function  GetTopLine: Integer;
    procedure SetCurrentLine( Value: Integer);
    procedure SetCurrentPosition( Value: Integer);
    procedure SetRules( Value: TDrawRules);
    procedure SetHotSpotProp( Value: THotSpot);
    function  GetLinesVisible: Integer;
    function  GetMaxLinesVisible: Integer;

    procedure CalcHotSpots( EBUF, PFrom: PChar; PCount: Integer);

    procedure SetAcceptFiles(const Value: boolean);
    procedure AdjustTextArea;
    function PointToHotSpot(x,y: integer): string;

    procedure ParseMultilineKeyDescr(Akeyd: PKeyDescr);
    function GetDragText: boolean;

    function IsKeywordChar(const Ac: Char): boolean;
    procedure SetGutterOpts(const Value: TCMGutterOptions);
    procedure SetPrintOptions(const Value: TCMPrintOptions);

    procedure PaintKeyDescr;
    procedure PaintGutter;

    procedure CalcTextRect(ADC: HDC; Ax, Ay: integer; AText: PChar; AMaxLen: integer; APRect: PRect);
    function GetOptions: TColorMemoOptions;
    procedure SetOptions(const Value: TColorMemoOptions);
    procedure SetTabStopWidth(const Value: Integer);
  protected
    procedure PaintColors( Sender: TObject; CurrLine: Boolean); virtual;


    procedure Change; override;
    procedure KeyDown( var Key: Word; Shift: TShiftState); override;
    procedure KeyUp( var Key: Word; Shift: TShiftState); override;
    procedure MouseDown( Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
    procedure MouseUp( Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
    procedure MouseMove( Shift: TShiftState; X, Y: Integer); override;
    procedure PaintWindow( DC: HDC); override;

    procedure WMDropFiles(var Message: TWMDropFiles); message WM_DROPFILES;
    procedure WMPaint( var Message: TWMPaint); message WM_PAINT;
    procedure WMHScroll( var Msg: TWMHScroll); message WM_HSCROLL;
    procedure WMVScroll( var Msg: TWMVScroll); message WM_VSCROLL;
    procedure WMSize( var Msg: TWMSize); message WM_SIZE;
    procedure WMKillFocus(var Message: TWMSetFocus); message WM_KILLFOCUS;
    procedure WMLButtonDown(var Message: TWMLButtonDown); message WM_LBUTTONDOWN;
    procedure WMCut(var Message: TWMCut); message WM_CUT;
    procedure WMCopy(var Message: TWMCopy); message WM_COPY;
    procedure WMContextMenu(var Message: TWMContextMenu); message WM_CONTEXTMENU;

    procedure CMFontchanged(var Message: TMessage); message CM_FONTCHANGED;
    procedure CMFontchange(var Message: TMessage); message CM_FONTCHANGE;
    procedure CMCtl3DChanged(var Message: TMessage); message CM_CTL3DCHANGED;
    procedure CMRecreateWnd(var Message: TMessage); message CM_RECREATEWND;
    procedure CMCursorchanged(var Message: TMessage); message CM_CURSORCHANGED;
    procedure EMSetTabStops(var Message: TMessage); message EM_SETTABSTOPS;

    procedure WndProc(var Message: TMessage); override;
    procedure CreateWindowHandle(const Params: TCreateParams); override;

    procedure DragOver(Source: TObject; X, Y: Integer;
       State: TDragState; var Accept: Boolean); override;
    procedure DoEndDrag(Target:TObject; X, Y: Integer); override;

    procedure AppendColBuffer(ABuff: PColBuff; Afrom, ATo: integer; AColor: TColor; ZOrder: integer);
    procedure CompileKeywordList (const ARule: TColorRule; const ABuff: PColBuff );
    procedure CompileBeginEndList (const ARule: TColorRule; const ABuff: PColBuff );
    procedure CompileLineEndList (const ARule: TColorRule; const ABuff: PColBuff );
    function  CompileColBuff: PColBuff;
    function  CompileColPortions: TStringList;

  public
    procedure DragDrop(Source: TObject; X, Y: Integer); override;

    constructor Create( AOwner: TComponent); override;
    destructor Destroy; override;

    property  CurrentLine: Integer read GetCurrentLine write SetCurrentLine;
    property  CurrentPosition: Integer read GetCurrentPosition write SetCurrentPosition;
    property  TopLine: Integer read GetTopLine;
    property  LinesVisible: Integer read GetLinesVisible;
    property  MaxLinesVisible: Integer read GetMaxLinesVisible;

    procedure ScrollBy( X: Integer; Y: Integer);
    procedure GetMaxLines;

    function  GetMark: TMemoMark;
    procedure DeleteMark( aMark: TMemoMark );
    procedure FreeMark( var AMark: TMemoMark );

    procedure AssignTo( Dest: TPersistent); override;
    procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;

    function CompileHTML ( const ATitle: string; const AContentOnly: boolean ): string;
    function CompileRTF: string;
    procedure SaveToHTML (const AFileName: string; const ATitle: string; const AContentOnly: boolean );
    procedure SaveToRTF (const AFileName: string);
    procedure Print;

    procedure TextOutEx(const Ax, Ay: integer; AText: PChar; AMaxLen: integer);
    procedure TextOut(const Ax, Ay: integer; AText: String);

    function NewKeyDescr: PKeyDescr;
    procedure DefineHotSpot(const Afrom, Ato: integer);

    procedure SetTabStopWidhts(ATabs: array of integer);
    property RGN: HRGN read FTextRgn;
    property Canvas: TCanvas read FCanvas;
  published
    property ColorRules: TDrawRules read FRules write SetRules;
    property RedrawAlways: Boolean read FFullRedraw write FFullRedraw default False;
    property HotSpot: THotSpot read FHotSpotProp write SetHotSpotProp;

    property Gutter: TCMGutterOptions read FGutterOpts write SetGutterOpts;
    property PrintOptions: TCMPrintOptions read FPrintOptions write SetPrintOptions;

    property Options: TColorMemoOptions read GetOptions write SetOptions;
    property TabStopWidth: Integer read  FLastTabStopWidth write SetTabStopWidth;

    property OnChange;
    property OnVScroll: TNotifyEvent read FOnVScroll write FOnVScroll;
    property OnHScroll: TNotifyEvent read FOnHScroll write FOnHScroll;
    property OnHotSpotClick: THotSpotClickEvent read FOnHotSpotClick write FOnHotSpotClick;
    property OnHoverHotSpot: THotSpotEvent read FOnHoverHotSpot write FOnHoverHotSpot;
    property OnHotSpotExit: THotSpotEvent read FOnHotSpotExit write FOnHotSpotExit;
    property OnDraw: TDrawEvent read FOnDraw write FOnDraw;
    property OnDrawEx: TDrawExEvent read FOnDrawEx write FOnDrawEx;
    property OnDrawKey: TKeyDrawEvent read FOnKeyDraw write FOnKeyDraw;
    property OnDropFile: TDropFileEvent read FOnDropFile write FOnDropFile;
    property OnIsKeywordChar: TIsKeywordCharEvent read FOnIsKeywordChar write FOnIsKeywordChar;
    property OnContextPopup: TCMContextPopupEvent read FOnContextPopup write FOnContextPopup;
    property OnSelectionChange: TNotifyEvent read FOnSelectionChange write FOnSelectionChange;
  end;

{$R ColMemo.res}

implementation
uses Dialogs, ExtCtrls, Buttons;

type
  RetLValue = array[0..1] of Short;

 {resource identifier}
const HAND_CURSOR = 1077;


//---------------------------------------------------------------------------


function TKeyDescrList.AddNew: PKeyDescr;
begin
 if FValidItemsCount=Count then begin
  New(result);
  Add(Result);
 end;
 Inc(FValidItemsCount);
 Result := PKeyDescr(items[FValidItemsCount-1]);
 Result.FontSt := FColMemo.Font.Style; // default style
end;

constructor TKeyDescrList.Create(AMemo: TColorMemo);
begin
 inherited Create;
 FColMemo := AMemo;
end;

procedure TKeyDescrList.ParseMultilines;
 var i, c: integer;
begin
 c := ValidItemsCount;
 for i := 0 to c-1 do FColMemo.ParseMultilineKeyDescr(PKeyDescr(Items[i]));

end;

procedure TKeyDescrList.MarkPaintStart;
begin
 FPaintStart := ValidItemsCount;
end;



procedure TKeyDescrList.CalcMinMax;
 var i: integer;
     curr: PKeyDescr;
begin
 for i := 0 to FValidItemsCount-1 do begin
  curr := PKeyDescr(Items[i]);
 if ( FColMemo.MINLEFT < 0) or ( FColMemo.MINLEFT > curr.Left) then
     FColMemo.MINLEFT := curr.Left;

 if ( FColMemo.MAXRIGHT < 0) or ( FColMemo.MAXRIGHT < curr.Right) then
     FColMemo.MAXRIGHT := curr.Right;
 end;
end;

procedure TKeyDescrList.Reset;
begin
 FValidItemsCount := 0;
end;

destructor TKeyDescrList.Destroy;
var
  I: Integer;
begin
  For I := 0 to Count-1 do if Items[ I] <> nil then Dispose( PKeyDescr( Items[ I]));
  Inherited Destroy;
end;

 // one semi - colon (";") stands for separator; double-semicolon stands
 // for actual semicolon, so string "one;two;three;;;four" will be split
 // to 'one','two', 'three;','four'
 // lines will be placed to ADest list.
procedure BreakSemiColonLine(s: string; const ADest: TStringList);
 var one_sc_found: boolean;
     i: integer;
     tmp: string;

begin
 ADest.Clear;

 while s<>'' do begin
      tmp := '';
      one_sc_found := false;
      while not one_sc_found do begin
       i := Pos(';', s);

       if i=0 then begin
        tmp := tmp+s;
        one_sc_found := true;
        s := '';
       end else begin
        one_sc_found := (i=Length(s)) or (s[i+1]<>';');
        if i<>1 then begin
         tmp := tmp+Copy(s, 1, i-1);
         Delete(s, 1, i-1);
        end;

        if one_sc_found
         then delete(s, 1,1)
         else begin
          tmp := tmp +';';
          delete(s, 1,2);
         end;
       end;
      end;
      tmp := trim(tmp);
      if tmp<>'' then  ADest.Add(tmp);
 end;

end;


function ColorValue( const S: String): TColor;
var
  Red, Blue: LongInt;
  S1: String[ 10];
  J : Integer;
begin
  S1 := AnsiUpperCase( Trim( S));
  if Pos('CL', S1)=1 then Delete(S1, 1, 2); // convert all "clGreen"=>"Green"

  For J := 1 to 16 do
    if S1 = Colors[ J] then
    begin
      Result := ColorValues[ J];
      Exit;
    end;
  try
    J := Pos('#', S1);
    if J > 0 then Delete( S1, J, 1);
    J := Pos('$', S1);
    if J > 0 then Result := StrToInt( S1)
    else Result := StrToInt('$'+S1);
    Red := Result and $FF;
    Blue := Result and $FF0000;
    Result := ( Result and $00FF00) + (Red shl 16) + (Blue shr 16);
  except
    Result := clWhite;
  end;
end;

{ TDrawRules }

function TDrawRules.Add: TColorRule;
begin
  Result := TColorRule( inherited Add);
end;

constructor TDrawRules.Create( CLMM: TColorMemo);
begin
  inherited Create(TColorRule);
  FColorMemo := CLMM;
  FRUpdate := True;
end;

function TDrawRules.GetOwner;
begin
 Result := FColorMemo;
end;

procedure TDrawRules.UpdRules;
var
  I: Integer;
  B, B1: Boolean;
begin
  B := False;
  if FRUpdate then
    For I := 0 to Count - 1 do
    begin
      B1 := TColorRule( Items[ I]).UpdateKeyParams;
      B := B or B1;
    end;

  FRUpdate := not B;
end;

function TDrawRules.GetRule(Index: Integer): TColorRule;
begin
  Result := TColorRule( inherited Items[ index]);
end;

procedure TDrawRules.SetRule(Index: Integer; Value: TColorRule);
begin
  Items[Index].Assign( Value);
end;
procedure TDrawRules.WriteToParam;
 var i: integer;
     lPar: TCMParamList;
begin
 for i := 0 to count-1 do begin
   lPar := TCMParamList.Create;
   AParam.Add(lPar);
   Items[i].WriteToParam(lPar);
 end;
end;

procedure TDrawRules.ReadFromParam;
 var i: integer;
begin
 Clear;
 for i := 0 to AParam.Count-1 do
  Add.ReadFromParam(AParam.Items[i]);
 UpdateRules := true;
 CMemo.Refresh;
end;

procedure TDrawRules.SaveToFile;
 var f: TCMParamFile;
begin
 f := TCMParamFile.Create;
 WriteToParam(f.Parameters);
 f.SaveAs(AFileName);
 f.Free;
end;

procedure TDrawRules.LoadFromFile;
 var f: TCMParamFile;
begin
 f := TCMParamFile.Create;
 f.Load(AFileName);
 ReadFromParam(f.Parameters);

 f.Free;
end;


function TDrawRules.GetAttrCount: Integer;
begin
  Result := 4;
end;

// attributes in object inspector
// 0: name; 1: type; 2: enabled/disabled; 3: Z-Order
function TDrawRules.GetAttr(Index: Integer): String;
begin
 Result := '';
 case Index of
  0: Result := 'Name';
  1: Result := 'Type';
  2: Result := 'Enabled';
  3: Result := 'Z-Order';
 end;
end;


function TDrawRules.GetItemAttr(Index, ItemIndex: Integer): String;
 const lTypes: array[0..3] of string =
  ('dtKeyShow', 'dtEventDraw', 'dtBeginEnd', 'dtBeginLineEnd');
 const lBool: array[0..1] of string = ('False', 'True');
begin
 Result := '';
 case Index of
  0: begin
   Result := Items[ItemIndex].Name;
   if Result='' then Result := 'Unnamed';
  end;
  1: Result := lTypes[Ord(Items[ItemIndex].KeyDrawingType)];
  2: Result := lBool[Ord(Items[ItemIndex].Enabled)];
  3: Result := IntToStr(Items[ItemIndex].ZOrder);
 end;
end;

{ TColorRule }
constructor TColorRule.Create( Collection: TCollection);
begin
  FColorMemo := nil;
  if Assigned( Collection) and (Collection is TDrawRules) then
    FColorMemo := TDrawRules( Collection).CMemo;

  inherited Create( Collection);
  FKeyList := TStringList.Create;
  FKeywords := TCMStringList.Create;
  FKeyBegEnd := TCMStringList.Create;
  FKeyLineEnd := TCMStringList.Create;
  FResultList := TCMStringList.Create;
  FKeyMaxLines := 1;
  FIntChar := '';
  FZOrder := 0;
  KeyDrawingType := dtBeginEnd;
  KeyCase  := False;
  Enabled := True;
  PartWord := False;
  DefKeyColor := clRed;
  KeySelColor := clYellow;
  KeyBrushColor := clWindow;

  CaseBuf := nil;
  CaseBufLen := 0;


  FMaxBegEndDscr := 0;
  FBegEnd := TBegEndList.Create;
end;

destructor TColorRule.Destroy;
begin
  StrDispose( CaseBuf);
  FKeywords.Free;
  FKeyBegEnd.Free;
  FKeyLineEnd.Free;
  FBegEnd.Destroy;
  FResultList.Free;
  FKeyList.Free;
  inherited Destroy;
end;

// returns the string that is displayed in Collection Editor at desing time
function TColorRule.GetDisplayName;
begin
 // Key drawing type
 Result := '<Other type>';
 case FRuleType of
   dtKeyShow: Result := 'Key Show';
   dtEventDraw: Result := 'Event Draw';
   dtBeginEnd: Result := 'Begin - End';
   dtBeginLineEnd: Result := 'Begin - Line End';
 end;
end;


procedure TColorRule.AssignTo( Dest: TPersistent);
 var lDest: TColorRule;
begin
  if Dest is TColorRule then
  begin
   lDest := TColorRule(Dest);
   lDest.Name := Name;
   lDest.IsHotspot := IsHotspot;
   lDest.KeyDrawingType := KeyDrawingType;
   lDest.ZOrder := ZOrder;
   lDest.KeyMaxHeight := KeyMaxHeight;
   lDest.KeyCase := KeyCase;
   lDest.Enabled := Enabled;
   lDest.PartWord := PartWord;
   lDest.DefKeyColor := DefKeyColor;
   lDest.KeyBrushColor := KeyBrushColor;

   lDest.Underline := Underline;
   lDest.Bold := Bold;
   lDest.Italic := Italic;
   lDest.IgnoreOtherRules := IgnoreOtherRules;


   lDest.SetKeywords(Keywords);
   lDest.SetKeyLineEnd(KeyLineEndLst);
   lDest.SetKeyBegEnd(KeyBegEndLst);
  end
  else inherited AssignTo(Dest);
end;

 {used in TDrawRules.UpdRules }
function TColorRule.UpdateKeyParams: Boolean;
begin
  Result := FKeyBegEnd.Count > 0;
  KeyBegEndLst := FKeyBegEnd;
  if KeyDrawingType = dtKeyShow then
  begin
    Keywords := FKeywords;
    Result := Result or ( FKeywords.Count > 0);  // FFFFFFFFFFFFFFFFF
  end;
  if KeyDrawingType = dtBeginLineEnd then
  begin
    KeyLineEndLst := FKeyLineEnd;
    Result := Result or ( FKeyLineEnd.Count > 0);
  end;
end;

 // used in CalcColors for Keywords color rule
procedure TColorRule.CalcKeywordColors;

  var i, j, n: integer;
      p, pTo: PChar;
      lKeyDescr: PKeyDescr;
      curr: PChar;

begin
  if FKeyList.Count=0 then Exit;

  j := 0;

    if not KeyCase then
    begin
      I := StrLen( PFrom)+1;
      if I >= CaseBufLen then
      begin
        StrDispose( CaseBuf);
        CaseBufLen := I;
        CaseBuf := StrAlloc(CaseBufLen);
        StrLCopy(CaseBuf, PFrom, CaseBufLen-1);
      end
      else StrCopy( CaseBuf, PFrom);
      CharUpper( CaseBuf);
    end;

    if not KeyCase then pTo := CaseBuf
    else pTo := PFrom;

   pTo := StrEnd(pTo)-1; 


    While j<FKeyList.Count do
    begin
      if not KeyCase then P := CaseBuf
      else P := PFrom;


      curr := PChar(FKeyList[j]);

      P := StrPos( P, curr);
      if P <> nil then
        Repeat
          N := Length(FKeyList[j]);

          if PartWord or (not CMemo.IsKeywordChar((P-1)^) and
             not CMemo.IsKeywordChar((P+N)^)  ) then
          begin
           lKeyDescr := NewKeyDescr;

            if IsHotspot
             then lKeyDescr.ZOrder := CM_HOTSPOT_Z;


            if not KeyCase
             then lKeyDescr.Left := ( PFrom - EBUF) + ( P - casebuf)
             else lKeyDescr.Left := P - EBUF;
            lKeyDescr.Right := lkeyDescr.Left + Pred( N);

            if IsHotspot then FColorMemo.FHotKeywords.Add(lKeyDescr.Left, lKeyDescr.Right);

            lKeyDescr.KeyColor := integer(FKeyList.Objects[j]);
            lKeyDescr.DrawKey := True;
          end;
          P := P + N;
          P := StrPos( P, curr);
        until (P = nil) or (P>pTo);

      inc(j);
    end;

end;

procedure TColorRule.CalcBegEndColors;
 var i: integer;
     mh: integer;
begin
 mh := KeyMaxHeight;
 if KeyDrawingType=dtBeginLineEnd then mh := 0; // no checking is needed
 for i := 0 to FBegEnd.ValidItemsCount-1 do
  with PBeginEndDescr(FBegEnd.List[i])^ do
   CalcFullBegEnds(EBUF, PFrom, PCount, CBegin, CEnd, mh, DefKeyColor, BGColor, ACompleteBuff, AIncEnd);
end;

 // does full calculation of begin-end pairs
procedure TColorRule.CalcFullBegEnds;

  var lStarts, lEnds, lEndsMax, lTo: PChar;
      lKeyDescr: PKeyDescr;
      lLineCount: integer;
begin
 lTo := StrEnd(PFrom)-1; //PFrom+PCount-1; //last visible character


 if ACompleteBuff and FColorMemo.FCalcFullBegEnds
  then lStarts := EBUF
  else lStarts := PFrom;

 while (lStarts<>nil) do begin
  lStarts := StrPos(lStarts, ABeg);
  if (lStarts=nil) or (lStarts>lTo) then exit; // no need to process more


  lEnds := lStarts; Inc(lEnds);
  lEnds := StrPos(lEnds, AEnd);
  if lEnds=nil then lEnds := lTo;

  if lEnds>PFrom then begin

    // let's calc if a key is exceeding MaxHeight
    lEndsMax := lStarts;
    lLineCount := 0;
    if MaxLines>0 then begin
      while (lEndsMax<>nil) and
         (MaxLines>lLineCount) and // limit not exceded
         (lEndsMax<lEnds) do
      begin // still inside KeyDescr
        lEndsMax := StrPos(lEndsMax, #13#10#0);
        if (lEndsMax<>nil)  then
        begin
          Inc(lLineCount);
          if (lLineCount=MaxLines) and (lEndsMax<lEnds)
          then // key exceeds limit:
           lEnds := lEndsMax-1;
        end;
        if lEndsMax<>nil then Inc(lEndsMax);
      end;
    end;

    if lStarts<PFrom then lStarts := PFrom;
    if lStarts<=lEnds then begin
      // here we have begin-end pair that is in the visible area:
      // begin is before last character and end is after first.
      // calculating actual bounds
      lKeyDescr := NewKeyDescr;
      lKeyDescr.Left := lStarts-EBUF;
      lKeyDescr.Right := lEnds-EBUF-1;
      if AIncEnd then Inc(lKeyDescr.Right, StrLen(AEnd));
      lKeyDescr.KeyColor := ACol;
      lKeyDescr.BGColor := ABGCol;
      lKeyDescr.DrawKey := false;
    end;


  end; // if Ends>pFrom ...

  lStarts := lEnds+1;

 end;

end;



{
 This method is used to determine the coloring boundaries for "KeyDescrList"
 EBUF points to begining of editing buffer, and PFROM to first character it.
}
procedure TColorRule.CalcColors( EBUF, PFrom: PChar; PCount: Integer);
begin
  case KeyDrawingType of
   dtBeginLineEnd: CalcBegEndColors(EBUF, PFrom, PCount, false, false);
   dtBeginEnd: CalcBegEndColors(EBUF, PFrom, PCount, true, true);
   dtKeyShow: CalcKeywordColors(EBUF, PFrom, PCount);
  end;
end;

procedure TColorRule.SetKeyCase( Value: Boolean);
begin
  FKeyCase := Value;
end;


procedure TColorRule.ReadFromParam;
 var typ: string;
begin
  typ := UpperCase(Aparam.ReadIdentifier('KeyDrawingType', 'dtBeginEnd'));
  if typ = 'DTKEYSHOW' then KeyDrawingType := dtKeyShow
  else if typ = 'DTEVENTDRAW' then KeyDrawingType := dtEventDraw
  else if typ = 'DTBEGINEND' then KeyDrawingType := dtBeginEnd
  else if typ = 'DTBEGINLINEEND' then KeyDrawingType := dtBeginLineEnd;

  Name := Aparam.ReadString('Name', Name);
  ZOrder := Aparam.ReadInteger('ZOrder', ZOrder);
  KeyMaxHeight := Aparam.ReadInteger('MaxHeight', KeyMaxHeight);
  DefKeyColor := Aparam.ReadInteger('DefKeyColor', DefKeyColor);
  KeySelColor := Aparam.ReadInteger('KeySelColor', KeySelColor);
  KeyBrushColor := Aparam.ReadInteger('KeyBrushColor', KeyBrushColor);
  Keywords.Text := Aparam.ReadString('Keywords', Keywords.Text);
  KeyBegEndLst.Text := Aparam.ReadString('KeyBegEndLst', KeyBegEndLst.Text);
  KeyLineEndLst.Text := Aparam.ReadString('KeyLineEndLst', KeyLineEndLst.Text);
  Enabled := Aparam.ReadBool('Enabled', Enabled);
  KeyCase := Aparam.ReadBool('KeyCase', KeyCase);
  PartWord := Aparam.ReadBool('PartWord', PartWord);

  Bold := Aparam.ReadBool('Bold', Bold);
  Italic := Aparam.ReadBool('Italic', Italic);
  Underline := Aparam.ReadBool('Underline', Underline);
  IgnoreOtherRules := Aparam.ReadBool('Ignore', Underline);
end;

 // writes only those properties that seem to be changed since create
procedure TColorRule.WriteToParam;
begin
   case KeyDrawingType of
     dtKeyShow: Aparam.WriteIdentifier('KeyDrawingType', 'dtKeyShow');
     dtEventDraw: Aparam.WriteIdentifier('KeyDrawingType', 'dtEventDraw');
     dtBeginEnd: Aparam.WriteIdentifier('KeyDrawingType', 'dtBeginEnd');
     dtBeginLineEnd: Aparam.WriteIdentifier('KeyDrawingType', 'dtBeginLineEnd');
   end;

   if Name<>'' then AParam.WriteString('Name', Name);
   if ZOrder<>0 then Aparam.WriteInteger('ZOrder', ZOrder);
   if FKeyMaxLines<>1 then Aparam.WriteInteger('MaxHeight', KeyMaxHeight);
   if DefKeyColor<>clRed then Aparam.WriteInteger('DefKeyColor', DefKeyColor);
   if KeySelColor<>clYellow then
     Aparam.WriteInteger('KeySelColor', KeySelColor);
   if KeyBrushColor<>clWindow then
     Aparam.WriteInteger('KeyBrushColor', KeyBrushColor);
   if Keywords.Text<>'' then Aparam.WriteString('Keywords', Keywords.Text);
   if KeyBegEndLst.Text<>'' then
     Aparam.WriteString('KeyBegEndLst', KeyBegEndLst.Text);
   if KeyLineEndLst.Text<>'' then
     Aparam.WriteString('KeyLineEndLst', KeyLineEndLst.Text);
   if not Enabled then Aparam.WriteBool('Enabled', Enabled);
   if KeyCase then Aparam.WriteBool('KeyCase', KeyCase);
   if PartWord then Aparam.WriteBool('PartWord', PartWord);

   if Bold then Aparam.WriteBool('Bold', Bold);
   if Italic then Aparam.WriteBool('Italic', Italic);
   if Underline then Aparam.WriteBool('Underline', Underline);
   if IgnoreOtherRules then Aparam.WriteBool('Ignore', IgnoreOtherRules);
end;


// Moves the description of dtBeginLineEnd type from FKeyLineEnd
// to BEGEND. Improves coloring speed
procedure TColorRule.SetKeyLineEnd( Value: TCMStringList);
var
  I: Integer;
  lBe: PBeginEndDescr;
begin
  FBegEnd.Reset;
  For I := 0 to Value.Count-1 do
  begin
    BreakSemiColonLine(Value[i], FResultList);
    if FResultList.Count=0 then Continue;
    lBe := FBegEnd.AddNew;

    StrPLCopy( lbe.CBegin, FResultList[0], BEG_END_SZ);

    lbe.CEnd := #13#10#0;
    lbe.BGColor := KeyBrushColor;

    if FResultList.Count<2
     then lbe.KeyColor := DefKeyColor
     else lbe.KeyColor := ColorValue (FResultList[1]);
  end;

  if Value <> FKeyLineEnd then FKeyLineEnd.Assign( Value);
end;

// Moves description of dtBeginEnd type from FKeybegEnd to
// array BEGEND. This transformation is needed to improve
// the speed of coloring, especialy on boundaries.
procedure TColorRule.SetKeyBegEnd( Value: TCMStringList);
 var i: integer;
  lBe: PBeginEndDescr;
begin
  FBegEnd.Reset;

  For I := 0 to Value.Count-1 do
  begin
    BreakSemiColonLine(Value[i], FResultList);
    if FResultList.Count<2 then Continue;
    lBe := FBegEnd.AddNew;

    StrPLCopy( lBe.CBegin, FResultList[0], BEG_END_SZ);
    StrPLCopy( lBe.CEnd, FResultList[1], BEG_END_SZ);

    lBe.BGColor := KeyBrushColor;
    if FResultList.Count<=2
     then lBe.KeyColor := DefKeyColor
     else lBe.KeyColor := ColorValue( FResultList[2]);
  end;

  if Value <> FKeyBegEnd then FKeyBegEnd.Assign( Value);
end;

procedure TColorRule.SetKeywords( Value: TCMStringList);
var k: Integer;
begin
 if FKeywords<>value then FKeywords.Assign(Value);

 FKeyList.Clear;
  For K := 0 to Keywords.Count-1 do
  begin
    BreakSemiColonLine(Keywords[k], FResultList);
    if FResultList.Count=0 then Continue;

    if KeyCase
     then  FKeyList.Add(FResultList[0])
     else  FKeyList.Add(AnsiUpperCase( FResultList[0]));

    if FResultList.Count>1
     then FKeyList.Objects[k] := TObject(ColorValue (FResultList[1]))
     else FKeyList.Objects[k] := TObject(DefKeyColor);

  end;
end;




 // creates new key and assigns color rule default values
function TColorRule.NewKeyDescr: PKeyDescr;
begin
 Result := FColorMemo.NewKeyDescr;
 Result.BGColor := FKeyBrushColor;
 Result.KeyColor := FKeyDefColor;
 Result.ZOrder := ZOrder;
 Result.IgnoreOthers := FIgnoreOtherRules;

 if Bold then Result.FontSt := Result.FontSt+[fsBold];
 if Italic then Result.FontSt := Result.FontSt+[fsItalic];
 if Underline then Result.FontSt := Result.FontSt+[fsUnderline];


end;

{ THotSpot }
constructor THotSpot.Create;
begin
  inherited Create;
  FHSBegChar := #30;
  FHSEndChar := #31;
  FHotSpotColor := clBlue;
  FHotSpotMarkerColor := clWindow;
  FHotSpotActive := False;
  FHotSpotUnderlined := True;
end;

procedure THotSpot.AssignTo( Dest: TPersistent);
 var lDest: THotSpot;
begin
  if Dest is THotSpot then
  begin
    lDest := THotSpot(Dest);
    lDest.FHSBegChar := FHSBegChar;
    lDest.FHSEndChar := FHSEndChar;
    lDest.FHotSpotColor := FHotSpotColor;
    lDest.FHotSpotMarkerColor := FHotSpotMarkerColor;
    lDest.FHotSpotActive := FHotSpotActive;
    lDest.FHotSpotUnderlined := FHotSpotUnderlined;
  end
  else inherited AssignTo (Dest);
end;


{ EMemoLost }

constructor EMemoLost.Create;
begin
  inherited Create('Owner of bookmark is destroyed.');
end;

{ TMemoMark }

constructor TMemoMark.Create;
begin
  inherited Create;
  FStartPos := 0;
  FEndPos := 0;
  FMemo := nil;
end;

{ if memo's still assigned, need to call DeleteMark before free }
destructor TMemoMark.Destroy;
begin
  if FMemo<>nil then FMemo.DeleteMark(self);
  inherited Destroy;
end;

procedure TMemoMark.ShowMark;
begin
  if FMemo<>nil then begin
    FMemo.SelStart := StartPos;
    FMemo.SelLength := EndPos - StartPos;
  end else
    raise EMemoLost.Create;
end;

function TMemoMark.GetLength: Integer;
begin
  result := EndPos-StartPos;
end;

function TMemoMark.GetStartLine: integer;
begin
  if FMemo<>nil then
    result := FMemo.Perform(EM_LINEFROMCHAR, StartPos, 0)
  else
    raise EMemoLost.Create;
end;

function TMemoMark.GetEndLine: Integer;
begin
  if FMemo<>nil then
    result := FMemo.Perform(EM_LINEFROMCHAR, EndPos, 0)
  else
    raise EMemoLost.Create;
end;

function TMemoMark.GetText: string;
begin
  if FMemo<>nil then
    result := copy(FMemo.text, StartPos, EndPos)
  else
    raise EMemoLost.Create;
end;


{ TPrintOptions }

procedure TCMPrintOptions.AssignTo(Dest: TPersistent);
 var d: TCMPrintOptions;
begin
  if Dest is TCMPrintOptions then begin
    d := TCMPrintOptions(Dest);
    d.FMargins.Assign(Margins);
    d.FHeader := FHeader;
    d.FFooter := FFooter;
    d.FHeaderAlignment := FHeaderAlignment;
    d.FFooterAlignment := FFooterAlignment;
  end else inherited;
end;

constructor TCMPrintOptions.Create;
begin
 inherited;
 FMargins := TCMPrintMargins.Create;
 FMargins.Left := 100;
 FMargins.Top := 100;
 FMargins.Right := 100;
 FMargins.Bottom := 100;

 FHeaderAlignment := taCenter;
 FFooterAlignment := taCenter;
end;

{ TColorMemo }

constructor TColorMemo.Create(AOwner:TComponent);
var pOSV: tOSVERSIONINFO;
begin
  inherited;
  {$ifDef CMDEMO}
  MessageDlg( 'Application contains unregistered ColorMemo component for Delphi'#13#10+
              '© 1997 - 2002 Baltic Solutions'#13#10#13#10+
              'E-mail: office@balticsolutions.com'#13#10+
              'Lithuania', mtInformation, [mbOk], 0);
  {$Endif}

  FCurrBuffLen :=  0;
  FCurrBuff := nil;
  FTextRgn := CreateRectRgn(0,0,1,1); // creating handle to the region
  FLastTabStopWidth := 32; // the default editor value

  FAllowCutCopy := true;
  FHotKeywords := TcmHotKeywordList.Create(Self);
  FGutterOpts := TCMGutterOptions.Create(Self);
  FPrintOptions := TCMPrintOptions.Create;


  Parent := TWinControl( AOwner);
  FRules := TDrawRules.Create( Self );
  FHotSpotProp := THotSpot.Create;

  CLAR := nil;
  CLAR_SIZ := 0;

  FCanvas := TControlCanvas.Create;
  TControlCanvas(FCanvas).Control := Self;
  FMaxLines := 0;
  FMemLnCnt := 0;
  FMemChCnt := 0;
  RedrawAlways := False;

  pOSV.dwOSVersionInfoSize := SizeOf( tOSVERSIONINFO);
  if GetVersionEx( pOSV) then
    VER95 := pOSV.dwMajorVersion >= 4
  else
    VER95 := False;



  FKeyDescr := TKeyDescrList.Create(Self);


  FCreated := True;
  FMemoMarks := TList.Create;
  DragLineX := -1;
  DragLineY := -1;
  LineDC := 0;
  FDragText := TRUE;
end;



destructor TColorMemo.Destroy;
var i: integer;
begin
  StrDispose(FCurrBuff);
  FCurrBuffLen := 0;
  FCanvas.Free;
  if Assigned( FHotSpotProp) then FHotSpotProp.Free;
  if Assigned( FRules) then FRules.Free;
  FKeyDescr.Free;
  if Assigned( CLAR) then FreeMem( CLAR, CLAR_SIZ);

  for i := 0 to FMemoMarks.Count-1 do
    TMemoMark(FMemoMarks.Items[i]).FMemo := nil;
  FMemoMarks.free;

  FGutterOpts.Free;
  FPrintOptions.Free;
  FHotKeywords.Free;

  DeleteObject(FTextRgn);

  inherited Destroy;
end;


procedure TColorMemo.CMCtl3DChanged(var Message: TMessage);
begin
  inherited;
  AdjustTextArea;
end;

procedure TColorMemo.KeyDown( var Key: Word; Shift: TShiftState);
var
  I: Integer;
begin
  inherited;

  if ( SelLength > 0) and ( Shift = []) and
     ( Key in [VK_RIGHT, VK_LEFT, VK_DOWN, VK_UP, VK_END, VK_HOME, VK_PRIOR, VK_NEXT]) then
  begin
    I := SelStart + SelLength;
    SelLength := 0;
    SelStart := I;
    PaintColors( Self, false);
  end;

end;

procedure TColorMemo.KeyUp( var Key: Word; Shift: TShiftState);
begin
  if ( SelLength > 0) and ( Shift = []) and ( Key = VK_SHIFT)
   then PaintColors( Self, False);

  inherited;
end;

procedure TColorMemo.MouseDown( Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  if ( Shift = [ssLeft]) and ( Button = mbLeft) then PaintColors( Self, False);
  inherited;

  if Cursor = HandCursor then
   if Assigned( FOnHotSpotClick)
    then OnHotSpotClick( Self, PointToHotSpot(X,Y), Button, Shift);
end;

procedure TColorMemo.MouseUp( Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  if Button = mbLeft then PaintColors( Self, False);

  inherited;
end;

procedure TColorMemo.MouseMove( Shift: TShiftState; X, Y: Integer);
var currSpot: String;
begin
  if HotSpot.Active then
  begin
   currSpot := PointToHotSpot(x,y);

   //  test if focus changed
   if (currSpot<>FLastSpot) then begin // hover changed
    // change cursor
    if (currSpot='') then Cursor := Fcursor  else Cursor := HandCursor;

    // fire events
    if  (FLastSpot<>'') and Assigned(OnHotSpotExit) then OnHotSpotExit(Self, FLastSpot);
    if  (currSpot<>'') and Assigned(FOnHoverHotSpot) then FOnHoverHotSpot(Self, currSpot);
   end;

   FLastSpot := currSpot;
 end;

  inherited;
end;

procedure TColorMemo.Change;
var
  I: Integer;
begin
  inherited Change;
  if ( csLoading in ComponentState) or
     ( csDesigning in ComponentState) or
     ( csReading in ComponentState) then Exit;

  if RedrawAlways then
  begin
    Refresh;
    Exit;
  end;

  I := Length( Lines[Pred( Lines.Count)]) +
       SendMessage(Handle, EM_LINEINDEX, Pred( Lines.Count), 0);

  PaintColors( Self, ( Lines.Count = FMemLnCnt) and ( FMemChCnt + 1 = I));

  FMemLnCnt := Lines.Count;  // ERRORERROR
  FMemChCnt := I;
end;

procedure TColorMemo.WMPaint( var Message: TWMPaint);
begin
  PaintHandler( Message);
  PaintGutter;
end;

procedure TColorMemo.PaintWindow(DC: HDC);
begin
  inherited PaintWindow( DC);

  FCanvas.Handle := DC;
  // Aufruf ERRORERROR
  try
    PaintColors( Self, False);
  finally
    FCanvas.Handle := 0;
  end;
end;


procedure TColorMemo.CalcHotSpots( EBUF, PFrom: PChar; PCount: Integer);
 var curr: PChar;
     lStart, lEnd: PChar;
     lStartPos, lEndPos: integer;
     lNew: PKeyDescr;
     i: integer;
     lPText: PChar;
     HSB : array[ 0..1] of Char; // begins with
     HSE : array[ 0..1] of Char; // ends with

begin
 lPText := FCurrBuff;
 if not HotSpot.Active then Exit;
 if (HotSpot.BeginChar = #0) or
     (HotSpot.EndChar = #0) then Exit;

 HSB[0] := HotSpot.BeginChar;
 HSB[1] := #0;
 HSE[0] := HotSpot.EndChar;
 HSE[1] := #0;
 curr := PFrom;

 while (curr<>nil) and (curr-PFrom<PCount) do begin
   lStart := StrPos(curr, HSB);
   lEnd := StrPos(curr, HSE);

   if (lStart<>nil) and (lEnd<>nil) and (lEnd>lStart) then begin
    // full hotspot found
    lStartPos := lStart-lPText;
    lEndPos := lEnd-lPText;
    FHotKeywords.Add(lStartPos+1, lEndPos-1);

    for i := 0 to 2 do begin
      lNew := NewKeyDescr;

      lNew.DrawKey := false;
      lNew.KeyColor := HotSpot.MarkerColor;
      lNew.BGColor := FRules.CMemo.Color;
      if i=1
       then lNew.ZOrder := CM_HOTSPOT_Z
       else lNew.ZOrder := CM_HOTSPOT_CHAR_Z;

      case i of
       0: begin
           lNew.Left := lStartPos;
           lNew.Right := lStartPos;
          end;
       1: begin
           lNew.Left := lStartPos+1;
           lNew.Right := lEndPos-1;
           lNew.KeyColor := HotSpot.Color;
           ParseMultilineKeyDescr(lNew);
          end;
       2: begin
           lNew.Left := lEndPos;
           lNew.Right := lEndPos;
          end;
       end; // case
    end; // for 0-2

   end;

   if lEnd<>nil
    then curr := lEnd+1
    else curr := nil;
 end;

end;

procedure TColorMemo.PaintColors( Sender: TObject; CurrLine: Boolean);
type
  TColArr = record
    key: PKeyDescr;
    Active : boolean;
  end;


  TCLAR = Array[0..32000] of TColArr;

var
  I,K,M,N,I1  : Integer;
  LL          : Integer;
  KeyON       : Boolean;
  TMRec       : tTextMetric;
  P: PChar;
  IND, PRI: Integer;
  KDL   : PKeyDescr;

  lBuffEnd: PChar;
  lTxtLen: integer;
  lLastKey: PKeyDescr;
  lIsSelection: boolean;
  lSelStart, lSelLen     : Integer;
  lNeedClarSiz: integer; // needed CLAR size
  lIgnoring: boolean;
begin
  if not VER95 then Exit;
  if not Enabled then Exit;
  if not Visible then Exit;
  if not Assigned( Parent) then Exit;
  // test if there's a need to do painting.
  if ( ColorRules.Count=0) and not Assigned(FOnDrawEx) and  not HotSpot.Active then Exit;

  GetTextMetrics( Canvas.Handle, TMRec);
  lSelStart := SelStart;
  lSelLen := SelLength;
  HideCaret( Handle);
  FHotKeywords.Clear;

  With Canvas do
    begin
      Font := Self.Font;
      Font.Color := Self.Color;
      Brush.Color := Self.Color;
    end;

 ColorRules.UpdRules;

 lTxtLen := GetTextLen;
 // get text into buffer
 if lTxtLen>=FCurrBuffLen-2 then
 begin
  try
    StrDispose(FCurrBuff);  // ERRORERRORERRORERROR
  finally
  end;

  while FCurrBuffLen<lTxtLen do Inc(FCurrBuffLen, 1024);
  FCurrBuff := StrAlloc( FCurrBuffLen);
 end;
 lTxtLen := SendMessage( Handle, WM_GETTEXT, lTxtLen+1, LongInt( FCurrBuff))+1;


    P := FCurrBuff;

    if CurrLine
      then N := GetCurrentLine
      else N := GetTopLine;
    M := Lines.Count - N;

    IND := N;

// Determines where starts/ends the visible part of editing buffer
    if IND < 0 then IND := 0;
    LL := SendMessage( Self.Handle, EM_LINEINDEX, IND, 0);
    Inc( P, LL);

    KeyON := True;
    For I := N to Pred( M + N) do
    begin
      LL := SendMessage( Self.Handle, EM_LINEINDEX, I, 0);
      M := SendMessage( Self.Handle, EM_POSFROMCHAR, LL, 0);
      if ( RetLValue( M)[1] < 0) or ( RetLValue( M)[1] + TMRec.tmHeight >= FTextArea.Bottom) then
      begin
        KeyON := False;
        Break;
      end;
    end;
    if KeyON then LL := LL + SendMessage( Self.Handle, EM_LINELENGTH, LL, 0);
// End
  if ll>lTxtLen-1 then LL := lTxtLen-1;
  lBuffEnd := FCurrBuff + LL;
  lBuffEnd^ := #0;



  FKeyDescr.Reset;
    // need to add one key that will hide any coloring from cursor till start of line
    // sometimes, when keyword is lost (let's say, some letters were added to it
    // which made it no longer keyword), it's colored part from line start till
    // cursor will not dissapear unless we hide it.
    KDL := NewKeyDescr;
    KDL.KeyColor := Font.Color;
    KDL.BGColor := Color;
    KDL.ZOrder := 0;
    KDL.DrawKey := false;
    KDL.FontSt := Font.Style;
    KDL.IgnoreOthers := false;
    KDL.Left := lSelStart;
    while (KDL.Left>0) and (FCurrBuff[KDL.Left-1]<>#10)
     do Dec(KDL.Left);
    KDL.Right := lSelStart-1;
    if KDL.Right<KDL.Left then FKeyDescr.Reset;

    CalcHotSpots(FCurrBuff, P, LL);

    For I := 0 to Pred( ColorRules.Count) do if ColorRules.Items[ I].Enabled then
      ColorRules.Items[ I].CalcColors( FCurrBuff, P, LL);

    if Assigned(FOnDrawEx) then FOnDrawEx(Self, FCurrBuff, P, LL);

 if FKeyDescr.ValidItemsCount>0 then
 begin
// calculate MINLEFT and MAXRIGHT
    MINLEFT := -1;
    MAXRIGHT := -1;
    FKeyDescr.CalcMinMax;

    FKeyDescr.ParseMultilines;

// According to Z-Order manages the areas that need to be colored
// and are overlaping each other
    lNeedClarSiz := (MAXRIGHT - MINLEFT + 3) * SizeOf(TColArr);
    if ( MINLEFT >= 0) and ( MAXRIGHT >= MINLEFT) and
       ( CLAR_SIZ < lNeedClarSiz) then
    begin
      if Assigned( CLAR) then FreeMem( CLAR, CLAR_SIZ);
      CLAR_SIZ := lNeedClarSiz;
      GetMem( CLAR, CLAR_SIZ);
    end;

    PRI := 0;

    FillChar( CLAR^, lNeedClarSiz, 0); // this should be enough

    While PRI < FKeyDescr.ValidItemsCount do
   // According to coloring intervals and Z-Orders compiles
   // the colors in memory - "CLAR" array
    begin
      KDL := PKeyDescr( FKeyDescr.List[ PRI]);
      if KDL^.Left = MaxInt then
      begin
        Inc( PRI);
        Continue;
      end;

      // finding out if key ignores others
      I1 := KDL.Left-MINLEFT;
      lIgnoring := KDL.IgnoreOthers and            // should ignore
                   ( not TCLAR(CLAR^)[I1].Active   // there's no other key
                     or
                     not TCLAR( CLAR^)[I1].key.IgnoreOthers); // there is a key, but it is not ignoring others.

      if KDL^.Right < MaxInt then
      For I := KDL^.Left to KDL^.Right do
      begin
        I1 := I - MINLEFT;
        if  (I1>=0)and(I1<CLAR_SIZ) and // I1 somehow gets negative on large files
         {$IFNDEF CM_DT} (FCurrBuff[MINLEFT+i1]<>#9) and {$ENDIF} //todo: this hack prevents from drawing tab characters , but also supresses background drawing (not necessary when DrawText is used)  
         (lIgnoring or not TCLAR(CLAR^)[i1].Active or (KDL^.ZOrder >= TCLAR( CLAR^)[I1].key.ZOrder))
          then
          begin
            TCLAR(CLAR^)[i1].key := KDL;
            TCLAR(CLAR^)[i1].Active := True;
          end;

      end;
      Inc( PRI);
    end; // while

    if ( MINLEFT >= 0) and ( MAXRIGHT >= MINLEFT) then
    // returns coloring intervals according with Z-Order taken in mind
    begin
      K := 0;
      I := 0;

      FKeyDescr.MarkPaintStart;

      lLastKey := nil;
      lIsSelection := lSelLen<>0;

      While I <= MAXRIGHT - MINLEFT + 1 do
      begin
        if (lLastKey<>TCLAR(CLAR^)[I].key) or
           (lIsSelection and ((i+MINLEFT=lSelStart)or (i+MINLEFT=lSelStart+lSelLen)))
          then
        begin
          if lLastKey<>nil then
          begin
            KDL := NewKeyDescr;

            KDL^ := lLastKey^;
            if (i-1>=lSelStart-MINLEFT) and (i<=lSelStart+lSelLen-MINLEFT)
               and (Focused or not HideSelection)
             then KDL.BGColor := clHighlight;


            KDL^.Right := Pred( I) + MINLEFT;
            KDL^.Left := K + MINLEFT;
          end;

          K := I;
          if TCLAR( CLAR^)[I].Active
           then lLastKey := TCLAR( CLAR^)[I].key
           else lLastKey := nil;
        end;

        Inc( I);
      end;

    end;


  //now all items in FKeyDescr list are
  // each in single-line, and split according to Z-buffer.
  // let's draw them.
  PaintKeyDescr;

 end; // valid items count>0

 
  ShowCaret( Handle);
end;

 // draw contents of KeyDescr onto ColMemo.
procedure TColorMemo.PaintKeyDescr;
 var oldFS, newFS: TFontStyles;
     i: integer;
     lCurr: PKeyDescr;
     pos: RetLValue;
     lRect: TRect;
     lStr: string;
     lSiz: TSize;

begin
  i := FKeyDescr.PaintStart;
  oldFS := Canvas.Font.Style;

  {$IFDEF CM_DT}
  with FTextArea do IntersectClipRect(Canvas.Handle, Left, Top, Right, Bottom);
  {$ENDIF}

  while i<FKeyDescr.ValidItemsCount do 
  begin
    lCurr := PKeyDescr(FKeyDescr.List[i]);
    if lCurr.Left<=lCurr.Right then 
    begin
      pos := RetLValue(SendMessage( Self.Handle, EM_POSFROMCHAR, lCurr.Left, 0));

      Canvas.Brush.Color := lCurr.BGColor;
      Canvas.Font.Color := lCurr.KeyColor;

      // preparing font style
      newFS := lCurr.FontSt;
      if (lCurr.ZOrder= CM_HOTSPOT_Z) and HotSpot.Underlined and HotSpot.Active
       then newFS := newFS+[fsUnderline];

      Canvas.Font.Style := newFS;

      if lCurr.DrawKey and Assigned(OnDrawKey) then 
      begin
       SetLength(lStr, lCurr.Right-lCurr.Left+1);
       StrLCopy(PChar(lStr), FCurrBuff+lCurr.Left, Length(lStr));

       // the rectangle calculated here is invalid;
       // but, if valid rectangle returned by CalcTextRect will be provided,
       //  X coordinate of text will be unknown if text is scrolled  horizontaly
       //CalcTextRect(Canvas.Handle, pos[0], pos[1], FCurrBuff+lCurr.Left, lCurr.Right-lCurr.Left+1, @lRect);
       lSiz := Canvas.TextExtent(lStr);
       lRect := Rect(pos[0], pos[1], pos[0]+lSiz.cx, pos[1]+lSiz.cy);
       FOnKeyDraw(Canvas, lStr, lRect, lCurr.KeyColor);
      end 
      else 
      begin
       TextOutEx(pos[0],pos[1], FCurrBuff+lCurr.Left, lCurr.Right-lCurr.Left+1);
      end;
   end; // lcurr.left


   Inc(i);
  end;

 Canvas.Font.Color := Self.Color;
 Canvas.Brush.Color := Self.Color;
 Canvas.Font.Style := oldFS;
end;


procedure TColorMemo.WMHScroll( var Msg: TWMHScroll);
begin
  if Assigned(FOnHScroll) then FOnHScroll(Self);
  inherited;
  PaintColors( Self, False);
end;

procedure TColorMemo.WMVScroll (var Msg: TWMVScroll);
begin
  if Assigned(FOnVScroll) then FOnVScroll(Self);
  inherited;
  PaintColors( Self, False);
end;

procedure TColorMemo.WMSize(var Msg: TWMSize);
begin
  FMaxLines := 0;
  inherited;
end;

function TColorMemo.GetCurrentLine: Integer;
begin
  FCurLine := SendMessage( Handle, EM_LINEFROMCHAR, SelStart, 0);
  Result := FCurLine;
end;

function TColorMemo.GetCurrentPosition: Integer;
begin
  FCurPosn := SelStart - SendMessage(Handle, EM_LINEINDEX,
             ( SendMessage(Handle, EM_LINEFROMCHAR, SelStart, 0)), 0);
  Result := FCurPosn;
end;

function TColorMemo.GetTopLine: Integer;
begin
  FCurTop := SendMessage(Handle, EM_GETFIRSTVISIBLELINE, 0, 0);
  Result := FCurTop;
end;

procedure TColorMemo.GetMaxLines;
var
  CM_TMP: TMemo;
  MaxPossible: Integer;
begin
  FMaxLines := 0;
  MaxPossible := Height div (-Font.Height);
  if MaxPossible = 0 then Exit;
  CM_TMP := nil;

  try
    CM_TMP := TMemo.Create(Self);
    CM_TMP.Parent := Self;
    CM_TMP.Left := Left;
    CM_TMP.Top := Top;
    CM_TMP.Height := Height;
    CM_TMP.Width := Width;
    CM_TMP.ScrollBars := ScrollBars;
    CM_TMP.Font := Font;
    CM_TMP.Show;
    CM_TMP.SendToBack;

    While SendMessage( CM_TMP.Handle, EM_GETFIRSTVISIBLELINE, 0, 0) = 0 do
    begin
      if FMaxLines > MaxPossible then
      begin
        FMaxLines := 0;
        Break;
      end;
      CM_TMP.Lines.Add('');
      Inc( FMaxLines);
    end;

  finally
    CM_TMP.Free;
  end;

end;

function TColorMemo.GetLinesVisible: Integer;
var
  I, LL, M: Integer;
begin
  Result := 0;
  if Height div (-Font.Height) = 0 then Exit;
  For I := GetTopLine to Pred( GetTopLine + Lines.Count) do
  begin
    LL := SendMessage( Self.Handle, EM_LINEINDEX, I, 0);
    M := SendMessage( Self.Handle, EM_POSFROMCHAR, LL, 0);
    if RetLValue( M)[1] - Font.Height >= ClientRect.Bottom then Break;

    Inc( Result);
  end;
end;

function TColorMemo.GetMaxLinesVisible: Integer;
begin
  if Visible then
  begin
    if FMaxLines = 0 then GetMaxLines;
    Result := FMaxLines;
  end
  else Result := 0;
end;

procedure TColorMemo.SetRules( Value: TDrawRules);
begin
  FRules.Assign( Value);
end;


procedure TColorMemo.SetHotSpotProp( Value: THotSpot);
begin
  FHotSpotProp.Assign( Value);
end;

procedure TColorMemo.SetCurrentLine( Value: Integer);
begin
  FCurLine := Value;
  if FCurLine < 0 then FCurLine := 0;
  if FCurLine > Lines.Count - 1 then FCurLine := Lines.Count - 1;

  SelLength := 0;
  SelStart := SendMessage(Handle, EM_LINEINDEX, FCurLine, 0);
end;

procedure TColorMemo.SetCurrentPosition( Value: Integer);
begin
  FCurPosn := Value;
  if FCurPosn < 0 then FCurPosn := 0;
  if ( FCurPosn > Length(Lines[ FCurLine])) then FCurPosn := Length(Lines[FCurLine]);

  SelLength := 0;
  SelStart := SendMessage(Handle, EM_LINEINDEX, FCurLine, 0) + FCurPosn;
end;

procedure TColorMemo.ScrollBy( X: Integer; Y: Integer);
begin
  SendMessage(Handle, EM_LINESCROLL, 0, ( LongInt(X) shl 16) + Y);
end;

procedure TColorMemo.SetAcceptFiles(const Value: boolean);
begin
  if FAcceptFiles = Value then exit;
  FAcceptFiles := Value;
  DragAcceptFiles(handle, Value);
end;

procedure TColorMemo.WMDropFiles(var Message: TWMDropFiles);
var lFileName: array[0..MAX_PATH] of Char;
    i, file_count: integer;
begin
  try
    // get file count
    file_count := DragQueryFile(Message.Drop, $FFFFFFFF, lFileName, MAX_PATH);
    // fire an event for every dropped file
    for i := 0 to file_count-1 do
      if DragQueryFile(Message.Drop, i, lFileName, MAX_PATH) > 0
       then if assigned(FOnDropFile) then FOnDropFile(Self, lFileName);

    Message.Result := 0;
  finally
    DragFinish(Message.Drop);
  end;
end;

procedure TColorMemo.CreateWindowHandle(const Params: TCreateParams);
begin
  inherited CreateWindowHandle(Params);
  FCreated := true;
end;

procedure TColorMemo.AssignTo( Dest: TPersistent);
 var lDest: TColorMemo;
begin
  if (Dest is TColorMemo) then begin
    lDest := TColorMemo(Dest);
    lDest.Lines.Assign(Lines);
    lDest.Color := Color;
    lDest.Font.Assign(Font);
    lDest.HideSelection := HideSelection;
    lDest.ColorRules := ColorRules;
  end else inherited AssignTo(Dest);
end;

{ creates and returns new MemoMark for current pos in memo }
function TColorMemo.GetMark: TMemoMark;
begin
  Result := TMemoMark.Create;
  Result.FMemo := self;
  Result.StartPos := SelStart;
  Result.EndPos := SelStart + SelLength;
  FMemoMarks.Add(Result);
end;


{ goes through all marks and updates their StartPos and Length
 taking into account old and new cursor pos and text length,
  i.e. makes sure, that all marks show to the right place.
 If the line was deleted the corresp. mark.FMemo is set to nil; }
procedure TColorMemo.UpdateBookmarks;
var i: integer;
begin
  if FLengthDiff=0 then exit;
  for i := 0 to FMemoMarks.Count-1 do
    with TMemoMark(FMemoMarks.Items[i]) do begin
      if (FLengthDiff>0) then
        if (FOldCursorPos<StartPos) then
          StartPos  := StartPos + FLengthDiff
        else
      else
        if (StartPos>FOldCursorPos) then
          if (StartPos<=FOldCursorPos-FLengthDiff) then
            StartPos :=  FOldCursorPos + FPosDiff
          else
            StartPos := StartPos + FLengthDiff;
      { the same with EndPos }
      if (FLengthDiff>0) then
        if (FOldCursorPos<EndPos) then
          EndPos  := EndPos + FLengthDiff
        else
      else
        if EndPos>FOldCursorPos then
          if (EndPos<FOldCursorPos-FLengthDiff) then
            EndPos :=  FOldCursorPos + FPosDiff
          else
            EndPos := EndPos + FLengthDiff;
      { check for existence }
      if EndPos-StartPos=0 then
        FMemo := nil;
    end;
end;

{ must be called whenever occures some editing
 sets new values to OldCursorPos and OldLength }
procedure TColorMemo.Edited;
var NewStart, NewSelLength, NewLen: integer;
begin
  NewStart := SelStart;
  NewSelLength := SelLength;
  NewLen := Length(Text);
  FPosDiff := NewStart - FOldCursorPos;
  FLengthDiff := NewLen - FOldLength;
  UpdateBookmarks;

  if FOldSelLength<>NewSelLength then PaintColors(self, false);

  if ((FOldCursorPos<>NewStart) or
     (FOldSelLength<>NewSelLength))
     and Assigned(FOnSelectionChange)
        then FOnSelectionChange(Self);

  FOldCursorPos := NewStart;
  FOldSelLength := NewSelLength;
  FOldLength := NewLen;
end;

procedure TColorMemo.WndProc(var Message: TMessage);
begin
  if FCreated and not(csDesigning in ComponentState)
   then
   if (Message.msg=WM_SetFocus)
       or (Message.msg=WM_SetText)
       or (Message.msg=WM_KeyDown)
       or (Message.msg=WM_Char)
       or (Message.msg=WM_KeyUp)
       or (Message.msg=WM_LBUTTONDOWN)
       or (Message.msg=WM_LBUTTONDBLCLK)
       or (Message.msg=WM_Cut)
       or (Message.msg=WM_Undo)
       or (Message.msg=WM_Clear)
       or (Message.msg=WM_Paste)
       or (Message.msg=EN_CHange)
       or (Message.msg=EN_Update)
    then Edited;

  inherited WndProc(Message);
end;

procedure TColorMemo.DeleteMark( aMark: TMemoMark );
var i: integer;
begin
  if aMark = nil then exit;
  i := FMemoMarks.IndexOf(aMark);
  if i<>-1 then FMemoMarks.Delete(i);
end;

procedure TColorMemo.FreeMark( var AMark: TMemoMark );
begin
  DeleteMark(aMark);
  AMark.FMemo := nil;
  AMark.Free;
  AMark := nil;
end;

procedure TColorMemo.WMLButtonDown(var Message: TWMLButtonDown);
var X, Y, charPos: Integer;
begin
  { remember selection state, as it will be cleared
    during inherited handler }
  FDragSelStart := SelStart;
  FDragSelLength := SelLength;
  X := Message.Pos.X;
  Y := Message.Pos.Y;
  FDownX := X;
  FDownY := Y;
  inherited;
  charPos := Perform(EM_CHARFROMPOS,0,MAKELPARAM(X,Y));
  charPos := loword(charPos);
  { if there is selection and button pressed
    in the selected area then start drag }
  if (FDragSelLength>0)and(GetDragText)and
    (CharPos>=FDragSelStart)and(CharPos<=FDragSelStart+FDragSelLength)
  then begin
    { restore selection to allow user view, what is dragged }
    SelStart := FDragSelStart;
    SelLength := FDragSelLength;
    BeginDrag(false);
  end;
end;

procedure TColorMemo.DragOver(Source: TObject; X, Y: Integer;
                                 State: TDragState; var Accept: Boolean);
  procedure DrawDropLine;  { highlights the droptarget }
  begin
    if DragLineX<>-1 then
      PatBlt(LineDC, DragLineX, DragLineY, 2, Font.Size+5, PATINVERT);
  end;

  procedure CalcDropCoord(x,y: Integer);
  var
    CharPos, Coor: integer;
  begin
    { find the coordinates of the closest character }
    charPos := Perform(EM_CHARFROMPOS,0,MAKELPARAM(X,Y));
    if CharPos=-1 then
      DragLineX := -1
    else begin
      charPos := loword(charpos);
      Coor := Perform(EM_POSFROMCHAR,CharPos,0);
      DragLineX := loword(coor);
      DragLineY := hiword(coor);
    end;
  end;
begin
  inherited;
  if Accept or(Source is TColorMemo) then begin
  { highlight droptarget only if accepted }
    Accept := True;
    if State=dsDragEnter then begin { start tracking }
      LineDC := GetDCEx(Handle, 0, DCX_CACHE or DCX_CLIPSIBLINGS
        or DCX_LOCKWINDOWUPDATE);
      CalcDropCoord(X,Y);
      DrawDropLine;
    end else if State=dsDragLeave then begin { end tracking }
      DrawDropLine;
      ReleaseDC(Handle, LineDC);
    end else begin
      DrawDropLine; { clear prev position }
      CalcDropCoord(X,Y);
      DrawDropLine; { draw new }
    end;
  end;
end;

procedure TColorMemo.DragDrop(Source: TObject; X, Y: Integer);
var
  charPos: Integer;
  sWK: string;
begin
  inherited;
  if (Source=self)and(FDragSelLength>0) then begin
    charPos := Perform(EM_CHARFROMPOS,0,MAKELPARAM(X,Y));
    if (CharPos=-1) then exit;  { not client area }
    CHarPos := loword(charPos);

    if (CharPos>=FDragSelStart)and(CharPos<=FDragSelStart+FDragSelLength)
    then begin
      //  drop inside selection
      SelStart := charPos;
      SelLength := 0;
      PaintColors(Self, false);
    end else begin
        // drop outside selection
      SelStart := FDragSelStart;
      SelLength := FDragSelLength;
      sWk := SelText; { text to be moved  }
      if (GetKeyState(VK_CONTROL) shr 31)=0 then begin
        if FDragSelStart<CharPos then { take into account deleted text }
          CharPos := CharPos - FDragSelLength;
        SelText := '';
      end;
      { move }
      SelStart := loword(CharPos);
      SelLength := 0;
      SelText := sWk;
    end;
  end;
end;

procedure TColorMemo.DoEndDrag(Target:TObject; X, Y: Integer);
var CharPos: integer;
  pnt: TPoint;
begin
 pnt.X := X;
 pnt.Y := Y;
 pnt := ScreenToClient(pnt);
  if ((pnt.X=FDownX)and(pnt.Y=FDownY)) or
     ((X=0) and (Y=0)) then begin // sometimes (x,y) evaluates to (0,0), when mouse didn't move in drag action
    charPos := Perform(EM_CHARFROMPOS,0,MAKELPARAM(FDownX,FDownY));
    if CharPos<>-1 then begin
      CharPos := loword(CharPos);
      if SelStart<>CharPos then
        SelStart := CharPos;
    end;
    SelLength := 0;
    PaintColors(Self, false);
  end;
 inherited;
end;


procedure TColorMemo.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
begin
  inherited;
  if parent<>nil then AdjustTextArea;
end;

procedure TColorMemo.CMRecreateWnd(var Message: TMessage);
begin
 inherited;
 AdjustTextArea;
end;

procedure TColorMemo.AdjustTextArea;
begin
  FTextArea := RECT( Gutter.Size+ClientRect.Left, ClientRect.Top,
                    ClientRect.Right, ClientRect.Bottom);


  if (BorderStyle=bsNone) then InflateRect(FtextArea, -1, -1);


//  SendMessage(Handle, EM_SETMARGINS, EC_LEFTMARGIN, FGutterSize);
  SendMessage(Handle, EM_SETRECT, 0 , Integer(@FTextArea));

  // refreshing clipping text region
  with FTextArea do SetRectRgn(FTextRgn, Left, Top, Right, Bottom);


  Refresh;
end;

 // returns empty string if point isn't in some hot spot area
function TColorMemo.PointToHotSpot;
 var i: integer; // number of a character under the mouse
     coords: TPoint; // real coordinates of the character
     tm: TSize;
begin
 Result := '';
 i := SendMessage( Handle, EM_CHARFROMPOS, 0, MAKELPARAM( X, Y)) mod $10000;

 // maybe we're far away from character? Exit then.
 coords.X := SendMessage( Handle, EM_POSFROMCHAR, i, 0);
 coords.Y := coords.X div $10000;
 coords.X := coords.X mod $10000;
 tm := Canvas.TextExtent('W');
 tm.cx := tm.cx div 2;
 if (Y>coords.Y+tm.cy) then exit;
 if (X>coords.X+tm.cx) or (X<coords.X-tm.cx) then exit;

 // using hotspot stack for retreiving a hotspot.
 Result := FHotKeywords.GetHotspot(i);
end;


procedure TColorMemo.CMCursorchanged(var Message: TMessage);
begin
inherited;
if Cursor<>HandCursor then Fcursor := Cursor;
end;


// takes a TkeyDescr defined by index and parses it into
// separate records, if there are line breaks inside
// given record's left-right identifiers.
procedure TColorMemo.ParseMultilineKeyDescr;
 var curr: PKeyDescr;
     lNew: PKeyDescr;

     pos1, pos2: RetLValue;

     lRight, lLeft: integer;
     tm: TSize;
     WND: HWND;

begin
 tm := Canvas.TextExtent('W');
 WND := Handle;

 curr := Akeyd;

 pos1 := RetLValue(SendMessage( WND, EM_POSFROMCHAR, curr.Left, 0));
 pos2 := RetLValue(SendMessage( WND, EM_POSFROMCHAR, curr.Right, 0));

 while pos1[1]<pos2[1] do begin
  lLeft := SendMessage(WND, EM_CHARFROMPOS, 0, MakeLParam(FTextArea.Left+1,pos1[1]+tm.cy)) mod $10000;
  lRight := lLeft-1;

  while  (curr.Left<lRight) and  (FCurrBuff[lRight] in [#13, #10, ' '])
    do Dec(lRight);

  if lRight>=curr.Left then begin
    lNew := NewKeyDescr;
    lNew^ := curr^;
    lNew.Right := lRight;   
  end;

  curr.Left := lLeft;

  pos1 := RetLValue(SendMessage( Self.Handle, EM_POSFROMCHAR, curr.Left, 0));
 end;

end;

function TColorMemo.GetDragText: boolean;
begin
  Result := FDragText and not ReadOnly;
end;

procedure TColorMemo.WMKillFocus(var Message: TWMSetFocus);
begin
inherited;
Repaint;
end;

// import/export
procedure TColorMemo.AppendColBuffer(ABuff: PColBuff; Afrom, ATo: integer; AColor: TColor; ZOrder: integer);
 var i: integer;
begin
 for i := AFrom to ATo do
   if ABuff[i].ZOrder<=ZOrder then begin
   ABuff[i].ZOrder := ZOrder;
   ABuff[i].col := AColor;
  end;
end;

procedure TColorMemo.CompileKeywordList (const ARule: TColorRule; const ABuff: PColBuff );

  var curr: PChar;
      i: integer;
      clr: TColor;
      sl: TStringList;
      lText: string;

begin
  // list that will hold BreakSemiColonLine result
  sl := TStringList.Create;

  if not ARule.KeyCase then lText := AnsiUpperCase(Text);

  for i := 0 to ARule.Keywords.Count-1 do begin
    BreakSemiColonLine(ARule.Keywords[i], sl);
    if sl.Count=0 then Continue;


    if not ARule.KeyCase then sl[0] := AnsiUpperCase(sl[0]);

    try
    if sl.Count>1
      then clr := ColorValue(sl[1])
      else clr := ARule.DefKeyColor;
    except
     clr := ARule.DefKeyColor;
    end;

    curr := PChar(lText);

    while curr<>nil do begin
      curr := StrPos(curr, PChar(sl[0]));
      if (curr<>nil) and
         (ARule.PartWord or (not IsKeywordChar((curr-1)^) and
                             not IsKeywordChar((curr+Length(sl[0]))^)))
         then begin
           AppendColBuffer(ABuff, curr-PChar(lText), Curr-PChar(lText)+Length(sl[0])-1, clr, ARule.ZOrder);
           inc(curr, Length(sl[0]));
         end
         else if curr<>nil then inc(curr);
    end;

  end;

  sl.Free;
end;

procedure TColorMemo.CompileBeginEndList (const ARule: TColorRule; const ABuff: PColBuff );
 var sl: TStringList;
     curr, curr_end: PChar;
     i: integer;
     clr: TColor;
     pText: PChar;
begin
 sl := TStringList.Create;      // parameters will be stored here

 for i := 0 to ARule.KeyBegEndLst.Count-1 do begin
  BreakSemiColonLine(ARule.KeyBegEndLst[i], sl);
  if sl.Count<2 then Continue;

 try
 if sl.Count>2
   then clr := ColorValue(sl[2])
   else clr := ARule.DefKeyColor;
 except
  clr := ARule.DefKeyColor;
 end;

  pText := PChar(Text);
  curr := pText;

    while curr<>nil do begin
      curr := StrPos(curr, PChar(sl[0]));
      if (curr<>nil) then begin
        curr_end := StrPos(curr+Length(sl[0]), PChar(sl[1]));
        if curr_end<>nil then begin
           AppendColBuffer(ABuff, curr-PText, Curr_end-PText+Length(sl[1])-1, clr, ARule.ZOrder);
           curr := curr_end;
           inc(curr, Length(sl[1]));
        end else curr := nil; // no more closing keys left.
      end;
    end;

 end;

 sl.Free;
end;

procedure TColorMemo.CompileLineEndList (const ARule: TColorRule; const ABuff: PColBuff );
 var sl: TStringList;
     PText, curr, curr_end: PChar;
     i: integer;
     clr: TColor;
begin
 sl := TStringList.Create;

 for i := 0 to ARule.KeyLineEndLst.Count-1 do begin
  BreakSemiColonLine(ARule.KeyLineEndLst[i], sl);
  if sl.Count=0 then Continue;

 try
 if sl.Count>1
   then clr := ColorValue(sl[1])
   else clr := ARule.DefKeyColor;
 except
  clr := ARule.DefKeyColor;
 end;


  PText := PChar(Text);
  curr := PText;

    while curr<>nil do begin
      curr := StrPos(curr, PChar(sl[0]));
      if (curr<>nil) then begin
        curr_end := StrPos(curr, #13#10);
        if curr_end = nil then curr_end := StrEnd(curr)-1;
        if curr_end<>nil then begin
           AppendColBuffer(ABuff, curr-PText, Curr_end-PText-1, clr, ARule.ZOrder);
           curr := curr_end+2;
        end else curr := nil;
      end;
    end;

 end;

 sl.Free;
end;



function TColorMemo.CompileColBuff;
 var i: integer;
begin
 try
   GetMem(Result, length(Text)*sizeof(TColBufferEntry));
   for i := 0 to length(Text)-1 do
    with Result[i] do begin
     col := Font.Color;
     ZOrder := -1;
    end;

   for i := 0 to FRules.Count-1 do
    case FRules[i].KeyDrawingType of
     dtKeyShow:CompileKeywordList(FRules[i], Result);
     dtBeginEnd: CompileBeginEndList(FRules[i], Result);
     dtBeginLineEnd: CompileLineEndList(FRules[i], Result);
    end;

 finally
 end;
end;

function TColorMemo.CompileColPortions;
 var beg, i, break_pos: integer;
     curr_clr: TColor;
     colBuff: PColBuff;
     s: string;
begin
 Result := TStringList.Create;
 if Text='' then exit;



 colBuff := CompileColBuff;
 i := 0;
 beg := 0;
 curr_clr := colBuff[0].col;
 while i<Length(Text) do begin
  if curr_clr<>colBuff[i].col then begin
   Result.AddObject(Copy(Text, beg+1, i-beg),TObject(curr_clr));
   beg := i;
   curr_clr := colBuff[i].col;
  end;
  inc(i);
 end;
 // last one needs to be added
   Result.AddObject(Copy(Text, beg+1, i-beg),TObject(curr_clr));


 // deal with lines that contain line breaks
 i := 0;
 while i<Result.Count do begin
  break_pos := Pos(#13#10, Result[i]);
  while break_pos<>0 do begin
   s := Copy(Result[i], 1, break_pos-1);
   if s<>'' then begin
     Result.InsertObject(i, s, Result.Objects[i]);
     inc(i);
   end;
   s := Result[i];
   Delete(s, 1, break_pos+1);
   Result[i] := s;

   if result[i]=''
    then Result[i] := #13#10
    else Result.InsertObject(i, #13#10, Result.Objects[i]); // even breaks should know their current color

   inc(i);

   if i>=Result.Count
    then break_pos := 0
    else break_pos := Pos(#13#10, Result[i]);
  end;

  inc(i);
 end;

  // sometimes "#13#10" that is between two keywords is painted in default color. Fixing this
  if (Result.Count>0) and (Result[Result.Count-1]=#13#10) then Result.Objects[Result.Count-1] := TObject(Font.Color);
  for i := Result.Count-2 downto 0 do
   if Result[i]=#13#10 then Result.Objects[i] := Result.Objects[i+1];


  // if some system color are used, we need to change clBtnFace to
  // corresponding RGB value
  for i := 0 to Result.Count-1 do
   Result.Objects[i] := TObject(ColorToRGB(TColor(Result.Objects[i])));


  FreeMem(colBuff);
end;


function ColorToHex(col: TColor; for_rtf: boolean): string;
 var r,g,b: byte;
begin
 // red and blue bytes must be swapped,
 // otherwise delphi and browser
 // won't understand each other:]
 col := ColorToRGB(col); // required if color is defined as, for example, clBtnFace


 r := (col mod $100);
 g := ((col div $100) mod $100);
 b := (col div $10000);

 col := r*$10000+g*$100+b;
 if for_rtf
  then Result := Format('\red%d\green%d\blue%d;', [r,g,b])
  else Result := IntToHex(col, 6);
end;


function TColorMemo.CompileHtml;
 var colPortions: TStringList;
     i, j: integer;
     s: string;
     newCol, currColor: TColor;

begin
 // memo text
 colPortions := CompileColPortions;
 currColor := Font.Color;

 // header
 if AContentOnly
  then Result := ''
  else Result:= '<html>'#13#10+
          '  <meta name=Generator content="ColorMemo 2.x by Baltic Solutions">'#13#10+
          '  <title>'+ATitle+'</title>'#13#10+
          '</html>'#13#10+
          #13#10+

          ' <body'+
          ' bgcolor="'+ColorToHex(Color, false)+'"'+
//          ' bgcolor="'+ColorToHex(clWhite, false)+'"'+
          ' text="'+ColorToHex(Font.Color, false)+'"'+
          '>'#13#10#13#10;

 Result := Result+'  <!-- Font face and size -->'#13#10+
          '  <font face="'+Font.Name+'" size="'+IntToStr(Font.Size div 4)+'">'#13#10#13#10+
          '    <!-- Memo content -->'#13#10'    ';




   // text itself
   for i := 0 to colPortions.Count-1 do begin
    if colPortions[i]=#13#10
     then Result := Result+'<br>'#13#10'    '
     else begin

       s := colPortions[i];

       // spaces in the beginning of the string must be converted to "&nbsp;"
       if s<>'' then begin
         j := 1;
         while (j<=Length(s)) and (s[j]=' ') do begin
          Insert('&nbsp', s, j);
          inc(j, 5);
          s[j] := ';';
          inc(j);
         end;
       end;

       // converting closing and ending tags:

       // '<' to "&lt;"
       j := Pos('<', s);
       while j<>0 do begin
        Insert('&lt', s, j);
        s[j+3] := ';';
        j := Pos('<', s);
       end;

       // '>' to "&gt;"
       j := Pos('>', s);
       while j<>0 do begin
        Insert('&gt', s, j);
        s[j+3] := ';';
        j := Pos('>', s);
       end;

        newCol := integer(colPortions.Objects[i]);
        // check if change of color is needed
        if (newCol<>Font.Color) and
           (newCol<>currColor)
         then  begin
          s := '<font color="'+ColorToHex(newCol, false)+'">'+s;
         end;

         currColor := newCol;

        // if next color is not the same,
        // close font tag.
        if ((i<colPortions.Count-1) and
            (integer(colPortions.Objects[i+1])<>currColor) and
            (currColor<>Font.Color))
           or
           ((i=colPortions.Count-1) and (Font.Color<>currColor))
         then s := s+'</font>';


      Result := Result+s;

     end;

   end;

// file end
Result := Result+#13#10#13#10'  </font>';
if not AContentOnly
 then Result := Result+#13#10' </body>'#13#10'<html>';

 colPortions.Free;
end;



function TColorMemo.CompileRTF;

 var colPortions: TStringList;
     i, j: integer;
     s: string;
     clrlst: TLIst;
     isNewLine: boolean;

begin
 colPortions := CompileColPortions;

 // build color list
 clrlst := TList.Create;
 for i := 0 to colPortions.Count-1 do begin
  if clrlst.IndexOf(colPortions.Objects[i])<0
   then clrlst.Add(colPortions.Objects[i]);
 end;

 // header
 Result := '{\rtf1\ansi\deff0'#13#10+
           ' {\fonttbl'#13#10+
           '  {\f0\fnil '+Font.Name+';}'#13#10+
           '  {\f1\fnil\fcharset'+IntToStr(Font.Charset)+' '+Font.Name+';}'#13#10+
           ' }'#13#10+
           ' {\colortbl ;'#13#10;

 for i := 0 to clrlst.Count-1 do
  Result := Result+'   '+ColorToHex(TColor(clrlst[i]), true)+#13#10;

 Result := Result+'  }'#13#10+
           '\viewkind4';



 // document body
 isNewLine := true;
 for i := 0 to colPortions.Count-1 do
  if colPortions[i]=#13#10
   then begin
    if isNewLine then Result := Result+'\par';
    Result := Result+#13#10;
    isNewLine := true;
   end else begin

     if isNewLine then begin
      Result := Result+'\par\pard\f1\fs'+IntToStr(Font.Size*2);
      isNewLine := false;
     end;


       // '{' to '\{', '}' to '\}'
       s := colPortions[i];
       j := 0;
       while j<=Length(s) do begin
        if s[j] in ['{', '}', '\']
         then begin
          Insert('\', s, j);
          Inc(j);
         end;
        Inc(j);
       end;


     // color and content
     Result := Result+
               '\cf'+IntToStr(clrlst.IndexOf(colPortions.Objects[i])+1)+' '+
               s;

   end;
 result := Result+#13#10'}';
 colPortions.Free;
end;


 // simply saves string to given file 
procedure StringToFile(const AString, AFile: string);
 var sl: TStringList;
begin
 sl := TStringList.Create;
 sl.Text := AString;
 Sl.SaveToFile(AFile);
 sl.Free;
end;

procedure TColorMemo.SaveToHTML(const AFileName, ATitle: string; const AContentOnly: boolean);
begin
StringToFile(CompileHTML(ATitle, AContentOnly), AFileName);
end;

procedure TColorMemo.SaveToRTF(const AFileName: string);
begin
StringToFile(CompileRTF, AFileName);
end;



procedure TColorMemo.CMFontchanged(var Message: TMessage);
begin
 inherited;
 AdjustTextArea;
end;

 // function tests if a given character is a valid keyword identifier;
 // user can provide his own event for testing; otherwise only characters
 // that
function TColorMemo.IsKeywordChar;
begin
 Result := True;
 if Assigned(FOnIsKeywordChar)
  then FOnIsKeywordChar(Self, Ac, Result)
  else Result := Ac in CM_DEF_KEYWORD_CHARS;
end;


procedure TColorMemo.SetGutterOpts;
begin
  FGutterOpts.Assign(Value);
end;

procedure TColorMemo.CMFontchange(var Message: TMessage);
begin
 inherited;
 AdjustTextArea;
end;


function WrapText(const Line: string; MaxCol: Integer): string;
const
  QuoteChars = ['''', '"'];
  BreakStr = #13#10;
  BreakChars = [' ', '-', #9];
var
  Col, Pos: Integer;
  LinePos, LineLen: Integer;
  BreakLen, BreakPos: Integer;
  QuoteChar, CurChar: Char;
  ExistingBreak: Boolean;
  L: Integer;
begin
  Col := 1;
  Pos := 1;
  LinePos := 1;
  BreakPos := 0;
  QuoteChar := ' ';
  ExistingBreak := False;
  LineLen := Length(Line);
  BreakLen := Length(BreakStr);
  Result := '';
  while Pos <= LineLen do
  begin
    CurChar := Line[Pos];
    if CurChar in LeadBytes then
    begin
      L := CharToByteLen(CurChar, 1) - 1;
      Inc(Pos, L);
      Inc(Col, L);
    end
    else
    begin
      if CurChar = BreakStr[1] then
      begin
        if QuoteChar = ' ' then
        begin
          ExistingBreak := CompareText(BreakStr, Copy(Line, Pos, BreakLen)) = 0;
          if ExistingBreak then
          begin
            Inc(Pos, BreakLen-1);
            BreakPos := Pos;
          end;
        end
      end
      else if CurChar in BreakChars then
      begin
        if QuoteChar = ' ' then BreakPos := Pos
      end
      else if CurChar in QuoteChars then
      begin
        if CurChar = QuoteChar then
          QuoteChar := ' '
        else if QuoteChar = ' ' then
          QuoteChar := CurChar;
      end;
    end;
    Inc(Pos);
    Inc(Col);
    if not (QuoteChar in QuoteChars) and (ExistingBreak or
      ((Col > MaxCol) and (BreakPos > LinePos))) then
    begin
      Col := Pos - BreakPos;
      Result := Result + Copy(Line, LinePos, BreakPos - LinePos + 1);
      if not (CurChar in QuoteChars) then
        while Pos <= LineLen do
        begin
          if Line[Pos] in BreakChars then
            Inc(Pos)
          else if Copy(Line, Pos, Length(BreakStr)) = BreakStr then
            Inc(Pos, Length(BreakStr))
          else
            break;
        end;
      if not ExistingBreak and (Pos < LineLen) then
        Result := Result + BreakStr;
      Inc(BreakPos);
      LinePos := BreakPos;
      ExistingBreak := False;
    end;
  end;
  Result := Result + Copy(Line, LinePos, MaxInt);
end;



procedure TColorMemo.Print;
 var colP, lBrokenkLine: TStringList;
     lRect: TRect;
     i,j: integer;

     lTxtH: integer;
     lCurrX: integer;
     lCurrY: integer;
     prn: TCanvas;


     procedure HeaderFooter (AY: integer; AText: String; Al: TAlignment);
      var lX: integer;
     begin
      case Al of
       taCenter: lX := (lRect.Right+lRect.Left-prn.TextWidth(AText)) div 2;
       taRightJustify: lX := lRect.Right-prn.TextWidth(AText);
       else lX := lRect.Left;
      end;
      prn.Font.Color := Font.Color;
      prn.TextOut(lX, AY, AText);
     end;

     procedure InitNewPage;
     begin
      lCurrX := lRect.Left;
      lCurrY := lRect.Top;
      if PrintOptions.Header<>'' then
         HeaderFooter(lRect.Top-lTxtH*2, PrintOptions.Header, PrintOptions.HeaderAlignment);
      if PrintOptions.Footer<>'' then
         HeaderFooter(lRect.Bottom, PrintOptions.Footer, PrintOptions.FooterAlignment);
     end;

     // prints a string and advances lCurrX/Y
     procedure PrintString( Astr: string; Acol: TColor );
      var lStrW: integer;
     begin
      // calculate rectangle of new text
      lStrW := prn.TextWidth(Astr);

      if lStrW+lCurrX>lRect.Right then begin
        lCurrX := lRect.Left;
        Inc(lCurrY, lTxtH);
      end;

      if lTxtH+lCurrY>lRect.Bottom then begin
       Printer.NewPage;
       InitNewPage;
      end;

      prn.Font.Color := Acol;

      if Astr=#13#10
       then begin
        Inc(lCurrY, lTxtH);
        lCurrX := lRect.Left;
       end
       else begin
        prn.TextOut(lCurrX, lCurrY, Astr);
        Inc(lCurrX, lStrW);
       end;

     end;


begin
 prn := Printer.Canvas;

 printer.BeginDoc;

 colP := CompileColPortions;

 // modifying color portions a bit
 // every line is broken at every position it can be wrapped
 lBrokenkLine := TStringList.Create;
 i := 0;
 while i<colP.Count do
  if colP[i]=#13#10 then Inc(i)
  else begin
    lBrokenkLine.Text := WrapText(colP[i], 1);
    for j := 0 to lBrokenkLine.Count-1 do begin
     colP.InsertObject(i, lBrokenkLine[j], colP.Objects[i]);
     Inc(i);
    end;
    colP.Delete(i); // this is the original line
   end;

 lBrokenkLine.Free;

   // prepare printer
 prn.Brush.Color := clWhite;
 prn.Font.Assign(Font);

 lTxtH := prn.TextHeight('W');
 lRect.Left := PrintOptions.Margins.Left;
 lRect.Top := PrintOptions.Margins.Top;
 lRect.Right := Printer.PageWidth-PrintOptions.Margins.Right;
 lRect.Bottom := Printer.PageHeight-PrintOptions.Margins.Bottom;
 if PrintOptions.Header<>'' then Inc(lRect.Top, lTxtH*2);
 if PrintOptions.Footer<>'' then Dec(lRect.Bottom, lTxtH*2);


 InitNewPage;

  // now printing strings
 i := 0;
 while not Printer.Aborted and (i<colP.Count) do begin
  PrintString(colP[i], TColor(colP.Objects[i]) );
  Inc(i);
 end;


 Printer.EndDoc;

 colP.Free;
end;

procedure TColorMemo.SetPrintOptions(const Value: TCMPrintOptions);
begin
  FPrintOptions.Assign(Value);
end;

procedure TColorMemo.TextOut(const Ax, Ay: integer; AText: String);
begin
 TextOutEx(Ax, Ay, PChar(AText), Length(AText));
end;

procedure TColorMemo.TextOutEx(const Ax, Ay: integer; AText: PChar; AMaxLen: integer);
   var rect: TRect;
       DC: HDC;
begin
   rect.Left := AX;
   rect.Top := AY;
   DC := Canvas.Handle;

   CalcTextRect(DC, Ax, Ay, AText, AMaxLen, @Rect);

   if rect.Right<=rect.Left then Exit;

   {$IFDEF CM_DT}
   SelectClipRgn(DC, FTextRgn);
   windows.DrawText(DC, AText, AMaxLen, Rect, DT_LEFT or DT_TOP or DT_EXPANDTABS or DT_SINGLELINE or DT_NOPREFIX);
   {$ELSE}
   windows.ExtTextOut(DC, Ax,AY,ETO_CLIPPED or ETO_OPAQUE, @Rect, AText, AMaxLen, nil);
   {$ENDIF}

end;


procedure TColorMemo.CalcTextRect(ADC: HDC; Ax, Ay: integer; AText: PChar;
  AMaxLen: integer; APRect: PRect);
begin
 APRect.Left := Ax;
 APRect.Top := Ay;

 {$IFNDEF CM_DT}
   DrawTextEx(ADC, AText, AMaxLen, APRect^, DT_CALCRECT, nil);
   if APrect.Right>=FTextArea.Right
     then APrect.Right := FTextArea.Right-1;
   if APrect.Left<=FTextArea.Left then APrect.Left := FTextArea.Left+1;
   if APRect.Bottom>FTextArea.Bottom then APRect.Bottom := FTextArea.Bottom;
  {$ENDIF} 

end;


procedure TColorMemo.WMCut(var Message: TWMCut);
begin
 if FAllowCutCopy then inherited;
end;

procedure TColorMemo.WMCopy(var Message: TWMCopy);
begin
 if FAllowCutCopy then inherited;
end;


procedure TColorMemo.WMContextMenu(var Message: TWMContextMenu);
 var lHandled: boolean;
begin
 lHandled := false; // if set to true in OnContextPopup, discards default popup window.
 if Assigned(FOnContextPopup) then
  FOnContextPopup(Self, Message.XPos, Message.YPos, lHandled);
 if not lHandled then inherited;
end;

function TColorMemo.NewKeyDescr: PKeyDescr;
begin
 Result := FKeyDescr.AddNew;
end;

procedure TColorMemo.DefineHotSpot(const Afrom, Ato: integer);
begin
  FHotKeywords.Add(Afrom, Ato);
end;

function TColorMemo.GetOptions: TColorMemoOptions;
begin
 Result := [];
 if FCalcFullBegEnds then Include(Result, cmoCalcFullBegEnds);
 if FDragText then Include(Result, cmoDragText);
 if FAcceptFiles then Include(Result, cmoAcceptFiles);
 if FAllowCutCopy then Include(Result, cmoAllowCutCopy);
end;

procedure TColorMemo.SetOptions(const Value: TColorMemoOptions);
begin
 FDragText := cmoDragText in Value;
 SetAcceptFiles(cmoAcceptFiles in Value);
 FAllowCutCopy := cmoAllowCutCopy in Value;
 FCalcFullBegEnds := cmoCalcFullBegEnds in Value;
end;


{ TCMLineNumberOptions }

procedure TCMGUtterOptions.AssignTo(Dest: TPersistent);
 var d: TCMGutterOptions;
begin
  if Dest is TCMGutterOptions then
  begin
    d := TCMGutterOptions(Dest);
    d.FShowLineNumbers := ShowLineNumbers;
    d.FAlignment := Alignment;
    d.FNumColor := FNumColor;
    d.FStartCount := FStartCount;
    d.FIs3D := FIs3D;
    d.FSize := FSize;
    d.FColor := FColor;
    d.Changed;
  end
  else inherited;
end;

procedure TCMGutterOptions.Changed;
begin
 FColMemo.Invalidate;
end;

constructor TCMGutterOptions.Create(AMemo: TColorMemo);
begin
 inherited Create;
 FShowLineNumbers := False;
 FColMemo := AMemo;
 FNumColor := AMemo.Font.Color;
 FAlignment := taLeftJustify;
 FStartCount := 1;
 FIs3D := false;
 FSize := 0;
 FNumColor := AMemo.Font.Color;
 FColor := clBtnFace;
end;

procedure TCMGutterOptions.SetAlignment(const Value: TAlignment);
begin
  FAlignment := Value;
  Changed;
end;

procedure TCMGutterOptions.SetColor(const Value: TColor);
begin
 FColor := Value;
 Changed;
end;

procedure TCMGutterOptions.SetIs3D(const Value: Boolean);
begin
  FIs3D := Value;
  Changed;
end;

procedure TCMGutterOptions.SetNumColor(const Value: TColor);
begin
  FNumColor := Value;
  Changed;
end;

procedure TCMGutterOptions.SetShowLineNumbers(const Value: boolean);
begin
  FShowLineNumbers := Value;
  FColMemo.Invalidate;
end;

procedure TCMGutterOptions.SetSize(const Value: Integer);
begin
  if FSize = Value then Exit;
  if Value<0
   then FSize := 0
   else FSize := Value;

  FColMemo.AdjustTextArea;
end;

procedure TCMGutterOptions.SetStartCount(const Value: Integer);
begin
  FStartCount := Value;
  Changed;
end;


procedure TColorMemo.PaintGutter;
 var lGutterRect: TRect;
     i: integer;
     lNRect: TRect; // rectangle of gutter numbers
     lLineNums: String;
     lNFlags: integer;
     lOldColor: TColor;
begin
 if Gutter.Size > 0 then  { Paint the gutter }
  Canvas.Font.Assign(Font);
  with Canvas do
    begin
      Brush.Color := Gutter.Color;
      lGutterRect := ClientRect;
      lGutterRect.Right := FTextArea.Left;
      if not Ctl3D and (BorderStyle = bsSingle)
       then begin
//          InflateRect(lGutterRect, -1, -1);
//          lGutterRect.Right := lGutterRect.Right+1;
         end;

     FillRect(lGutterRect);

      if Gutter.ShowLineNumbers then
      begin
         lNFlags := DT_EXPANDTABS;
         case Gutter.FAlignment of
          taLeftJustify: lNFlags := DT_LEFT;
          taRightJustify: lNFlags := DT_RIGHT;
          taCenter: lNFlags := DT_CENTER;
         end;

         lOldColor := Font.Color;
         Font.Color := Gutter.NumColor;

         // generate line number text
         lLineNums := '';
         i := TopLine+Gutter.StartCountAt;
         lNRect.Top := 0;
         lNRect.Left := 0;
         lNRect.Bottom := 0;
         lNRect.Right := 0;
         while lNRect.Bottom-lNRect.Top<ClientHeight do
         begin
          lLineNums := lLineNums+IntToStr(i)+#13#10;
          Inc(i);
          // recalculate text rectangle
          DrawText(Handle, PChar(lLineNums), Length(lLineNums),
                   lNRect, DT_CALCRECT);
         end;

         InflateRect(lGutterRect, -1, -1);
         if Gutter.Is3D then Dec(lGutterRect.Right,3);
         DrawText(Handle, PChar(lLineNums), Length(lLineNums), lGutterRect, lNFlags);
         if Gutter.Is3D then Inc(lGutterRect.Right,3);

         InflateRect(lGutterRect, 1, 1);
         Font.Color := lOldColor;
       end;



      { draw a line at the right side of Gutter }
      if Gutter.Is3D then
      begin
        Pen.Color := clBtnHighlight;
        MoveTo(lGutterRect.Right-1, lGutterRect.Top);
        LineTo(lGutterRect.Right-1, lGutterRect.Bottom);
        Pen.Color := clBtnShadow;
        MoveTo(lGutterRect.Right, lGutterRect.Top);
        LineTo(lGutterRect.Right, lGutterRect.Bottom);
      end;
    end;

end;

procedure TColorMemo.EMSetTabStops(var Message: TMessage);
begin
 // determine the TabStopWidth property value
 case Message.WParam of
  0: FLastTabStopWidth := 32;
  1: FLastTabStopWidth := PInteger(Message.LParam)^;
  else FLastTabStopWidth := -1;
 end;

 inherited;
end;

procedure TColorMemo.SetTabStopWidth(const Value: Integer);
begin
 if Value<=0 then
  raise Exception.Create(Format('Invalid TabStopWidth value (%d)', [Value]));
  
 SetTabStopWidhts([Value]);
end;

procedure TColorMemo.SetTabStopWidhts(ATabs: array of integer);
begin
 SendMessage(Handle, EM_SETTABSTOPS, high(ATabs)+1, Integer(@ATabs));
end;

{ TCMPrintMargins }

procedure TCMPrintMargins.AssignTo(Dest: TPersistent);
 var d: TCMPrintMargins;
begin
  if Dest is TCMPrintMargins then begin
    d := TCMPrintMargins(Dest);
    d.FTop := FTop;
    d.FBottom := FBottom;
    d.FRight := FRight;
    d.FLeft := FLeft;
  end else inherited;
end;

destructor TCMPrintOptions.Destroy;
begin
  FMargins.Free;
  inherited;
end;

{ TcmHotKeywordList }

procedure TcmHotKeywordList.Add(left, right: integer);
begin
 if FActLength=FCount then begin
  Inc(FActLength, 10);
  ReallocMem(FList, FActLength*sizeof(TcmHotKeyword));
 end;
 Inc(FCount);
 FList[FCount-1].left := left;
 FList[FCount-1].right := right;
end;

procedure TcmHotKeywordList.Clear;
begin
 FCount := 0;
end;


constructor TcmHotKeywordList.Create(const AMemo: TColorMemo);
begin
 inherited Create;
 FMemo := AMemo;
 FActLength := 10;
 GetMem(FList, FActLength*SizeOf(TcmHotKeyword));
 FCount := 0;

end;

destructor TcmHotKeywordList.Destroy;
begin
  FreeMem(FList);
  inherited;
end;

function TcmHotKeywordList.GetHotspot(const APosition: integer): string;
 var i: integer;
     lText: string;
begin
 Result := '';
 lText := FMemo.Text;
 i := 0;
 while (result='') and (i<FCount) do begin
  if (FList[i].left<=APosition) and (FList[i].right>=APosition)
   then Result := Copy(FMemo.Text, FList[i].left+1, Flist[i].right-Flist[i].left+1);
  inc(i);
 end; // while

end;

{ TCMStringList }

procedure TCMStringList.AddColored(Astring: string; AColor: TColor);
begin
  Astring := Trim(Astring);
  if (Length(Astring)<=0) or (Astring[Length(AString)]<>';')
   then Astring := Astring+';';

 Astring := Astring+ ColorToString(ColorToRGB(AColor));

 inherited Add(Astring);
end;


{ TBegEndList }

function TBegEndList.AddNew: PBeginEndDescr;
begin
 if FValidItems=Count then begin
  New(Result);
  Add(Result);
 end;
 Inc(FValidItems);
 Result := PBeginEndDescr(items[FValidItems-1]);
end;

destructor TBegEndList.Destroy;
 var i: integer;
begin
 For I := 0 to Count-1 do
  if Items[ I] <> nil then
   Dispose( PBeginEndDescr(Items[I]));
  inherited;
end;

procedure TBegEndList.Reset;
begin
 FValidItems := 0;
end;

initialization
  // set up IE-like hand cursor
  Screen.Cursors[HandCursor] := LoadCursor( HInstance, MakeIntResource( HAND_CURSOR));
end.

(*

Install Colormemo
-----------------
Alle Projekte in Delphi schließen
Öffnen *.dpk

d:\Daten\DP60\html\Current Version\bs_cm25_D6.dpk

Compile
Installieren

Pfad in der Umgebungsvariable: 
D:\Daten\Dp60\Colormemo\ColMemo.pas

*)
