Skip to content

Commit

Permalink
redirection et mise en péremption des fichiers à la racine du dépôt (#45
Browse files Browse the repository at this point in the history 
)
  • Loading branch information
@DeveloppeurPascal
DeveloppeurPascal committed Mar 10, 2024
1 parent 0abe836 commit fdcd33a
Show file tree
Hide file tree
Showing 35 changed files with 70 additions and 8,454 deletions.
74 changes: 2 additions & 72 deletions Olf.FMX.Streams.pas
View file
Original file line number Diff line number Diff line change
@@ -1,72 +1,2 @@
unit Olf.FMX.Streams;

interface

uses
FMX.Graphics,
System.SysUtils,
System.Classes;

procedure SaveBitmapToStream(ABitmap: TBitmap; AToStream: TStream);
function LoadBitmapFromStream(AFromStream: TStream): TBitmap;

implementation

procedure SaveBitmapToStream(ABitmap: TBitmap; AToStream: TStream);
var
ms: TMemoryStream;
size: int64;
begin
if not assigned(AToStream) then
raise exception.create('Need an existing stream to save the bitmap !');

if not assigned(ABitmap) then
begin
size := 0;
AToStream.WriteData(size);
end
else
begin
ms := TMemoryStream.create;
try
ABitmap.SaveToStream(ms);
size := ms.size;
AToStream.WriteData(size);
if (size > 0) then
begin
ms.Position := 0;
AToStream.CopyFrom(ms, size);
end;
finally
ms.free;
end;
end;
end;

function LoadBitmapFromStream(AFromStream: TStream): TBitmap;
var
ms: TMemoryStream;
size: int64;
begin
if not assigned(AFromStream) then
raise exception.create('Need an existing stream to load the bitmap !');

if (AFromStream.ReadData(size) <> sizeof(size)) then
result := nil
else if (size < 1) then
result := nil
else
begin
ms := TMemoryStream.create;
try
ms.CopyFrom(AFromStream, size);
ms.Position := 0;
result := TBitmap.create;
result.LoadFromStream(ms);
finally
ms.free;
end;
end;
end;

end.
{$I 'src\Olf.FMX.Streams.pas'}
{$message warn 'This file is deprecated. It will be deleted after the 2025-03-10. Use "src\Olf.FMX.Streams.pas" instead of it.'}
215 changes: 2 additions & 213 deletions Olf.FMX.TextImageFrame.pas
View file
Original file line number Diff line number Diff line change
@@ -1,213 +1,2 @@
unit Olf.FMX.TextImageFrame;

interface

uses
System.SysUtils, System.Types, System.UITypes, System.Classes,
System.Variants,
FMX.Types, FMX.Graphics, FMX.Controls, FMX.Forms, FMX.Dialogs, FMX.StdCtrls,
System.ImageList, FMX.ImgList;

type
TOlfFMXTextImageFrame = class;

TOlfFMXTIFOnGetImageIndexOfUnknowChar = function
(Sender: TOlfFMXTextImageFrame; AChar: char): integer of object;

TOlfFMXTextImageFrame = class(TFrame)
private
FText: string;
FFont: TCustomImageList;
FOnGetImageIndexOfUnknowChar: TOlfFMXTIFOnGetImageIndexOfUnknowChar;
FLetterSpacing: single;
FSpaceWidth, FRealSpaceWidth: single;
procedure SetFont(const Value: TCustomImageList);
procedure SetText(const Value: string);
procedure SetOnGetImageIndexOfUnknowChar(const Value
: TOlfFMXTIFOnGetImageIndexOfUnknowChar);
procedure SetLetterSpacing(const Value: single);
procedure SetSpaceWidth(const Value: single);
protected
function AjoutImageEtRetourneLargeur(AImages: TCustomImageList;
AImageIndex: TImageIndex; AX: single): single;
procedure RefreshTexte;
public
property Font: TCustomImageList read FFont write SetFont;
property Text: string read FText write SetText;
property SpaceWidth: single read FSpaceWidth write SetSpaceWidth;
property LetterSpacing: single read FLetterSpacing write SetLetterSpacing;
property OnGetImageIndexOfUnknowChar: TOlfFMXTIFOnGetImageIndexOfUnknowChar
read FOnGetImageIndexOfUnknowChar write SetOnGetImageIndexOfUnknowChar;
constructor Create(AOwner: TComponent); override;
function RetourneLargeur(AImages: TCustomImageList;
AImageIndex: TImageIndex): single;
function getImageIndexOfChar(AChar: string): integer;
end;

implementation

{$R *.fmx}

const
CPosChiffres = 0;
CPosMajuscules = CPosChiffres + 10;
CPosMinuscules = CPosMajuscules;
// Pas de minuscules dans les fontes prises sur ce jeu
CPosPonctuation = CPosMajuscules + 26;
// TODO : à modifier si nécessaire selon les fontes

{ TcadAffichageTexteGraphique }

function TOlfFMXTextImageFrame.AjoutImageEtRetourneLargeur
(AImages: TCustomImageList; AImageIndex: TImageIndex; AX: single): single;
var
g: tglyph;
wi, hi: single;
begin
if (not assigned(AImages)) or (AImageIndex < 0) or
(AImageIndex >= AImages.Count) then
result := 0
else
begin
g := tglyph.Create(self);
g.Parent := self;
wi := AImages.Destination[AImageIndex].Layers[0].MultiResBitmap[0].Width;
hi := AImages.Destination[AImageIndex].Layers[0].MultiResBitmap[0].height;
g.height := height;
g.Width := g.height * wi / hi;
g.Images := AImages;
g.ImageIndex := AImageIndex;
g.Position.x := AX;
g.Position.y := 0;
result := g.Width;
end;
end;

constructor TOlfFMXTextImageFrame.Create(AOwner: TComponent);
begin
inherited;
name := '';
FFont := nil;
FText := '';
FLetterSpacing := 0;
FSpaceWidth := 0;
FRealSpaceWidth := 0;
FOnGetImageIndexOfUnknowChar := nil;
end;

function TOlfFMXTextImageFrame.getImageIndexOfChar(AChar: string): integer;
begin
result := 0;
while (result < FFont.Count) and
(FFont.Destination[result].Layers[0].Name <> AChar) do
inc(result);
if (result >= FFont.Count) then
result := -1;
end;

procedure TOlfFMXTextImageFrame.RefreshTexte;
var
i: integer;
x: single;
idx: integer;
begin
for i := childrencount - 1 downto 0 do
if (children[i] is tglyph) then
children[i].Free;

x := 0;
if assigned(FFont) and (FText.Length > 0) then
for i := 0 to FText.Length - 1 do
begin
idx := getImageIndexOfChar(FText.Chars[i]);
if (idx < 0) and assigned(FOnGetImageIndexOfUnknowChar) then
idx := FOnGetImageIndexOfUnknowChar(self, FText.Chars[i]);
if (idx >= 0) then
x := x + AjoutImageEtRetourneLargeur(FFont, idx, x) + FLetterSpacing
else if (FText.Chars[i] = ' ') then
begin
if (FRealSpaceWidth < 1) then
begin
idx := getImageIndexOfChar('.');
if (idx < 0) and assigned(FOnGetImageIndexOfUnknowChar) then
idx := FOnGetImageIndexOfUnknowChar(self, '.');
if (idx >= 0) then
FRealSpaceWidth := RetourneLargeur(FFont, idx);

idx := getImageIndexOfChar('i');
if (idx < 0) and assigned(FOnGetImageIndexOfUnknowChar) then
idx := FOnGetImageIndexOfUnknowChar(self, 'i');
if (idx >= 0) then
FRealSpaceWidth := RetourneLargeur(FFont, idx);

idx := getImageIndexOfChar('I');
if (idx < 0) and assigned(FOnGetImageIndexOfUnknowChar) then
idx := FOnGetImageIndexOfUnknowChar(self, 'I');
if (idx >= 0) then
FRealSpaceWidth := RetourneLargeur(FFont, idx);

idx := getImageIndexOfChar('1');
if (idx < 0) and assigned(FOnGetImageIndexOfUnknowChar) then
idx := FOnGetImageIndexOfUnknowChar(self, '1');
if (idx >= 0) then
FRealSpaceWidth := RetourneLargeur(FFont, idx);
end;
x := x + FRealSpaceWidth;
end;
end;

Width := x;
end;

function TOlfFMXTextImageFrame.RetourneLargeur(AImages: TCustomImageList;
AImageIndex: TImageIndex): single;
var
wi, hi: single;
begin
if (not assigned(AImages)) or (AImageIndex < 0) or
(AImageIndex >= AImages.Count) then
result := 0
else
begin
wi := AImages.Destination[AImageIndex].Layers[0].MultiResBitmap[0].Width;
hi := AImages.Destination[AImageIndex].Layers[0].MultiResBitmap[0].height;
result := height * wi / hi;
end;
end;

procedure TOlfFMXTextImageFrame.SetFont(const Value: TCustomImageList);
begin
FFont := Value;
FRealSpaceWidth := FSpaceWidth;
if (FText.Length > 0) then
RefreshTexte;
end;

procedure TOlfFMXTextImageFrame.SetLetterSpacing(const Value: single);
begin
FLetterSpacing := Value;
end;

procedure TOlfFMXTextImageFrame.SetOnGetImageIndexOfUnknowChar
(const Value: TOlfFMXTIFOnGetImageIndexOfUnknowChar);
begin
FOnGetImageIndexOfUnknowChar := Value;
end;

procedure TOlfFMXTextImageFrame.SetSpaceWidth(const Value: single);
begin
FSpaceWidth := Value;
FRealSpaceWidth := FSpaceWidth;
end;

procedure TOlfFMXTextImageFrame.SetText(const Value: string);
begin
FText := Value;
if not assigned(FFont) then
exit;
RefreshTexte;
end;

// TODO : gérer changement de taille des chiffres en cas de resize de la zone

end.
{$I 'src\Olf.FMX.TextImageFrame.pas'}
{$message warn 'This file is deprecated. It will be deleted after the 2025-03-10. Use "src\Olf.FMX.TextImageFrame.pas" instead of it.'}
Loading

0 comments on commit fdcd33a

Please sign in to comment.