I draw several textures on my canvas and on one of them i would like to apply a TGaussianBlurEffect. Problem is that TGaussianBlurEffect will apply to all the container in with it is placed (so all the canvas) where me i want to apply it only to one texture.
i found this function in delphi
procedure TFilterEffect.ProcessTexture(const Visual: TTexture; const Context: TContext3D);
var
Ver: TVertexBuffer;
Ind: TIndexBuffer;
Mat: TTextureMaterial;
begin
if Assigned(FFilter) then
begin
FFilter.ValuesAsTexture['Input'] := Visual;
FFilter.ApplyWithoutCopytoOutput;
if Assigned(Context) then
if Context.BeginScene then
try
Ver := TVertexBuffer.Create([TVertexFormat.Vertex, TVertexFormat.TexCoord0], 4);
Ver.Vertices[0] := Point3D(Context.PixelToPixelPolygonOffset.X,
Context.PixelToPixelPolygonOffset.Y, 0);
Ver.TexCoord0[0] := PointF(0.0, 0.0);
Ver.Vertices[1] := Point3D(Context.PixelToPixelPolygonOffset.X + Visual.Width,
Context.PixelToPixelPolygonOffset.Y, 0);
Ver.TexCoord0[1] := PointF(Visual.Width / TFilterManager.FilterTexture.Width, 0.0);
Ver.Vertices[2] := Point3D(Context.PixelToPixelPolygonOffset.X + Visual.Width,
Context.PixelToPixelPolygonOffset.Y + Visual.Height, 0);
Ver.TexCoord0[2] := PointF(Visual.Width / TFilterManager.FilterTexture.Width,
Visual.Height / TFilterManager.FilterTexture.Height);
Ver.Vertices[3] := Point3D(Context.PixelToPixelPolygonOffset.X,
Context.PixelToPixelPolygonOffset.Y + Visual.Height, 0);
Ver.TexCoord0[3] := PointF(0.0, Visual.Height / TFilterManager.FilterTexture.Height);
Ind := TIndexBuffer.Create(6);
Ind[0] := 0;
Ind[1] := 1;
Ind[2] := 3;
Ind[3] := 3;
Ind[4] := 1;
Ind[5] := 2;
Mat := TTextureMaterial.Create;
Mat.Texture := TFilterManager.FilterTexture;
Context.Clear(0);
Context.SetContextState(TContextState.cs2DScene);
Context.SetContextState(TContextState.csZWriteOff);
Context.SetContextState(TContextState.csZTestOff);
Context.SetMatrix(TMatrix3D.Identity);
Context.DrawTriangles(Ver, Ind, Mat, 1);
Mat.Free;
Ind.Free;
Ver.Free;
finally
Context.EndScene;
end;
end;
end;
but i don't understand it's purpose and how to use it :(
Related
I'm creating an application with Delphi Seattle with FMX, and I'm working with creating meshes directly myself. What I don't understand is why this mesh doesn't appear:
Mesh.Data.VertexBuffer.Length := 4;
Mesh.Data.IndexBuffer.Length := 6;
with Mesh.Data.VertexBuffer do
begin
Vertices[0] := TPoint3D.Create( 1, 1, 0);
Vertices[1] := TPoint3D.Create( 1, -1, 0);
Vertices[2] := TPoint3D.Create(-1, -1, 0);
Vertices[3] := TPoint3D.Create(-1, 1, 0);
TexCoord0[0] := TPointF.Create(0, 1);
TexCoord0[1] := TPointF.Create(0, 1);
TexCoord0[2] := TPointF.Create(0, 1);
TexCoord0[3] := TPointF.Create(0, 1);
end;
with Mesh.Data.IndexBuffer do
begin
Indices[0] := 0;
Indices[1] := 1;
Indices[2] := 2;
Indices[3] := 2;
Indices[4] := 3;
Indices[5] := 0;
end;
The mesh has a colour material however when I run it, the mesh does not appear. Everything else does (a cube and a grid).
The answer is to set the mesh to TwoSide true, then I can see it. I did try rotating the object, but still couldn't see anything.
I'm trying to create a function to create a TBitmap.
This bitmap will be a Glyph with Transparent background, and it will be only a character of the Wingdings font.
After this, I will use this glyph to assign to a TBitBtn (button).
This is my current code:
function CreateTransparent(aChar: Char; aFontSize, aWidth, aHeight: Integer; aColor: TColor): TBitmap;
function _GPColor(Col: TColor): TGPColor;
begin
Result := ColorRefToARGB(ColorToRGB(Col));
end;
var
f: TGPFont;
r, rTx: TGPRectF;
b: TGPSolidBrush;
c: TGPGraphics;
tx: TGPStringFormat;
bt: TGPBitmap;
h: HBITMAP;
bk, fg: Cardinal;
s: string;
attr: TGPImageAttributes;
begin
s := aChar;
fg := _GPColor(aColor);
bt := TGPBitmap.Create(abs(aWidth), aHeight, PixelFormat32bppARGB);
try
c := TGPGraphics.Create(bt);
f := TGPFont.Create('Wingdings', aFontSize, FontStyleRegular, UnitPixel);
b := TGPSolidBrush.Create( MakeColor(0, 0, 0, 0) );
tx := TGPStringFormat.Create;
try
// configura o device
tx.SetLineAlignment(StringAlignmentCenter);
r.X := 0;
r.Y := 0;
r.Width := 2000;
r.Height := aHeight;
c.MeasureString(WideString(s), -1, f, r, rTx);
if (aWidth < 0) and (rTx.Width > Abs(aWidth)) then
begin
c.Free;
bt.Free;
aWidth := Ceil(rTx.Width);
bt := TGPBitmap.Create(aWidth, aHeight, PixelFormat32bppARGB);
c := TGPGraphics.Create(bt);
end;
c.SetTextRenderingHint(TextRenderingHintAntiAlias);
// inicializa as variáveis
r.X := 0;
r.Y := 0;
r.Width := bt.GetWidth;
r.Height := bt.GetHeight;
// escreve o texto
b.SetColor(fg);
c.DrawString(WideString(s), -1, f, r, tx, b);
finally
f.Free;
b.Free;
tx.Free;
c.Free;
end;
Result := TBitmap.Create;
if bt.GetHBITMAP(0, h)= ok then
TBitmap(Result).Handle := h;
finally
bt.Free;
end;
end;
Usage:
myGlyph := CreateTransparent('N', 14, 16, 16, clGray);
The problem:
The resulting bitmap isn't transparent, the background becomes black!
Can someone tell me what I need to do to "fill" the background as transparent?
According to what I understood , you want the background of bitmap to be transparent ?
If so , you need to use alpha channel bitmap ..
By default the background color is black so you only need to set the property AlphaFormat of your bitmap to afDefined :
...
Result := TBitmap.Create;
Result.AlphaFormat := afDefined;
if bt.GetHBITMAP(0, h) = ok then
TBitmap(Result).Handle := h;
...
And this is the result :
I'm trying to create a mask window with "loading" text, to alert the user about a busy state of my application.
For this, I first created a single form with:
BorderStyle = bsNone
Color = clBlack
AlphaBlend = True
AlphaBlendValue = 180;
As the second step, I want to create another Form, but this one will has dynamic content.
I need to create a transparent bitmap with some status text and use the UpdateLayeredWindow to draw the window as the text.
Take a look and my desired result:
Remember: the text will be different in some cases, like:
Recalculating
Loading resources
Loading report
That's the reason what I need a dynamic bitmap generation.
QUESTION
How can I create a transparent bitmap with text and use it on a form with UpdateLayeredWindow?
I'm trying this, but without success ( to try the code put a Button5 and Label2 on a form):
procedure Inc(var p: pointer);
begin
p := Pointer(Integer(p) + 1);
end;
var
s: string;
frm: TForm;
f: HFont;
tx: HDC;
bmp, old: HBITMAP;
rc: TRect;
h: BITMAPINFOHEADER;
pvBits: Pointer;
t: tagBITMAPINFO;
x,y: integer;
a, r, g, b: byte;
sz: TSize;
p: tpoint;
BlendFunction: TBlendFunction;
begin
tx := CreateCompatibleDC(0);
s := label2.Caption;
f := SelectObject(tx, label2.Font.Handle);
fillchar(rc, SizeOf(rc), 0);
DrawText(tx, PChar(s), length(s), rc, DT_CALCRECT);
fillchar(h, SizeOf(h), 0);
pvBits := nil;
h.biSize := SizeOf(h);
h.biWidth := rc.Right - rc.Left;
h.biHeight := rc.Bottom - rc.Top;
h.biPlanes := 1;
h.biBitCount := 32;
h.biCompression := BI_RGB;
FillChar(t, SizeOf(t), 0);
t.bmiHeader := h;
bmp := CreateDIBSection(tx, t, 0, pvBits, 0, 0);
old := SelectObject(tx, bmp);
if old > 0 then
begin
SetTextColor(tx, $00FFFFFF);
SetBkColor(tx, $00000000);
SetBkMode(tx, TRANSPARENT);
DrawText(tx, PChar(s), length(s), rc, DT_NOCLIP);
r := GetRValue($FF);
g := GetGValue($FF);
b := GetBValue($FF);
for x := 0 to h.biWidth-1 do
for y := 0 to h.biHeight-1 do
begin
a := Byte(pvBits^);
Inc(pvBits);
Byte(pvBits^) := (b * a) shr 8;
Inc(pvBits);
Byte(pvBits^) := (g * a) shr 8;
Inc(pvBits);
Byte(pvBits^) := (r * a) shr 8;
Inc(pvBits);
Byte(pvBits^) := a;
end;
SelectObject(tx, old);
end;
SelectObject(tx, f);
deleteDC(tx);
sz.cx := h.biWidth;
sz.cy := h.biHeight;
p := Point(0,0);
BlendFunction.BlendOp := AC_SRC_OVER;
BlendFunction.BlendFlags := 0;
BlendFunction.SourceConstantAlpha := 255;
BlendFunction.AlphaFormat := AC_SRC_ALPHA;
frm := TForm.CreateNew(self);
frm.BorderStyle := bsNone;
frm.Position := poOwnerFormCenter;
frm.Show;
UpdateLayeredWindow(frm.Handle, 0, nil, #sz, bmp, #p, 0, #BlendFunction, ULW_ALPHA);
end;
Assuming you can use Windows API functions from Delphi (since you've tagged winapi), one easy way is:
CreateDIBSection() to create a 32 bit bitmap
FillRect() to fill the background, DrawText() to draw the text
Fix up the alpha
Use that bitmap with UpdateLayeredWindow()
Fixing up the alpha is done by directly modifying the bitmap bits that you get back from CreateDIBSection(). Note that UpdateLayeredWindow() requires pre-multiplied alpha, so you have to multiple the RGB components by the alpha value in advance.
The following code is C but hopefully will give you the idea:
LPVOID pBits; // bits from CreateDIBSection
const int width, height; // size of bitmap
const int alpha; // level of transparency
RGBQUAD* pPtr = (RGBQUAD*)pBits;
for (int y = 0; y < height; ++y)
{
for (int x = 0; x < width; ++x, ++pPtr)
{
pPtr->rgbBlue = (alpha * pPtr->rgbBlue) / 255;
pPtr->rgbGreen = (alpha * pPtr->rgbGreen) / 255;
pPtr->rgbRed = (alpha * pPtr->rgbRed) / 255;
pPtr->rgbReserved = alpha;
}
}
I am trying to put this to the canvas text out
Name
Flying
Lava
Water
Doing it like so.. it checks if the player should have something under there name like flying,lava,or water. So label text starts as the players name. All labels will have this. and then if any of the "extras" like canwater are true then it will add a new line with the related text. Seen below.
canwater := (FTherePlayers.Player[strtoint(name2)].values['water'] = 'Yes'); //checks if unit can enter water
canlava := (FTherePlayers.Player[strtoint(name2)].values['lava'] = 'Yes'); //checks if unit can enter lava
canfly := (FTherePlayers.Player[strtoint(name2)].values['Flying'] = 'Yes'); //checks if unit can fly
labeltext := FTherePlayers.Player[strtoint(name2)].values['name'];
if canfly then
labeltext := labeltext+ #13#10+ 'Flying';
if canlava then
labeltext := Labeltext+#13#10+'Lava';
if canwater then
labeltext := labeltext+#13#10+'Water';
hexmap1.AddLabelName(Labeltext,posL); //add name to placement label
Now it will give the correct info to the caption. But it never adds the new line, instead it will look something like this
name[][]flying[][]lava[][]water[][]
where [] are small squares
The code i am using for the textout looks like this.
procedure THexmap.AddLabelName(text :string; Position :TPoint);
var
hex_id :string;
P0:tpoint;
begin
with TempMap.canvas do
begin
hex_id := text;
hex_id := text;
{font := self.font;}
p0 := convertcoords(point(Position.X,Position.Y),ptROWCOL);
textout(p0.x - (trunc(textwidth(hex_id) / 2)) ,p0.y- (textheight(hex_id)) ,hex_id);
end;
Refresh;
end;
pretty much it loads the new images or in this case text, to a temp map.. the hex_ID is the name/flying/lava..ect the PO is Where to put it on the map aka row 1 , column 3. As for the textout, i am not sure how that works.. But figure the "newline" code #10#13 is getting messed up there. So any ideas on how i can fix this?
added how i get my XY(tpoint)
{******************************************************************************}
{ This function will return the Row / Col pair based on a given X/Y
for a using application that calls it}
function THexMap.ConvertCoords(point:Tpoint;pointtype:Tpointtype):Tpoint;
var
temp:TPoint;
begin
case PointType of
ptXY: {Convert from x/y to Row/Col}
Begin
temp.x:= round( (point.x + (HexRadius/2) ) / (1.5 * Hexradius));
if odd(temp.x) then
temp.y := round( (point.y + rise) / (rise*2))
else
temp.y := round( point.y / (2*rise));
{ This section insures row / col is good}
if (temp.x < 1) or (temp.y < 1) then
begin
temp.x := 0;
temp.y := 0;
end
else if (temp.y > HexRows) or (temp.x > HexColumns) then
begin
temp.y := 0;
temp.x := 0;
end;
ConvertCoords := temp;
end;
ptRowCol: { Converts Row/Col to X/Y }
begin
if point.x=1 then
temp.x:= HexRadius
else
temp.x := HexRadius+(point.x-1) * (round(1.5 * hexradius));
if odd(point.x) then
if point.y=1 then
temp.y:= rise
else
temp.y := rise+(point.y-1) * (2 * rise)
else
temp.y := (point.y * (2*rise));
ConvertCoords := temp;
end;
end;
end;
TextOut simply treats #13#10 as two characters to draw. That's why you see the squares.
It does not know that you intend to put the text on different lines.
You have to put the text to draw on different lines, e.g. by writing 4 calls to TextOut.
You could also use DrawText from the Win32 API.
var
s:String;
r:TRect;
begin
s := 'Just'#13#10'for'#13#10'demonstration';
r.Left := 10;
r.top := 10;
r.Right := 100;
r.Bottom := 100;
// you can use this with newer Delphiversions
// Canvas.TextRect(r,s, [tfCenter,tfWordBreak]);
// with olderversions you can use this =1 =16
DrawTextEx(Canvas.Handle, PChar(s), Length(s), r, DT_CENTER or DT_WORDBREAK, nil);
end;
as answer of the question how to get rect from point
var
s:String;
r:TRect;
begin
s := 'Just'#13#10'for'#13#10'demonstration';
r.Left := p0.x;
r.top := p0.y;
r.Right := p0.x + 10000; // we will calculate needed rect later
r.Bottom := p0.y + 10000; // via DT_CALCRECT
// you can use this with newer Delphiversions
// Canvas.TextRect(r,s, [tfCenter,tfWordBreak,tfCalcRect]);
// with olderversions you can use this =1 =16 1024
DrawTextEx(Canvas.Handle, PChar(s), Length(s), r, DT_CENTER or DT_WORDBREAK or DT_CALCRECT, nil);
// you can use this with newer Delphiversions
// Canvas.TextRect(r,s, [tfCenter,tfWordBreak]);
// with olderversions you can use this =1 =16
DrawTextEx(Canvas.Handle, PChar(s), Length(s), r, DT_CENTER or DT_WORDBREAK, nil);
end;
How can i display data in the form of table in the FastReport ?
Edit
I mean ,I want to create a report like this : (with tabular format).
The easiest way to use FR wizard
from FR File menu > new > Standard report wizard
when you reach the "Layout" page, choose tabular from layout then OK
I think you need to build the grid yourself. Here's a bit of code that builds a grid layout to get you started. You will need to adjust the column widths and add the formatting code (memo.frame) to get your desired look.
procedure CreateHeader(frxDataset: TfrxDBDataSet; Page: TfrxReportPage);
var
i: Integer;
X, Y, ThisWidth: Extended;
HeaderMemo: TfrxCustomMemoView;
Column: TcxGridDBColumn;
begin
Band := TfrxPageHeader.Create(Page);
Band.CreateUniqueName;
Band.SetBounds(0, 0, 0, fr01cm * 7);
Band.Height := edtHeightHeader.Value;
HeaderMemo := CreateMemo(Band);
HeaderMemo.SetBounds(0, 0, PageWidth, 0);
// Set memo style
// Or just add a frame HeaderMemo.Frame....
HeaderMemo.Style := 'Header line';
X := 0;
Y := 0;
Memo := CreateMemo(Band);
Memo.SetBounds(0, Y, X, fr01cm * 6);
Memo.Height := Band.Height - 1;
for i := 0 to pred(frxDataset.Fields.Count) do
begin
ThisWidth := 100;
Memo := CreateMemo(Band);
Memo.SetBounds(X, Y, ThisWidth, fr01cm * 6);
Memo.Text := frxDataset.Fields[i].FieldName;
// Set memo style
// Or just add a frame HeaderMemo.Frame....
Memo.Style := 'Header';
Memo.Height := Band.Height - 1;
X := X + ThisWidth;
end;
HeaderMemo.Height := Band.Height;
end;
procedure CreateFastReportDataBand(frxDataset: TfrxDBDataSet; Page: TfrxReportPage);
var
i: Integer;
X, Y, ThisWidth: Extended;
begin
Band := TfrxMasterData.Create(Page);
Band.CreateUniqueName;
Band.SetBounds(0, CurY, 0, 0);
Band.Height := edtHeightData.Value;
TfrxMasterData(Band).frxDataset := frxDataset;
X := 0;
Y := 0;
for i := 0 to pred(frxDataset.Fields.Count) do
begin
ThisWidth := 100;
Memo := CreateMemo(Band);
Memo.SetBounds(X, Y, ThisWidth, fr01cm * 5);
Memo.Dataset := frxDataset;
Memo.DataField := frxDataset.Fields[i].FieldName;
// Set memo style
// Or just add a frame HeaderMemo.Frame....
Memo.Style := 'Data';
Memo.Height := Band.Height - 1;
X := X + ThisWidth;
end;
end;
It should work ok, but I've not had a chance to test since decoupling it from my application.
It will be possible using Framing Property of Memos.