TCoolMemo
我们先起个名字叫做TCoolMemo。以上篇已经讲了很多组件的技术,这里就只说出几个重点。其余不多说了。
首先,该Memo从CustomMemo继承,它有这样外观:属于平面的,边框是可以设置颜色的线,对应的颜色变量为FEdgeColor,另外,离边框以内的两个象素处,还有另一个框,当鼠标进入Memo时,这个框会显示,当鼠标离开时,为个框消失,同样也可以设置颜色,对应变量为FEnterColor。
那么鼠标进入和离开怎么判断呢,这里Memo将截获两个Delphi的内部消息:
//下面两个获得Delphi的内部消息,鼠标进入和离开时发生
procedure CMMouseEnter (var Message: TMessage); message CM_MOUSEENTER;
procedure CMMouseLeave (var Message: TMessage); message CM_MOUSELEAVE;
其实父类已经截获了这两个消息,并作了相应处理,所以TCoolMemo中的消息处理函数要
Inherited;再作自己的处理。这里又用到了一个变量
MouseIn:Boolean;//标识鼠标是否进入组件
接下来TCoolMemo还要截获两个消息:
procedure WMPaint (var Message: TMessage); message WM_PAINT;
procedure WMNCCalcSize (var Message: TWMNCCalcSize); message WM_NCCALCSIZE;
第一个很熟悉,当需要重画时,触发该消息,
第二个是当窗体需要计算位置和尺寸时触发,消息中包含了窗口客户区的大小,我们用这个的目的主要是将客户区缩小三个象素,以便画组件时不会画到客户区。
procedure TCoolMemo.WMNCCalcSize (var Message: TWMNCCalcSize);
begin
inherited;
InflateRect(Message.CalcSize_Params^.rgrc[0], -3, -3);
end;
而上面几个消息处理函数,CM_MOUSEENTER和CM_MOUSELEAVE;将引起TCoolMemo的外观变化,WM_PAINT保存其外观不被擦去。所以要用到一个画组件的函数,即:
drawBorder;
里面用到了几个API的GDI函数。我在代码中有详细的说明,加上自己看帮助,应该是可以看懂的。
另外,相比于Memo,它的扩展了这样的功能:设置边距和获得光标的位置。这两个对应的性属为Margin,Position。他们都是Public的,不可以在对象察看器中看到。
我们一个个来说
边距设置
property Margin:byte read FMargin write setMargin default 0;
其中setMargin函数中发送了两个消息:
//该消息取得输入区的尺寸
SendMessage(Handle, EM_GETRECT, 0, Longint(@Rect));
//该消息设定输入区的大小
SendMessage(Handle, EM_SETRECT, 0, Longint(@Rect));
光标的位置:
property Position:TPosition read getPosition;
TPostion是一个结构,其中有行和列两个值:
TPosition=record //指定光标的行和列
row:longint;
col:longint;
end;
getPosition;中还要处理中文的问题,代码有详细说明,如果文本中有中文,一样也可以得到正确的行和列。
最后增加了两个事件
property OnEnter;
property OnExit;
都是从父类中显化出来的,其实就是CM_MOUSEENTER和CM_MOUSELEAVE;消息引起的。,当你想作一个三态按钮,这两个事件很有作用。
好了,重点就是上面那几个了,以下是源代码,其中也有详细的说明:
- unit CoolMemo;
- interface
- uses
- Windows, Messages, Classes, Forms,Controls, Graphics, StdCtrls;
- type
- //用设定边缘的空白
- TPosition=record //指定光标的行和列
- row:longint;
- col:longint;
- end;
- TCoolMemo=class(TCustomMemo)
- private
- FMargin:byte; //边距的大小
- FEdgeColor:TColor;//边框的颜色
- FEnterColor:TColor;//鼠标进入时边框内侧的框颜色
- MouseIn: Boolean; //标识鼠标是否进入
- function getPosition:TPosition;//光标的行和列
- procedure setMargin(value:byte);
- procedure setEdgeColor(Value:TColor);
- procedure setEnterColor(Value:TColor);
- //下面两个获得Delphi的内部消息,鼠标进入和离开时发生
- procedure CMMouseEnter (var Message: TMessage); message CM_MOUSEENTER;
- procedure CMMouseLeave (var Message: TMessage); message CM_MOUSELEAVE;
- //当一个窗口的外观必须被画时,应用程序发送这个消息给该窗口
- procedure WMPaint (var Message: TMessage); message WM_PAINT;
- //窗体需要计算位置和尺寸时触发
- //我们用这个的目的主要是将客户区缩小三个象素,以便画组件时不会画到客户区。
- procedure WMNCCalcSize (var Message: TWMNCCalcSize); message WM_NCCALCSIZE;
- protected
- //画窗体的边框,使其看起来更美观.
- procedure drawBorder;
- public
- constructor Create (AOwner: TComponent); override;
- property Position:TPosition read getPosition;
- property Margin:byte read FMargin write setMargin default 0;
- published
- property EdgeColor:TColor read FEdgeColor write SetEdgeColor default $ff0000;
- property EnterColor:TColor read FEnterColor write SetEnterColor default $0000ff;
- //显式化父类的属性
- property Align;
- property Alignment;
- property DragCursor;
- property DragMode;
- property Enabled;
- property Color;
- property Font;
- property Lines;
- property MaxLength;
- property OEMConvert;
- property ParentFont;
- property ParentShowHint;
- property PopupMenu;
- property ReadOnly;
- property ShowHint;
- property ScrollBars;
- property TabOrder;
- property TabStop;
- property Visible;
- property WantReturns;
- property WantTabs;
- property WordWrap;
- property OnChange;
- property OnClick;
- property OnDblClick;
- property OnDragDrop;
- property OnDragOver;
- property OnEndDrag;
- //增加这两个事件,处理鼠标进入和离开
- property OnEnter;
- property OnExit;
- property OnKeyDown;
- property OnKeyPress;
- property OnKeyUp;
- property OnMouseDown;
- property OnMouseMove;
- property OnMouseUp;
- property OnStartDrag;
- end;
- procedure Register;
- implementation
- procedure Register;
- begin
- RegisterComponents('Samples', [TCoolMemo]);
- end;
- constructor TCoolMemo.Create(AOwner:TComponent);
- begin
- inherited Create(Aowner);
- ControlStyle := ControlStyle - [csFramed];
- ParentFont := True;
- FEdgeColor := $ff0000;
- FEnterColor := $0000ff;
- //设定外观,平面无边形
- Ctl3D := False;
- FMargin:=0;
- BorderStyle:=bsNone;
- height:=150;
- width:=200;
- end;
- procedure TCoolMemo.setMargin(Value:byte);
- var
- Rect: TRect;
- begin
- //该消息取得客户区的尺寸
- SendMessage(Handle, EM_GETRECT, 0, Longint(@Rect));
- //以下是重新确定尺寸
- Rect.Top := Value;
- Rect.Left := Value;
- Rect.Right := Width -Value;
- Rect.Bottom := Height -Value;
- //该消息设定客户区的大小
- SendMessage(Handle, EM_SETRECT, 0, Longint(@Rect));
- Fmargin:=value;
- end;
- function TCoolMemo.getPosition:TPosition;
- var
- row,Col:longint;
- CBLines:longint;
- str:WideString;
- begin
- //该消息取得光标所在的行,
- row:= SendMessage(Handle,EM_LINEFROMCHAR,SelStart,0);
- //该消息取得光标所在行开始的位置,位置从第一行的0开始计数,
- //每过一个字符增加1,
- CBLines:=SendMessage(Handle,EM_LINEINDEX,row,0);
- //得到光标的所在行的所在列
- Col:=SelStart-CBLines;
- //为了解决中文的问题,需要用宽字符型来取得光标所在行
- //,行中光标所在列之前的字符串,这样可以解决中文列数的确定问题.
- str:=Copy(Lines[row],1,col);
- col:=Length(Str)+1;
- result.row:=row+1;
- result.col:=col;
- end;
- procedure TCoolMemo.setEdgeColor(Value:TCOlor);
- begin
- if FEdgeColor<>value then
- begin
- FEdgeColor:=value;
- drawBorder;
- end;
- end;
- procedure TCoolMemo.setEnterColor(Value:TColor);
- begin
- if FEnterColor<>value then
- begin
- FEnterColor:=value;
- drawBorder;
- end;
- end;
- procedure TCoolMemo.CMMouseEnter(var Message: TMessage);
- begin
- inherited;
- MouseIn:= True;
- drawBorder;
- end;
- procedure TCoolMemo.CMMouseLeave(var Message:TMessage);
- begin
- inherited;
- MouseIn:=False;
- drawBorder;
- end;
- procedure TCoolMemo.WMPaint (var Message: TMessage);
- begin
- inherited;
- drawBorder;
- end;
- procedure TCoolMemo.WMNCCalcSize (var Message: TWMNCCalcSize);
- begin
- inherited;
- InflateRect(Message.CalcSize_Params^.rgrc[0], -3, -3);
- end;
- procedure TCoolMemo.drawBorder;
- var
- DC: HDC; //设备描述表
- R: TRect; //客户区
- EnterBrush,OuterBrush,BorderBrush:HBRUSH; //画笔句柄,API
- begin
- DC:= GetWindowDC(Handle); //取得该组件的设备描述表
- try
- GetWindowRect(Handle, R); //取得该组件的客户区尺寸
- OffsetRect(R, -R.Left, -R.Top); //左上偏移
- //创建画笔,两个,分别代码边框,边框内,白色画笔
- BorderBrush := CreateSolidBrush(ColorToRGB(FEdgeColor));
- EnterBrush:= CreateSolidBrush(ColorToRGB(FEnterColor));
- OuterBrush:=CreateSolidBrush(ColorToRGB(clWhite));
- //not(csDesigning in ComponentState保证在设计期不变
- if (not(csDesigning in ComponentState)) and
- (MouseIn=true) then //如果鼠标进入
- begin
- //画一个矩形框,用BorderBrush画笔
- FrameRect(DC, R, BorderBrush);
- //把R缩小一个象素
- InflateRect(R, -1, -1);
- //画一个矩形框,用outerBrush画笔
- FrameRect(DC, R, outerBrush);
- InflateRect(R, -1, -1);
- FrameRect(DC, R, EnterBrush);
- end
- else //如果鼠标没有进入
- begin
- FrameRect(DC, R, BorderBrush);
- InflateRect(R, -1, -1);
- FrameRect(DC, R, outerBrush);
- InflateRect(R, -1, -1);
- FrameRect(DC, R, outerBrush);
- end;
- finally
- ReleaseDC(Handle, DC); //释放设备描述表
- end;
- DeleteObject(BorderBrush); //释放画笔
- DeleteObject(EnterBrush);
- DeleteObject(OuterBrush);
- end;
- end.
参考:
http://blog.csdn.net/iseekcode/article/details/4698412
http://www.delphixe.net/thread-5339-1-1.html
TCoolMemo的更多相关文章
随机推荐
- Webserver issues | PHP manager for IIS
4 down vote accepted In order to successfully install the PHP manager for IIS 8, you need the .NET 3 ...
- MediaRecorder类介绍
audiocallbackvideojavadescriptorencoding 目录(?)[+] 找到个MediaRecorder类介绍和大家分享一下. Mediarecorder类在官网的介绍和在 ...
- 利用ajax在javascript中获取后台的值
<script type="text/javascript"> function login() { var sa = WebForm1.Hello().value; ...
- springMVC之事务配置(问题来源:为什么数据保存不了)
参考文章:http://www.cnblogs.com/leiOOlei/p/3725911.html 自己的亲身体会,来源问题this.sessionFactory.getCurrentSessio ...
- Oracle 的证也会过期咯
How does this recertification requirement affect me? If your Database Certification credential is re ...
- 【F#】核心数据多线程处理的首选
http://www.cnblogs.com/zilin-xiao/archive/2011/08/26/2155124.html
- matlab实现的嵌套乘法、高精度、二分法
嵌套乘法的计算: \[ P(x) = 1 - x + x^2 - x^3 + ...+ x ^ {98} - x^{99} \] function y = nest( d, c, x, b ) if ...
- .Xresources 配置文件
安装rxvt-unicode-256color,如果不是这个版本的话VIM配色会显示不正常. ~/.Xresources配置文件如下 !urxvt color scheme: URxvt*backgr ...
- 7zip 命令行
转自 http://www.cnblogs.com/langlang/archive/2010/12/01/1893866.html 7z.exe 是 7-Zip 的命令行版本.7z.exe 使用 7 ...
- matlab查找回车字符
Hi all, I would like to read the data all at once with: `file_text = fread(fid, inf, 'uint8=>char ...