看在你自称小虾的份上,就
unit mx_formcaption;
interface
uses
Forms, Classes, Windows, Controls, Messages, Graphics, SysUtils;
{.$DEFINE DEBUG}
type
{ TMX_FormCaption }
TMX_FormCaption = class(TComponent)
private
FOldWndProc : TWndMethod;
FFrameWidth : Integer;
FFrameHeight : Integer;
FFrameSize : Integer;
FDlgFrameWidth : Integer;
FDlgFrameHeight : Integer;
FBorderWidth : Integer;
FBorderHeight : Integer;
FCaptionWidth : Integer;
FCaptionHeight : Integer;
FSmCaptionWidth : Integer;
FSmCaptionHeight : Integer;
FCaptionLogFont : TLogFontA;
FSmCaptionLogFont : TLogFontA;
FForm : TForm;
FEnabled : Boolean;
FFont : TFont;
FCaption : TCaption;
FCaptionColor : TColor;
FColored : Boolean;
FVShift : Integer;
FHShift : Integer;
FAlignment : TAlignment;
procedure WndProc(var Message: TMessage);
procedure SetForm(const Value: TForm);
procedure SetEnabled(const Value: Boolean);
procedure SetFont(const Value: TFont);
procedure SetCaption(const Value: TCaption);
procedure SetColored(const Value: Boolean);
procedure GetMetrics;
function GetCaptionRectLSpace: Integer;
function GetCaptionRectRSpace: Integer;
function GetCaptionRectTSpace: Integer;
function GetCaptionRectHeight: Integer;
function GetCaptionLogFont: TLogFontA;
procedure DrawCaption;
procedure SetCaptionColor;
procedure SetVShift(const Value: Integer);
procedure SetHShift(const Value: Integer);
procedure SetAlignment(const Value: TAlignment);
procedure SetOwnerCaption(const ACaption: string; ARefresh: Boolean);
property Form: TForm read FForm write SetForm;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure Repaint;
procedure Refresh;
published
property Alignment: TAlignment read FAlignment write SetAlignment;
property Enabled: Boolean read FEnabled write SetEnabled default true;
property Font: TFont read FFont write SetFont;
property Caption: TCaption read FCaption write SetCaption;
property Colored: Boolean read FColored write SetColored;
property VShift: Integer read FVShift write SetVShift;
property HShift: Integer read FHShift write SetHShift;
end;
procedure Register;
implementation
{ Register }
procedure Register;
begin
RegisterComponents('MXLab', [TMX_FormCaption]);
end;
{ CLASS : TMX_FormCaption }
{ Create }
constructor TMX_FormCaption.Create(AOwner: TComponent);
var
VForm : TForm;
begin
inherited;
FFont := TFont.Create;
FFont.Color := clWhite;
FForm := nil;
FEnabled := true;
FCaption := '';
FColored := true;
FVShift := 0;
FHShift := 0;
FAlignment := taLeftJustify;
FCaptionColor := FFont.Color;
@FOldWndProc := nil;
GetMetrics;
if (AOwner is TForm) then begin
VForm := (AOwner as TForm);
FCaption := VForm.Caption;
Form := VForm;
end;
end;
{ Destroy }
destructor TMX_FormCaption.Destroy;
begin
try
if (FForm <> nil) then begin
FForm.WindowProc := FOldWndProc;
SetOwnerCaption(FCaption, true);
end;
FFont.Free;
finally
inherited;
end;
end;
{ UpdateCaption }
procedure TMX_FormCaption.SetOwnerCaption(const ACaption: string; ARefresh: Boolean);
begin
if (FForm <> nil) and not (csDestroying in FForm.ComponentState) then begin
SendMessage(FForm.Handle, WM_SETTEXT, 0, Integer(PChar(ACaption)));
if ARefresh then Refresh;
end;
end;
{ WndProc }
procedure TMX_FormCaption.WndProc(var Message: TMessage);
{ _OldWndProc }
procedure _OldWndProc;
begin
if Assigned(FOldWndProc) then FOldWndProc(Message);
end;
begin
if FEnabled and not (csDestroying in ComponentState) then begin
case Message.Msg of
//
WM_SETTINGCHANGE : begin
_OldWndProc;
GetMetrics;
Refresh;
end;
//
WM_ACTIVATE : begin
_OldWndProc;
// inactive
if (LongRec(Message.WParam).Lo = WA_INACTIVE) then
FCaptionColor := clInactiveCaptionText
// active
else begin
if FColored and (FFont <> nil) then FCaptionColor := FFont.Color else FCaptionColor := clCaptionText;
end;
Refresh;
end;
//
WM_NCACTIVATE, WM_NCPAINT, WM_PAINT : begin
_OldWndProc;
Refresh;
end;
//
else _OldWndProc;
end;
end
else _OldWndProc;
end;
{ SetForm }
procedure TMX_FormCaption.SetForm(const Value: TForm);
var
VForm : TForm;
begin
if (FForm <> Value) and not (csDestroying in ComponentState) then begin
if (FForm <> nil) then FForm.WindowProc := FOldWndProc;
if (Value is TForm) then VForm := Value else VForm := nil;
if (VForm = nil) then
@FOldWndProc := nil
else begin
FOldWndProc := VForm.WindowProc;
VForm.WindowProc := WndProc;
end;
FForm := VForm;
SetOwnerCaption(FCaption, true);
end;
end;
{ SetEnabled }
procedure TMX_FormCaption.SetEnabled(const Value: Boolean);
begin
FEnabled := Value;
end;
{ SetFont }
procedure TMX_FormCaption.SetFont(const Value: TFont);
begin
if (Value is TFont) and not (csDestroying in ComponentState) then begin
FFont.Assign(Value);
SetCaptionColor;
Repaint;
end;
end;
{ SetCaption }
procedure TMX_FormCaption.SetCaption(const Value: TCaption);
begin
if not (csDestroying in ComponentState) then begin
FCaption := Value;
Repaint;
end;
end;
{ SetColored }
procedure TMX_FormCaption.SetColored(const Value: Boolean);
begin
if (FColored <> Value) then begin
FColored := Value;
Refresh;
end;
end;
{ SetVShift }
procedure TMX_FormCaption.SetVShift(const Value: Integer);
begin
if (FVShift <> Value) then begin
FVShift := Value;
Repaint;
end;
end;
{ SetHShift }
procedure TMX_FormCaption.SetHShift(const Value: Integer);
begin
if (FHShift <> Value) then begin
FHShift := Value;
Repaint;
end;
end;
{ SetAlignment }
procedure TMX_FormCaption.SetAlignment(const Value: TAlignment);
begin
if (FAlignment <> Value) then begin
FAlignment := Value;
Repaint;
end;
end;
{ SetCaptionColor }
procedure TMX_FormCaption.SetCaptionColor;
var
VActive : Boolean;
begin
if (FForm = nil) then VActive := true else VActive := (GetActiveWindow = FForm.Handle);
if VActive then begin
if FColored and (FFont <> nil) then FCaptionColor := FFont.Color else FCaptionColor := clCaptionText;
end
end;
{ GetCaptionRectLSpace
returns CaptionRect.Left - WindowRect.Left
}
function TMX_FormCaption.GetCaptionRectLSpace: Integer;
var
VFrWidth : Integer;
VIcWidth : Integer;
begin
Result := -1;
if (FForm = nil) or (FForm.BorderStyle = bsNone) then Exit;
// define frame width
if (csDesigning in ComponentState) then
VFrWidth := FFrameWidth
else begin
// thick frame
if (FForm.BorderStyle = bsSizeable) or (FForm.BorderStyle = bsSizeToolWin) then VFrWidth := FFrameWidth
// thin frame
else VFrWidth := FDlgFrameWidth;
end;
// define left icon width
if (csDesigning in ComponentState) then
VIcWidth := FCaptionWidth
else begin
// left icon exists
if ((FForm.BorderStyle = bsSizeable) or (FForm.BorderStyle = bsSingle)) and (biSystemMenu in FForm.BorderIcons) then VIcWidth := FCaptionWidth
// left icon doesn't exist
else VIcWidth := 0;
end;
Result := VFrWidth + VIcWidth + FBorderWidth + 1 + FHShift;
end;
{ GetCaptionRectRSpace
returns WindowRect.Right - CaptionRect.Right
}
function TMX_FormCaption.GetCaptionRectRSpace: Integer;
var
VBtnWidth : Integer;
VBtnCount : Integer;
begin
Result := -1;
if (FForm = nil) or (FForm.BorderStyle = bsNone) then Exit;
// define frame width
if (csDesigning in ComponentState) then
FFrameSize := FFrameWidth
else begin
// thick frame
if (FForm.BorderStyle = bsSizeable) or (FForm.BorderStyle = bsSizeToolWin) then FFrameSize := FFrameWidth
// thin frame
else FFrameSize := FDlgFrameWidth;
end;
// define buttons width
if (csDesigning in ComponentState) then
VBtnWidth := FCaptionWidth
else begin
// small caption
if (FForm.BorderStyle = bsToolWindow) or (FForm.BorderStyle = bsSizeToolWin) then VBtnWidth := FSmCaptionWidth
// ordinal caption
else VBtnWidth := FCaptionWidth;
end;
// define buttons count
if (csDesigning in ComponentState) then
VBtnCount := 3
else begin
// border style: dialog
if (FForm.BorderStyle = bsDialog) then begin
if (biSystemMenu in FForm.BorderIcons) then begin
if (biHelp in FForm.BorderIcons) then VBtnCount := 2 else VBtnCount := 1;
end
else VBtnCount := 0;
end
// border style: sizeable, single
else if (FForm.BorderStyle = bsSizeable) or (FForm.BorderStyle = bsSingle) then begin
if (biSystemMenu in FForm.BorderIcons) then begin
if (biHelp in FForm.BorderIcons) then begin
//
if not ((biMinimize in FForm.BorderIcons) and (biMaximize in FForm.BorderIcons)) then VBtnCount := 2
//
else if (biMinimize in FForm.BorderIcons) and (biMaximize in FForm.BorderIcons) then VBtnCount := 3
//
else VBtnCount := 4;
end
else begin
if (biMinimize in FForm.BorderIcons) or (biMaximize in FForm.BorderIcons) then VBtnCount := 3 else VBtnCount := 1;
end;
end
else VBtnCount := 0;
end
// border style: toolwindow, sizetoolwin
else begin
if (biSystemMenu in FForm.BorderIcons) then VBtnCount := 1 else VBtnCount := 0;
end;
end;
Result := FFrameSize + VBtnWidth * VBtnCount + FBorderWidth;
end;
{ GetCaptionRectTSpace
returns CaptionRect.Top - WindowRect.Top
}
function TMX_FormCaption.GetCaptionRectTSpace: Integer;
begin
Result := -1;
if (FForm = nil) or (FForm.BorderStyle = bsNone) then Exit;
// thick frame
if (FForm.BorderStyle = bsSizeable) or (FForm.BorderStyle = bsSizeToolWin) then FFrameSize := FFrameHeight
// thin frame
else FFrameSize := FDlgFrameHeight;
Result := FFrameSize + FBorderHeight - 1 + FVShift;
end;
{ GetCaptionRectHeight }
function TMX_FormCaption.GetCaptionRectHeight: Integer;
begin
Result := 0;
if (FForm = nil) or (FForm.BorderStyle = bsNone) then Exit;
// define caption rectangle height
if (csDesigning in ComponentState) then
Result := FCaptionHeight
else begin
// small caption
if (FForm.BorderStyle = bsToolWindow) or (FForm.BorderStyle = bsSizeToolWin) then Result := FSmCaptionHeight
// ordinal caption
else Result := FCaptionHeight;
end;
end;
{ GetCaptionLogFont }
function TMX_FormCaption.GetCaptionLogFont: TLogFontA;
begin
FillChar(Result, SizeOf(Result), 0);
if (FForm = nil) or (FForm.BorderStyle = bsNone) then Exit;
// define caption rectangle height
if (csDesigning in ComponentState) then
Result := FCaptionLogFont
else begin
// small caption
if (FForm.BorderStyle = bsToolWindow) or (FForm.BorderStyle = bsSizeToolWin) then Result := FSmCaptionLogFont
// ordinal caption
else Result := FCaptionLogFont;
end;
end;
{ GetMetrics }
procedure TMX_FormCaption.GetMetrics;
var
NCMetrics : TNonClientMetrics;
begin
FillChar(NCMetrics, SizeOf(TNonClientMetrics), 0);
NCMetrics.cbSize := SizeOf(TNonClientMetrics);
SystemParametersInfo(SPI_GETNONCLIENTMETRICS, NCMetrics.cbSize, @NCMetrics, 0);
FBorderWidth := NCMetrics.iBorderWidth;
FBorderHeight := NCMetrics.iBorderWidth;
FCaptionWidth := NCMetrics.iCaptionWidth;
FCaptionHeight := NCMetrics.iCaptionHeight;
FSmCaptionWidth := NCMetrics.iSmCaptionWidth;
FSmCaptionHeight := NCMetrics.iSmCaptionHeight;
FFrameWidth := GetSystemMetrics(SM_CXFRAME);
FFrameHeight := GetSystemMetrics(SM_CYFRAME);
FDlgFrameWidth := GetSystemMetrics(SM_CXDLGFRAME);
FDlgFrameHeight := GetSystemMetrics(SM_CYDLGFRAME);
FCaptionLogFont := NCMetrics.lfCaptionFont;
FSmCaptionLogFont := NCMetrics.lfSmCaptionFont;
end;
{ Refresh }
procedure TMX_FormCaption.Refresh;
begin
if not (csDestroying in ComponentState) then DrawCaption;
end;
{ Repaint }
procedure TMX_FormCaption.Repaint;
begin
if ((FForm = nil) or (FForm.BorderStyle = bsNone)) and (not (csDestroying in ComponentState)) then Exit;
SetOwnerCaption('', false);
Refresh;
end;
{ DrawCaption }
procedure TMX_FormCaption.DrawCaption;
var
VDC : HDC;
VHandle : HWND;
VRect : TRect;
VText : array[0..256] of Char;
VFormat : DWORD;
VLogFont : TLogFontA;
VFont : HFont;
VOldFont : HFont;
VTextSize : TSize;
VRectLSpace : Integer;
VRectRSpace : Integer;
VRectTSpace : Integer;
VRectHeight : Integer;
{$IFNDEF DEBUG}
VTop : Integer;
VBottom : Integer;
VRgn : HRGN;
{$ENDIF}
begin
if ((FForm = nil) or (FForm.BorderStyle = bsNone)) and (not (csDestroying in ComponentState)) then Exit;
VHandle := FForm.Handle;
VDC := GetWindowDC(VHandle);
try
FillChar(VText, SizeOf(VText), 0);
StrPCopy(@VText, FCaption);
VLogFont := GetCaptionLogFont;
if (FFont <> nil) then begin
StrPCopy(@VLogFont.lfFaceName, FFont.Name);
VLogFont.lfHeight := FFont.Height;
VLogFont.lfCharSet := FFont.Charset;
VLogFont.lfItalic := BYTE(fsItalic in FFont.Style);
VLogFont.lfUnderline := BYTE(fsUnderline in FFont.Style);
VLogFont.lfStrikeOut := BYTE(fsStrikeOut in FFont.Style);
end;
VFont := CreateFontIndirect(VLogFont);
try
VOldFont := SelectObject(VDC, VFont);
try
GetTextExtentPoint32(VDC, @VText, Length(FCaption), VTextSize);
GetWindowRect(VHandle, VRect);
VRectLSpace := GetCaptionRectLSpace;
VRectRSpace := GetCaptionRectRSpace;
VRectTSpace := GetCaptionRectTSpace;
VRectHeight := GetCaptionRectHeight;
// don't change order
VRect.Right := VRect.Right - VRect.Left - VRectRSpace;
VRect.Left := VRectLSpace;
VRect.Top := VRectTSpace + (VRectHeight - VTextSize.cy) div 2;
VRect.Bottom := VRect.Top + VTextSize.cy;
{$IFNDEF DEBUG}
VTop := VRect.Top;
if (VTop < FFrameSize) then VTop := FFrameSize;
VBottom := VRect.Bottom;
if (VBottom > FFrameSize + VRectHeight) then VBottom := FFrameSize + VRectHeight;
VRgn := CreateRectRgn(VRect.Left, VTop, VRect.Right, VBottom);
try
SelectClipRgn(VDC, VRgn);
try
{$ENDIF}
SetTextColor(VDC, ColorToRGB(FCaptionColor));
{$IFDEF DEBUG}
SetBkColor(VDC, clRed);
{$ELSE}
SetBkMode(VDC, TRANSPARENT);
{$ENDIF}
VFormat := DT_VCENTER or DT_END_ELLIPSIS;
case FAlignment of
taLeftJustify : VFormat := VFormat or DT_LEFT;
taRightJustify : VFormat := VFormat or DT_RIGHT;
taCenter : VFormat := VFormat or DT_CENTER;
end;
DrawText(VDC, @VText, -1, VRect, VFormat);
{$IFNDEF DEBUG}
finally
SelectClipRgn(VDC, 0);
end;
finally
DeleteObject(VRgn);
end;
{$ENDIF}
finally
SelectObject(VDC, VOldFont);
end;
finally
DeleteObject(VFont);
end;
finally
ReleaseDC(VHandle, VDC);
end;
end;
end.
