一个带标题的编辑框 - Delphi K.Top 討論區

發表時間：2013-08-28 08:45:56

IP:61.138.xxx.xxx 訂閱

做了一个带标题的编辑框，标题和内容在同一个框里面，基于TWinControl实现。
能够自动改变字体大小或者高度以显示全部内容。
另外，在chromium不支持这个编辑框吗？

[code delphi]
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.
[/code]