ホーム >プログラム >Delphiソースコード一覧 >lib >myLabel.pas
unit myLabel;
{Unicodeの表示に対応したLabel}

interface

uses
  Classes,
  Forms,
  Graphics,
  Windows,
  StdCtrls;

type
  TMyLabel = class(TLabel)
  private
    { Private 宣言 }
    F_bsBorderStyle:  TBorderStyle;  //ボーダースタイル
    F_bDisabledStyle: Boolean; //Enabled = False の時に影つきのグレイテキストにするか
    F_bTextShadow:    Boolean; //影つき
    F_bSingleLine:    Boolean; //改行を無視して一行表示にするか
    F_bEndEllipsis:   Boolean; //文字列を範囲内に収まらないとき末尾を...にするか
    F_iLeftMargin,             //左マージン
    F_iRightMargin,            //右マージン
    F_iTopMargin,              //上マージン
    F_iBottomMargin:  Integer; //下マージン

    function F_AnsiToWide(sSrc: AnsiString): WideString;
    function F_WideToAnsi(sSrc: WideString): AnsiString;
    function  GetText: WideString;
    procedure SetText(sText: WideString);

    procedure F_SetBorderStyle  (bsStyle: TBorderStyle);
    procedure F_SetDisabledStyle(bFlag: Boolean);
    procedure F_SetEndEllipsis  (bFlag: Boolean);
    procedure F_SetSingleLine   (bFlag: Boolean);
    procedure F_SetTextShadow   (bFlag: Boolean);
    procedure F_SetLeftMargin   (iLeft:   Integer);
    procedure F_SetRightMargin  (iRight:  Integer);
    procedure F_SetTopMargin    (iTop:    Integer);
    procedure F_SetBottomMargin (iBottom: Integer);
  protected
    { Protected 宣言 }
    procedure DoDrawText(var Rect: TRect; Flags: Longint); override;
  public
    constructor Create(AOwner: TComponent); override;
  published
    { Published 宣言 }
    property Border:        TBorderStyle read F_bsBorderStyle  write F_SetBorderStyle   default bsNone;
    property Caption:       WideString   read GetText          write SetText;
    property DisabledStyle: Boolean      read F_bDisabledStyle write F_SetDisabledStyle default True;
    property EndEllipsis:   Boolean      read F_bEndEllipsis   write F_SetEndEllipsis   default False;
    property SingleLine:    Boolean      read F_bSingleLine    write F_SetSingleLine    default False;
    property Shadow:        Boolean      read F_bTextShadow    write F_SetTextShadow    default False;
    property LeftMargin:    Integer      read F_iLeftMargin    write F_SetLeftMargin    default 0;
    property TopMargin:     Integer      read F_iTopMargin     write F_SetTopMargin     default 0;
    property RightMargin:   Integer      read F_iRightMargin   write F_SetRightMargin   default 0;
    property BottomMargin:  Integer      read F_iBottomMargin  write F_SetBottomMargin  default 0;

    property OnResize;
{
    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 default False;
    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
  SysUtils;


//------------------------------------------------------------------------------
function gfniNumLimit(iNum: Integer; iMin, iMax: Integer): Integer;
begin
  if (iMin = iMax) then begin
    Result := iMin;
  end else begin
    //間違いの元なので気を利かせるのをやめた
    //l_pcNumSwap_MinMax(iMin, iMax);
    if (iNum < iMin) then begin
      Result := iMin;
    end else if (iNum > iMax) then begin
      Result := iMax;
    end else begin
      Result := iNum;
    end;
  end;
end;


//------------------------------------------------------------------------------
{ MyLabel }
constructor TMyLabel.Create(AOwner: TComponent);
begin
  inherited;

  F_bsBorderStyle  := bsNone;
  F_bDisabledStyle := True;
  F_bEndEllipsis   := False;
  F_bSingleLine    := False;
  F_bTextShadow    := False;
  F_iLeftMargin    := 0;
  F_iTopMargin     := 0;
  F_iRightMargin   := 0;
  F_iBottomMargin  := 0;

  Color       := clBtnFace;
  ParentColor := False;
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.F_SetBorderStyle(bsStyle: TBorderStyle);
begin
  F_bsBorderStyle := bsStyle;
  Paint;
end;
procedure TMyLabel.F_SetDisabledStyle(bFlag: Boolean);
begin
  F_bDisabledStyle := bFlag;
  Paint;
end;
procedure TMyLabel.F_SetEndEllipsis(bFlag: Boolean);
begin
  F_bEndEllipsis := bFlag;
  Paint;
end;
procedure TMyLabel.F_SetSingleLine(bFlag: Boolean);
begin
  F_bSingleLine := bFlag;
  Paint;
end;
procedure TMyLabel.F_SetTextShadow(bFlag: Boolean);
begin
  F_bTextShadow := bFlag;
  Paint;
  Invalidate;
end;
procedure TMyLabel.F_SetLeftMargin(iLeft: Integer);
begin
  F_iLeftMargin := iLeft;
  Paint;
end;
procedure TMyLabel.F_SetRightMargin(iRight: Integer);
begin
  F_iRightMargin := iRight;
  Paint;
end;
procedure TMyLabel.F_SetTopMargin(iTop: Integer);
begin
  F_iTopMargin := iTop;
  Paint;
end;
procedure TMyLabel.F_SetBottomMargin(iBottom: Integer);
begin
  F_iBottomMargin := iBottom;
  Paint;
end;

procedure TMyLabel.DoDrawText(var Rect: TRect; Flags: Longint);
//Unicode表示。
//オリジナルのDrawTextをDrawTextWに変えた。
//2009-03-03:ボーダーラインを描くとレイアウトがうまくいっていなかった不具合を修正
const
  lci_SHADOW = $20;
var
  ls_Text:   WideString;
  lcl_Color: TColor;
  li_Red, li_Green, li_Blue: Integer;
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;

  if (F_bEndEllipsis) then begin
    Flags := Flags or DT_END_ELLIPSIS;
  end else begin
    if ((Flags and DT_END_ELLIPSIS) <> 0) then begin
      Flags := Flags - DT_END_ELLIPSIS;
    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
    if ((Flags and DT_CALCRECT) = 0) then begin
      Inc(Rect.Left,   F_iLeftMargin);
      Inc(Rect.Top,    F_iTopMargin);
      Dec(Rect.Right,  F_iRightMargin);
      Dec(Rect.Bottom, F_iBottomMargin);
      if (F_bsBorderStyle = bsSingle) then begin
        //枠を描画するのでその分を調整
        Inc(Rect.Left);
        Inc(Rect.Top);
        Dec(Rect.Right);
        Dec(Rect.Bottom);
      end;
      //影つき
      if (F_bTextShadow) then begin
        OffsetRect(Rect, 1, 1);
        lcl_Color := Canvas.Font.Color;
        li_Blue  := gfniNumLimit( lcl_Color shr 16          - lci_SHADOW, 0, $FFFFFF) shl 16;
        li_Green := gfniNumLimit((lcl_Color shr 8) mod $100 - lci_SHADOW, 0, $FFFFFF) shl  8;
        li_Red   := gfniNumLimit( lcl_Color        mod $100 - lci_SHADOW, 0, $FFFFFF);
//        Canvas.Font.Color := gfniNumLimit(lcl_Color - $606060, 0, $FFFFFF);
        Canvas.Font.Color := li_Blue + li_Green + li_Red;
        DrawTextW(Canvas.Handle, PWideChar(ls_Text), Length(ls_Text), Rect, Flags);
        Canvas.Font.Color := lcl_Color;
        OffsetRect(Rect, -1, -1);
      end;
    end;
    DrawTextW(Canvas.Handle, PWideChar(ls_Text), Length(ls_Text), Rect, Flags);

    if ((Flags and DT_CALCRECT) <> 0) then begin
{
      //計算するだけ
      Dec(Rect.Left,   F_iLeftMargin);
      Dec(Rect.Top,    F_iTopMargin);
      Inc(Rect.Right,  F_iRightMargin);
      Inc(Rect.Bottom, F_iBottomMargin);
      if (F_bsBorderStyle = bsSingle) then begin
        //枠を描画するのでその分を調整
        Dec(Rect.Left);
        Dec(Rect.Top);
        Inc(Rect.Right);
        Inc(Rect.Bottom);
      end;
}

      Inc(Rect.Right,  F_iLeftMargin + F_iRightMargin);
      Inc(Rect.Bottom, F_iTopMargin  + F_iBottomMargin);
      if (F_bsBorderStyle = bsSingle) then begin
        //枠を描画するのでその分を調整
        Inc(Rect.Right,  2);
        Inc(Rect.Bottom, 2);
      end;
    end;
  end;

  //枠の描画
  if ((Flags and DT_CALCRECT) = 0) and (F_bsBorderStyle = bsSingle) 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.