unit myLabel;
{Unicode表示に対応したTLabel}
interface
uses
Windows,
Classes,
Graphics,
StdCtrls;
type
TMyLabelBorderStyle = (lbNone, lbSingle);
TMyLabel =
class(TCustomLabel)
private
{ Private 宣言 }
F_bsBorderStyle: TMyLabelBorderStyle;
//ボーダースタイル
F_bDisabledStyle: Boolean;
//Enabled = False の時に影つきのグレイテキストにするか
F_bSingleLine: Boolean;
//改行を無視して一行表示にするか
F_iLeftMargin,
//左マージン
F_iRightMargin: Byte;
//右マージン
function F_AnsiToWide(sSrc: AnsiString):
WideString;
function F_WideToAnsi(sSrc:
WideString): AnsiString;
function GetText:
WideString;
procedure SetText(sText:
WideString);
protected
{ Protected 宣言 }
procedure DoDrawText(
var Rect: TRect; Flags: Longint);
override;
public
constructor Create(AOwner: TComponent);
override;
published
{ Published 宣言 }
property Caption:
WideString read GetText
write SetText;
property DisabledStyle: Boolean
read F_bDisabledStyle
write F_bDisabledStyle
default True;
property SingleLine: Boolean
read F_bSingleLine
write F_bSingleLine
default False;
property LeftMargin: Byte
read F_iLeftMargin
write F_iLeftMargin
default 0;
property RightMargin: Byte
read F_iRightMargin
write F_iRightMargin
default 0;
property Border: TMyLabelBorderStyle
read F_bsBorderStyle
write F_bsBorderStyle
default lbNone;
property Align;
property Alignment;
property Anchors;
property AutoSize;
property BiDiMode;
property Color
default clBtnFace;
property Constraints;
property DragCursor;
property DragKind;
property DragMode;
property Enabled;
property FocusControl;
property Font;
property ParentBiDiMode;
property ParentColor;
property ParentFont;
property ParentShowHint;
property PopupMenu;
property ShowAccelChar;
property ShowHint;
property Transparent;
property Layout;
property Visible;
property WordWrap;
property OnClick;
property OnContextPopup;
property OnDblClick;
property OnDragDrop;
property OnDragOver;
property OnEndDock;
property OnEndDrag;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
property OnMouseEnter;
property OnMouseLeave;
property OnStartDock;
property OnStartDrag;
end;
procedure Register;
//==============================================================================
implementation
uses
Forms,
SysUtils;
const
lciMARGIN = 2;
//------------------------------------------------------------------------------
{ MyLabel }
constructor TMyLabel.Create(AOwner: TComponent);
begin
inherited;
F_bSingleLine := False;
F_bDisabledStyle := True;
F_bsBorderStyle := lbNone;
F_iLeftMargin := 0;
F_iRightMargin := 0;
// inherited Color := clBtnFace;
end;
function TMyLabel.F_WideToAnsi(sSrc:
WideString): AnsiString;
//WideStringをUTF-7にエンコードして返す
var
li_Len: Integer;
lp_Buff: PAnsiChar;
begin
//WC_COMPOSITECHECKはNG
li_Len := WideCharToMultiByte(CP_UTF7, 0, PWideChar(sSrc), -1,
nil, 0,
nil,
nil);
lp_Buff := AllocMem(li_Len + 1);
try
WideCharToMultiByte(CP_UTF7, 0, PWideChar(sSrc), -1, lp_Buff, li_Len,
nil,
nil);
Result := AnsiString(lp_Buff);
finally
FreeMem(lp_Buff);
end;
end;
function TMyLabel.F_AnsiToWide(sSrc: AnsiString):
WideString;
//UTF-7でエンコードされている文字列をWideStringにして返す
var
li_Len: Integer;
lp_Buff: PWideChar;
begin
li_Len := MultiByteToWideChar(CP_UTF7, 0, PAnsiChar(sSrc), -1,
nil, 0);
lp_Buff := AllocMem((li_Len + 1) * 2);
try
MultiByteToWideChar(CP_UTF7, 0, PAnsiChar(sSrc), -1, lp_Buff, li_Len);
Result :=
WideString(lp_Buff);
finally
FreeMem(lp_Buff);
end;
end;
function TMyLabel.GetText:
WideString;
//AnsiStringに可逆変換したTLabelのCaptionをWideStringに戻して返す。
begin
Result := F_AnsiToWide(
inherited Caption);
end;
procedure TMyLabel.SetText(sText:
WideString);
//TLabelのCaptionにWideStringを可逆変換関数でAnsiStringにしてセット。
begin
inherited Caption := F_WideToAnsi(sText);
end;
procedure TMyLabel.DoDrawText(
var Rect: TRect; Flags: Longint);
//Unicode表示。
//オリジナルのDrawTextをDrawTextWに変えた。
var
ls_Text:
WideString;
begin
ls_Text := F_AnsiToWide(GetLabelText);
if (Flags
and DT_CALCRECT <> 0)
and ((ls_Text = '')
or ShowAccelChar
and (Text[1] = '&')
and (Text[2] = #0))
then begin
ls_Text := ls_Text + ' ';
end;
if not(ShowAccelChar)
then Flags := Flags
or DT_NOPREFIX;
if (F_bSingleLine)
then begin
Flags := Flags
or DT_SINGLELINE;
end else begin
if ((Flags
and DT_SINGLELINE) > 0)
then begin
Flags := Flags - DT_SINGLELINE;
end;
end;
Flags := DrawTextBiDiModeFlags(Flags);
Canvas.Font := Font;
if (Enabled = False)
and (F_bDisabledStyle = True)
then begin
OffsetRect(Rect, 1, 1);
Canvas.Font.Color := clBtnHighlight;
DrawTextW(Canvas.Handle, PWideChar(ls_Text), Length(ls_Text), Rect, Flags);
OffsetRect(Rect, -1, -1);
Canvas.Font.Color := clBtnShadow;
DrawTextW(Canvas.Handle, PWideChar(ls_Text), Length(ls_Text), Rect, Flags);
end else begin
//2008-10-02:AutoSizeがTrueの時描画が切れてしまうのでコメントアウト
if (Flags
and DT_CALCRECT = 0)
then begin
Inc(Rect.Left, F_iLeftMargin);
Dec(Rect.Right, F_iRightMargin);
end;
DrawTextW(Canvas.Handle, PWideChar(ls_Text), Length(ls_Text), Rect, Flags);
if (Flags
and DT_CALCRECT <> 0)
then begin
Inc(Rect.Right, F_iLeftMargin + F_iRightMargin);
end;
if (F_bsBorderStyle = lbSingle)
then begin
//枠を描画するのでその分を拡げる
Inc(Rect.Right, 2);
Inc(Rect.Bottom, 2);
end;
end;
//枠の描画
if (F_bsBorderStyle = lbSingle)
then begin
with Self
do begin
Canvas.Pen.Color := clBtnShadow;
Canvas.MoveTo(0, 0);
Canvas.LineTo(Width -1, 0);
Canvas.LineTo(Width -1, Height -1);
Canvas.LineTo(0, Height -1);
Canvas.LineTo(0, 0);
end;
end;
end;
//------------------------------------------------------------------------------
procedure Register;
begin
RegisterComponents('Samples', [TMyLabel]);
end;
end.