带标题的编辑框

unit ExEdit;
 
interface
 
uses
  System.Classes, Vcl.Controls, Winapi.Windows, Vcl.Graphics, Vcl.StdCtrls,
  System.SysUtils, Winapi.messages;
 
type
 
  TBorders = class(TPersistent)
  private
    FRight: Boolean;
    FBottom: Boolean;
    FTop: Boolean;
    FLeft: Boolean;
    FPen: TPen;
  public
    constructor Create;
    destructor Destroy; override;
  published
    property Pen: TPen read FPen write FPen;
    property Left: Boolean read FLeft write FLeft;
    property Right: Boolean read FRight write FRight;
    property Top: Boolean read FTop write FTop;
    property Bottom: Boolean read FBottom write FBottom;
  end;
 
  TAlterMode = (alterNone, alterFont, alterHeight);
 
  TExEdit = class(TWinControl)
  private
    FTitle: TCaption;
    FTitleLength: Integer;
    FLines: string;
    fAlterMode: TAlterMode;
    FBorders: TBorders;
    fMinHeight: Integer;
    fMaxFont: Integer;
    fOldText: string;
    fMinFont: Integer;
    fMaxHeight: Integer;
    procedure WMChar(var Msg: TWMChar); message WM_CHAR;
    procedure WMKeyDown(var Msg: TWMKeyDown); message WM_KEYDOWN;
    procedure WMPaint(var Msg: TWMPaint);message WM_PAINT;
    procedure setLines(const Value: string);
    procedure setTitle(const Value: TCaption);
    procedure Polyline(const Points: array of TPoint);
    function getSelection: TSelection;
    procedure checkMode(isRecursion: Boolean = False);
    procedure checkText;
    procedure setMaxHeight(const Value: Integer);
  protected
    { protected declarations }
    procedure CreateParams(var Params: TCreateParams); override;
    procedure Loaded();override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property Font;
    property AlterMode: TAlterMode read fAlterMode write fAlterMode;
    property Borders: TBorders read FBorders write FBorders stored True;
    property Title: TCaption read FTitle write setTitle;
    property Lines: string read FLines write setLines;
    property MinFont: Integer read fMinFont write fMinFont default 12;
    property MaxHeight: Integer read fMaxHeight write setMaxHeight default 0;
  end;
 
implementation
 
{ TExEdit }
 
procedure TExEdit.checkMode(isRecursion: Boolean);
var
  vhdc: HDC;
  vidx,vpos,tmpH: Integer;
  vsize: TSize;
begin
 
  FLines := string(Text).Substring(FTitleLength);
 
  vhdc := GetDC(Self.Handle);
  vidx := Length(Text);
  vpos := Perform(EM_POSFROMCHAR,vidx - 1,0);
  SelectObject(vhdc, Font.Handle);
  Winapi.Windows.GetTextExtentPoint32(vhdc, 'A', 1, vsize);
  tmpH := HiWord(vpos)+vsize.cy + 5;
 
  if fAlterMode = alterNone then
  begin
    if (vpos = -1) or (tmpH > Height) then
      Perform(WM_CHAR,VK_BACK,$E0001);
  end;
 
  if fAlterMode = alterFont then
  begin
    if (vpos = -1) or (tmpH > Height) then
    begin
      Font.Size := Font.Size - 1;
      if fMinFont > Font.Size then
      begin
        Font.Size := fMinFont;
        Perform(WM_CHAR,VK_BACK,$E0001);
      end else
        checkMode(True);
    end
    else
    begin
      if not isRecursion and (fMaxFont > Font.Size) then
      begin
        Font.Size := Font.Size + 1;
        checkMode;
      end;
    end;
  end;
  if fAlterMode = alterHeight then
  begin
    if (vpos = -1) or (tmpH > Height) then
    begin
      Height := tmpH;
      if (fMaxHeight > 0) and (fMaxHeight < height) then
      begin
        Height := fMaxHeight;
        Perform(WM_CHAR,VK_BACK,$E0001);
      end else
        checkMode;
    end
    else
    begin
      Height := tmpH;
      if fMinHeight > Height then
        Height := fMinHeight;
    end;
  end;
end;
 
procedure TExEdit.checkText;
begin
  if fOldText <> Text then
  begin
    fOldText := Text;
    checkMode;
  end;
end;
 
constructor TExEdit.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FBorders := TBorders.Create;
  FBorders.Left := True;
  FBorders.Right := True;
  FBorders.Top := True;
  FBorders.Bottom := True;
  fMinFont := 12;
  fMaxHeight := 0;
end;
 
procedure TExEdit.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  CreateSubClass(Params, 'EDIT');
  with Params do
  begin
    Style := Style or ES_MULTILINE;
    { 完全重画 }
    Style := Style and not WS_CLIPCHILDREN;
    Style := Style and not WS_CLIPSIBLINGS;
    { 增加透明 }
    ExStyle := ExStyle or WS_EX_TRANSPARENT;
  end;
end;
 
destructor TExEdit.Destroy;
begin
  FBorders.Free;
  inherited Destroy;
end;
 
function TExEdit.getSelection: TSelection;
begin
  SendMessage(Handle, EM_GETSEL, NativeInt(@Result.StartPos),
  NativeInt(@Result.EndPos));
end;
 
procedure TExEdit.Loaded;
begin
  inherited;
  fMinHeight := Height;
  fMaxFont := Font.Size;
end;
 
type
  PPoints = ^TPoints;
  TPoints = array[0..0] of TPoint;
 
procedure TExEdit.Polyline(const Points: array of TPoint);
var
  vhdc: HDC;
begin
  vhdc := GetDC(Self.Handle);
  SelectObject(vhdc,Borders.Pen.Handle);
  SetROP2(vhdc, R2_COPYPEN);
  Winapi.Windows.Polyline(vhdc, PPoints(@Points)^, High(Points) + 1);
end;
 
procedure TExEdit.setLines(const Value: string);
begin
  FLines := Value;
  Text := Title + Lines;
end;
 
procedure TExEdit.setMaxHeight(const Value: Integer);
begin
  fMaxHeight := Value;
  if (fMaxHeight > 0) and (fMaxHeight < height) then
    fMaxHeight := Height;
end;
 
procedure TExEdit.setTitle(const Value: TCaption);
begin
  FTitle := Value;
  FTitleLength := Length(FTitle);
  Text := Title + Lines;
end;
 
procedure TExEdit.WMChar(var Msg: TWMChar);
var
  canInherited: Boolean;
begin
  canInherited := False;
  case Msg.CharCode of
    VK_BACK:
      canInherited :=
        (getSelection.StartPos >= FTitleLength)
          and (getSelection.EndPos > FTitleLength)
          and (Msg.KeyData <> 0);
  else
    canInherited := getSelection.StartPos >= FTitleLength;
  end;
  if canInherited then
  begin
    inherited;
    checkText;
  end;
end;
 
procedure TExEdit.WMKeyDown(var Msg: TWMKeyDown);
var
  canInherited: Boolean;
begin
  canInherited := False;
  case Msg.CharCode of
    VK_DELETE:
      canInherited := getSelection.StartPos >= FTitleLength;
  else
    canInherited := True;
  end;
  if canInherited then
  begin
    inherited;
    checkText;
  end;
end;
 
procedure TExEdit.WMPaint(var Msg: TWMPaint);
begin
  inherited;
  if Borders.Bottom then
    Polyline([Point(0, Height-1), Point(Width - 1, Height-1)]);
  if Borders.Left then
    Polyline([Point(0, 0), Point(0, Height - 1)]);
  if Borders.Right then
    Polyline([Point(Width - 1, 0), Point(Width - 1, Height - 1)]);
  if Borders.Top then
    Polyline([Point(0, 0), Point(Width - 1, 0)]);
end;
 
{ TBorders }
 
constructor TBorders.Create;
begin
  FPen := TPen.Create;
end;
 
destructor TBorders.Destroy;
begin
  FPen.Free;
  inherited Destroy;
end;
 
end.