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;
}
}
Related
I am using the WinAPI DrawText to write to the canvas within a Rectangle. I have to write text horizontally and vertically. Using the uFormat constant to set how the text is aligned.
I cannot get it to align vertical text to the top of the rectangle. see image
This is the code I am using to draw the text
procedure SetOrientation(pIndex: Integer);
var j: Integer;
begin
f := 0;
j := fPinCount div 4;
if pindex < j then begin
fBuffer.Canvas.font.orientation := 0 ;
f := DT_RIGHT
end else
if pIndex < 2 * j then begin
fBuffer.Canvas.font.Orientation := 900 ;
f := DT_TOP
end else
if pIndex < 3 * j then begin
fBuffer.Canvas.font.orientation := 0;
f := DT_LEFT
end else begin
fBuffer.Canvas.font.Orientation := 900;
f := DT_LEFT;
f := f or DT_SINGLELINE or DT_NOCLIP;
end;
SetOrientation(i);
DrawText(FBuffer.Canvas.Handle, s, Length(s), PinDscRects[i], f);
fBuffer.Canvas.Font.Orientation := 0;
I have tried all values of uFormat but none will justify the vertical text. Can you suggest an alternative method?
GDI is a very old graphics API, and sometimes this is quite noticeable. One could argue that this is one of those situations.
However, working around this limitation isn't difficult at all. For instance, you can do
procedure TForm1.FormPaint(Sender: TObject);
const
S = 'Nargles are cute!';
begin
Canvas.Font.Orientation := 900;
var R := ClientRect;
OffsetRect(R, 0, Canvas.TextWidth(S));
DrawText(Canvas.Handle, PChar(S), S.Length, R, DT_SINGLELINE or DT_NOCLIP);
end;
or (since I think the DT_NOCLIP part is a bit ugly)
procedure TForm1.FormPaint(Sender: TObject);
const
S = 'Nargles are cute!';
begin
Canvas.Font.Orientation := 900;
TextOut(Canvas.Handle, 0, Canvas.TextWidth(S), PChar(S), S.Length);
end;
As you see, I simply translate the vertical spatial coordinate(s) I pass to the text-drawing function by the logical width of the text in pixels.
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 :(
I use this code to scan very fast Bitmap.
Everything is Ok When PixelFormat = pf24bit but my program only work with 256 image color and for this reason PixelFormat = pf8bit.
When PixelFormat = pf8bit this code show error.
var
w, h: Integer;
CurrRow, OffSet: Integer;
x: byte;
pRed, pGreen, pBlue: PByte;
begin
CurrRow := Integer(aBitmap.Scanline[0]);
OffSet := Integer(aBitmap.Scanline[1]) - CurrRow;
Result:= False;
for h := 0 to aBitmap.Height - 1 do
begin
for w := 0 to aBitmap.Width - 1 do
begin
pBlue := PByte(CurrRow + w * 3);
pGreen := PByte(CurrRow + w * 3 + 1);
pRed := PByte(CurrRow + w * 3 + 2);
end;
inc(CurrRow, OffSet);
end;
now I use this code to swap color but dont work because scanline dont check color
procedure ReplaceColor(aBitmap: TBitmap; swap1, swap2: TRGBQuad);
var
w, h, k: Integer;
pScanline: pByte;
Red, Green, Blue, palindex: Byte;
PalEntries: array[0..255] of TRGBQuad;
begin
if aBitmap.Palette <> 0 then
GetPaletteEntries(aBitmap.Palette, 0, 255, PalEntries);
for h := 0 to aBitmap.Height - 1 do
begin
pScanline := pByte(aBitmap.Scanline[h]);
for w := 0 to aBitmap.Width - 1 do
begin
Blue:= PalEntries[pScanline^].rgbBlue ;
Red:= PalEntries[pScanline^].rgbRed ;
Green:= PalEntries[pScanline^].rgbGreen ;
if (Blue = swap1.rgbBlue) and (Red = swap1.rgbRed) and
(Green = swap1.rgbGreen) then
begin
Blue := swap2.rgbBlue;
Green := swap2.rgbGreen;
Red := swap2.rgbRed;
end
else if (Blue = swap2.rgbBlue) and (Red = swap2.rgbRed) and
(Green = swap2.rgbGreen) then
begin
Blue := swap1.rgbBlue;
Green := swap1.rgbGreen;
Red := swap1.rgbRed;
end;
Inc(pScanline);
end;
end;
end;
The code fails for pf8bit because it is not written to handle pf8bit. It is written to handle pf24bit instead.
The code is expecting each scanline to consist of width number of 3-byte (24 bits) pixels containing the actual RGB values. But in pf8bit, each scanline contains 1-byte (8 bit) pixels which are indexes into the bitmap's color palette. You are not accounting for that at all.
Try something more like this instead:
var
w, h: Integer;
pScanline: PByte;
Red, Green, Blue: Byte;
PalEntries: array[0..255] of TRGBQuad;
begin
Result := False;
if aBitmap.Palette <> 0 then
GetPaletteEntries(aBitmap.Palette, 0, 255, PalEntries);
for h := 0 to aBitmap.Height - 1 do
begin
pScanline := PByte(aBitmap.Scanline[h]);
for w := 0 to aBitmap.Width - 1 do
begin
case aBitmap.PixelFormat of
pf8Bit: begin
Blue := PalEntries[pScanline^].rgbBlue;
Green := PalEntries[pScanline^].rgbGreen;
Red := PalEntries[pScanline^].rgbRed;
Inc(pScanline);
end;
pf24Bit: begin
Blue := PRGBTriple(pScanline).rgbtBlue;
Green := PRGBTriple(pScanline).rgbtGreen;
Red := PRGBTriple(pScanline).rgbtRed;
Inc(pScanline, SizeOf(TRGBTriple));
end;
// etc for other color depths...
end;
end;
end;
end;
You need to do some research on how bitmaps actually work, particularly in relation to the format of the scanlines at the various color depths.
Bitmaps overview
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 :
Any library/code to fade the edges of a bitmap in a gradient manner?
Something like this:
Edit: final code
Ok came up with this code after your example, it's ~10 times faster after optimization with scanlines. Ideally I think I should convert it to use a 32bit bitmap instead and modify the actual alpha layer, but this works for now, ty!
procedure FadeEdges(b: TBitmap; Depth, Start, Col: TColor);
Var f, x, y, i: Integer;
w,h: Integer;
pArrays: Array of pRGBArray;
xAlpha: Array of byte;
sR, sG, sB: Byte;
a,a2: Double;
r1,g1,b1: Double;
Lx,Lx2: Integer;
procedure AlphaBlendPixel(X, Y: Integer);
begin
pArrays[y,x].rgbtRed := Round(r1 + pArrays[y,x].rgbtRed * a2);
pArrays[y,x].rgbtGreen := Round(g1 + pArrays[y,x].rgbtGreen * a2);
pArrays[y,x].rgbtBlue := Round(b1 + pArrays[y,x].rgbtBlue * a2);
end;
procedure AlphaBlendRow(Row: Integer; Alpha: Byte);
Var bR, bG, bB, xA: Byte;
t: Integer;
s,s2: Double;
begin
s := alpha / 255;
s2 := (255 - Alpha) / 255;
for t := 0 to b.Width-1 do begin
bR := pArrays[Row,t].rgbtRed;
bG := pArrays[Row,t].rgbtGreen;
bB := pArrays[Row,t].rgbtBlue;
pArrays[Row,t].rgbtRed := Round(sR*s + bR*s2);
pArrays[Row,t].rgbtGreen := Round(sG*s + bG*s2);
pArrays[Row,t].rgbtBlue := Round(sB*s + bB*s2);
end;
end;
begin
b.PixelFormat := pf24bit;
// cache scanlines
SetLength(pArrays,b.Height);
for y := 0 to b.Height-1 do
pArrays[y] := pRGBArray(b.ScanLine[y]);
// pre-calc Alpha
SetLength(xAlpha,Depth);
for y := 0 to (Depth-1) do
xAlpha[y] := Round(Start + (255 - Start)*y/(Depth-1));
// pre-calc bg color
sR := GetRValue(Col);
sG := GetGValue(Col);
sB := GetBValue(Col);
// offsets
w := b.Width-Depth;
h := b.Height-Depth;
for i := 0 to (Depth-1) do begin
a := xAlpha[i] / 255;
a2 := (255 - xAlpha[i]) / 255;
r1 := sR * a;
g1 := sG * a;
b1 := sB * a;
Lx := (Depth-1)-i;
Lx2 := i+w;
for y := 0 to b.Height - 1 do begin
AlphaBlendPixel(Lx, y); // Left
AlphaBlendPixel(Lx2, y); // right
end;
end;
for i := 0 to (Depth-1) do begin
AlphaBlendRow((Depth-1)-i, xAlpha[i]); // top
AlphaBlendRow(i+(h), xAlpha[i]); // bottom
end;
SetLength(xAlpha,0);
SetLength(pArrays,0);
end;
Final result: (left = original, right = blended on hovering with a ListView)
edit: further speed improvements, twice as fast as original proc.
I can give you some code I wrote a couple of years ago to achieve this. It might be useful as a guide. The code is part of a class that manipulates a bitmap and this is the part that fades the left edge of the bitmap into a white background:
procedure TScreenShotEnhancer.FadeOutLeft(Position, Start: Integer);
var
X, Y: Integer;
F, N: Integer;
I: Integer;
begin
BeginUpdate;
try
N := Position;
for I := 0 to N - 1 do begin
X := Position - I - 1;
F := Round(Start + (255 - Start)*I/N);
for Y := 0 to Height - 1 do
AlphaBlendPixel(X, Y, clWhite, F);
end;
finally
EndUpdate;
end;
end;
The actual work is done in this method:
procedure TScreenShotEnhancer.AlphaBlendPixel(X, Y: Integer; Color: TColor;
Alpha: Byte);
var
backgroundColor: TColor;
displayColor: TColor;
dR, dG, dB: Byte;
bR, bG, bB: Byte;
sR, sG, sB: Byte;
begin
backgroundColor := Bitmap.Canvas.Pixels[X, Y];
bR := GetRValue(backgroundColor);
bG := GetGValue(backgroundColor);
bB := GetBValue(backgroundColor);
sR := GetRValue(Color);
sG := GetGValue(Color);
sB := GetBValue(Color);
dR := Round(sR * alpha / 255 + bR * (255 - alpha) / 255);
dG := Round(sG * alpha / 255 + bG * (255 - alpha) / 255);
dB := Round(sB * alpha / 255 + bB * (255 - alpha) / 255);
displayColor := RGB(dR, dG, dB);
Bitmap.Canvas.Pixels[X, Y] := displayColor;
end;