{----------------------------------------------------------------------------- The contents of this file are subject to the Mozilla Public License Version 1.1 (the "License"); you may not use this file except in compliance with the License. You may obtain a copy of the License at http://www.mozilla.org/MPL/MPL-1.1.html Software distributed under the License is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for the specific language governing rights and limitations under the License. The Original Code is: JvgLabel.PAS, released on 2003-01-15. The Initial Developer of the Original Code is Andrey V. Chudin, [chudin att yandex dott ru] Portions created by Andrey V. Chudin are Copyright (C) 2003 Andrey V. Chudin. All Rights Reserved. Contributor(s): Michael Beck [mbeck att bigfoot dott com]. You may retrieve the latest version of this file at the Project JEDI's JVCL home page, located at http://jvcl.sourceforge.net Known Issues: -----------------------------------------------------------------------------} // $Id: JvgLabel.pas 10612 2006-05-19 19:04:09Z jfudickar $ unit JvgLabel; {$I jvcl.inc} {$I windowsonly.inc} // (ahuser) uses WndProc and Wnd hooks interface uses {$IFDEF USEJVCL} {$IFDEF UNITVERSIONING} JclUnitVersioning, {$ENDIF UNITVERSIONING} {$ENDIF USEJVCL} Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, ExtCtrls, {$IFDEF USEJVCL} JvComponent, {$ENDIF USEJVCL} JvgTypes, JvgCommClasses, JvgUtils; const FTextAlign = DT_LEFT or DT_SINGLELINE; RadianEscapments: array [TglLabelDir] of Integer = (0, -1800, -900, 900); type TFontWeight = (fwDONTCARE, fwTHIN, fwEXTRALIGHT, fwLIGHT, fwNORMAL, fwMEDIUM, fwSEMIBOLD, fwBOLD, fwEXTRABOLD, fwHEAVY); {$IFDEF USEJVCL} TJvgCustomLabel = class(TJvGraphicControl) {$ELSE} TJvgCustomLabel = class(TGraphicControl) {$ENDIF USEJVCL} private FAutoSize: Boolean; FFocusControl: TWinControl; FFocusControlMethod: TFocusControlMethod; FTransparent: Boolean; FPrevWndProc: Pointer; FNewWndProc: Pointer; procedure SetFocusControl(Value: TWinControl); procedure SetTransparent(Value: Boolean); procedure WMLMouseUp(var Msg: TMessage); message WM_LBUTTONUP; procedure WMLMouseDown(var Msg: TMessage); message WM_LBUTTONDOWN; protected FActiveNow: Boolean; FShowAsActiveWhileControlFocused: Boolean; ActiveWhileControlFocused: Boolean; FNeedRehookFocusControl: Boolean; FExternalCanvas: TCanvas; procedure HookFocusControlWndProc; procedure UnhookFocusControlWndProc; procedure FocusControlWndHookProc(var Msg: TMessage); procedure Notification(AComponent: TComponent; Operation: TOperation); override; {$IFDEF USEJVCL} procedure MouseEnter(Control: TControl); override; procedure TextChanged; override; {$ENDIF USEJVCL} property AutoSize: Boolean read FAutoSize write FAutoSize default True; property FocusControl: TWinControl read FFocusControl write SetFocusControl; property FocusControlMethod: TFocusControlMethod read FFocusControlMethod write FFocusControlMethod default fcmOnMouseDown; property Transparent: Boolean read FTransparent write SetTransparent default True; property ExternalCanvas: TCanvas read FExternalCanvas write FExternalCanvas; procedure Paint; override; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; end; TJvgLabel = class(TJvgCustomLabel) private FDirection: TglLabelDir; FTextStyles: TJvgLabelTextStyles; FColors: TJvgLabelColors; FFontWeight: TFontWeight; // FActiveTextColor: TColor; FOptions: TglLabelOptions; FSupressPaint: Boolean; FGradient: TJvgGradient; FIllumination: TJvgIllumination; FTexture: TBitmap; FBackground: TBitmap; FTextureImage: TImage; FBackgroundImage: TImage; FAlignment: TAlignment; FUFontWeight: Word; FRunOnce: Boolean; FFirstCreate: Boolean; FNeedUpdateOnlyMainText: Boolean; FNeedRemakeTextureMask: Boolean; FImg: TBitmap; FTextureMask: TBitmap; FBackgroundBmp: TBitmap; FTextureBmp: TBitmap; FTargetCanvas: TCanvas; procedure SetDirection(Value: TglLabelDir); procedure SetFontWeight(Value: TFontWeight); procedure SetOptions(Value: TglLabelOptions); procedure SetTexture(Value: TBitmap); procedure SetBackground(Value: TBitmap); function GetTexture: TBitmap; function GetBackground: TBitmap; procedure SetTextureImage(Value: TImage); procedure SetBackgroundImage(Value: TImage); procedure SetAlignment(Value: TAlignment); procedure OnGradientChanged(Sender: TObject); procedure OnIlluminationChanged(Sender: TObject); procedure CreateLabelFont; procedure InvalidateLabel(UpdateBackgr: Boolean); protected {$IFDEF USEJVCL} procedure MouseEnter(Control: TControl); override; procedure MouseLeave(Control: TControl); override; procedure FontChanged; override; {$ENDIF USEJVCL} procedure Notification(AComponent: TComponent; Operation: TOperation); override; procedure Loaded; override; public FreeFont: TFont; constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure Paint; override; property SupressPaint: Boolean read FSupressPaint write FSupressPaint; property Canvas; property ExternalCanvas; published property Anchors; property Align; property Caption; property DragCursor; property DragMode; property Enabled; property Font; property ParentColor; property ParentFont; property ParentShowHint; property PopupMenu; // property ShowAccelChar; property ShowHint; property Visible; property OnClick; property OnDblClick; property OnDragDrop; property OnDragOver; property OnEndDrag; property OnMouseDown; property OnMouseMove; property OnMouseUp; property OnStartDrag; {$IFDEF USEJVCL} property OnMouseEnter; property OnMouseLeave; {$ENDIF USEJVCL} property FocusControl; property FocusControlMethod; property AutoSize; property Transparent; property Direction: TglLabelDir read FDirection write SetDirection default fldLeftRight; property TextStyles: TJvgLabelTextStyles read FTextStyles write FTextStyles; property Colors: TJvgLabelColors read FColors write FColors; property FontWeight: TFontWeight read FFontWeight write SetFontWeight; property Options: TglLabelOptions read FOptions write SetOptions; property Gradient: TJvgGradient read FGradient write FGradient; property Illumination: TJvgIllumination read FIllumination write FIllumination; property Texture: TBitmap read GetTexture write SetTexture; property Background: TBitmap read GetBackground write SetBackground; property TextureImage: TImage read FTextureImage write SetTextureImage; property BackgroundImage: TImage read FBackgroundImage write SetBackgroundImage; property Alignment: TAlignment read FAlignment write SetAlignment; end; TJvgStaticTextLabel = class(TJvgCustomLabel) private FActiveColor: TColor; FAlignment: TglAlignment; FOptions: TglStaticTextOptions; FWordWrap: Boolean; procedure DrawTextBroadwise(Canvas: TCanvas); procedure AdjustBounds; procedure SetAlignment(Value: TglAlignment); procedure SetOptions(Value: TglStaticTextOptions); procedure SetWordWrap(Value: Boolean); function GetAutoSize: Boolean; protected procedure SetAutoSize(Value: Boolean); override; {$IFDEF USEJVCL} procedure MouseEnter(Control: TControl); override; procedure MouseLeave(Control: TControl); override; {$ENDIF USEJVCL} public constructor Create(AOwner: TComponent); override; procedure Paint; override; property Canvas; property ExternalCanvas; published property Anchors; property Align; property Caption; property Color; property DragCursor; property DragMode; property Enabled; property Font; property ParentColor; property ParentFont; property ParentShowHint; property PopupMenu; property ShowHint; property Visible; property OnClick; property OnDblClick; property OnDragDrop; property OnDragOver; property OnEndDrag; property OnMouseDown; property OnMouseMove; property OnMouseUp; property OnStartDrag; {$IFDEF USEJVCL} property OnMouseEnter; property OnMouseLeave; {$ENDIF USEJVCL} property FocusControl; property FocusControlMethod; property Transparent; property ActiveColor: TColor read FActiveColor write FActiveColor default clWhite; property Alignment: TglAlignment read FAlignment write SetAlignment default ftaBroadwise; property AutoSize: Boolean read GetAutoSize write SetAutoSize; property Options: TglStaticTextOptions read FOptions write SetOptions; property WordWrap: Boolean read FWordWrap write SetWordWrap default True; end; TJvgGlyphLabel = class(TJvgLabel) private FGlyphOn: TBitmap; FGlyphOff: TBitmap; FGlyphDisabled: TBitmap; FGlyphKind: TglGlyphKind; function IsCustomGlyph: Boolean; procedure SetGlyphOn(Value: TBitmap); function GetGlyphOn: TBitmap; procedure SetGlyphOff(Value: TBitmap); function GetGlyphOff: TBitmap; procedure SetGlyphDisabled(Value: TBitmap); function GetGlyphDisabled: TBitmap; procedure SetGlyphKind(Value: TglGlyphKind); public constructor Create(AOwner: TComponent); override; destructor Destroy; override; published property GlyphKind: TglGlyphKind read FGlyphKind write SetGlyphKind default fgkDefault; property GlyphOn: TBitmap read GetGlyphOn write SetGlyphOn stored True; property GlyphOff: TBitmap read GetGlyphOff write SetGlyphOff stored True; property GlyphDisabled: TBitmap read GetGlyphDisabled write SetGlyphDisabled stored IsCustomGlyph; end; {$IFDEF USEJVCL} {$IFDEF UNITVERSIONING} const UnitVersioning: TUnitVersionInfo = ( RCSfile: '$URL: https://jvcl.svn.sourceforge.net/svnroot/jvcl/tags/JVCL3_32/run/JvgLabel.pas $'; Revision: '$Revision: 10612 $'; Date: '$Date: 2006-05-19 21:04:09 +0200 (ven., 19 mai 2006) $'; LogPath: 'JVCL\run' ); {$ENDIF UNITVERSIONING} {$ENDIF USEJVCL} implementation uses {$IFDEF USEJVCL} Math, JvJVCLUtils; {$ELSE} Math; {$ENDIF USEJVCL} {$IFNDEF USEJVCL} function JvMakeObjectInstance(Method: TWndMethod): Pointer; begin {$IFDEF COMPILER6_UP} Result := Classes.MakeObjectInstance(Method); {$ELSE} Result := MakeObjectInstance(Method); {$ENDIF COMPILER6_UP} end; procedure JvFreeObjectInstance(ObjectInstance: Pointer); begin if ObjectInstance <> nil then {$IFDEF COMPILER6_UP} Classes.FreeObjectInstance(ObjectInstance); {$ELSE} FreeObjectInstance(ObjectInstance); {$ENDIF COMPILER6_UP} end; {$ENDIF !USEJVCL} //=== { TJvgCustomLabel } ==================================================== constructor TJvgCustomLabel.Create(AOwner: TComponent); begin inherited Create(AOwner); ControlStyle := ControlStyle + [csOpaque, csReplicatable]; ActiveWhileControlFocused := True; FAutoSize := True; FTransparent := True; FFocusControlMethod := fcmOnMouseDown; end; destructor TJvgCustomLabel.Destroy; begin SetFocusControl(nil); inherited Destroy; end; procedure TJvgCustomLabel.Paint; begin //...if FocusControl have changed his parent in Run-Time... if FNeedRehookFocusControl then HookFocusControlWndProc; //don't inherited; end; procedure TJvgCustomLabel.Notification(AComponent: TComponent; Operation: TOperation); begin inherited Notification(AComponent, Operation); if (AComponent = FocusControl) and (Operation = opRemove) then begin {UnhookFocusControlWndProc;} FFocusControl := nil; end; end; {$IFDEF USEJVCL} procedure TJvgCustomLabel.MouseEnter(Control: TControl); begin if csDesigning in ComponentState then Exit; inherited MouseEnter(Control); if Assigned(FocusControl) and (FocusControlMethod = fcmOnMouseEnter) then FocusControl.SetFocus; end; {$ENDIF USEJVCL} procedure TJvgCustomLabel.WMLMouseUp(var Msg: TMessage); begin inherited; if Enabled and (FocusControlMethod = fcmOnMouseUp) and Assigned(FocusControl) and FocusControl.CanFocus then FocusControl.SetFocus; end; procedure TJvgCustomLabel.WMLMouseDown(var Msg: TMessage); begin inherited; if Enabled and (FocusControlMethod = fcmOnMouseDown) and Assigned(FocusControl) and FocusControl.CanFocus then FocusControl.SetFocus; end; {$IFDEF USEJVCL} procedure TJvgCustomLabel.TextChanged; begin inherited TextChanged; Invalidate; end; {$ENDIF USEJVCL} procedure TJvgCustomLabel.HookFocusControlWndProc; var P: Pointer; begin P := Pointer(GetWindowLong(FocusControl.Handle, GWL_WNDPROC)); if P <> FNewWndProc then begin FPrevWndProc := P; FNewWndProc := JvMakeObjectInstance(FocusControlWndHookProc); SetWindowLong(FocusControl.Handle, GWL_WNDPROC, Longint(FNewWndProc)); end; end; procedure TJvgCustomLabel.UnhookFocusControlWndProc; begin // if not(csDesigning in ComponentState) then Exit; if (FNewWndProc <> nil) and (FPrevWndProc <> nil) and (Pointer(GetWindowLong(FocusControl.Handle, GWL_WNDPROC)) = FNewWndProc) then begin SetWindowLong(FocusControl.Handle, GWL_WNDPROC, Longint(FPrevWndProc)); // (rom) JvFreeObjectInstance call added JvFreeObjectInstance(FNewWndProc); FNewWndProc := nil; end; end; procedure TJvgCustomLabel.FocusControlWndHookProc(var Msg: TMessage); begin case Msg.Msg of WM_SETFOCUS: begin {$IFDEF USEJVCL} MouseEnter(Self); {$ENDIF USEJVCL} FShowAsActiveWhileControlFocused := True; end; WM_KILLFOCUS: begin FShowAsActiveWhileControlFocused := False; {$IFDEF USEJVCL} MouseLeave(Self); {$ENDIF USEJVCL} end; WM_DESTROY: FNeedRehookFocusControl := True; end; Msg.Result := CallWindowProc(FPrevWndProc, TForm(Owner).Handle, Msg.Msg, Msg.WParam, Msg.LParam); end; procedure TJvgCustomLabel.SetFocusControl(Value: TWinControl); begin if FFocusControl = Value then Exit; if ActiveWhileControlFocused and Assigned(FFocusControl) then UnhookFocusControlWndProc; FFocusControl := Value; if ActiveWhileControlFocused and Assigned(FFocusControl) then HookFocusControlWndProc; end; procedure TJvgCustomLabel.SetTransparent(Value: Boolean); begin FTransparent := Value; Invalidate; end; //=== { TJvgLabel } ========================================================== constructor TJvgLabel.Create(AOwner: TComponent); begin inherited Create(AOwner); TextStyles := TJvgLabelTextStyles.Create; Colors := TJvgLabelColors.Create; Gradient := TJvgGradient.Create; FIllumination := TJvgIllumination.Create; FImg := TBitmap.Create; FFirstCreate := True; FreeFont := TFont.Create; if csDesigning in ComponentState then Self.Font.Name := 'Arial'; AutoSize := True; // FRunOnce:=False; // FActiveNow := False; FDirection := fldLeftRight; FFontWeight := fwDONTCARE; // FSupressPaint := False; FUFontWeight := Word(fwDONTCARE); // FNeedUpdateOnlyMainText:=False; FGradient.OnChanged := OnGradientChanged; FIllumination.OnChanged := OnIlluminationChanged; TextStyles.OnChanged := OnIlluminationChanged; Colors.OnChanged := OnIlluminationChanged; FOptions := [floActiveWhileControlFocused]; FTargetCanvas := Canvas; FTransparent := True; Width := 100; Height := 16; end; destructor TJvgLabel.Destroy; begin TextStyles.Free; Colors.Free; Gradient.Free; FIllumination.Free; FTexture.Free; FBackground.Free; FTextureMask.Free; FImg.Free; inherited Destroy; DeleteObject(FreeFont.Handle); FreeFont.Free; end; procedure TJvgLabel.Notification(AComponent: TComponent; Operation: TOperation); begin inherited Notification(AComponent, Operation); if (AComponent = BackgroundImage) and (Operation = opRemove) then BackgroundImage := nil else if (AComponent = TextureImage) and (Operation = opRemove) then TextureImage := nil; end; {$IFDEF USEJVCL} procedure TJvgLabel.FontChanged; begin inherited FontChanged; CreateLabelFont; Invalidate; end; procedure TJvgLabel.MouseEnter(Control: TControl); begin if csDesigning in ComponentState then Exit; if not Enabled or (floIgnoreMouse in Options) or FShowAsActiveWhileControlFocused then Exit; //inherited; FActiveNow := True; with TextStyles, Colors do if (Passive <> Active) or ((Background <> BackgroundActive) and not Transparent) then begin if floBufferedDraw in Options then Repaint else InvalidateLabel(True); end else if (floDelineatedText in Options) and (DelineateActive <> Delineate) then Repaint else if TextActive <> Text then begin FNeedUpdateOnlyMainText := True; Repaint; end; inherited MouseEnter(Control); end; procedure TJvgLabel.MouseLeave(Control: TControl); begin if csDesigning in ComponentState then Exit; if not Enabled or (floIgnoreMouse in Options) or FShowAsActiveWhileControlFocused then Exit; //inherited; FActiveNow := False; with TextStyles, Colors do if (Passive <> Active) or ((Background <> BackgroundActive) and not Transparent) then begin if floBufferedDraw in Options then Repaint else InvalidateLabel(True); end else if (floDelineatedText in Options) and (DelineateActive <> Delineate) then Repaint else if TextActive <> Text then begin FNeedUpdateOnlyMainText := True; Repaint; end; inherited MouseLeave(Control); end; {$ENDIF USEJVCL} procedure TJvgLabel.Loaded; begin inherited Loaded; if FTexture <> nil then FTextureBmp := FTexture else if Assigned(FTextureImage) then FTextureBmp := FTextureImage.Picture.Bitmap else FTextureBmp := nil; if Assigned(FBackground) then FBackgroundBmp := FBackground else if Assigned(FBackgroundImage) then FBackgroundBmp := FBackgroundImage.Picture.Bitmap else FBackgroundBmp := nil; end; procedure TJvgLabel.Paint; var R: TRect; X, Y, X1, Y1, TX, TY: Integer; Size, TextSize: TSize; FontColor: TColor; CurrTextStyle: TglTextStyle; CurrDelinColor: TColor; OldGradientFActive, LUseBackgroundBmp, LUseTextureBmp, LBufferedDraw: Boolean; begin inherited Paint; if FSupressPaint or (Length(Caption) = 0) then Exit; if floTransparentFont in Options then LBufferedDraw := True else LBufferedDraw := (floBufferedDraw in Options) and not (csDesigning in ComponentState); if LBufferedDraw then FTargetCanvas := FImg.Canvas else if Assigned(ExternalCanvas) then FTargetCanvas := ExternalCanvas else FTargetCanvas := Canvas; FNeedUpdateOnlyMainText := FNeedUpdateOnlyMainText and not LBufferedDraw and (not IsItAFilledBitmap(FBackgroundBmp)); if not FRunOnce then begin FNeedUpdateOnlyMainText := False; FRunOnce := True; end; FTargetCanvas.Font := FreeFont; //...CALC POSITION GetTextExtentPoint32(FTargetCanvas.Handle, PChar(Caption), Length(Caption), Size); with TextStyles, Colors do if FActiveNow then begin CurrTextStyle := Active; CurrDelinColor := DelineateActive; FontColor := TextActive; end else if Enabled then begin CurrTextStyle := Passive; CurrDelinColor := Delineate; FontColor := Text; end else begin CurrTextStyle := Disabled; CurrDelinColor := Delineate; FontColor := TextDisabled; end; X := 0; Y := 0; Size.cx := Size.cx + 2 + Trunc(Size.cx * 0.01); // Size.cy:=Size.cy+Trunc(Size.cy*0.1); Size.cy := Size.cy + 2; TextSize := Size; if (CurrTextStyle = fstShadow) or (CurrTextStyle = fstVolumetric) then begin Inc(Size.cy, Illumination.ShadowDepth); Inc(Size.cx, Illumination.ShadowDepth); end; if floDelineatedText in Options then begin Inc(Size.cy, 2); Inc(Size.cx, 2); end; if (Align = alNone) and AutoSize then case FDirection of fldLeftRight, fldRightLeft: begin Width := Size.cx; Height := Size.cy; end; else {fldDownUp,fldUpDown:} begin Width := Size.cy; Height := Size.cx; end; end; // pt := CalcAlignedTextPosition( FTargetCanvas.Handle, Caption, Size ); // X := pt.X; Y := pt.Y; //CalcAlignedTextPosition( FTargetCanvas.Handle, Caption, Size ); case FDirection of fldLeftRight: begin //if Align = alNone then begin Width:=Max(w,Size.cx);Height:=Max(h,Size.cy); end; case Alignment of taCenter: X := (Width - Size.cx) div 2; taRightJustify: X := Width - Size.cx; end; end; fldRightLeft: begin //if Align = alNone then begin Width:=Max(w,Size.cx);Height:=Max(h,Size.cy);X:=Width;Y:=Height; end; case Alignment of taCenter: X := (Width + Size.cx) div 2; taLeftJustify: X := Width - (Size.cx - TextSize.cx) - 2; else X := TextSize.cx; end; Y := TextSize.cy; end; fldDownUp: begin //if Align = alNone then begin Height:=Max(h,Size.cx);Width:=Max(w,Size.cy);Y:=Height-2; end; case Alignment of taCenter: Y := (Height + TextSize.cx - (Size.cy - TextSize.cy)) div 2; taRightJustify: Y := TextSize.cx - 4; else Y := Height - (Size.cy - TextSize.cy) - 2; end; end; fldUpDown: begin //if Align = alNone then begin Height:=Max(h,Size.cx);Width:=Max(w,Size.cy);X:=Width; end; case Alignment of taCenter: Y := (Height - Size.cx) div 2; taRightJustify: Y := Height - Size.cx; else Y := 1; end; X := TextSize.cy; end; end; //...CALC POSITION end R := GetClientRect; if FTargetCanvas = FImg.Canvas then begin FImg.Width := Width; FImg.Height := Height; end; SetBkMode(FTargetCanvas.Handle, Windows.TRANSPARENT); if not Transparent then begin FTargetCanvas.Brush.Style := bsSolid; if FActiveNow then FTargetCanvas.Brush.Color := Colors.BackgroundActive else FTargetCanvas.Brush.Color := Colors.Background; FTargetCanvas.FillRect(R); end; try LUseBackgroundBmp := IsItAFilledBitmap(FBackgroundBmp); except // raise; LUseBackgroundBmp := False; FBackgroundBmp := nil; FBackgroundImage := nil; end; try LUseTextureBmp := IsItAFilledBitmap(FTextureBmp); except LUseTextureBmp := False; FTextureBmp := nil; FTextureImage := nil; end; // ShadowColor_ := Colors.Shadow; // HighlightColor_ := Colors.Highlight; if LUseBackgroundBmp then begin //...FillBackground TX := 0; TY := 0; while TX < Width do begin while TY < Height do begin BitBlt(FTargetCanvas.Handle, TX, TY, FBackgroundBmp.Width, FBackgroundBmp.Height, FBackgroundBmp.Canvas.Handle, 0, 0, SRCCOPY); Inc(TY, FBackgroundBmp.Height); end; Inc(TX, FBackgroundBmp.Width); TY := 0; end; end else if LBufferedDraw then with FTargetCanvas do begin if Transparent or (floTransparentFont in Options) then try Brush.Color := Parent.Brush.Color; Brush.Style := bsSolid; FillRect(R); Brush.Style := bsClear; GetParentImageRect(Self, Bounds(Left, Top, Width, Height), FTargetCanvas.Handle); except end; end; OldGradientFActive := Gradient.Active; //...Supress Gradient if needed with Colors do if (FActiveNow and (TextActive <> Text)) or not Enabled then Gradient.Active := False; if floDelineatedText in Options then begin X1 := 4; Y1 := 4; end else begin X1 := 2; Y1 := 2; end; if CurrTextStyle = fstNone then begin X1 := X1 div 2 - 1; Y1 := Y1 div 2 - 1; end; if CurrTextStyle = fstShadow then begin X1 := X1 div 2 - 1; Y1 := Y1 div 2 - 1; end; if {FNeedRemakeTextureMask and} LUseTextureBmp or (floTransparentFont in Options) then begin if not Assigned(FTextureMask) then FTextureMask := TBitmap.Create; with FTextureMask do begin Width := Self.Width; Height := Self.Height; Canvas.Brush.Color := clBlack; Canvas.Brush.Style := bsSolid; Canvas.FillRect(GetClientRect); Canvas.Font := FreeFont; Canvas.Font.Color := clWhite; if (CurrTextStyle = fstNone) or (CurrTextStyle = fstShadow) then Canvas.TextOut(X + X1, Y + Y1, Caption) else Canvas.TextOut(X + X1 div 2, Y + Y1 div 2, Caption); TX := 0; TY := 0; if not Self.Transparent then begin BitBlt(Canvas.Handle, TX, TY, Width, Height, FTargetCanvas.Handle, 0, 0, SRCAND); if FActiveNow then ChangeBitmapColor(FTextureMask, clBlack, Colors.BackgroundActive) else ChangeBitmapColor(FTextureMask, clBlack, Colors.Background); BitBlt(Self.Canvas.Handle, 0, 0, Width, Height, Canvas.Handle, 0, 0, SRCCOPY); Exit; end; if floTransparentFont in Options then BitBlt(Canvas.Handle, TX, TY, Width, Height, FTargetCanvas.Handle, 0, 0, SRCAND) else if LUseTextureBmp then //...fill mask with texture while TX < Width do begin while TY < Height do begin BitBlt(Canvas.Handle, TX, TY, FTextureBmp.Width, FTextureBmp.Height, FTextureBmp.Canvas.Handle, 0, 0, SRCAND); Inc(TY, FTextureBmp.Height); end; Inc(TX, FTextureBmp.Width); TY := 0; end; end; end; if IsItAFilledBitmap(FTextureBmp) then FontColor := 0; ExtTextOutExt(FTargetCanvas.Handle, X, Y, GetClientRect, Caption, CurrTextStyle, floDelineatedText in Options, FNeedUpdateOnlyMainText, FontColor, CurrDelinColor, Colors.Highlight, Colors.Shadow, Illumination, Gradient, FreeFont); // SetBkMode( FTargetCanvas.Handle, iOldBkMode ); FNeedUpdateOnlyMainText := False; Gradient.Active := OldGradientFActive; if (Assigned(FTextureBmp) or (floTransparentFont in Options)) and (CurrTextStyle <> fstPushed) then if Assigned(FTextureMask) then {fix access violation! WPostma.} BitBlt(FTargetCanvas.Handle, 0, 0, FTextureMask.Width, FTextureMask.Height, FTextureMask.Canvas.Handle, 0, 0, SRCPAINT); if FImg.Canvas = FTargetCanvas then BitBlt(Canvas.Handle, 0, 0, FImg.Width, FImg.Height, FTargetCanvas.Handle, 0, 0, SRCCOPY); //R:=Rect(Left,Top,Left+Width,Top+Height); //ValidateRect( Parent.Handle, @R ); end; procedure TJvgLabel.CreateLabelFont; begin if not FFirstCreate then DeleteObject(FreeFont.Handle); FreeFont.Handle := CreateRotatedFont(Font, RadianEscapments[FDirection]); FFirstCreate := False; end; procedure TJvgLabel.InvalidateLabel(UpdateBackgr: Boolean); var R: TRect; begin R := Bounds(Left, Top, Width, Height); if not (csDestroying in ComponentState) then InvalidateRect(Parent.Handle, @R, UpdateBackgr); end; procedure TJvgLabel.OnGradientChanged(Sender: TObject); begin FNeedUpdateOnlyMainText := True; Repaint; //InvalidateLabel(False); end; procedure TJvgLabel.OnIlluminationChanged(Sender: TObject); begin CalcShadowAndHighlightColors((Parent as TWinControl).Brush.Color, Colors); InvalidateLabel(True); end; procedure TJvgLabel.SetDirection(Value: TglLabelDir); begin FDirection := Value; CreateLabelFont; FNeedRemakeTextureMask := True; InvalidateLabel(True); end; procedure TJvgLabel.SetFontWeight(Value: TFontWeight); begin if FFontWeight = Value then Exit; FFontWeight := Value; FUFontWeight := Word(Value) * 100; CreateLabelFont; FNeedRemakeTextureMask := True; InvalidateLabel(True); end; procedure TJvgLabel.SetOptions(Value: TglLabelOptions); begin if FOptions = Value then Exit; FOptions := Value; ActiveWhileControlFocused := floActiveWhileControlFocused in Options; if floTransparentFont in Options then Options := Options + [floBufferedDraw]; CalcShadowAndHighlightColors((Parent as TWinControl).Brush.Color, Colors); FNeedRemakeTextureMask := True; InvalidateLabel(True); end; procedure TJvgLabel.SetTexture(Value: TBitmap); begin if Assigned(FTexture) then FTexture.Free; FTexture := nil; if (Value <> nil) and (Value.Handle <> 0) then begin FTexture := TBitmap.Create; FTexture.Assign(Value); FTextureBmp := FTexture; end else if Assigned(FTextureImage) then FTextureBmp := FTextureImage.Picture.Bitmap else FTextureBmp := nil; FNeedRemakeTextureMask := True; InvalidateLabel(True); end; procedure TJvgLabel.SetBackground(Value: TBitmap); begin if Assigned(FBackground) then FBackground.Free; FBackground := nil; if (Value <> nil) and (Value.Handle <> 0) then begin FBackground := TBitmap.Create; FBackground.Assign(Value); FBackgroundBmp := FBackground; end else if FBackgroundImage <> nil then FBackgroundBmp := FBackgroundImage.Picture.Bitmap else FBackgroundBmp := nil; InvalidateLabel(True); end; function TJvgLabel.GetTexture: TBitmap; begin if not Assigned(FTexture) then FTexture := TBitmap.Create; Result := FTexture; end; function TJvgLabel.GetBackground: TBitmap; begin if not Assigned(FBackground) then FBackground := TBitmap.Create; Result := FBackground; end; procedure TJvgLabel.SetTextureImage(Value: TImage); begin FTextureImage := Value; //mb if (not IsItAFilledBitmap(FTexture)) and Assigned(Value) then if Value <> nil then begin FTextureBmp := FTextureImage.Picture.Bitmap; end else if FTexture <> nil then FTextureBmp := FTexture else FTextureBmp := nil; InvalidateLabel(True); end; procedure TJvgLabel.SetBackgroundImage(Value: TImage); begin FBackgroundImage := Value; //mb if (not IsItAFilledBitmap(FBackground)) and Assigned(Value) then if Value <> nil then begin FBackgroundBmp := FBackgroundImage.Picture.Bitmap; InvalidateLabel(True); end else if FBackground <> nil then FBackgroundBmp := FBackground else FBackgroundBmp := nil; InvalidateLabel(True); end; procedure TJvgLabel.SetAlignment(Value: TAlignment); begin FAlignment := Value; Invalidate; end; //=== { TJvgStaticTextLabel } ================================================ constructor TJvgStaticTextLabel.Create(AOwner: TComponent); begin inherited Create(AOwner); FActiveColor := clWhite; FAlignment := ftaBroadwise; FOptions := [ftoActiveWhileControlFocused]; FWordWrap := True; Width := 100; Height := 16; end; {$IFDEF USEJVCL} procedure TJvgStaticTextLabel.MouseEnter(Control: TControl); begin if (ftoIgnoreMouse in Options) or FShowAsActiveWhileControlFocused then Exit; FActiveNow := True; Repaint; inherited MouseEnter(Control); end; procedure TJvgStaticTextLabel.MouseLeave(Control: TControl); begin if (ftoIgnoreMouse in Options) or FShowAsActiveWhileControlFocused then Exit; FActiveNow := False; if ftoUnderlinedActive in Options then Invalidate else Repaint; inherited MouseLeave(Control); end; {$ENDIF USEJVCL} procedure TJvgStaticTextLabel.Paint; const Alignments: array [TglAlignment] of Word = (DT_LEFT, DT_RIGHT, DT_CENTER, 0); WordWraps: array [Boolean] of Word = (0, DT_WORDBREAK); var LAlignment: TglAlignment; FTargetCanvas: TCanvas; Rect: TRect; begin //inherited; if Caption = '' then Exit; if Assigned(ExternalCanvas) then FTargetCanvas := ExternalCanvas else FTargetCanvas := Canvas; FTargetCanvas.Font.Assign(Font); LAlignment := FAlignment; SetBkMode(FTargetCanvas.Handle, Integer(FTransparent)); { if FActiveNow and(ftoUnderlinedActive in Options) then FTargetCanvas.Font.Style := Font.Style + [fsUnderline] else FTargetCanvas.Font.Style := Font.Style - [fsUnderline]; } if FActiveNow then SetTextColor(FTargetCanvas.Handle, ColorToRGB(ActiveColor)) else SetTextColor(FTargetCanvas.Handle, ColorToRGB(Font.Color)); // TextOut( FTargetCanvas.Handle, 0, 0, 'lpszString', 10); // BitBlt( FTargetCanvas.Handle, 0, 0, Width, Height, Image.FTargetCanvas.Handle, Width, Height, SRCCOPY ); if Alignment = ftaBroadwise then begin if FWordWrap then begin DrawTextBroadwise(FTargetCanvas); Exit; end else LAlignment := ftaLeftJustify; end; Rect := ClientRect; Windows.DrawText(FTargetCanvas.Handle, PChar(Caption), Length(Caption), Rect, DT_EXPANDTABS or WordWraps[FWordWrap] or Alignments[LAlignment]); end; procedure TJvgStaticTextLabel.DrawTextBroadwise(Canvas: TCanvas); var DrawPos, Pos1, Pos2, LineWidth, LineNo, LexemCount, TextHeight: Integer; Lexem: string; Size: TSize; LStop, LBroadwiseLine: Boolean; function GetNextLexem(var Pos1, Pos2: Integer; ATrimLeft: Boolean): string; var Pos: Integer; begin Pos := Pos1; if Caption[Pos] = ' ' then repeat Inc(Pos); until (Pos > Length(Caption)) or (Caption[Pos] <> ' '); Pos2 := Pos; if ATrimLeft and (LineNo > 0) then Pos1 := Pos; repeat Inc(Pos2); until (Pos2 > Length(Caption)) or (Caption[Pos2] = ' '); Result := Copy(Caption, Pos1, Pos2 - Pos1); end; procedure DrawLine(AdditSpace: Cardinal); var I, DrawPos1, DrawPos2: Integer; Lexem: string; Size: TSize; X, X1: Single; begin DrawPos1 := DrawPos; DrawPos2 := DrawPos; X := 0; X1 := 0; LineWidth := 0; for I := 1 to LexemCount do begin Lexem := GetNextLexem(DrawPos1, DrawPos2, I = 1); // if LexemCount=1 then Lexem:=Lexem+' '; GetTextExtentPoint32(Canvas.Handle, PChar(Lexem), Length(Lexem), Size); Inc(LineWidth, Trunc(X)); X := X + Size.cx; if (Trunc(X) > Width) and (LexemCount > 1) then Exit; if (LexemCount > 1) and LBroadwiseLine then X := X + AdditSpace / (LexemCount - 1); TextOut(Canvas.Handle, Trunc(X1), LineNo * TextHeight, PChar(Lexem), Length(Lexem)); X1 := X; DrawPos1 := DrawPos2; end; end; begin if Text = '' then Exit; LineWidth := 0; LineNo := 0; DrawPos := 1; Pos1 := 1; Pos2 := 1; LexemCount := 0; TextHeight := 0; LStop := False; LBroadwiseLine := True; repeat Lexem := GetNextLexem(Pos1, Pos2, LexemCount = 0); // if LexemCount=0 then Lexem:=Lexem+' '; GetTextExtentPoint32(Canvas.Handle, PChar(Lexem), Length(Lexem), Size); Inc(LineWidth, Size.cx); Inc(LexemCount); if TextHeight < Size.cy then TextHeight := Size.cy; if (LineWidth > Width) or (Pos2 >= Length(Caption)) then begin if LineWidth > Width then begin if LexemCount = 1 then Pos1 := Pos2; if LexemCount > 1 then Dec(LexemCount); DrawLine(Width - (LineWidth - Size.cx)); DrawPos := Pos1; Inc(LineNo); LexemCount := 0; LineWidth := 0; LStop := Pos1 > Length(Caption); end else begin LBroadwiseLine := ftoBroadwiseLastLine in Options; DrawLine(Width - LineWidth); Inc(LineNo); LStop := True; end; end else Pos1 := Pos2; until LStop; if FAutoSize then Height := Max(12, LineNo * TextHeight); end; procedure TJvgStaticTextLabel.AdjustBounds; const WordWraps: array [Boolean] of Word = (0, DT_WORDBREAK); var DC: HDC; X: Integer; Rect: TRect; begin if not (csReading in ComponentState) and FAutoSize then begin Rect := ClientRect; DC := GetDC(HWND_DESKTOP); Canvas.Handle := DC; Windows.DrawText(Canvas.Handle, PChar(Caption), Length(Caption), Rect, DT_EXPANDTABS or DT_CALCRECT or WordWraps[FWordWrap]); Canvas.Handle := 0; ReleaseDC(HWND_DESKTOP, DC); X := Left; if FAlignment = ftaRightJustify then Inc(X, Width - Rect.Right); SetBounds(X, Top, Rect.Right, Rect.Bottom); end; end; procedure TJvgStaticTextLabel.SetAlignment(Value: TglAlignment); begin FAlignment := Value; Invalidate; end; procedure TJvgStaticTextLabel.SetOptions(Value: TglStaticTextOptions); begin FOptions := Value; ActiveWhileControlFocused := ftoActiveWhileControlFocused in Options; Invalidate; end; procedure TJvgStaticTextLabel.SetWordWrap(Value: Boolean); begin FWordWrap := Value; Invalidate; end; procedure TJvgStaticTextLabel.SetAutoSize(Value: Boolean); begin inherited AutoSize := Value; AdjustBounds; end; function TJvgStaticTextLabel.GetAutoSize: Boolean; begin Result := inherited AutoSize; end; //=== { TJvgGlyphLabel } ===================================================== // (rom) Glyph handling is a mess constructor TJvgGlyphLabel.Create(AOwner: TComponent); begin inherited Create(AOwner); ControlStyle := [csCaptureMouse, csOpaque, csClickEvents, csSetCaption, csReplicatable]; end; destructor TJvgGlyphLabel.Destroy; begin FGlyphOn.Free; FGlyphOff.Free; FGlyphDisabled.Free; inherited Destroy; end; function TJvgGlyphLabel.IsCustomGlyph: Boolean; begin Result := FGlyphKind = fgkCustom; end; procedure TJvgGlyphLabel.SetGlyphOn(Value: TBitmap); begin if Assigned(FGlyphOn) then FGlyphOn.Free; FGlyphOn := TBitmap.Create; FGlyphKind := fgkCustom; FGlyphOn.Assign(Value); Invalidate; end; function TJvgGlyphLabel.GetGlyphOn: TBitmap; begin if not Assigned(FGlyphOn) then FGlyphOn := TBitmap.Create; Result := FGlyphOn; end; procedure TJvgGlyphLabel.SetGlyphOff(Value: TBitmap); begin if Assigned(FGlyphOff) then FGlyphOff.Free; FGlyphOff := TBitmap.Create; FGlyphKind := fgkCustom; FGlyphOff.Assign(Value); Invalidate; end; function TJvgGlyphLabel.GetGlyphOff: TBitmap; begin if not Assigned(FGlyphOff) then FGlyphOff := TBitmap.Create; Result := FGlyphOff; end; procedure TJvgGlyphLabel.SetGlyphDisabled(Value: TBitmap); begin if Assigned(FGlyphDisabled) then FGlyphDisabled.Free; FGlyphDisabled := TBitmap.Create; FGlyphDisabled.Assign(Value); Invalidate; end; function TJvgGlyphLabel.GetGlyphDisabled: TBitmap; begin if not Assigned(FGlyphDisabled) then FGlyphDisabled := TBitmap.Create; Result := FGlyphDisabled; end; procedure TJvgGlyphLabel.SetGlyphKind(Value: TglGlyphKind); begin if FGlyphKind <> Value then FGlyphKind := Value; if (FGlyphKind = fgkCustom) and (csReading in ComponentState) then begin GlyphOn := nil; GlyphOff := nil; GlyphDisabled := nil; end else begin FGlyphOn.Assign(nil); // fixes GDI resource leak FGlyphOff.Assign(nil); // fixes GDI resource leak FGlyphOn.LoadFromResourceName(HInstance, 'JvgON'); FGlyphOff.LoadFromResourceName(HInstance, 'JvgOFF'); FGlyphDisabled := TBitmap.Create; FGlyphDisabled.LoadFromResourceName(HInstance, 'JvgDISABLED'); end; end; {$IFDEF USEJVCL} {$IFDEF UNITVERSIONING} initialization RegisterUnitVersion(HInstance, UnitVersioning); finalization UnregisterUnitVersion(HInstance); {$ENDIF UNITVERSIONING} {$ENDIF USEJVCL} end.