In Delphi 10 Seattle, I need to insert an image into an ImageList. The image is in a descendant of TGraphicControl (see source code below). The insertion seems to work. However, I get only a white rectangle in the ImageList:
function InsertCloudImageIntoImageList(AdvCloudImage1: TAdvCloudImage): Integer;
// TAdvCloudImage = class(TGraphicControl)
// WebPicture is TCloudPicture = class(TGraphic)
var
TempBitmap: TBitmap;
R: TRect;
begin
Result := 0;
TempBitmap := TBitmap.Create;
try
TempBitmap.SetSize(16, 16);
R.Width := 16;
R.Height := 16;
R.Top := 0;
R.Left := 0;
AdvCloudImage1.WebPicture.Draw(TempBitmap.Canvas, R);
Result := Form1.ImageList1.Add(TempBitmap, nil);
finally
TempBitmap.Free;
end;
end;
I suspect the bug is in the drawing on the bitmap canvas?
The correct way to draw here is to call Draw on the destination bitmap's canvas, passing the source graphic. The method you call is declared protected in TGraphic which indicates that you are not meant to call it from consumer code.
So instead of
AdvCloudImage1.WebPicture.Draw(TempBitmap.Canvas, R);
You should use
TempBitmap.Canvas.Draw(0, 0, AdvCloudImage1.WebPicture);
This greatly simplifies the function since you no longer need the TRect variable. Furthermore, there's no point assigning to Result more than once. The entire function can be:
function InsertCloudImageIntoImageList(AdvCloudImage1: TAdvCloudImage): Integer;
var
TempBitmap: TBitmap;
begin
TempBitmap := TBitmap.Create;
try
TempBitmap.SetSize(16, 16);
TempBitmap.Canvas.Draw(0, 0, AdvCloudImage1.WebPicture);
Result := Form1.ImageList1.Add(TempBitmap, nil);
finally
TempBitmap.Free;
end;
end;
Related
Could an TGPImage be loaded from PNG file or resource
himg := TGPImage.Create('heading.png');
and then be modified by painting on it like using canvas?
Or, better to say, I would like to paint a background using programmatic methods and then load an image from PNG above my painting in order to operate with this merged image as one solid TGPImage.
I looked at methods and properties of TGPImage and didn't find painting instruments.
Could I probably do this using TBitmap?
Following does not work:
_hbm := TBitmap.Create();
_hbm.Width := 1000;
_hbm.Height := 1000;
_hbm.Canvas.Brush.Color := clBlack;
_hbm.Canvas.Pen.Color := clBlack;
_hbm.Canvas.FillRect(Rect(0, 0, 1000, 1000));
_hgb := TGPBitmap.Create(_hbm.Handle);
....................
GPGraphics.DrawImage(_hgb, 0, 0, _hgb.GetWidth(), _hgb.GetHeight());
You don't need a TBitmap for that.
You simply need to use a TGPGraphics associated with the TGPImage to draw on the TGPImage surface.
Here is a very simple example:
uses GDIPOBJ, GDIPAPI, GDIPUTIL;
procedure TForm1.Button1Click(Sender: TObject);
var
b: TGPBitmap;
g: TGPGraphics;
pen: TGPPen;
encoderClsid: TGUID;
begin
b := TGPBitmap.Create('D:\in.png');
try
g := TGPGraphics.Create(b);
try
pen := TGPPen.Create(MakeColor(255, 255, 0), 3);
try
{ Draw a yellow Rectangle }
g.DrawRectangle(pen, MakeRect(0, 0, 200, 200));
GetEncoderClsid('image/png', encoderClsid);
b.Save('D:\out.png', encoderClsid);
finally
pen.Free;
end;
finally
g.Free;
end;
finally
b.Free;
end;
end;
I want to draw on a canvas a word vertically and next to it a word horizontally.
I used a old suggestion like this :
in the maiForm's create event :
GetObject(MainForm.Font.Handle,SizeOf(TLogFont),#LogFont);
NewLogFont := LogFont;
NewLogFont.lfEscapement := 900;
NewFont := CreateFontIndirect(NewLogFont);
OldFont := MainForm.Font.Handle;
where
LogFont,NewLogFont : TLogFont;
NewFont,OldFont : HFont;
and in drawing routine :
fontTemp := TFont.Create;
fontTemp.Assign(aCanvas.Font);
......
aCanvas.Font.Handle := newFont; // if i coment this line the two strings drawn verically else both drawn horizonatlly
aCanvas.Font.Size := 8;
h := textHeight('1');
aCanvas.textOut(x,y,aString);
aCanvas.Font.Assign(fontTemp);
aCanvas.textOut(x+20,y,bString);
.....
fontTemp.Free;
In my old application (D2007) it worked ok but in Delphi 10.2, the change of orientation (from vert to horiz) changes both strings to horiz.
Any help please ?
No, as you said it is not an absolutely rare code. This approach lets you rotate text without using VCL's canvas properties.
Pure WinAPI for output text with rotation
The code below uses no VCL's capabilities to output rotated text onto provided device context (HDC).
procedure TForm1.DrawTextRotatedA(ADC: HDC; AFontHandle: HFONT;
Angle, X, Y: Integer; AColor: COLORREF; AText: String);
var
LogFont: tagLOGFONT;
OldFontHandle: HFONT;
NewFontHandle: HFONT;
begin
if (ADC = 0) or (AFontHandle = 0) then
Exit;
if GetObject(AFontHandle, SizeOf(LogFont), #LogFont) = 0 then
Exit;
// Set color of text and its rotation angle
SetTextColor(ADC, AColor);
if Angle > 360 then
Angle := 0;
LogFont.lfEscapement := Angle * 10;
LogFont.lfCharset := 1;
LogFont.lfOutPrecision := OUT_TT_PRECIS;
LogFont.lfQuality := PROOF_QUALITY;
// Create new font
NewFontHandle := CreateFontIndirect(LogFont);
try
OldFontHandle := SelectObject(ADC, NewFontHandle);
try
// Output result
SetBKMode(ADC, TRANSPARENT);
try
TextOut(ADC, X, Y, LPCWSTR(AText), Length(AText));
finally
SetBKMode(ADC, OPAQUE);
end;
finally
// Restore font handle
NewFontHandle := SelectObject(ADC, OldFontHandle);
end;
finally
// Delete font handle
DeleteObject(NewFontHandle);
end;
end;
There are places for improvements but this is just an example to prove you are wrong calling such a code rare. This example expects HFONT as one of arguments to perform all actions over it. You probably could get font handle from TControl by using WM_GETFONT message, but most of VCL's components don't honor this message (it works, f.e. with TListView which returns correct font handle). Trying to get font handle from HDC returns System font that doesn't support rotation at all. Perhaps I did something wrong but I have acted accordingly to microsoft.docs.
Using VCL for output text with rotation
I didn't get what code you have provide in your question should to do (it is cannot be compiled) so I rewrite it to show you how to output rotated text with using VCL's capabilities.
procedure TForm1.DrawTextRotatedB(ACanvas: TCanvas; Angle, X, Y: Integer;
ATextColor: TColor; AText: String);
var
NewX: Integer;
NewY: integer;
Escapement: Integer;
LogFont: TLogFont;
NewFontHandle: HFONT;
OldFontHandle: HFONT;
begin
if not Assigned(ACanvas) then
Exit;
// Get handle of font and prepare escapement
GetObject(ACanvas.Font.Handle, SizeOf(LogFont), #LogFont);
if Angle > 360 then
Angle := 0;
Escapement := Angle * 10;
// We must initialise all fields of the record structure
LogFont.lfWidth := 0;
LogFont.lfHeight := ACanvas.Font.Height;
LogFont.lfEscapement := Escapement;
LogFont.lfOrientation := 0;
if fsBold in ACanvas.Font.Style then
LogFont.lfWeight := FW_BOLD
else
LogFont.lfWeight := FW_NORMAL;
LogFont.lfItalic := Byte(fsItalic in ACanvas.Font.Style);
LogFont.lfUnderline := Byte(fsUnderline in ACanvas.Font.Style);
LogFont.lfStrikeOut := Byte(fsStrikeOut in ACanvas.Font.Style);
LogFont.lfCharSet := ACanvas.Font.Charset;
LogFont.lfOutPrecision := OUT_DEFAULT_PRECIS;
LogFont.lfClipPrecision := CLIP_DEFAULT_PRECIS;
LogFont.lfQuality := DEFAULT_QUALITY;
LogFont.lfPitchAndFamily := DEFAULT_PITCH;
StrPCopy(LogFont.lfFaceName, ACanvas.Font.Name);
// Create new font with rotation
NewFontHandle := CreateFontIndirect(LogFont);
try
// Set color of text
ACanvas.Font.Color := ATextColor;
// Select the new font into the canvas
OldFontHandle := SelectObject(ACanvas.Handle, NewFontHandle);
try
// Output result
ACanvas.Brush.Style := VCL.Graphics.bsClear;
try
ACanvas.TextOut(X, Y, AText);
finally
ACanvas.Brush.Style := VCL.Graphics.bsSolid;
end;
finally
// Restore font handle
NewFontHandle := SelectObject(ACanvas.Handle, OldFontHandle);
end;
finally
// Delete the deselected font object
DeleteObject(NewFontHandle);
end;
end;
Using case
Here is the code showing how to use procedures for rotating text.
procedure TForm1.aButton1Click(Sender: TObject);
var
DC: HDC;
begin
Repaint;
DC := GetDC(Handle);
try
DrawTextRotatedA(DC, Canvas.Font.Handle, TrackBar1.Position, 100, 100, clNavy, 'String');
finally
ReleaseDC(Handle, DC);
end;
DrawTextRotatedB(Canvas, TrackBar1.Position, 200, 100, clNavy, 'String');
end;
Sometimes it is faster to output rotated text onto DC without VCL. This could be useful if you are trying to deal with control that have no access to canvas. F.e. if you will try to paint tooltip (tooltip_class32) in your own style you probably might want to use the first method to output text (rotated or not).
Information
Here are links from docs.microsoft. they describe how and why one or another function was used.
About Device Contexts
TextOutW function
SetTextColor function
tagLOGFONTW structure
GetObject function
WM_GETFONT message
It's simple!
TFont has the property orientation that does the work! All this stuf I used is absolutely rare.
I draw a dotted line on a layer of an ImgView32. Later, I want to save each layer as transparent PNGs.
For any other layer that I have, the saving works just fine. But for the drawing layer, it does not.
In order to make the question simpler to understand, take the example code from the gr32 library, more specifically the Layers example. One of the options in its main menu is to add a custom drawing layer (New Custom Layer -> Simple Drawing Layer).
Then try to save that layer as a transparent PNG image and you will end up with a corrupted PNG file (you can't open it with any other picture viewer like for example Paint.net or Microsoft Photo Viewer). Same thing happens if you try to save the layer's bitmap32 as a bitmap as you can see in the bellow code...
I tried two approaches for saving Bitmap32 as a transparent PNG, so the first one is as follows:
procedure TMainForm.SavePNGTransparentX(bm32:TBitmap32; dest:string);
var
Y: Integer;
X: Integer;
Png: TPortableNetworkGraphic32;
function IsBlack(Color32: TColor32): Boolean;
begin
Result:= (TColor32Entry(Color32).B = 0) and
(TColor32Entry(Color32).G = 0) and
(TColor32Entry(Color32).R = 0);
end;
function IsWhite(Color32: TColor32): Boolean;
begin
Result:= (TColor32Entry(Color32).B = 255) and
(TColor32Entry(Color32).G = 255) and
(TColor32Entry(Color32).R = 255);
end;
begin
bm32.ResetAlpha;
for Y := 0 to bm32.Height-1 do
for X := 0 to bm32.Width-1 do
begin
// if IsWhite(bm32.Pixel[X, Y]) then
// bm32.Pixel[X,Y]:=Color32(255,255,255, 0);
if IsBlack(bm32.Pixel[X, Y]) then
bm32.Pixel[X,Y]:=Color32( 0, 0, 0, 0);
end;
Png:= TPortableNetworkGraphic32.Create;
try
Png.Assign(bm32);
Png.SaveToFile(dest);
finally
Png.Free;
end;
end;
So the above method works if I have a PNG loaded into the layer like this:
mypng := TPortableNetworkGraphic32.Create;
mypng.LoadFromStream(myStream);
B := TBitmapLayer.Create(ImgView.Layers);
with B do
try
mypng.AssignTo(B.Bitmap);
...
But as soon as I try to save the layer created with the code from the Layers example, the result is corrupted.
Even if I try to save the layer as bitmap like this (though this is not my intention since I need them to be PNG):
mylay := TBitmapLayer(ImgView.Layers.Items[i]);
mylay.Bitmap.SaveToFile('C:\tmp\Layer'+IntToStr(i)+'.bmp');
the same corruption occurs.
So, it's not like I receive an exception or anything... it just gets saved corrupted somehow;
I also tried other ways to save the Bitmap32 as transparent PNG, like for instance the GR32_PNG approach:
function SaveBitmap32ToPNG (sourceBitmap: TBitmap32;transparent: Boolean;bgColor32: TColor32;filename: String;compressionLevel: TCompressionLevel = 9;interlaceMethod: TInterlaceMethod = imNone): boolean;
var png: TPNGImage;
begin
result := false;
try
png := Bitmap32ToPNG (sourceBitmap,false,transparent,WinColor(bgColor32),compressionLevel,interlaceMethod);
try
png.SaveToFile (filename);
result := true;
finally
png.Free;
end;
except
result := false;
end;
end;
where
function Bitmap32ToPNG (sourceBitmap: TBitmap32;paletted, transparent: Boolean;bgColor: TColor;compressionLevel: TCompressionLevel = 9;interlaceMethod: TInterlaceMethod = imNone): TPNGImage; // TPNGObject
var
bm: TBitmap;
png: TPNGImage;//TPngObject;
TRNS: TCHUNKtRNS;
p: pngImage.PByteArray;
x, y: Integer;
begin
Result := nil;
png := TPngImage.Create; // TPNGObject
try
bm := TBitmap.Create;
try
bm.Assign (sourceBitmap); // convert data into bitmap
// force paletted on TBitmap, transparent for the web must be 8bit
if paletted then
bm.PixelFormat := pf8bit;
png.interlaceMethod := interlaceMethod;
png.compressionLevel := compressionLevel;
png.Assign(bm); // convert bitmap into PNG
// this is where the access violation occurs
finally
FreeAndNil(bm);
end;
if transparent then begin
if png.Header.ColorType in [COLOR_PALETTE] then begin
if (png.Chunks.ItemFromClass(TChunktRNS) = nil) then png.CreateAlpha;
TRNS := png.Chunks.ItemFromClass(TChunktRNS) as TChunktRNS;
if Assigned(TRNS) then TRNS.TransparentColor := bgColor;
end;
if png.Header.ColorType in [COLOR_RGB, COLOR_GRAYSCALE] then png.CreateAlpha;
if png.Header.ColorType in [COLOR_RGBALPHA, COLOR_GRAYSCALEALPHA] then
begin
for y := 0 to png.Header.Height - 1 do begin
p := png.AlphaScanline[y];
for x := 0 to png.Header.Width - 1
do p[x] := AlphaComponent(sourceBitmap.Pixel[x,y]); // TARGB(bm.Pixel[x,y]).a;
end;
end;
end;
Result := png;
except
png.Free;
end;
end;
but using this approach, I get an EAccessViolation when trying to save this particular layer. For any other layers (not drawing ones), it does not crash my project except for this custom drawing one.
The access violation occurs at this line:
png.Assign(bm);
inside the Bitmap32ToPNG function
Do you have any idea why that happens and how can I prevent this?
EDIT
I tried using TBitmapLayer instead, because the TPositionedLayer might lack the Bitmap32 for some reason.
So my code is like this:
// adding a BitmapLayer and setting it's onPaint event to my handler
procedure TMainForm.Mynewlayer1Click(Sender: TObject);
var
B: TBitmapLayer;
P: TPoint;
W, H: Single;
begin
B := TBitmapLayer.Create(ImgView.Layers);
with B do
try
Bitmap.SetSize(100,200);
Bitmap.DrawMode := dmBlend;
with ImgView.GetViewportRect do
P := ImgView.ControlToBitmap(GR32.Point((Right + Left) div 2, (Top + Bottom) div 2));
W := Bitmap.Width * 0.5;
H := Bitmap.Height * 0.5;
with ImgView.Bitmap do
Location := GR32.FloatRect(P.X - W, P.Y - H, P.X + W, P.Y + H);
Scaled := True;
OnMouseDown := LayerMouseDown;
OnPaint := PaintMy3Handler;
except
Free;
raise;
end;
Selection := B;
end;
// and the PaintHandler is as follows:
procedure TMainForm.PaintMy3Handler(Sender: TObject;Buffer: TBitmap32);
var
Cx, Cy: Single;
W2, H2: Single;
const
CScale = 1 / 200;
begin
if Sender is TBitmapLayer then
with TBitmapLayer(Sender).GetAdjustedLocation do
begin
// Five black pixels, five white pixels since width of the line is 5px
Buffer.SetStipple([clBlack32, clBlack32, clBlack32, clBlack32, clBlack32,
clWhite32, clWhite32, clWhite32, clWhite32, clWhite32]);
W2 := (Right - Left) * 0.5;
H2 := (Bottom - Top) * 0.5;
Cx := Left + W2;
Cy := Top + H2;
W2 := W2 * CScale;
H2 := H2 * CScale;
Buffer.PenColor := clRed32;
Buffer.StippleCounter := 0;
Buffer.MoveToF(Cx-2,Top);
Buffer.LineToFSP(Cx-2 , Bottom);
Buffer.StippleCounter := 0;
Buffer.MoveToF(Cx-1,Top);
Buffer.LineToFSP(Cx-1 , Bottom);
Buffer.StippleCounter := 0;
Buffer.MoveToF(Cx,Top);
Buffer.LineToFSP(Cx , Bottom);
Buffer.StippleCounter := 0;
Buffer.MoveToF(Cx+1,Top);
Buffer.LineToFSP(Cx+1 , Bottom);
Buffer.StippleCounter := 0;
Buffer.MoveToF(Cx+2,Top);
Buffer.LineToFSP(Cx+2 , Bottom);
end;
end;
Keep in mind that I use the default layers demo application. So this is just added code. I did not remove nor change anything in the demo code.
So I create a new layer (TBitmapLayer) and onPaint I do my drawing. In the end I want to save the contents of that layer as PNG. But it seems like the onPaint might draw somewhere else instead of the actual layer. Otherwise I do not understand why the saved image is empty.
So this time the resulted PNG is not corrupted, but it is empty...
The error is in the fact that the examples create TPositionedLayer layers which do not hold a bitmap. You can not type cast this layer type into a TBitmapLayer and expect it to create a bitmap image of the layer, as you do in this code:
mylay := TBitmapLayer(ImgView.Layers.Items[i]);
mylay.Bitmap.SaveToFile('C:\tmp\Layer'+IntToStr(i)+'.bmp');
I assume you do something similar to save to .png file, although you did not show that code.
The examples (with TPositionedLayer layers) use ImgView.Buffer for drawing on the screen. You can save that to a .png file like this:
SavePNGTransparentX(ImgView.Buffer, 'c:\tmp\imgs\buffer.png');
but I don't expect that to work satisfactorily for your separate layer images.
What is the reason you don't use TBitmapLayers as you have done before?
Edit after comments by user1137313
Inspired by the solution you found yourself (ref. your comment) I suggest the following which paints the layer to the extra bitmap only when needed for saving.
Starting from a menu item
procedure TMainForm.mnFileSaveClick(Sender: TObject);
begin
SaveLayerToPng(ImgView.Layers[ImgView.Layers.Count-1], 'c:\tmp\imgs\buffer.png');
end;
You possibly want to call SaveLayerToPng() in a loop if you save several layers at the same time, and also change the file name(s) as needed.
Then the SaveLayerToPng() procedure
procedure TMainForm.SaveLayerToPng(L: TCustomLayer; FileName: string);
var
bm32: TBitmap32;
begin
bm32:= TBitmap32.Create;
try
bm32.SetSizeFrom(ImgView.Buffer);
PaintSimpleDrawingHandler(L, bm32);
SavePNGTransparentX(bm32, FileName);
finally
bm32.Free;
end;
end;
It calls the existing PaintSimpleDrawingHandler(Sender: TObject; buffer: TBitmap32) procedure to paint to bm32 which it then passes on to `SavePNGTransparentX() for actual saving.
I used the paint handler of the Graphics32 example, but your PaintMy3Handler() can be used just as well.
The end result is same as your solution, just that the extra TBitmap32 is only painted when the file is to be saved.
The code below should be creating a bitmap that is a 48x48 rectangle, of blue background color and a Text (actually just a letter) centered horizontally and vertically of white color.
However nothing happens.
procedure MakeCustomIcon(AText: string; AWidth: Integer; AHeight: Integer; AColor: TAlphaColor; var ABlob: TBlob);
var
Bitmap: TBitmap;
Rect: TRectF;
InStream: TMemoryStream;
begin
Bitmap := TBitmap.Create;
InStream := TMemoryStream.Create;
try
Bitmap.SetSize(AWidth, AHeight);
Bitmap.Canvas.Clear(AColor);
Bitmap.Canvas.Stroke.Kind := TBrushKind.bkSolid;
Bitmap.Canvas.StrokeThickness := 1;
Bitmap.Canvas.Fill.Color := TAlphaColorRec.White;
Bitmap.Canvas.BeginScene;
Rect.Create(0, 0, AWidth, AHeight);
Bitmap.Canvas.FillText(Rect, AText, true, 100, [TFillTextFlag.ftRightToLeft], TTextAlign.taCenter, TTextAlign.taCenter);
Bitmap.Canvas.EndScene;
Bitmap.SaveToStream(InStream);
InStream.Position := 0;
ABlob.Clear;
ABlob.LoadFromStream(InStream);
finally
Bitmap.Free;
InStream.Free;
end;
I have tested the rest of my program to make sure the image (that Blob) is actually transporting and getting displayed, and it is doing so. The problem is fully contained on the way it is drawn the bitmap on the method above.
This TBlob is an array of byte.
I am looking to do rectangles like this below, to be used in TListView:
I have prepared a project.
1-) Write Text on TImage
2-) Draw on TImage
3-) Effect to TImage
I Try on XE5
Samples:
procedure ReDraw(Image: TImage);
var
MyRect: TRectF;
begin
if Image.Bitmap.IsEmpty then Exit;
MyRect := TRectF.Create(0, Ozellik.SeritTop, Image.Bitmap.Width, Ozellik.SeritBot);
with Image.Bitmap.Canvas do
begin
BeginScene;
if not Seffaf.IsChecked then
Fill.Color := Ozellik.SeritRenk
else
Fill.Color := TAlphaColorRec.Null;
FillRect(MyRect, 0, 0, [], 1);
Fill.Color := Ozellik.YaziRenk;
if FontCombo.ItemIndex <> -1 then
Font.Family := FontCombo.Items[FontCombo.ItemIndex];
Font.Size := Ozellik.YaziBoyut;
FillText(MyRect,FonYazi.Text.Trim,True,1,[],TTextAlign.taCenter,TTextAlign.taCenter);
EndScene;
end;
Image.Repaint;
end;
http://www.dosya.tc/server32/vHsbaC/CapsYapMasa_st_.rar.html
All canvas drawings must be grouped into a BeginScene/EndScene block. Also, it is recommended to draw within a try-finally block.
So, instead of
Bitmap.Canvas.Clear(AColor);
...
Bitmap.Canvas.BeginScene;
...
Bitmap.Canvas.EndScene;
you should do:
Bitmap.Canvas.BeginScene;
try
Bitmap.Canvas.Clear(AColor);
...
finally
Bitmap.Canvas.EndScene;
end;
-- Regards
For the sake of a minimal complete question, I have a WMF file loaded into a TImage control on a form. This control contains the property Picture, which is a TPicture type. I am trying to "rasterize" the WMF file that I loaded into the TImage, and store that into a TSpeedButton.Glyph.
What is interesting about this process is I am able to use this technique to create a resolution independent custom control (a button in my case) that will redraw its glyph for any resolution you like.
In real world usage, I would not have a TImage or a TSpeedButton, but this question is fundamentally about the process of moving content from TPicture to a TBitmap.
Here is the relevant semi-working code:
procedure CopyBitmap( Source:TImage; DestSpeedButton:TSpeedButton );
var
bmp: TBitmap;
begin
bmp:=TBitmap.Create;
try
// note: with WMF loaded, Source.Picture.Bitmap.Width and Height are 0.
bmp.Width := Source.Width; // originally I had Source.Picture.Bitmap.Width, which didn't work.
bmp.Height := Source.Height; //because Source.Picture.Bitmap.Height, doesn't work.
bmp.Canvas.Draw(0,0, Source.Picture.Graphic );
DestSpeedButton.Glyph:=bmp;
finally
bmp.Free;
end;
end;
Is this the correct approach? Why does the image invert during copy?
A sample WMF file, the exact file I'm using, is found here.
Thanks David, for suggesting that I draw the background. This works.
Note that in production I would change the code below to use Vcl.GraphUtils helper called ScaleImage as the results are much prettier. See the second code sample.
// Quick and Dirty : No sub-pixel anti-aliasing.
// Also does not modifies Source, so set Source's size before you
// call this.
procedure CopyBitmap( Source:TImage; DestSpeedButton:TSpeedButton );
var
bmp: TBitmap;
begin
bmp:=TBitmap.Create;
try
bmp.SetSize( Source.Width, Source.Height);
bmp.Canvas.Pen.Style := psClear;
bmp.Canvas.Brush.Style := bsSolid;
bmp.Canvas.Brush.Color := clFuchsia;
bmp.Canvas.Rectangle(0,0, Source.Width+1,Source.Height+1 );
bmp.Canvas.Draw(0,0, Source.Picture.Graphic );
bmp.TransparentColor := clFuchsia;
DestSpeedButton.Glyph:=bmp;
finally
bmp.Free;
end;
end;
Alternative that uses more memory, and is using the TPicture type instead of TImage because in real use I don't even have a TImage just a TPicture, also this looks nicer. Note that it is written around some custom control of my own design (or yours) that has some property type TBitmap. You have to substitute your own controls, or change TMyControlWithAGlyph to TSpeedButton if that's what you want to do:
// A Bit Better Looking. Uses Vcl.GraphUtils function ScaleImage
procedure CopyBitmap( Source:TPicture;
Dest:TMyControlWithAGlyph;
DestType:TCopyDestTypeEnum;
AWidth,AHeight:Integer;
DoInvert:Boolean;
TransparentColor:TColor=clFuchsia );
var
bmp,bmpFullSize: TBitmap;
ARect:TRect;
ScaleAmount:Double;
begin
if not Assigned(Source) then
exit;
if not Assigned(Dest) then
exit;
if not Assigned(Source.Graphic) then
exit;
bmp:=TBitmap.Create;
bmpFullSize := TBitmap.Create;
try
bmpFullSize.SetSize( Source.Width, Source.Height );
bmpFullSize.PixelFormat := pf24bit;
bmpFullSize.Canvas.Pen.Style := psClear;
bmpFullSize.Canvas.Brush.Style := bsSolid;
bmpFullSize.Canvas.Brush.Color := TransparentColor;
bmpFullSize.Canvas.Rectangle(0,0, Source.Width+1,Source.Height+1 );
bmpFullSize.Canvas.Draw(0,0, Source.Graphic );
bmp.SetSize( AWidth, AHeight);
bmp.PixelFormat := pf24bit;
// Vcl.GraphiUtil version needs a floating point scale.
ScaleAmount := AWidth / Source.Width;
ScaleImage(bmpFullSize,bmp,ScaleAmount );
// This lets me have a white icon and turn it black if I want to
// or vice versa
if DoInvert then
InvertBitmap(bmp);
if DestType=DestLargeGlyph then
begin
Dest.LargeGlyph := bmp;
end
else
begin
Dest.Glyph:=bmp;
end;
finally
bmp.Free;
bmpFullSize.Free;
end;
end;
The above code also calls this little helper:
function InvertBitmap(ABitmap: TBitmap): TBitmap;
var
x, y: Integer;
ByteArray: PByteArray;
begin
ABitmap.PixelFormat := pf24Bit;
for y := 0 to ABitmap.Height - 1 do
begin
ByteArray := ABitmap.ScanLine[y];
for x := 0 to ABitmap.Width * 3 - 1 do
begin
ByteArray[x] := 255 - ByteArray[x];
end;
end;
Result := ABitmap;
end;