|
PRÉSENTATION :
C'est un composant libellé dont le texte est orientable et étirable
NOTES :
Installation:
Installer le composant TOrLabel contenu dans le fichier UOrLabel.PAS
Utilisation: comme un label mais avec quelques changements :
- la propriété Font n'existe pas, utilisez OrFont
- OrFont.Orient définit la rotation par pas de 0,1 degré
- OrLabel ne fonctionne qu'avec des polices TrueType
- Alignement/WordWarp etc n'existent pas...
Remarques:
TOrFont n'est pas descendante de TFont, elle ne peut donc pas être assignée à un autre composant. Mais vous pouvez l'utiliser dans vos propres composants : voir la méthode Paint du TOrLabel pour l'utilisation du TOrFont.
TOrFont et TOrLabel fonctionnent avec Delphi5 et Delphi6.
CODE :
//
// TOrLabel : label orientable et étirable par Nono40
//
// ( Système de limitation d'occupation resources inspiré de Graphics.pas )
//
// 26/04/2002 : Création
// 27/04/2002 : Ajout de TOrFont.Incline
// : Ajout de TOrLabel.AutoSize
// : Ajout de TOrLabel.InclineMode
// 28/04/2002 : Ajout de quelques commentaires...
// : Ajout de TOrFont.Width
// 29/04/2002 : Modification de CalculXY pour tenir compte de OrFont.Width
//
// OrFont.Orient défini l'orientation du texte entier
// OrFont.Incline défini l'orientation de chaque caractère dans le texte
// Incline n'est utilisé que ici OrLabel.InclineMode=IM_ADVANCED
// IM_ADVANCED ne fonctionne qu'avec WNT4 et supérieur
// Incline et InclineMode sont ignorés avec W95,W98,WMe
// OrFont.Width défini la largeur moyenne de chaque caractère
// Une largeur de 0 utilise la proportion normale de la police
//
//
Unit UOrLabel;
{$P+,S-,W-,R-,T-,X+,H+,B-}
Interface
Uses Windows, SysUtils, Classes, Graphics, Controls, Messages;
Type
// Structure utilisée par le gestionnaire de ressource et décrivant un OrFont
POrFontData = ^TOrFontData;
TOrFontData = Record
Handle : HFont;
Height : Integer;
Pitch : TFontPitch;
Style : TFontStylesBase;
Charset : TFontCharset;
Name : TFontDataName;
Orient : Integer;
Incline : Integer;
Width : Integer;
End;
POrResource = ^TOrResource;
TOrResource = Record
Next : POrResource;
RefCount : Integer;
Handle : THandle;
HashCode : Word;
OrFont : TOrFontData;
End;
// Objet font orientable
TOrFont = Class(TGraphicsObject)
Private
FColor : TColor;
FPixelsPerInch : Integer;
FOrResource : POrResource;
Procedure GetData(Var OrFontData: TOrFontData);
Procedure SetData(Const OrFontData: TOrFontData);
Protected
Function GetHandle : HFont;
Function GetHeight : Integer;
Function GetName : TFontName;
Function GetPitch : TFontPitch;
Function GetSize : Integer;
Function GetStyle : TFontStyles;
Function GetCharset : TFontCharset;
Function GetOrient : Integer;
Function GetIncline : Integer;
Function GetWidth : Integer;
Procedure SetColor ( Value: TColor );
Procedure SetHandle ( Value: HFont );
Procedure SetHeight ( Value: Integer );
Procedure SetName (Const Value: TFontName );
Procedure SetPitch ( Value: TFontPitch );
Procedure SetSize ( Value: Integer );
Procedure SetStyle ( Value: TFontStyles );
Procedure SetCharset ( Value: TFontCharset );
Procedure SetOrient ( Value: Integer );
Procedure SetIncline ( Value: Integer );
Procedure SetWidth ( Value: Integer );
Public
Constructor Create;
Destructor Destroy; override;
Procedure Assign(Source: TPersistent); override;
Property Handle: HFont read GetHandle write SetHandle;
Property PixelsPerInch: Integer read FPixelsPerInch write FPixelsPerInch;
Published
Property Charset : TFontCharset read GetCharset write SetCharset;
Property Color : TColor read FColor write SetColor;
Property Height : Integer read GetHeight write SetHeight;
Property Name : TFontName read GetName write SetName;
Property Pitch : TFontPitch read GetPitch write SetPitch default fpDefault;
Property Size : Integer read GetSize write SetSize stored False;
Property Style : TFontStyles read GetStyle write SetStyle;
Property Orient : Integer read GetOrient write SetOrient;
Property Incline : Integer read GetIncline write SetIncline;
Property Width : Integer read GetWidth write SetWidth;
End;
// Définition du type label orientable
TInclineMode= (IM_COMPATIBLE,IM_ADVANCED);
TOrLabel = Class(TGraphicControl)
Private
FTransparent : Boolean; // Le texte est transparent
FOnMouseLeave : TNotifyEvent;
FOnMouseEnter : TNotifyEvent;
FOrFont : TOrFont; // Font orientable utilisée
FDecalX : Integer; // Déclage du coin haut gauche du texte par rapport
// au centre du composant
FDecalY : Integer; // Est déduit en fonction des autres propriétés et de la fonte
FInclineMode : TInclineMode; // Mode de gestion de la propriété incline de la fonte
// car incline n'est utilisable que sous NT4 ou supérieur
Procedure SetTransparent(Value: Boolean );
Procedure SetInclineMode(Value: TInclineMode );
Procedure CMTextChanged(Var Message: TMessage); message CM_TEXTCHANGED;
Procedure CMMouseEnter (Var Message: TMessage); message CM_MOUSEENTER;
Procedure CMMouseLeave (Var Message: TMessage); message CM_MOUSELEAVE;
Procedure OnOrFontChanged(Sender:TObject);
Procedure CalculXY; // Procédure interne qui calcule DecalX et DecalY
Protected
Procedure SetAutosize (Value: Boolean );Override;
Procedure Paint; override;
Public
Constructor Create(AOwner: TComponent); override;
Destructor Destroy; override;
Published
Property Transparent : Boolean read FTransparent write SetTransparent default False;
Property InclineMode : TInclineMode read FInclineMode Write SetInclineMode;
Property OrFont : TOrFont read FOrFont write FOrFont;
Property AutoSize;
Property Align;
Property Anchors;
Property Caption;
Property Color;
Property Constraints;
Property DragCursor;
Property DragKind;
Property DragMode;
Property Enabled;
Property ParentColor;
Property ParentShowHint;
Property PopupMenu;
Property ShowHint;
Property Visible;
Property OnClick;
Property OnContextPopup;
Property OnDblClick;
Property OnDragDrop;
Property OnDragOver;
Property OnEndDock;
Property OnEndDrag;
Property OnMouseDown;
Property OnMouseMove;
Property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;
Property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;
Property OnMouseUp;
Property OnStartDock;
Property OnStartDrag;
End;
Procedure Register;
Implementation
Uses Consts,Math;
Var
ScreenLogPixels: Integer;// Variable de finesse de l'écran pour définir Size en fonctoin de Height
IM_ADVANCED_OK : Boolean;// Variable à vrai di le mode étendu est utiliable, en fait à vrai si
// l'environnement est de type WNT4
{ Resource managers }
// Ce gestionnaire de ressources est inspiré de celui de Borland pour le TFont.
// Il permet de limité le nomnre de Handles de Font demandés à windows : toutes les OrFont
// identiques utiliseront le même HFont.
// ( ce qui évite le "out of ressource error" si souvent présent avec delphi 1 )
Type
TResourceManager = Class(TObject)
ResList: POrResource;
FLock: TRTLCriticalSection;
Constructor Create;
Destructor Destroy; override;
Function AllocResource(Const ResData): POrResource;
Procedure FreeResource(Resource: POrResource);
Procedure ChangeResource(GraphicsObject: TOrFont; Const ResData);
Procedure AssignResource(GraphicsObject: TOrFont; AResource: POrResource);
Procedure Lock;
Procedure Unlock;
End;
Var
OrFontManager: TResourceManager;
Function GetHashCode(Const Buffer; Count: Integer): Word; assembler;
Asm
MOV ECX,EDX
MOV EDX,EAX
Xor EAX,EAX
@@1: ROL AX,5
Xor AL,[EDX]
INC EDX
DEC ECX
JNE @@1
End;
Constructor TResourceManager.Create;
Begin
InitializeCriticalSection(FLock);
ResList := Nil;
End;
Destructor TResourceManager.Destroy;
Begin
DeleteCriticalSection(FLock);
End;
Procedure TResourceManager.Lock;
Begin
EnterCriticalSection(FLock);
End;
Procedure TResourceManager.Unlock;
Begin
LeaveCriticalSection(FLock);
End;
Function TResourceManager.AllocResource(Const ResData): POrResource;
Var
ResHash: Word;
Begin
ResHash := GetHashCode(ResData, SizeOf(TOrFontData));
Lock;
Try
Result := ResList;
While (Result <> Nil) And ((Result^.HashCode <> ResHash) Or
Not CompareMem(@Result^.OrFont, @ResData, SizeOf(TOrFontData))) Do
Result := Result^.Next;
If Result = Nil Then
Begin
GetMem(Result, SizeOf(TOrResource));
With Result^ Do
Begin
Next := ResList;
RefCount := 0;
Handle := TOrFontData(ResData).Handle;
HashCode := ResHash;
Move(ResData, OrFont, SizeOf(OrFont));
End;
ResList := Result;
End;
Inc(Result^.RefCount);
Finally
Unlock;
End;
End;
Procedure TResourceManager.FreeResource(Resource: POrResource);
Var
P: POrResource;
DeleteIt: Boolean;
Begin
If Resource <> Nil Then
With Resource^ Do
Begin
Lock;
Try
Dec(RefCount);
DeleteIt := RefCount = 0;
If DeleteIt Then
Begin
If Resource = ResList Then
ResList := Resource^.Next
Else
Begin
P := ResList;
While P^.Next <> Resource Do P := P^.Next;
P^.Next := Resource^.Next;
End;
End;
Finally
Unlock;
End;
If DeleteIt Then
Begin // this is outside the critsect to minimize lock time
If Handle <> 0 Then DeleteObject(Handle);
FreeMem(Resource);
End;
End;
End;
Procedure TResourceManager.ChangeResource(GraphicsObject: TOrFont; Const ResData);
Var
P: POrResource;
Begin
Lock;
Try // prevent changes to GraphicsObject.FResource pointer between steps
P := GraphicsObject.FOrResource;
GraphicsObject.FOrResource := AllocResource(ResData);
If GraphicsObject.FOrResource <> P Then GraphicsObject.Changed;
FreeResource(P);
Finally
Unlock;
End;
End;
Procedure TResourceManager.AssignResource(GraphicsObject: TOrFont; AResource: POrResource);
Var
P: POrResource;
Begin
Lock;
Try
P := GraphicsObject.FOrResource;
If P <> AResource Then
Begin
Inc(AResource^.RefCount);
GraphicsObject.FOrResource := AResource;
GraphicsObject.Changed;
FreeResource(P);
End;
Finally
Unlock;
End;
End;
// Font 'orientable' utilisée par le TOrLabel
{ TFont }
Var
// Valeurs par défaut d'une OrFont
DefOrFontData: TOrFontData = (
Handle: 0;
Height: 0;
Pitch: fpDefault;
Style: [];
Charset : DEFAULT_CHARSET;
Name: 'Arial';
Orient: 0);
// Procédure d'initialisation appelée au lancement de l'unité
Procedure InitScreenLogPixelsEtAutre;
Var
DC : HDC;
Ver : TOSVersionInfo;
Begin
// définition de la précision de l'écran ( utilisé pour le rapport height/size de la font
DC := GetDC(0);
ScreenLogPixels := GetDeviceCaps(DC, LOGPIXELSY);
ReleaseDC(0,DC);
DefOrFontData.Height := -MulDiv(8, ScreenLogPixels, 72);
// recherche de l'environnement pour déterminer si la gestion de Incline est possible
Ver.dwOSVersionInfoSize:= SizeOf(Ver);
GetVersionEx(Ver);
IM_ADVANCED_OK:= Ver.dwPlatformID=VER_PLATFORM_WIN32_NT;
End;
// Procédure utilisé pour extraire les paramètres d'une fonte existante
// assignée à OrFont via la propriété Handle
Function GetFontData(Font: HFont): TOrFontData;
Var
LogFont: TLogFont;
Begin
Result := DefOrFontData;
If Font <> 0 Then
Begin
If GetObject(Font, SizeOf(LogFont), @LogFont) <> 0 Then
With Result, LogFont Do
Begin
Height := lfHeight;
Width := lfWidth;
If lfWeight >= FW_BOLD Then Include(Style, fsBold);
If lfItalic = 1 Then Include(Style, fsItalic);
If lfUnderline = 1 Then Include(Style, fsUnderline);
If lfStrikeOut = 1 Then Include(Style, fsStrikeOut);
Incline := lfOrientation;
Orient := lfEscapement;
Charset := TFontCharset(lfCharSet);
Name := lfFaceName;
Case lfPitchAndFamily And $F Of
VARIABLE_PITCH: Pitch := fpVariable;
FIXED_PITCH: Pitch := fpFixed;
Else
Pitch := fpDefault;
End;
Handle := Font;
End;
End;
End;
// Création du OrFont...
Constructor TOrFont.Create;
Begin
DefOrFontData.Handle := 0;
FOrResource := OrFontManager.AllocResource(DefOrFontData);
FColor := clWindowText;
FPixelsPerInch := ScreenLogPixels;
Name := 'Arial';
End;
//... et sa destruction
Destructor TOrFont.Destroy;
Begin
OrFontManager.FreeResource(FOrResource);
End;
// Une autre fonte est assignée à OrFont on en rercherche les valeurs
Procedure TOrFont.Assign(Source: TPersistent);
Begin
If Source Is TFont Then
Begin
Lock;
Try
TOrFont(Source).Lock;
Try
OrFontManager.AssignResource(Self, TOrFont(Source).FOrResource);
Color := TOrFont(Source).Color;
If PixelsPerInch <> TOrFont(Source).PixelsPerInch Then
Size := TOrFont(Source).Size;
Finally
TOrFont(Source).Unlock;
End;
Finally
Unlock;
End;
Exit;
End;
Inherited Assign(Source);
End;
Procedure TOrFont.GetData(Var OrFontData: TOrFontData);
Begin
OrFontData := FOrResource^.OrFont;
OrFontData.Handle := 0;
End;
Procedure TOrFont.SetData(Const OrFontData: TOrFontData);
Begin
Lock;
Try
OrFontManager.ChangeResource(Self, OrFontData);
Finally
Unlock;
End;
End;
Procedure TOrFont.SetColor(Value: TColor);
Begin
If FColor <> Value Then
Begin
FColor := Value;
Changed;
End;
End;
// Fonction de création du Handle de resource si besoin
Function TOrFont.GetHandle: HFont;
Var
LogFont: TLogFont;
Begin
With FOrResource^ Do
Begin
If Handle = 0 Then
Begin
OrFontManager.Lock;
With LogFont Do
Try
If Handle = 0 Then
Begin
lfHeight := OrFont.Height;
lfWidth := OrFont.Width;
lfEscapement := OrFont.Orient;
lfOrientation := OrFont.Incline;
If fsBold In OrFont.Style
Then lfWeight := FW_BOLD
Else lfWeight := FW_NORMAL;
lfItalic := Byte(fsItalic In OrFont.Style);
lfUnderline := Byte(fsUnderline In OrFont.Style);
lfStrikeOut := Byte(fsStrikeOut In OrFont.Style);
lfCharSet := DEFAULT_CHARSET;
lfQuality := DEFAULT_QUALITY;
lfOutPrecision := Out_DEFAULT_PRECIS;
lfClipPrecision := CLIP_DEFAULT_PRECIS;
lfPitchAndFamily := DEFAULT_PITCH;
StrPCopy(lfFaceName, OrFont.Name);
Handle := CreateFontIndirect(LogFont);
End;
Finally
OrFontManager.Unlock;
End;
End;
Result := Handle;
End;
End;
Procedure TOrFont.SetHandle(Value: HFont);
Begin
SetData(GetFontData(Value));
End;
Function TOrFont.GetHeight: Integer;
Begin
Result := FOrResource^.OrFont.Height;
End;
Procedure TOrFont.SetHeight(Value: Integer);
Var
FontData: TOrFontData;
Begin
GetData(FontData);
FontData.Height := Value;
SetData(FontData);
End;
Function TOrFont.GetName: TFontName;
Begin
Result := FOrResource^.OrFont.Name;
End;
Procedure TOrFont.SetName(Const Value: TFontName);
Var
FontData: TOrFontData;
Begin
If Value <> '' Then
Begin
GetData(FontData);
FillChar(FontData.Name, SizeOf(FontData.Name), 0);
FontData.Name := Value;
SetData(FontData);
End;
End;
Function TOrFont.GetSize: Integer;
Begin
Result := -MulDiv(Height, 72, FPixelsPerInch);
End;
Procedure TOrFont.SetSize(Value: Integer);
Begin
Height := -MulDiv(Value, FPixelsPerInch, 72);
End;
Function TOrFont.GetStyle: TFontStyles;
Begin
Result := FOrResource^.OrFont.Style;
End;
Procedure TOrFont.SetStyle(Value: TFontStyles);
Var
FontData: TOrFontData;
Begin
GetData(FontData);
FontData.Style := Value;
SetData(FontData);
End;
Function TOrFont.GetPitch: TFontPitch;
Begin
Result := FOrResource^.OrFont.Pitch;
End;
Procedure TOrFont.SetPitch(Value: TFontPitch);
Var
FontData: TOrFontData;
Begin
GetData(FontData);
FontData.Pitch := Value;
SetData(FontData);
End;
Function TOrFont.GetCharset: TFontCharset;
Begin
Result := FOrResource^.OrFont.Charset;
End;
Procedure TOrFont.SetCharset(Value: TFontCharset);
Var
FontData: TOrFontData;
Begin
GetData(FontData);
FontData.Charset := Value;
SetData(FontData);
End;
Function TOrFont.GetOrient: Integer;
Begin
Result := FOrResource^.OrFont.Orient;
End;
Procedure TOrFont.SetOrient(Value: Integer);
Var
FontData: TOrFontData;
Begin
GetData(FontData);
FontData.Orient := Value;
SetData(FontData);
End;
Function TOrFont.GetIncline: Integer;
Begin
Result := FOrResource^.OrFont.Incline;
End;
Procedure TOrFont.SetIncline(Value: Integer);
Var
FontData: TOrFontData;
Begin
GetData(FontData);
FontData.Incline := Value;
SetData(FontData);
End;
Function TOrFont.GetWidth: Integer;
Begin
Result := FOrResource^.OrFont.Width;
End;
Procedure TOrFont.SetWidth(Value: Integer);
Var
FontData: TOrFontData;
Begin
GetData(FontData);
FontData.Width := Value;
SetData(FontData);
End;
{ TOrLabel }
// Creation du OrLabel...
Constructor TOrLabel.Create(AOwner: TComponent);
Begin
Inherited Create(AOwner);
ControlStyle := ControlStyle + [csReplicatable];
Width := 65;
Height := 17;
OrFont := TOrFont.Create; // Création de la fonte utilisée
OrFont.OnChange := OnOrFontChanged;
End;
// ...et sa destruction
Destructor TOrLabel.Destroy;
Begin
OrFont.Free; // Libération de la fonte
Inherited Destroy;
End;
// Calcul de la position du coin haut gauche par rapport au centre du label
Procedure TOrLabel.CalculXY;
Var
i,j :Integer;
a,b,d : Double;
l : Double;
Taille : TSize;
OldMode : Integer;
Begin
With Canvas Do
Begin
OldMode:=0;
// Quand c'est possible et quand c'est demandé on passe le HDC en mode étendu
If IM_ADVANCED_OK And(InclineMode=IM_ADVANCED)
Then OldMode:=SetGraphicsMode(Canvas.Handle,GM_ADVANCED);
// On cherche la taille du texte avec les fonctions de Windows
SelectObject(Canvas.Handle, FOrFont.Handle);
GetTextExtentPoint32(Canvas.Handle,PChar(Caption),Length(Caption),Taille);
i:=Taille.cx;
j:=Taille.cy;
// On remet la fonte d'origine et le mode origine avant de quitter
SelectObject(Canvas.Handle, Canvas.Font.Handle);
If (OldMode<>0)And(InclineMode=IM_ADVANCED) Then SetGraphicsMode(Canvas.Handle,OldMode);
// ArcTan(j/i) donne l'angle de la diagonale du texte par rapport au bas du texte
// Orient donne l'angle entre la bas du texte et l'horizontale
// donc "a" représente l'angle entre la diagonale et la bas du texte
Try
If i<>0 Then d:=ArcTan(j/i)
Else d:=PI/2;
Except
d:=PI/2;
End;
a:=FOrFont.Orient*2*PI/3600-d;
// "l" est la diagonale du label, on en déduit alors la position de coin haut-gauche du texte
l:=Sqrt(i*i+j*j);
FDecalX:= Round(l*cos(a)) Div 2;
FDecalY:=-Round(l*sin(a)) Div 2;
// En cas d'ajustement automatique, on définit la nouvelle taille
If AutoSize
Then Begin
// "b" représente l'angle formé par le centre du label et le coin bas-gauche du texte
b:=FOrFont.Orient*2*PI/3600+d;
Self.Width :=Max(Abs(FDecalX)Shl 1,Abs(Round(l*cos(b))));
Self.Height :=Max(Abs(FDecalY)Shl 1,Abs(Round(l*sin(b))));
End;
End;
End;
// Dessin du label, tout est fait par l'API
Procedure TOrLabel.Paint;
Var OldMode:Integer;
Begin
With Canvas Do
Begin
// sélection du pinceau pour gérer la transparence.
If Transparent
Then Begin
Brush.Style := bsClear;
End
Else Begin
Brush.Color := Self.Color;
Brush.Style := bsSolid;
// Comme on dessine par l'API il faut spécifier explicitement l'usage du pinceau
SelectObject(Canvas.Handle, Brush.Handle);
End;
// De même que la couleur d'écriture
SetTextColor(Canvas.Handle, FOrFont.Color);
// et la fonte utilisée
SelectObject(Canvas.Handle, FOrFont.Handle);
OldMode:=0;
// Quand c'est possible et quand c'est demandé on passe le HDC en mode étendu
If IM_ADVANCED_OK And(InclineMode=IM_ADVANCED)
Then OldMode:=SetGraphicsMode(Canvas.Handle,GM_ADVANCED);
// On dessine le texte avec ExtTextOut ( DrawText ne gère pas les fonte orientées )
ExtTextOut (Canvas.Handle, Self.Width Div 2-FDecalX
, Self.Height Div 2-FDecalY
, 0
, Nil
, PChar(Caption),Length(Caption)
, Nil);
// On remet la fonte d'origine et le mode origine avant de quitter
SelectObject(Canvas.Handle, Canvas.Font.Handle);
If (OldMode<>0)And(InclineMode=IM_ADVANCED) Then SetGraphicsMode(Canvas.Handle,OldMode)
End;
End;
// Procédures de mise à jour des propriétés
Procedure TOrLabel.SetTransparent(Value: Boolean);
Begin
If FTransparent <> Value Then
Begin
FTransparent:=Value;
Invalidate;
End;
End;
Procedure TOrLabel.SetInclineMode(Value: TInclineMode);
Begin
If FInclineMode <> Value Then
Begin
FInclineMode:=Value;
Invalidate;
End;
End;
// Celle-ci surcharge celle du GraphicControl car il faut calculer DecalX et DecalY
Procedure TOrLabel.SetAutosize(Value: Boolean);
Begin
Inherited SetAutoSize(Value);
If AutoSize Then CalculXY;
End;
// Réaction aux changements de texte et de fonte
Procedure TOrLabel.CMTextChanged(Var Message: TMessage);
Begin
CalculXY;
Invalidate;
End;
Procedure TOrLabel.OnOrFontChanged(Sender:TObject);
Begin
CalculXY;
Invalidate;
End;
// Et enfin gestion des évènements nouveaux
Procedure TOrLabel.CMMouseEnter(Var Message: TMessage);
Begin
Inherited;
If Assigned(FOnMouseEnter) Then FOnMouseEnter(Self);
End;
Procedure TOrLabel.CMMouseLeave(Var Message: TMessage);
Begin
Inherited;
If Assigned(FOnMouseLeave) Then FOnMouseLeave(Self);
End;
Procedure Register;
Begin
RegisterComponents('Exemples', [TOrLabel]);
End;
Initialization
InitScreenLogPixelsEtAutre;
OrFontManager := TResourceManager.Create;
Finalization
OrFontManager.Free;
End.
|
| |
