Transparencia do TRLImage não está funcionando corretamente #334

Dorpoa · 2023-09-08T00:31:28Z

O Objeto TRLImage não reproduz a transparência original da imagem tanto em modo DESIGNER quanto em modo IMPRESSÃO.
basicamente, ele ignora o fundo gerando a impressão da imagem com o FUNDO BRANCO, ignorando assim a imagem de BackGround ou até mesmo o COLOR do TRLPanel ou TRLBand.

Gostaria de salientar que a imagem é um PNG e seu fundo é transparente.

Versões:

Estou utilizando Delphi 11.3
Fortesreport-CR Revisão 539

Caso necessite de contato posso responder pelo email dor_poa@hotmail.com

Agradeço desde já, e estou disposto a ajudar se existir alguma forma.

Exemplo completo incluindo o .PAS:
Demo.zip

Imagens:

Dorpoa · 2023-09-11T18:51:42Z

Solução:
Ajustes nas funções:

FromMetaGraphic
ToMetaGraphic

RLMetaVCL.zip

Dorpoa · 2023-09-11T18:51:53Z

{ Projeto: FortesReport Community Edition }
{ É um poderoso gerador de relatórios disponível como um pacote de componentes }
{ para Delphi. Em FortesReport, os relatórios são constituídos por bandas que }
{ têm funções específicas no fluxo de impressão. Você definir agrupamentos }
{ subníveis e totais simplesmente pela relação hierárquica entre as bandas. }
{ Além disso possui uma rica paleta de Componentes }
{ }
{ Direitos Autorais Reservados(c) Copyright © 1999-2015 Fortes Informática }
{ }
{ Colaboradores nesse arquivo: Ronaldo Moreira }
{ Márcio Martins }
{ Régys Borges da Silveira }
{ Juliomar Marchetti }
{ }
{ Você pode obter a última versão desse arquivo na pagina do Projeto }
{ localizado em }
{ https://github.com/fortesinformatica/fortesreport-ce }
{ }
{ Para mais informações você pode consultar o site www.fortesreport.com.br ou }
{ no Yahoo Groups https://groups.yahoo.com/neo/groups/fortesreport/info }
{ }
{ Esta biblioteca é software livre; você pode redistribuí-la e/ou modificá-la }
{ sob os termos da Licença Pública Geral Menor do GNU conforme publicada pela }
{ Free Software Foundation; tanto a versão 2.1 da Licença, ou (a seu critério) }
{ qualquer versão posterior. }
{ }
{ Esta biblioteca é distribuída na expectativa de que seja útil, porém, SEM }
{ NENHUMA GARANTIA; nem mesmo a garantia implícita de COMERCIABILIDADE OU }
{ ADEQUAÇÃO A UMA FINALIDADE ESPECÍFICA. Consulte a Licença Pública Geral Menor}
{ do GNU para mais detalhes. (Arquivo LICENÇA.TXT ou LICENSE.TXT) }
{ }
{ Você deve ter recebido uma cópia da Licença Pública Geral Menor do GNU junto}
{ com esta biblioteca; se não, escreva para a Free Software Foundation, Inc., }
{ no endereço 59 Temple Street, Suite 330, Boston, MA 02111-1307 USA. }
{ Você também pode obter uma copia da licença em: }
{ http://www.opensource.org/licenses/gpl-license.php }
{ }
{******************************************************************************}

{******************************************************************************
|* Historico
|*
|* xx/xx/xxxx: Autor...
|* - Descrição...
******************************************************************************}

{$I RLReport.inc}

unit RLMetaVCL;

interface

uses
{$IfDef MSWINDOWS}
Windows,
{$EndIf}
{$IfDef FPC}
LCLIntf, LCLType, LCLProc,
{$EndIf}
SysUtils, Classes, Math,
Graphics, StdCtrls,
RLMetaFile, RLUtils, RLConsts,
Vcl.Imaging.pngimage;

type
TPointArray = array of TPoint;

function ToMetaRect(const ASource: TRect): TRLMetaRect;
function ToMetaColor(ASource: TColor): TRLMetaColor;
function ToMetaPenMode(ASource: TPenMode): TRLMetaPenMode;
function ToMetaPenStyle(ASource: TPenStyle): TRLMetaPenStyle;
procedure ToMetaPen(ASource: TPen; ADest: TRLMetaPen);
function ToMetaBrushStyle(ASource: TBrushStyle): TRLMetaBrushStyle;
procedure ToMetaBrush(ASource: TBrush; ADest: TRLMetaBrush);
function ToMetaPoint(const ASource: TPoint): TRLMetaPoint;
function ToMetaPointArray(const ASource: array of TPoint): TRLMetaPointArray;
function ToMetaFontCharset(ASource: TFontCharset): TRLMetaFontCharset;
function ToMetaFontPitch(ASource: TFontPitch): TRLMetaFontPitch;
function ToMetaFontStyles(ASource: TFontStyles): TRLMetaFontStyles;
procedure ToMetaFont(ASource: TFont; ADest: TRLMetaFont);
function ToMetaGraphic(ASource: TGraphic): string;
function ToMetaTextAlignment(ASource: TAlignment): TRLMetaTextAlignment;
function ToMetaTextLayout(ASource: TTextLayout): TRLMetaTextLayout;
function FromMetaRect(const ASource: TRLMetaRect): TRect;
function FromMetaPoint(const ASource: TRLMetaPoint): TPoint;
function FromMetaColor(const ASource: TRLMetaColor): TColor;
function FromMetaPenMode(ASource: TRLMetaPenMode): TPenMode;
function FromMetaPenStyle(ASource: TRLMetaPenStyle): TPenStyle;
procedure FromMetaPen(ASource: TRLMetaPen; ADest: TPen);
function FromMetaBrushStyle(ASource: TRLMetaBrushStyle): TBrushStyle;
procedure FromMetaBrush(ASource: TRLMetaBrush; ADest: TBrush);
function FromMetaFontStyles(ASource: TRLMetaFontStyles): TFontStyles;
function FromMetaFontCharset(ASource: TRLMetaFontCharset): TFontCharset;
function FromMetaFontPitch(ASource: TRLMetaFontPitch): TFontPitch;
procedure FromMetaFont(ASource: TRLMetaFont; ADest: TFont; AFactor: Double = 1);
function FromMetaGraphic(const ASource: String): TGraphic;
function FromMetaPointArray(const ASource: TRLMetaPointArray): TPointArray;
function FromMetaTextAlignment(ASource: TRLMetaTextAlignment): TAlignment;
function FromMetaTextLayout(ASource: TRLMetaTextLayout): TTextLayout;
//
procedure PenInflate(APen: TPen; AFactor: Double);
procedure CanvasStart(ACanvas: TCanvas);
procedure CanvasStop(ACanvas: TCanvas);
function CanvasGetClipRect(ACanvas: TCanvas): TRect;
procedure CanvasSetClipRect(ACanvas: TCanvas; const ARect: TRect);
procedure CanvasResetClipRect(ACanvas: TCanvas);
function CanvasGetRectData(ACanvas: TCanvas; const ARect: TRect): String;
procedure CanvasSetRectData(ACanvas: TCanvas; const ARect: TRect; const AData: String; AParity: Boolean);
procedure CanvasStretchDraw(ACanvas: TCanvas; const ARect: TRect; const AData: String; AParity: Boolean);
procedure CanvasTextRectEx(ACanvas: TCanvas; const ARect: TRect; AX, AY: Integer; const AText: String; AAlignment: TRLMetaTextAlignment; ALayout: TRLMetaTextLayout; ATextFlags: TRLMetaTextFlags);
function CanvasGetPixels(ACanvas: TCanvas; X, Y: Integer): TColor;
procedure CanvasLineToEx(ACanvas: TCanvas; X, Y: Integer);
procedure FontGetMetrics(const AFontName: AnsiString; AFontStyles: TFontStyles; var AFontRec: TRLMetaFontMetrics);

implementation

{ CONVERSION }

function ToMetaRect(const ASource: TRect): TRLMetaRect;
begin
Result.Left := ASource.Left;
Result.Top := ASource.Top;
Result.Right := ASource.Right;
Result.Bottom := ASource.Bottom;
end;

function ToMetaColor(ASource: TColor): TRLMetaColor;
var
rgb: Cardinal;
begin
rgb := ColorToRGB(ASource);
Result.Red := Byte(rgb);
Result.Green := Byte(rgb shr 8);
Result.Blue := Byte(rgb shr 16);
end;

function ToMetaPenMode(ASource: TPenMode): TRLMetaPenMode;
begin
case ASource of
pmBlack: Result := MetaPenModeBlack;
pmWhite: Result := MetaPenModeWhite;
pmNop: Result := MetaPenModeNop;
pmNot: Result := MetaPenModeNot;
pmCopy: Result := MetaPenModeCopy;
pmNotCopy: Result := MetaPenModeNotCopy;
pmMergePenNot: Result := MetaPenModeMergePenNot;
pmMaskPenNot: Result := MetaPenModeMaskPenNot;
pmMergeNotPen: Result := MetaPenModeMergeNotPen;
pmMaskNotPen: Result := MetaPenModeMaskNotPen;
pmMerge: Result := MetaPenModeMerge;
pmNotMerge: Result := MetaPenModeNotMerge;
pmMask: Result := MetaPenModeMask;
pmNotMask: Result := MetaPenModeNotMask;
pmXor: Result := MetaPenModeXor;
pmNotXor: Result := MetaPenModeNotXor;
else
Result := MetaPenModeCopy;
end;
end;

function ToMetaPenStyle(ASource: TPenStyle): TRLMetaPenStyle;
begin
case ASource of
psSolid: Result := MetaPenStyleSolid;
psDash: Result := MetaPenStyleDash;
psDot: Result := MetaPenStyleDot;
psDashDot: Result := MetaPenStyleDashDot;
psDashDotDot: Result := MetaPenStyleDashDotDot;
psClear: Result := MetaPenStyleClear;
psInsideFrame: Result := MetaPenStyleInsideFrame;
else
Result := MetaPenStyleSolid;
end;
end;

procedure ToMetaPen(ASource: TPen; ADest: TRLMetaPen);
begin
ADest.Color := ToMetaColor(ASource.Color);
ADest.Mode := ToMetaPenMode(ASource.Mode);
ADest.Style := ToMetaPenStyle(ASource.Style);
ADest.Width := ASource.Width;
end;

function ToMetaBrushStyle(ASource: TBrushStyle): TRLMetaBrushStyle;
begin
case ASource of
bsSolid: Result := MetaBrushStyleSolid;
bsClear: Result := MetaBrushStyleClear;
bsHorizontal: Result := MetaBrushStyleHorizontal;
bsVertical: Result := MetaBrushStyleVertical;
bsFDiagonal: Result := MetaBrushStyleFDiagonal;
bsBDiagonal: Result := MetaBrushStyleBDiagonal;
bsCross: Result := MetaBrushStyleCross;
bsDiagCross: Result := MetaBrushStyleDiagCross;
else
Result := MetaBrushStyleSolid;
end;
end;

procedure ToMetaBrush(ASource: TBrush; ADest: TRLMetaBrush);
begin
ADest.Color := ToMetaColor(ASource.Color);
ADest.Style := ToMetaBrushStyle(ASource.Style);
end;

function ToMetaPoint(const ASource: TPoint): TRLMetaPoint;
begin
Result.X := ASource.X;
Result.Y := ASource.Y;
end;

function ToMetaPointArray(const ASource: array of TPoint): TRLMetaPointArray;
var
I: Integer;
begin
SetLength(Result, High(ASource) + 1);
for I := 0 to High(ASource) do
Result[I] := ToMetaPoint(ASource[I]);
end;

function ToMetaFontCharset(ASource: TFontCharset): TRLMetaFontCharset;
begin
Result := TRLMetaFontCharset(ASource);
end;

function ToMetaFontPitch(ASource: TFontPitch): TRLMetaFontPitch;
begin
case ASource of
fpDefault: Result := MetaFontPitchDefault;
fpVariable: Result := MetaFontPitchVariable;
fpFixed: Result := MetaFontPitchFixed;
else
Result := MetaFontPitchDefault;
end;
end;

function ToMetaFontStyles(ASource: TFontStyles): TRLMetaFontStyles;
begin
Result := 0;
if fsBold in ASource then
Result := Result or MetaFontStyleBold;
if fsItalic in ASource then
Result := Result or MetaFontStyleItalic;
if fsUnderline in ASource then
Result := Result or MetaFontStyleUnderline;
if fsStrikeOut in ASource then
Result := Result or MetaFontStyleStrikeOut;
end;

procedure ToMetaFont(ASource: TFont; ADest: TRLMetaFont);
begin
ADest.PixelsPerInch := ASource.PixelsPerInch;
ADest.Charset := ToMetaFontCharset(ASource.Charset);
ADest.Color := ToMetaColor(ASource.Color);
ADest.Height := ASource.Height;
ADest.Name := ASource.Name;
ADest.Pitch := ToMetaFontPitch(ASource.Pitch);
ADest.Size := ASource.Size;
ADest.Style := ToMetaFontStyles(ASource.Style);
end;

function ToMetaGraphic(ASource: TGraphic): string;
var
S: TStringStream;
M: TBitmap;
G: TGraphic;
begin
M := nil;
S := TStringStream.Create('');
try
G := ASource;
// identifica os tipos nativos
if G = nil then
S.WriteString('NIL')
else if G is TBitmap then
S.WriteString('BMP')
else if G is TIcon then
S.WriteString('ICO')
else if G is TPngImage then
S.WriteString('PNG')
else
begin
// qualquer outro formato é transformado em bmp para ficar compatível com um carregador de qualquer plataforma
M := TRLBitmap.Create;
M.Width := ASource.Width;
M.Height := ASource.Height;
G := M;
M.Canvas.Draw(0, 0, ASource);
S.WriteString('BMP');
end;
if Assigned(G) then
G.SaveToStream(S);
Result := S.DataString;
finally
if Assigned(M) then
M.free;
S.free;
end;
end;

function ToMetaTextAlignment(ASource: TAlignment): TRLMetaTextAlignment;
begin
case ASource of
taLeftJustify: Result := MetaTextAlignmentLeft;
taRightJustify: Result := MetaTextAlignmentRight;
taCenter: Result := MetaTextAlignmentCenter;
else
if ASource > High(TAlignment) then
Result := MetaTextAlignmentJustify
else
Result := MetaTextAlignmentLeft;
end;
end;

function ToMetaTextLayout(ASource: TTextLayout): TRLMetaTextLayout;
begin
case ASource of
tlTop: Result := MetaTextLayoutTop;
tlBottom: Result := MetaTextLayoutBottom;
tlCenter: Result := MetaTextLayoutCenter;
else
if ASource > High(TTextLayout) then
Result := MetaTextLayoutJustify
else
Result := MetaTextLayoutTop;
end;
end;

function FromMetaRect(const ASource: TRLMetaRect): TRect;
begin
Result.Left := ASource.Left;
Result.Top := ASource.Top;
Result.Right := ASource.Right;
Result.Bottom := ASource.Bottom;
end;

function FromMetaPoint(const ASource: TRLMetaPoint): TPoint;
begin
Result.X := ASource.X;
Result.Y := ASource.Y;
end;

function FromMetaColor(const ASource: TRLMetaColor): TColor;
begin
Result := RGB(ASource.Red, ASource.Green, ASource.Blue);
end;

function FromMetaPenMode(ASource: TRLMetaPenMode): TPenMode;
begin
case ASource of
MetaPenModeBlack: Result := pmBlack;
MetaPenModeWhite: Result := pmWhite;
MetaPenModeNop: Result := pmNop;
MetaPenModeNot: Result := pmNot;
MetaPenModeCopy: Result := pmCopy;
MetaPenModeNotCopy: Result := pmNotCopy;
MetaPenModeMergePenNot: Result := pmMergePenNot;
MetaPenModeMaskPenNot: Result := pmMaskPenNot;
MetaPenModeMergeNotPen: Result := pmMergeNotPen;
MetaPenModeMaskNotPen: Result := pmMaskNotPen;
MetaPenModeMerge: Result := pmMerge;
MetaPenModeNotMerge: Result := pmNotMerge;
MetaPenModeMask: Result := pmMask;
MetaPenModeNotMask: Result := pmNotMask;
MetaPenModeXor: Result := pmXor;
MetaPenModeNotXor: Result := pmNotXor;
else
Result := pmCopy;
end;
end;

function FromMetaPenStyle(ASource: TRLMetaPenStyle): TPenStyle;
begin
case ASource of
MetaPenStyleSolid: Result := psSolid;
MetaPenStyleDash: Result := psDash;
MetaPenStyleDot: Result := psDot;
MetaPenStyleDashDot: Result := psDashDot;
MetaPenStyleDashDotDot: Result := psDashDotDot;
MetaPenStyleClear: Result := psClear;
MetaPenStyleInsideFrame: Result := psInsideFrame;
else
Result := psSolid;
end;
end;

procedure FromMetaPen(ASource: TRLMetaPen; ADest: TPen);
begin
ADest.Color := FromMetaColor(ASource.Color);
ADest.Mode := FromMetaPenMode(ASource.Mode);
ADest.Style := FromMetaPenStyle(ASource.Style);
ADest.Width := ASource.Width;
end;

function FromMetaBrushStyle(ASource: TRLMetaBrushStyle): TBrushStyle;
begin
case ASource of
MetaBrushStyleSolid: Result := bsSolid;
MetaBrushStyleClear: Result := bsClear;
MetaBrushStyleHorizontal: Result := bsHorizontal;
MetaBrushStyleVertical: Result := bsVertical;
MetaBrushStyleFDiagonal: Result := bsFDiagonal;
MetaBrushStyleBDiagonal: Result := bsBDiagonal;
MetaBrushStyleCross: Result := bsCross;
MetaBrushStyleDiagCross: Result := bsDiagCross;
else
Result := bsSolid;
end;
end;

procedure FromMetaBrush(ASource: TRLMetaBrush; ADest: TBrush);
begin
ADest.Color := FromMetaColor(ASource.Color);
ADest.Style := FromMetaBrushStyle(ASource.Style);
end;

function FromMetaFontStyles(ASource: TRLMetaFontStyles): TFontStyles;
begin
Result := [];
if (MetaFontStyleBold and ASource) = MetaFontStyleBold then
Include(Result, fsBold);
if (MetaFontStyleItalic and ASource) = MetaFontStyleItalic then
Include(Result, fsItalic);
if (MetaFontStyleUnderline and ASource) = MetaFontStyleUnderline then
Include(Result, fsUnderline);
if (MetaFontStyleStrikeOut and ASource) = MetaFontStyleStrikeOut then
Include(Result, fsStrikeOut);
end;

function FromMetaFontCharset(ASource: TRLMetaFontCharset): TFontCharset;
begin
Result := TFontCharset(ASource);
end;

function FromMetaFontPitch(ASource: TRLMetaFontPitch): TFontPitch;
begin
case ASource of
MetaFontPitchDefault: Result := fpDefault;
MetaFontPitchVariable: Result := fpVariable;
MetaFontPitchFixed: Result := fpFixed;
else
Result := fpDefault;
end;
end;

procedure FromMetaFont(ASource: TRLMetaFont; ADest: TFont; AFactor: Double = 1);
var
A, B: Integer;
begin
A := ASource.PixelsPerInch;
if A = 0 then
A := ScreenPPI;
B := ADest.PixelsPerInch;
if B = 0 then
B := ScreenPPI;
//
//aDest.PixelsPerInch:=aSource.PixelsPerInch;
ADest.Charset := FromMetaFontCharset(ASource.Charset);
ADest.Color := FromMetaColor(ASource.Color);
//aDest.Height :=aSource.Height;
ADest.Name := ASource.Name;
ADest.Pitch := FromMetaFontPitch(ASource.Pitch);
ADest.Size := Round(ASource.Size * AFactor * A / B);
ADest.Style := FromMetaFontStyles(ASource.Style);
end;

function FromMetaGraphic(const ASource: String): TGraphic;
var
S: TStringStream;
T: String;
begin
if ASource = '' then
Result := nil
else
begin
S := TStringStream.Create(ASource);
try
S.Seek(0, soFromBeginning);
T := S.ReadString(3);
if (S.Position = 0) then
S.Seek(3, soFromCurrent);

  if T = 'NIL' then
    Result := nil
  else if T = 'BMP' then
    Result := TRLBitmap.Create
  else if T = 'ICO' then
    Result := TIcon.Create
  else if T = 'PNG' then
    Result := TPNGImage.Create
  else
    Result := nil;
  if Assigned(Result) then
    Result.LoadFromStream(S);
finally
  S.free;
end;

end;
end;

function FromMetaPointArray(const ASource: TRLMetaPointArray): TPointArray;
var
I: Integer;
begin
SetLength(Result, High(ASource) + 1);
for I := 0 to High(ASource) do
Result[I] := FromMetaPoint(ASource[I]);
end;

function FromMetaTextAlignment(ASource: TRLMetaTextAlignment): TAlignment;
begin
case ASource of
MetaTextAlignmentLeft: Result := taLeftJustify;
MetaTextAlignmentRight: Result := taRightJustify;
MetaTextAlignmentCenter: Result := taCenter;
MetaTextAlignmentJustify: Result := High(TAlignment);
else
Result := taLeftJustify;
end;
end;

function FromMetaTextLayout(ASource: TRLMetaTextLayout): TTextLayout;
begin
case ASource of
MetaTextLayoutTop: Result := tlTop;
MetaTextLayoutBottom: Result := tlBottom;
MetaTextLayoutCenter: Result := tlCenter;
MetaTextLayoutJustify: Result := High(TTextLayout);
else
Result := tlTop;
end;
end;

{ MISC }

procedure PenInflate(APen: TPen; AFactor: Double);
begin
if APen.Width > 1 then
APen.Width := Max(1, Round(APen.Width * AFactor));
end;

procedure CanvasStart(ACanvas: TCanvas);
begin
end;

procedure CanvasStop(ACanvas: TCanvas);
begin
end;

function CanvasGetClipRect(ACanvas: TCanvas): TRect;
begin
{$IfDef FPC}
Result := ACanvas.ClipRect;
{$Else}
GetClipBox(ACanvas.Handle, Result);
{$EndIf}
end;

procedure CanvasSetClipRect(ACanvas: TCanvas; const ARect: TRect);
var
isnull: Boolean;
begin
isnull := ((ARect.Right - ARect.Left) = 0) or ((ARect.Bottom - ARect.Top) = 0);
if isnull then
SelectClipRgn(ACanvas.Handle, 0)
else
begin
SelectClipRgn(ACanvas.Handle, 0);
IntersectClipRect(ACanvas.Handle, ARect.Left, ARect.Top, ARect.Right, ARect.Bottom);
end;
end;

procedure CanvasResetClipRect(ACanvas: TCanvas);
begin
SelectClipRgn(ACanvas.Handle, 0);
end;

function CanvasGetRectData(ACanvas: TCanvas; const ARect: TRect): String;
var
B: TBitmap;
begin
B := NeedAuxBitmap;
try
B.Width := ARect.Right - ARect.Left;
B.Height := ARect.Bottom - ARect.Top;
B.PixelFormat := pf32bit;
B.Canvas.CopyRect(Rect(0, 0, B.Width, B.Height), ACanvas, ARect);
Result := ToMetaGraphic(B);
finally
B.Free;
end;
end;

procedure CanvasSetRectData(ACanvas: TCanvas; const ARect: TRect; const AData: String; AParity: Boolean);
var
graphic: TGraphic;
auxrect: TRect;
aux: Integer;
begin
graphic := FromMetaGraphic(AData);
if graphic <> nil then
try
auxrect := ARect;
if AParity then
begin
aux := (auxrect.Right - auxrect.Left) div graphic.Width;
auxrect.Right := auxrect.Left + aux * graphic.Width + 1;
end;
ACanvas.StretchDraw(auxrect, graphic);
finally
graphic.free;
end;
end;

procedure CanvasStretchDraw(ACanvas: TCanvas; const ARect: TRect; const AData: String; AParity: Boolean);
begin
CanvasSetRectData(ACanvas, ARect, AData, AParity);
end;

procedure CanvasTextRectEx(ACanvas: TCanvas; const ARect: TRect; AX, AY: Integer; const AText: String; AAlignment: TRLMetaTextAlignment; ALayout: TRLMetaTextLayout; ATextFlags: TRLMetaTextFlags);
var
delta, left, top, txtw, txth, wid, I: Integer;
buff: AnsiString;
begin
buff := AnsiString(AText);
delta := ACanvas.TextWidth(' ') div 2;
txtw := ACanvas.TextWidth(buff + ' ');
txth := ACanvas.TextHeight(buff + ' ');
case AAlignment of
MetaTextAlignmentCenter: left := (ARect.Left + ARect.Right - txtw) div 2 + delta;
MetaTextAlignmentRight: left := ARect.Right - txtw + delta;
else
left := AX + delta;
end;
case ALayout of
MetaTextLayoutCenter: top := (ARect.Top + ARect.Bottom - txth) div 2;
MetaTextLayoutBottom: top := ARect.Bottom - txth;
else
top := AY;
end;
if AAlignment = MetaTextAlignmentJustify then
begin
wid := ARect.Right - left;
I := Length(buff);
while (ACanvas.TextWidth(buff + #32) <= wid) and IterateJustification(buff, I) do;
end;
if (ATextFlags and MetaTextFlagAutoSize) = MetaTextFlagAutoSize then
ACanvas.TextOut(left, top, buff)
else
ACanvas.TextRect(ARect, left, top, buff);
end;

function CanvasGetPixels(ACanvas: TCanvas; X, Y: Integer): TColor;
begin
Result := ACanvas.Pixels[X, Y];
end;

type
TLinePattern = record
Count: Byte;
Lengths: array[0..5] of Byte;
end;

const
LinePatterns: array[TPenStyle] of TLinePattern = (
(Count: 0;Lengths: (0, 0, 0, 0, 0, 0)), // psSolid
(Count: 2;Lengths: (3, 1, 0, 0, 0, 0)), // psDash
(Count: 2;Lengths: (1, 1, 0, 0, 0, 0)), // psDot
(Count: 4;Lengths: (2, 1, 1, 1, 0, 0)), // psDashDot
(Count: 6;Lengths: (3, 1, 1, 1, 1, 1)), // psDashDotDot
{$IfDef FPC}
(Count: 0;Lengths: (0, 0, 0, 0, 0, 0)), // psInsideFrame
(Count: 0;Lengths: (0, 0, 0, 0, 0, 0)), // psPattern
(Count: 0;Lengths: (0, 0, 0, 0, 0, 0)) // psClear
{$Else}
(Count: 0;Lengths: (0, 0, 0, 0, 0, 0)), // psClear
{$ifdef DELPHI2006}
(Count: 0;Lengths: (0, 0, 0, 0, 0, 0)), // psClear
(Count: 0;Lengths: (0, 0, 0, 0, 0, 0)), // psClear
(Count: 0;Lengths: (0, 0, 0, 0, 0, 0)),
(Count: 0;Lengths: (0, 0, 0, 0, 0, 0)),
{$endif}
(Count: 0;Lengths: (0, 0, 0, 0, 0, 0)) // psInsideFrame
{$IfDef DELPHI2007_UP}// delphi 2007 em diante
,
(Count: 0;Lengths: (0, 0, 0, 0, 0, 0)), // psUserStyle
(Count: 0;Lengths: (0, 0, 0, 0, 0, 0)) // psAlternate
{$endif}
{$endif}
);

procedure CanvasLineToEx(ACanvas: TCanvas; X, Y: Integer);
var
x0, y0: Integer;
xb, yb: Integer;
I, P, dist: Integer;
theta: Double;
sn, cs: Double;
patt: ^TLinePattern;
forecl: TColor;
backcl: TColor;
width0: Integer;
style0: TPenStyle;
factor: Integer;
cli: Integer;
begin
if (LinePatterns[ACanvas.Pen.Style].Count = 0) or (ACanvas.Pen.Width <= 1) then
ACanvas.LineTo(X, Y)
else
begin
style0 := ACanvas.Pen.Style;
width0 := ACanvas.Pen.Width;
x0 := ACanvas.PenPos.X;
y0 := ACanvas.PenPos.Y;
if X - x0 = 0 then
theta := pi / 2
else
theta := ArcTan((Y - y0) / (X - x0));
sn := Sin(theta);
cs := Cos(theta);
dist := Round(Sqrt(Sqr(X - x0) + Sqr(Y - y0)));
patt := @LinePatterns[ACanvas.Pen.Style];
P := 0;
I := 0;
forecl := ACanvas.Pen.Color;
backcl := ACanvas.Brush.Color;
factor := 4 * ACanvas.Pen.Width;
ACanvas.Pen.Style := psSolid;
if ACanvas.Brush.Style <> bsClear then
begin
ACanvas.Pen.Color := backcl;
ACanvas.LineTo(X, Y);
end;
ACanvas.Pen.Color := forecl;
ACanvas.MoveTo(x0, y0);
cli := 0;
while I < dist do
begin
Inc(I, patt^.Lengths[P] * factor);
if not (I < dist) then
I := dist;
xb := x0 + Round(I * cs);
yb := y0 + Round(I * sn);
if cli = 0 then
ACanvas.LineTo(xb, yb)
else
ACanvas.MoveTo(xb, yb);
cli := 1 - cli;
P := Succ(P) mod patt^.Count;
end;
ACanvas.Pen.Style := style0;
ACanvas.Pen.Width := width0;
end;
end;

{$IfDef MSWINDOWS}
procedure FontGetMetrics(const AFontName: AnsiString; AFontStyles: TFontStyles; var AFontRec: TRLMetaFontMetrics);
var
size: Integer;
outl: POutlineTextMetricA;
I: Integer;
bmp: TBitmap;
begin
bmp := NeedAuxBitmap;
try
bmp.Width := 1;
bmp.Height := 1;
bmp.Canvas.Font.Name := AFontName;
bmp.Canvas.Font.Style := AFontStyles;
bmp.Canvas.Font.Size := 750;
//
size := GetOutlineTextMetricsA(bmp.Canvas.Handle, SizeOf(TOutlineTextmetricA), nil);
if size = 0 then
raise Exception.Create('Invalid font for GetOutlineTextMetrics');
GetMem(outl, size);
try
outl^.otmSize := size;
if GetOutlineTextMetricsA(bmp.Canvas.Handle, size, outl) = 0 then
raise Exception.Create('GetOutlineTextMetrics failed');
//
AFontRec.TrueType := (outl^.otmTextMetrics.tmPitchAndFamily and TMPF_TRUETYPE) = TMPF_TRUETYPE;
AFontRec.BaseFont := AFontName;
AFontRec.FirstChar := Byte(outl^.otmTextMetrics.tmFirstChar);
AFontRec.LastChar := Byte(outl^.otmTextMetrics.tmLastChar);

  {$IfDef FPC}
  GetCharWidth(bmp.Canvas.Handle,aFontRec.FirstChar,aFontRec.LastChar,aFontRec.Widths[aFontRec.FirstChar]);
  {$Else}
  for I := AFontRec.FirstChar to AFontRec.LastChar do
    AFontRec.Widths[I] := bmp.Canvas.TextWidth(Chr(I));
  {$EndIf}

  AFontRec.FontDescriptor.Name := AFontName;
  AFontRec.FontDescriptor.Styles := '';
  if fsBold in AFontStyles then
    AFontRec.FontDescriptor.Styles := AFontRec.FontDescriptor.Styles + 'Bold';
  if fsItalic in AFontStyles then
    AFontRec.FontDescriptor.Styles := AFontRec.FontDescriptor.Styles + 'Italic';
  if fsUnderline in AFontStyles then
    AFontRec.FontDescriptor.Styles := AFontRec.FontDescriptor.Styles + 'Underline';
  if fsStrikeOut in AFontStyles then
    AFontRec.FontDescriptor.Styles := AFontRec.FontDescriptor.Styles + 'StrikeOut';
  AFontRec.FontDescriptor.Flags := 32;
  AFontRec.FontDescriptor.FontBBox := outl^.otmrcFontBox;
  AFontRec.FontDescriptor.MissingWidth := 0;
  AFontRec.FontDescriptor.StemV := 0;
  AFontRec.FontDescriptor.StemH := 0;
  AFontRec.FontDescriptor.ItalicAngle := outl^.otmItalicAngle;
  AFontRec.FontDescriptor.CapHeight := outl^.otmsCapEmHeight;
  AFontRec.FontDescriptor.XHeight := outl^.otmsXHeight;
  AFontRec.FontDescriptor.Ascent := outl^.otmTextMetrics.tmAscent;
  AFontRec.FontDescriptor.Descent := outl^.otmTextMetrics.tmDescent;
  AFontRec.FontDescriptor.Leading := outl^.otmTextMetrics.tmInternalLeading;
  AFontRec.FontDescriptor.MaxWidth := outl^.otmTextMetrics.tmMaxCharWidth;
  AFontRec.FontDescriptor.AvgWidth := outl^.otmTextMetrics.tmAveCharWidth;
finally
  FreeMem(outl, size);
end;

finally
bmp.Free;
end;
end;
{$Else}
// Extraido do projeto Fortes4Lazarus
procedure FontGetMetrics(const aFontName:string; aFontStyles:TFontStyles; var aFontRec:TRLMetaFontMetrics);
var
bmp:TBitmap;
i :integer;
begin
bmp := NeedAuxBitmap;
try
bmp.Canvas.Font.Name := aFontName;
bmp.Canvas.Font.Style := aFontStyles;
bmp.Canvas.Font.Size := 750;
//
aFontRec.TrueType := True;
aFontRec.BaseFont := aFontName;
aFontRec.FirstChar := 32;
aFontRec.LastChar := 255;
for i:=aFontRec.FirstChar to aFontRec.LastChar do
aFontRec.Widths[i] := bmp.Canvas.TextWidth( GetLocalizeStr(Chr(i)) );
//
aFontRec.FontDescriptor.Name := aFontName;
aFontRec.FontDescriptor.Styles := '';
if fsBold in aFontStyles then
aFontRec.FontDescriptor.Styles := aFontRec.FontDescriptor.Styles+'Bold';
if fsItalic in aFontStyles then
aFontRec.FontDescriptor.Styles := aFontRec.FontDescriptor.Styles+'Italic';
if fsUnderline in aFontStyles then
aFontRec.FontDescriptor.Styles := aFontRec.FontDescriptor.Styles+'Underline';
if fsStrikeOut in aFontStyles then
aFontRec.FontDescriptor.Styles := aFontRec.FontDescriptor.Styles+'StrikeOut';
aFontRec.FontDescriptor.Flags :=32;
aFontRec.FontDescriptor.FontBBox := Rect(-498,1023,1120,-307);
aFontRec.FontDescriptor.MissingWidth := 0;
aFontRec.FontDescriptor.StemV := 0;
aFontRec.FontDescriptor.StemH := 0;
aFontRec.FontDescriptor.ItalicAngle := 0;
aFontRec.FontDescriptor.CapHeight := 0;
aFontRec.FontDescriptor.XHeight := 0;
aFontRec.FontDescriptor.Ascent := 0;
aFontRec.FontDescriptor.Descent := 0;
aFontRec.FontDescriptor.Leading := 0;
aFontRec.FontDescriptor.MaxWidth := 0;
aFontRec.FontDescriptor.AvgWidth := 0;
finally
bmp.Free;
end;
end;
{$EndIf}

end.

juliomar · 2023-09-11T19:11:39Z

favor enviar pull request com as alterações sugeridas

…to em modo DESIGNER quanto em modo IMPRESSÃO. Adicionado suporte a imagem PNG, TIF e GIF fortesinformatica#334

dopidaniel · 2023-09-13T21:25:23Z

A Implementação parece correta, mas precisa de algum tratamento para manter compatibilidade com Delphi 7 e Lazarus/FPC

#334

dopidaniel · 2023-09-13T22:15:20Z

Subi alguns ajustes, baseado em sua implementação...

Muito obrigado pela analise e contribuição

juliomar closed this as completed Sep 11, 2023

Dorpoa pushed a commit to Dorpoa/fortesreport-ce that referenced this issue Sep 12, 2023

O Objeto TRLImage não reproduz a transparência original da imagem tan…

a62215e

…to em modo DESIGNER quanto em modo IMPRESSÃO. Adicionado suporte a imagem PNG, TIF e GIF fortesinformatica#334

Dorpoa mentioned this issue Sep 12, 2023

O Objeto TRLImage não reproduz a transparência original da imagem tan… #338

Closed

Dorpoa pushed a commit to Dorpoa/fortesreport-ce that referenced this issue Sep 13, 2023

O Objeto TRLImage não reproduz a transparência original da imagem tan…

5f274d2

…to em modo DESIGNER quanto em modo IMPRESSÃO. Adicionado suporte a imagem PNG, TIF e GIF fortesinformatica#334

dopidaniel added a commit that referenced this issue Sep 13, 2023

Support for PNG image

b50c4cc

#334

Provide feedback

Saved searches

Use saved searches to filter your results more quickly

Transparencia do TRLImage não está funcionando corretamente #334

Transparencia do TRLImage não está funcionando corretamente #334

Dorpoa commented Sep 8, 2023

Dorpoa commented Sep 11, 2023

Dorpoa commented Sep 11, 2023

juliomar commented Sep 11, 2023

dopidaniel commented Sep 13, 2023

dopidaniel commented Sep 13, 2023

Transparencia do TRLImage não está funcionando corretamente #334

Transparencia do TRLImage não está funcionando corretamente #334

Comments

Dorpoa commented Sep 8, 2023

Dorpoa commented Sep 11, 2023

Dorpoa commented Sep 11, 2023

juliomar commented Sep 11, 2023

dopidaniel commented Sep 13, 2023

dopidaniel commented Sep 13, 2023