ietextc.pas

·ImageEn 2.3.0 ImageEn一组用于图像处理、查看和分析的Delphi控件。能够保存几种图像格式

(*
Copyright (c) 1998-2007 by HiComponents. All rights reserved.

This software comes without express or implied warranty.
In no case shall the author be liable for any damage or unwanted behavior of any
computer hardware and/or software.

HiComponents grants you the right to include the compiled component
in your application, whether COMMERCIAL, SHAREWARE, or FREEWARE,
BUT YOU MAY NOT DISTRIBUTE THIS SOURCE CODE OR ITS COMPILED .DCU IN ANY FORM.

ImageEn, IEvolution and ImageEn ActiveX may not be included in any commercial,
shareware or freeware libraries or components.

email: [e-mail]

http://www.hicomponents.com
*)

unit ietextc;

{$R-}
{$Q-}

{$I ie.inc}

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, ImageEnView,
  Controls, StdCtrls, Forms, hyieutils, hyiedefs;

type
  TIECharInfo = record
    refcount: integer;
    // single char info
    name: string[255];
    height: integer;
    style: TFontStyles;
    color: TColor;
    brushColor: TColor;
    brushStyle: TBrushStyle;
    // paragraph info (all chars inside before the #10 must have equal values)
    align: TIEAlignment;
  end;
  PIECharInfo = ^TIECharInfo;

  TIETextControl = class(TCustomControl)
  private
  protected
    fText: pchar;
    fTextLength: integer; // without ZERO ending
    fInsertPos: integer;
    fBackbuf: TBitmap;
    fCaretX, fCaretY, fCaretH: integer;
    fDefaultFont: TFont;
    fDefaultFontBrush: TBrush;
    fBorderPen: TPen;
    fBrush: TBrush;
    fInsMode: boolean;
    fDefaultAlign: TIEAlignment;
    fZoom: double;
    fSelStart: integer;
    fSelStop: integer;
    fMouseDownX, fMouseDownY: integer;
    fInsertingCharInfo: PIECharInfo;
    fForceDefaultColors: boolean;
    fFontLocked: boolean;
    fAutoSize: boolean;
    fLineSpace: integer;
    fFixedHeight: integer;
    //
    fcache_h: pbytearray;
    fcache_w: pbytearray;
    fcache_InternalLeading: pbytearray;
    fposxarray, fposyarray: pintegerarray;
    fCharInfo: TList;
    fCharRef: pintegerarray; // reference to fCharInfo for each character
    fWriteFormattedString: boolean;
    fFormattedString: string;
    fOnCursorMoved:TNotifyEvent;
    fUnderBuffer:TBitmap;
    fMarginLeft,fMarginTop,fMarginRight,fMarginBottom:double; // margins in percentage
    procedure CreateParams(var Params: TCreateParams); override;
    procedure WMSize(var Message: TWMSize); message WM_SIZE;
    procedure WMEraseBkgnd(var Message: TMessage); message WM_ERASEBKGND;
    procedure WMLButtonDblClk(var Message: TWMLButtonDblClk); message WM_LBUTTONDBLCLK;
    procedure CMWantSpecialKey(var Msg: TCMWantSpecialKey); message CM_WANTSPECIALKEY;
    procedure WMCut(var Message: TMessage); message WM_CUT;
    procedure WMCopy(var Message: TMessage); message WM_COPY;
    procedure WMPaste(var Message: TMessage); message WM_PASTE;
    procedure WMKillFocus(var Msg: TWMKillFocus); message WM_KILLFOCUS;
    procedure WMSetFocus(var Msg: TWMSetFocus); message WM_SETFOCUS;
    procedure KeyDown(var Key: Word; Shift: TShiftState); override;
    procedure CNChar(var Message: TWMChar); message CN_CHAR;
    procedure KeyUp(var Key: Word; Shift: TShiftState); override;
    procedure GoBack(var CurPos: pchar);
    function GoBackIdx(var CurPos: integer): boolean;
    procedure GoForwardIdx(var CurPos: integer);
    procedure SaveCharInfo(idx: integer; charinf: PIECharInfo);
    function FindCharInfo(info: PIECharInfo): integer;
    procedure RestoreCharInfo(idx: integer; XCanvas: TCanvas);
    procedure CopyCharInfoTo(source: integer; charinf: PIECharInfo);
    function DelChar(idx: integer): integer;
    procedure IncFontSize;
    procedure DecFontSize;
    procedure MoveUp;
    procedure MoveDown;
    procedure MoveHome;
    procedure MoveEnd;
    procedure MoveTo(x, y: integer);
    procedure ClearBitmap;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
    procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
    procedure ResetSelection;
    procedure SStop(PrevPos: integer; Shift: TShiftState);
    procedure RemoveSelected;
    procedure CopyToClipboard;
    procedure PasteFromClipboard;
    procedure ResetCache(from, len: integer);
    procedure SwitchFontStyle(sty: TFontStyle);
    procedure GoWordBackIdx(var CurPos: integer);
    procedure GoWordForwardIdx(var CurPos: integer);
    procedure SetFontLocked(value: boolean);
    procedure DoCursorMoved;
  public
    constructor Create(Owner: TComponent); override;
    destructor Destroy; override;
    procedure Paint; override;
    procedure Update; override;
    property Text: pchar read fText write fText;
    property TextFormatRef: pintegerarray read fCharRef write fCharRef;
    property TextFormat: TList read fCharInfo write fCharInfo;
    procedure KeyPress(var Key: Char); override;
    procedure PaintTo(DestCanvas: TCanvas; DestX, DestY, NonZoomDestWidth, NonZoomDestHeight: integer);
    procedure AddChar(key: char);
    procedure InsertAlign(Align: TIEAlignment);
    procedure Init;
    procedure RemoveUnreferenced;
    property DefaultFont: TFont read fDefaultFont;
    property DefaultFontBrush: TBrush read fDefaultFontBrush;
    property DefaultAlign: TIEAlignment read fDefaultAlign write fDefaultAlign;
    property BorderPen: TPen read fBorderPen;
    property Brush: TBrush read fBrush;
    property Zoom: double read fZoom write fZoom;
    property OnKeyDown;
    property ForceDefaultColors: boolean read fForceDefaultColors write fForceDefaultColors;
    property IsFontLocked: boolean read fFontLocked write SetFontLocked;
    property AutoSize: boolean read fAutoSize write fAutoSize;
    property GlobalLineSpace: integer read fLineSpace write fLineSpace;
    property GlobalFixedHeight: integer read fFixedHeight write fFixedHeight; // 0=use font size (default)
    property WriteFormattedString: boolean read fWriteFormattedString write fWriteFormattedString;
    property FormattedString: string read fFormattedString;
    property InsertingCharInfo:PIECharInfo read fInsertingCharInfo;
    procedure SetXFont(fnt: TFont);
    procedure SetXBackColor(bk: TColor);
    property OnCursorMoved:TNotifyEvent read fOnCursorMoved write fOnCursorMoved; // occurs only on Mouse movements
    property UnderBuffer:TBitmap read fUnderBuffer write fUnderBuffer;
    property MarginLeft:double read fMarginLeft write fMarginLeft;
    property MarginTop:double read fMarginTop write fMarginTop;
    property MarginRight:double read fMarginRight write fMarginRight;
    property MarginBottom:double read fMarginBottom write fMarginBottom;
  end;

  TIEEdit=class(TEdit)
    private
      procedure CMWantSpecialKey(var Msg: TCMWantSpecialKey); message CM_WANTSPECIALKEY;
    protected
      procedure KeyPress(var Key: Char); override;
    public
  end;

implementation

uses menus, imageenproc, dialogs, ievect;

const
  IETEXTMEMOCLIPFORMAT_NAME: string = 'IMAGEEN TEXTMEMO';

var
  IETEXTMEMOCLIPFORMAT: integer;

constructor TIETextControl.Create(Owner: TComponent);
begin
  inherited;
  fWriteFormattedString := false;
  fFormattedString := '';
  fLineSpace := 0;
  fFixedHeight := 0;
  fAutoSize := false;
  fFontLocked := false;
  fDefaultFont := TFont.Create;
  fDefaultFontBrush := TBrush.Create;
  fBorderPen := TPen.Create;
  fBrush := TBrush.Create;
  ControlStyle := ControlStyle + [csOpaque];
  fText := nil;
  fBackbuf := TBitmap.Create;
  fBackbuf.PixelFormat := pf24bit;
  fcache_h := nil;
  fcache_w := nil;
  fcache_InternalLeading := nil;
  fCaretX := 0;
  fCaretY := 0;
  fCaretH := 0;
  fTextLength := 0;
  fCharInfo := nil;
  fCharRef := nil;
  fposxarray := nil;
  fposyarray := nil;
  fInsMode := true;
  fDefaultAlign := iejLeft;
  fZoom := 1;
  Cursor := crIBeam;
  fSelStart := 0;
  fSelStop := 0;
  fMouseDownX := 0;
  fMouseDownY := 0;
  fForceDefaultColors := false;
  getmem(fInsertingCharInfo, sizeof(TIECharInfo));
  fOnCursorMoved:=nil;
  fMarginLeft:=0;
  fMarginTop:=0;
  fMarginRight:=0;
  fMarginBottom:=0;
end;

destructor TIETextControl.Destroy;
begin
  freemem(fInsertingCharInfo);
  freemem(fcache_h);
  freemem(fcache_w);
  freemem(fcache_internalLeading);
  freemem(fCharRef);
  freemem(fposxarray);
  freemem(fposyarray);
  FreeAndNil(fBackbuf);
  if fCharInfo <> nil then
    while fCharInfo.count > 0 do
    begin
      freemem(fCharInfo[0]);
      fCharInfo.Delete(0);
    end;
  FreeAndNil(fCharInfo);
  FreeAndNil(fDefaultFont);
  FreeAndNil(fDefaultFontBrush);
  FreeAndNil(fBrush);
  FreeAndNil(fBorderPen);
  inherited;
end;

procedure TIETextControl.RemoveUnreferenced;
var
  ref: pintegerarray; //1=referenced 0=unref
  i, j: integer;
  ci: PIECharInfo;
begin
  getmem(ref, sizeof(integer) * fCharInfo.Count);
  i := 0;
  while i < fCharInfo.Count do
  begin
    ci := PIECharInfo(fCharInfo[i]);
    if ci^.refcount = 0 then
    begin
      for j := 0 to fTextLength - 1 do
        if fCharRef[j] > i then
          dec(fCharRef[j]);
      freemem(ci);
      fCharInfo.Delete(i);
    end
    else
      inc(i);
  end;
  freemem(ref);
end;

procedure TIETextControl.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  with Params do
    WindowClass.style := WindowClass.style and not (CS_HREDRAW or CS_VREDRAW);
end;

procedure TIETextControl.WMSize(var Message: TWMSize);
begin
  inherited;
  Update;
end;

procedure TIETextControl.WMEraseBkgnd(var Message: TMessage);
begin
  Message.Result := 0;
end;

procedure TIETextControl.CMWantSpecialKey(var Msg: TCMWantSpecialKey);
begin
  inherited;
  case msg.CharCode of
    VK_LEFT, VK_RIGHT, VK_UP, VK_DOWN, VK_PRIOR, VK_NEXT, VK_HOME, VK_END, VK_TAB:
      begin
        msg.Result := 1;
        KeyUp(Msg.CharCode, KeyDataToShiftState(Msg.KeyData));
      end;
  end;
end;

procedure TIEEdit.CMWantSpecialKey(var Msg: TCMWantSpecialKey);
begin
  inherited;
  case msg.CharCode of
    VK_LEFT, VK_RIGHT, VK_UP, VK_DOWN, VK_PRIOR, VK_NEXT, VK_HOME, VK_END, VK_TAB:
      begin
        msg.Result := 1;
        KeyUp(Msg.CharCode, KeyDataToShiftState(Msg.KeyData));
      end;
  end;
end;

procedure TIEEdit.KeyPress(var Key: Char);
begin
  if key=#9 then
  begin
    key:=#0;
    exit;
  end;
  inherited;
end;

function irealloc(old: pointer; oldsize, newsize: integer): pointer;
const
  BLOCKSIZE = 256;
var
  ab: integer; // already allocated blocks
  rb: integer; // required blocks
begin
  ab := (oldsize div BLOCKSIZE);
  rb := (newsize div BLOCKSIZE) + 1;
  if (rb > ab) or (oldsize = 0) then
  begin
    reallocmem(old, rb * BLOCKSIZE);
    result := old;
  end
  else
    result := old;
end;

// insert at fInsertPos

procedure TIETextControl.AddChar(key: char);
var
  ll, ol, xl: integer;
begin
  if fText <> nil then
  begin
    ol := fTextLength + 1; // +1 is the ending Zero
    ll := ol + 1;
    fText := irealloc(fText, ol, ll);
    move(fText[fInsertPos], fText[fInsertPos + 1], ol - fInsertPos);
    fCharRef := irealloc(fCharRef, ol * sizeof(integer), ll * sizeof(integer));
    move(fCharRef[fInsertPos], fCharRef[fInsertPos + 1], (ol - fInsertPos) * sizeof(integer));
  end
  else
  begin
    ol := 0;
    ll := 2;
    getmem(fText, 2);
    fText[1] := #0;
    getmem(fCharRef, 2 * sizeof(integer));
  end;
  fText[fInsertPos] := Key;
  SaveCharInfo(fInsertPos, fInsertingCharInfo);
  // resize
  fcache_h := irealloc(fcache_h, ol, ll);
  fcache_w := irealloc(fcache_w, ol, ll);
  fcache_InternalLeading := irealloc(fcache_InternalLeading, ol, ll);
  fposxarray := irealloc(fposxarray, sizeof(integer) * ol, sizeof(integer) * ll);
  fposyarray := irealloc(fposyarray, sizeof(integer) * ol, sizeof(integer) * ll);
  // reset all from inserting position
  xl := ll - fInsertPos;
  ResetCache(fInsertPos, xl);
  //
  inc(fInsertPos);
  inc(fTextLength);
end;

procedure TIETextControl.ResetCache(from, len: integer);
begin
  zeromemory(@fcache_h[from], len);
  zeromemory(@fcache_w[from], len);
  zeromemory(@fcache_InternalLeading[from], len);
  fillchar(fposxarray[from], sizeof(integer) * len, 255); // set to -1
  fillchar(fposyarray[from], sizeof(integer) * len, 255); // set to -1
end;

// delete the idx char
// return the modified idx (only if it need to be changed)

function TIETextControl.DelChar(idx: integer): integer;
var
  xl: integer;
begin
  result := idx;
  if idx >= fTextLength then
    exit;
  if (idx < fTextLength) then
  begin
    with PIECharInfo(fCharInfo[fCharRef[idx]])^ do
      if refcount > 0 then
        dec(refcount);
    move(fText[idx + 1], fText[idx], fTextLength - idx);
    move(fCharRef[idx + 1], fCharRef[idx], (fTextLength - idx) * sizeof(integer));
    dec(fTextLength);
    xl := fTextLength - idx;
    ResetCache(idx, xl);
    result := idx;
  end;
end;

procedure TIETextControl.GoBack(var CurPos: pchar);
begin
  dec(CurPos);
  if integer(CurPos) < integer(fText) then
    CurPos := fText;
end;

// return true if CurPos has changed

function TIETextControl.GoBackIdx(var CurPos: integer): boolean;
begin
  result := CurPos > 0;
  if result then
    dec(CurPos);
end;

procedure TIETextControl.GoForwardIdx(var CurPos: integer);
begin
  if CurPos < fTextLength then
    inc(CurPos);
end;

procedure TIETextControl.GoWordBackIdx(var CurPos: integer);
begin
  dec(CurPos);
  while (CurPos > 0) and (fText[CurPos] < #33) do
    dec(CurPos);
  while (CurPos > 0) and (fText[CurPos] > #32) do
    dec(CurPos);
  if CurPos < 0 then
    CurPos := 0;
  if (CurPos < fTextLength) and (fText[CurPos] < #33) then
    inc(CurPos);
  CurPos := imax(imin(CurPos, fTextLength - 1), 0);
end;

procedure TIETextControl.GoWordForwardIdx(var CurPos: integer);
begin
  inc(CurPos);
  while (CurPos < fTextLength) and (fText[CurPos] < #33) do
    inc(CurPos);
  while (CurPos < fTextLength) and (fText[CurPos] > #32) do