How can I set TImage size as double value? Example Image1.width := 50.1; or what component accept it, because TImage only accept integer values.
I'm working with download files, and one image should be the number of elements to download, so Image1.width max value is 340, i need to divide this value by the amount of files who will be downloaded, and increase this value on image1.width when every download be finished, but TImage only accept Integer value.
I already did it using "Round" but it is not what I need.
As answered, you cannot set the image's size to any floating point value.
However, using coordinate spaces and transformations functions, you can set an arbitrary transformation between a logical coordinate system and the viewing device. This can be used to increase the logical extent of the image's canvas size with each download and yet keep the image on the screen with an entirely different size.
The below example demonstrates the concept by drawing 4 rows and 4 columns of a 256x256 image on a 105x105 bitmap canvas of a TPicture of a TImage. Basically it achieves to draw a single 256x256 image on a 26.25x26.25 px. surface.
uses
pngimage;
procedure TForm1.Button1Click(Sender: TObject);
const
Col = 4;
Row = 4;
var
Png: TPngImage;
ImgCanvas: TCanvas;
ExtX, ExtY: Integer;
MapMode: Integer;
Size: TSize;
i, j: Integer;
begin
Png := TPngImage.Create;
try
Png.LoadFromFile('...\Attention.png');
Png.Draw(Canvas, Rect(0, 0, Png.Width, Png.Height)); // original picture
Image1.Picture.Bitmap.Canvas.Brush.Color := Color;
Image1.Picture.Bitmap.SetSize(Image1.Width, Image1.Height);
ImgCanvas := Image1.Picture.Bitmap.Canvas;
SetStretchBltMode(ImgCanvas.Handle, HALFTONE);
MapMode := SetMapMode(ImgCanvas.Handle, MM_ISOTROPIC);
if MapMode <> 0 then
try
ExtX := Png.Width * Col;
ExtY := Png.Height * Row;
if not GetWindowExtEx(ImgCanvas.Handle, Size) then
RaiseLastOSError;
if not SetWindowExtEx(ImgCanvas.Handle, Size.cx * ExtX div Image1.Width,
Size.cy * ExtY div Image1.Height, nil) then
RaiseLastOSError;
if not SetViewportExtEx(ImgCanvas.Handle, Size.cx, Size.cy, nil) then
RaiseLastOSError;
i := 0;
j := 0;
while j < ExtY do begin
while i < ExtX do begin
Png.Draw(ImgCanvas, Rect(i, j, i + Png.Width, j + Png.Height));
Inc(i, Png.Width);
end;
i := 0;
Inc(j, Png.Height);
end;
finally
SetMapMode(ImgCanvas.Handle, MapMode);
end
else
RaiseLastOSError;
finally
Png.Free;
end;
end;
Probably worth noting that GDI may not be the best graphics system when scaling is involved. For quick reference, here's what the above yields:
Assuming you're using the VCL framework, all controls across Delphi are Integer based. You simply cannot assign a float value, not without first converting it to an integer.
The Firemonkey framework on the other hand is widely based on float values.
Related
Below is my sample code:
var lBitmap: TBitmap;
begin
lBitmap := TBitmap.Create;
lBitmap.PixelFormat := TPixelFormat.pf32bit;
lBitmap.Transparent := TRUE; // !
lBitmap.LoadFromFile( 'd:\temp\bmp32b_300dpi_transparent_400x250.bmp' );
// Bitmap RGB+Alpha created with GIMP
// modifications on pixels
Canvas.Draw(100, 0, lBitmap);
// Up to this point it is correct, the drawing is painted with transparency
lBitmap.SaveToFile( 'd:\tmp\after.bmp' ); // after this -> I have lost transparency
lBitmap.Free;
end;
How to use correctly TBitmap object to save a file with transparency?
It seems to me like TBitmap doesn't support saving bitmaps with alpha channels. And maybe we shouldn't blame the VCL for this, because BMPs with alpha transparency are uncommon. Many applications don't support transparent BMPs.
This being said, I "reverse-engineered" a BMP with alpha channel created in GIMP and wrote the following Delphi routine to produce the very same bitmap:
procedure SaveTransparentBitmap(ABitmap: TBitmap; const AFileName: string);
var
FS: TFileStream;
BFH: TBitmapFileHeader;
BIH: TBitmapV5Header;
y: Integer;
sl: PUInt64;
begin
// ABitmap MUST have the GIMP BGRA format.
FS := TFileStream.Create(AFileName, fmOpenWrite);
try
// Bitmap file header
FillChar(BFH, SizeOf(BFH), 0);
BFH.bfType := $4D42; // BM
BFH.bfSize := 4 * ABitmap.Width * ABitmap.Height + SizeOf(BFH) + SizeOf(BIH);
BFH.bfOffBits := SizeOf(BFH) + SizeOf(BIH);
FS.Write(BFH, SizeOf(BFH));
// Bitmap info header
FillChar(BIH, SizeOf(BIH), 0);
BIH.bV5Size := SizeOf(BIH);
BIH.bV5Width := ABitmap.Width;
BIH.bV5Height := ABitmap.Height;
BIH.bV5Planes := 1;
BIH.bV5BitCount := 32;
BIH.bV5Compression := BI_BITFIELDS;
BIH.bV5SizeImage := 4 * ABitmap.Width * ABitmap.Height;
BIH.bV5XPelsPerMeter := 11811;
BIH.bV5YPelsPerMeter := 11811;
BIH.bV5ClrUsed := 0;
BIH.bV5ClrImportant := 0;
BIH.bV5RedMask := $00FF0000;
BIH.bV5GreenMask := $0000FF00;
BIH.bV5BlueMask := $000000FF;
BIH.bV5AlphaMask := $FF000000;
BIH.bV5CSType := $73524742; // BGRs
BIH.bV5Intent := LCS_GM_GRAPHICS;
FS.Write(BIH, SizeOf(BIH));
// Pixels
for y := ABitmap.Height - 1 downto 0 do
begin
sl := ABitmap.ScanLine[y];
FS.Write(sl^, 4 * ABitmap.Width);
end;
finally
FS.Free;
end;
end;
This write a BITMAPFILEHEADER followed by a BITMAPV5HEADER and the pixel data in BGRA format.
I omit all kinds of error checking. For instance, I don't verify that ABitmap actually has the required format.
Test:
procedure TForm1.FormCreate(Sender: TObject);
var
bm: TBitmap;
begin
bm := TBitmap.Create;
try
bm.LoadFromFile('C:\Users\Andreas Rejbrand\Desktop\Test.bmp');
SaveTransparentBitmap(bm, 'C:\Users\Andreas Rejbrand\Desktop\Test2.bmp');
finally
bm.Free;
end;
end;
After this, Test.bmp and Test2.bmp are binary equal.
Saving 32-bit bitmaps with alpha channels needs a workaround as #Andreas Rejbrand has pointed out. There also seems to be some more confusion about the BMP file format, what the TBitmap.Transparent property does, and how you draw bitmaps transparently with the VCL.
32-bit bitmaps are the only bitmaps that carry information about transparency in the files. They have that information in the alpha channel and nowhere else. In the alpha channel, every pixel has its own 0-255 alpha value in the RGBA structure. This is often referred to as partial transparency.
When you draw/display 32-bit bitmaps, you have to pay attention to the TBitmap.AlphaFormat property. It defaults to afIgnore, which means that the bitmap is drawn without transparency. Use afPremultiplied or afDefined to draw with transparency. The latter is probably what you want.
The TBitmap.Transparent property is specific to the VCL TBitmap, and there is nothing in the BMP file format that corresponds to it. It's just a simple way to display bitmaps transparently, where a color defines which pixels should be fully transparent. The application must be familiar with the bitmaps to be able to use this method. It's also important to be aware of how the TBitmap.TransparentMode property works. It defaults to tmAuto, which sets the color of the bottom-leftmost pixel of the bitmap as TBitmap.TransparentColor. When TransparentMode is set to tmFixed, the TBitmap.TransparentColor you have specified is used. This method can also be used on 32-bit bitmaps.
Note that when you draw with the standard VCL TCanvas drawing routines on a 32-bit bitmap with transparency in the alpha channel, the transparency will be lost where you have drawn.
It seems that in your sample code, you have ignored AlphaFormat and TransparentMode. You should also decide if you want to use the transparency in the alpha channel or the TBitmap.Transparent method. But we have no bitmap in order to check if that is the real problem.
I have problems saving an ImgView32 layer as a TRANSPARENT PNG.
I use the code from this question to do the saving.
However, the image saves with a white background.
Here is how I initialize my ImgView32, create a layer on it, and then draw a line on it:
procedure TputLine.FormCreate(Sender: TObject);
var
P: TPoint;
W, H: Single;
imwidth: integer;
imheight: integer;
begin
imwidth := Iv1.Width;
imheight := Iv1.Height;
with iv1 do
begin
Selection := nil;
Layers.Clear;
Scale := 1;
Scaled := True;
Bitmap.DrawMode := dmTransparent;
Bitmap.SetSize(imwidth, imheight);
Bitmap.Canvas.Pen.Width := 4;
end;
BL := TBitmapLayer.Create(iv1.Layers);
try
BL.Bitmap.DrawMode := dmTransparent;
BL.Bitmap.SetSize(imwidth,imheight);
BL.Bitmap.Canvas.Pen.Width := penwidth;
BL.Bitmap.Canvas.Pen.Color := pencolor;
BL.Location := GR32.FloatRect(0, 0, imwidth, imheight);
BL.Scaled := False;
except
BL.Free;
raise;
end;
end;
So iv1 is the name of my ImgView32.
Then I draw a line on it using this code:
var
bm32:TBitmapLayer;
...
begin
bm32:=(iv1.Layers[0] as TBitmapLayer).Bitmap;
bm32.canvas.pen.color:=clwhite;
bm32.canvas.brush.color:=clwhite;
bm32.canvas.rectangle(0,0,bm32.width-1, bm32.height-1);
bm32.canvas.Pen.Color:=WinColor(ColorPickerGTK1.SelectedColor);
bm32.canvas.brush.color:=clWhite;
bm32.Canvas.Pen.Width:=3;
bm32.Canvas.MoveTo(0,bm32.Height);
bm32.Canvas.LineTo(0+150,bm32.Height-250);
end;
If I use the clWhite32 for the above code when drawing the rectangle, then when saving the PNG, the background of the imgView turns black... So I do not understand the problem really.
I do the saving like this:
procedure TputLine.Button2Click(Sender: TObject);
var
myLay:TBitmapLayer;
begin
mylay := iv1.Layers.Items[0] as TBitmapLayer;
SavePNGTransparentX(mylay.Bitmap);
end;
and the actual saving code (from the link described above)
procedure TPutLine.SavePNGTransparentX(bm32:TBitmap32);
var
Y: Integer;
X: Integer;
Png: TPortableNetworkGraphic32;
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);
end;
Png:= TPortableNetworkGraphic32.Create;
Png.Assign(bm32);
Png.SaveToFile('C:\ThisShouldBeTransparent.png');
Png.Free;
end;
I do not understand why it does not save the layer as transparent PNG.
How can I fix it? Any idea is welcome.
You can replicate my problem using the above code. It uses GR32_PNG and GR32_PortableNetworkGraphic. You only need to add a TImgView32 control to your form and add the code listed above.
The reason to the problem seems to be two-fold.
First, when you call Png.Assign(bm32); in unit GR32_PNG, it attempts to find out what the smallest format would be to store the image in. If the image has less than 256 distinct colors, it creates a paletted format, and depending on how many colors it finds, the bit depth can become 1, 2, 4 or 8. As far as my knowledge goes, only images with TrueColor and Alpha can be saved as variable transparency png images.
Secondly, you draw with only one color, which triggers the above problem. This is of course not your fault, IMO the above mentioned analysis should be possible to bypass.
The TPortableNetworkGraphic32 class has two properties, BitDepth and ColorType wich control the format of the png image, that would be useful, if they were settable! Attempting to set them in code as:
Png.BitDepth := 8;
Png.ColorType := ctTrueColorAlpha;
leads to exceptions
EPngError with message 'Bit depth may not be specified directly yet!
EPngError with message 'Color Type may not be specified directly yet!
From the wording we can assume some further development in the future.
The cure
To bypass the above described image analysis, you can change line 459 in GR32_PNG.pas.
procedure TPortableNetworkGraphic32.AssignPropertiesFromBitmap32()
var
...
begin
...
IsPalette := True; // <--- change to False
...
That will take care of the bit depth analysis and prevents palette creation if less than 256 colors.
After this hack you can use the SavePNGTransparentX() procedure to save a TBitmap32 to a .png file and preserving transparency.
Then, there's one change more that you may be interested in, regarding the SavePNGTransparentX() procedure. As you have seen, it requires the background of your drawing surface to be white, because it specifically sets the Alpha channel to zero for all white pixels. A TBitmapLayer is however initialized with all pixels (RGBA) as all zeros, so the color components of each pixel makes up to black color (which is not visible because the alpha channel is zero). Therefore you need to fill the drawing layer with white, which makes it opaque, which again covers up all lower layers (beneath the drawing layer).
To make a correction to this you can
remove the initialization of the drawing layer to all white
change the IsWhite function into an IsBlack function
change the assignment of the transparent pixels
Code would become
procedure TForm8.SavePNGTransparentX(bm32:TBitmap32);
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;
Png.Assign(bm32);
Png.SaveToFile('C:\tmp\imgs\ThisShouldBeTransparent3.png');
Png.Free;
end;
With this change you can see the layers beneath your drawing layer and the resulting file of your drawing layer will have all non-drawn pixels transparent.
There is however still one problem in general with the above procedure, and that is that partially transparent pixels loose their transparency, but that will remain for a future excercise.
Here's a few images, First the ImageView with a bitmap loaded on the bottom layer:
Then, I draw a blue cross on the BL layer (ref. your code) using basically the code in your Button1Click() but without the white rectangle.
Then I save the BL layer to a .png file and look at it with Windows Explorer "Preview":
I'm trying to convert a bunch of images with could have pixel formats of anything (4bit, 8bit, 16bit, 24bit etc) to an image that is 1bit.
I have the following code which will convert 24bit to 1bit, but this doesn't handle any other pixel formats.
procedure TFormMain.ButtonConvertClick(Sender: TObject);
var
Bitmap: TBitmap;
NewBitmap: TBitmap;
x,y: Integer;
ScanLine: pRGBTriple;
Colour: Integer;
FilePath: String;
FileName: String;
begin
Bitmap := TBitmap.Create;
try
Bitmap.LoadFromFile(EditFileName.Text);
NewBitmap := TBitmap.Create;
try
NewBitmap.PixelFormat := pf1bit;
NewBitmap.Height := Bitmap.Height;
NewBitmap.Width := Bitmap.Width;
for y := 0 to Bitmap.Height -1 do
begin
ScanLine := Bitmap.ScanLine[y];
for x := 0 to Bitmap.Width -1 do
begin
Colour := (ScanLine.rgbtBlue + ScanLine.rgbtGreen + ScanLine.rgbtRed) div 3;
if (Colour >= 128)
then Colour := clWhite
else Colour := clBlack;
NewBitmap.Canvas.Pixels[x, y] := Colour;
Inc(ScanLine);
end;
end;
FilePath := ExtractFilePath(EditFileName.Text);
FileName := TPath.GetFileNameWithoutExtension(EditFileName.Text);
NewBitmap.SaveToFile(TPath.Combine(FilePath, FileName + '-copy.bmp'));
finally
FreeAndNil(NewBitmap);
end;
finally
FreeAndNil(Bitmap);
end;
end;
I could handle each case individually, but there seems like there should be a function that does this. I have looked into the TGPBitmap.Clone function class, but I could only get it to produce blank(white) images and was unable to find any examples of its use.
The simplest way - draw any bitmap on 24bit one and use existing code.
The slowest way - get color of every pixel through Pixels[] property
Otherwise you have to treat every kind of bitmap individually. Note that 1,4 and 8-bit bitmaps contain indexes of palette, so you need to get proper color from bitmap palette, and 15 and 16-bit bitmaps pixels have structure xRRRRRGGGGGBBBBB and RRRRRGGGGGGBBBBB, so you need to extract 5 and 6-bit color parts and calculate overall pixel luminance.
Gretings to all!
How to print pictures in Delphi on TPrinter, in real sizes of pictures?
From canvas of TImage I have good results, but if I paints on TPrinter canvas, I have BAD result, puctures is too small than real size of bitmap.
Why that happens What I'm need to do for fix bug?
UPDATE
Yes, I seen question from the hint in the 1st post.
I can't use JCL/JVCL code in my project, but I got idea from it.
I create temporary TImage, and calculate dimensions of it in accordance with the factor of printer's DPI:
var
i, iRow, iCol, // Counter
iBorderSize, // Ident from left/top borders
iImgDistance, // Ident between images in grid
iRows, // Rows Count
iColumns, // Colun count
iLeft, iTop: Integer; // For calc
bmp: TBitmap;
bStop, bRowDone, bColDone: Boolean;
Img1: TImage;
scale: Double;
function CalcY: Integer;
begin
if (iRow = 1) then
Result := iBorderSize
else
Result := iBorderSize + (iImgDistance * (iRow - 1)) +
(bmp.Height * (iRow - 1));
end;
function CalcX: Integer;
begin
if (iCol = 1) then
Result := iBorderSize
else
Result := iBorderSize + (iImgDistance * (iCol - 1)) +
(bmp.Width * (iCol - 1));
end;
begin
iBorderSize := StrToInt(BorderSizeEdit.Text);
iImgDistance := StrToInt(ImgsDistanceEdit.Text);
iRows := StrToInt(RowsCountEdit.Text);
iColumns := StrToInt(ColCountEdit.Text);
iRow := 1;
iCol := 1;
iLeft := iBorderSize;
iTop := iBorderSize;
if Printer.Orientation = poPortrait then
scale := GetDeviceCaps(Printer.Handle, LOGPIXELSX) /
Screen.PixelsPerInch
else
scale := GetDeviceCaps(Printer.Handle, LOGPIXELSY) /
Screen.PixelsPerInch;
bmp := TBitmap.Create;
Img1 := TImage.Create(nil);
Img1.Height := Trunc(Printer.PageHeight / scale); //Calc canvas size
Img1.Width := Trunc(Printer.PageWidth / scale); //Calc canvas size
Img1.Canvas.Brush.Color := clWhite;
Img1.Canvas.FillRect(Rect(0, 0, Img1.Width, Img1.Height));
try
bmp.LoadFromFile(ExtractFilePath(ParamStr(0)) + 'Source.bmp');
for i := 1 to 18 do
begin
if (iRow <= iRows) then
begin
iTop := CalcY;
iLeft := CalcX;
Img1.Canvas.Draw(iLeft, iTop, bmp);
if not((iRow = iRows) and (iCol = iColumns)) then
begin
if (iCol = iColumns) then
begin
Inc(iRow);
iCol := 1;
end
else
Inc(iCol);
end
else
begin
PrintImage(Img1, 100);
iRow := 1;
iCol := 1;
Img1.Canvas.Brush.Color := clWhite;
Img1.Canvas.FillRect(Rect(0, 0, Img1.Width, Img1.Height));
end;
end;
end;
finally
FreeAndNil(bmp);
FreeAndNil(Img1);
end;
end;
And draw it on TPrinter.Canvas.
You can see results below:
Results is good, but not perfect.
As you can see, in the last column, all images are drawn not to the end, some part misses off the paper and not drawn.
I think it's happens because I use the Trunc to get integer part of double when I'm calculate dimensions of TImage.Canvas in accordance with the factor of printer's DPI.
By experiments I know value 0.20. 0.20 is a part of last column images, in pixels, that not drawn. If I change code, that gets scale factor by this:
if Printer.Orientation = poPortrait then
scale := GetDeviceCaps(Printer.Handle, LOGPIXELSX) /
Screen.PixelsPerInch - 0.20
else
scale := GetDeviceCaps(Printer.Handle, LOGPIXELSY) /
Screen.PixelsPerInch - 0.20;
I have that, what I need:
I think the value 0.20 isn't a constant and it will change on every PC.
How to calculate this value? What need to solve this problem?
The basic problem here is one of scaling. More or less, figure out how much to expand the resolution of the image and then stretchdraw it to the printer canvas. Something like this gets the image stretched out to the dimension of the printer canvas.
procedure TForm1.Button2Click(Sender: TObject);
var
MyRect: TRect;
scale: Double;
begin
if PrintDialog1.Execute then
begin
Printer.BeginDoc;
scale := Printer.PageWidth / Bitmap1.Width;
ShowMessage(FloatToStr(scale));
{ horizontal pixels, vertical pixels, bit depth 600 x 600 x 24}
MyRect.Left := 0;
MyRect.Top := 0;
MyRect.Right := trunc(Bitmap1.Width * scale);
MyRect.Bottom := trunc(Bitmap1.Height * scale);
Printer.Canvas.StretchDraw(MyRect, Bitmap1);
Printer.EndDoc;
end;
Of course, you have to check "Right" and "Bottom" to make sure they don't exceed your PageWidth and PageHeight depending on the type of scaling you use (6.25 or 600/96 seems fine for simply making an image the same relative size as the screen, assuming those numbers match your printer and screen), assuming you want to keep the image to one page and not mosaic pieces of it onto multiple pages.
I don't know if this works entirely since I don't have a varied number of devices (i.e. different DPIs) to test both orientations on, but this seems to be what you want to get both DPI numbers dynamically.
if Printer.Orientation = poPortrait then
scale := GetDeviceCaps(Printer.Handle, LOGPIXELSX) / PixelsPerInch
else
scale := GetDeviceCaps(Printer.Handle, LOGPIXELSY) / pixelsperinch;
Then of course, you multiply like above.
The issue you're running into is that there really isn't a "real size" of an image, it's all relative. The printer often has a lot higher resolution then your monitor and that's why pictures look small.
Your monitor has often a resolution of 96 dpi and normal printer has a resolution of 600 dpi which means your image prints in its real size it just looks small because a printer can put a lot more dots in the same space then a monitor can.
Delphi Basics link was also helpful : http://www.delphibasics.co.uk/RTL.asp?Name=printer&ExpandCode1=Yes
on form : drag n drop TPrintDialog from your Tool Palette
and manually add this to the uses clause under [Implementation]
uses printers; // Unit containing the printer command
With that and this post I was able to print directly to any printer at the size I wanted for images or text. There is no need to call the bitmap or assign the TPrinter once you have added the unit above. Just draw directly to the canvas in your PC printer queue.
procedure TForm1.cmdPrintCircleClick(Sender: TObject);
var
xx, yy, mySize : integer;
//printer1 : TPrinter;
begin
// create image directly on Printer Canvas and print it
//Ellipse( X-(Width div 2), Y-(Height div 2), X+(Width div 2), Y+(Height div 2));
if PrintDialog1.Execute then
try
with Printer do
begin
if Printer.Orientation = poPortrait then
begin
// represents 1/2 US-inch relative to Portrait page size 8.5 x 11
mySize := Trunc(PageWidth / 8.5 / 2);
end
else
begin
// represents 1/2 US-inch relative to Landscape page size 11 x 8.5
mySize := Trunc(PageHeight / 8.5 / 2);
end;
xx := Trunc(PageWidth / 2);
yy := Trunc(PageHeight / 2);
// Start printing
BeginDoc;
// Write out the ellipse // create one-inch black circle
Canvas.Brush.Color := clBlack;
Canvas.Ellipse(xx - mySize, yy - mySize, xx + mySize, yy + mySize);
// Finish printing
EndDoc;
end;
finally
end;
end;
My application is developed in Delphi 6. This is a resource intesive application due to background processing and large volume of data (It consumes around 60MB - 120MB of physical memory). One of the functionality of this application is to create barcode images after doing certain procesing.
If user keeps on generating the Barcodes, then at least One out of Ten Barcode has missing lines in it.
We have following steps in generating the output:
Create a Barcode image (TImage) in the memory. The height of the image is 10 pixels. We use pf24bit pixel format.
Resizing the image in the memory according to printer's canvas and passing it to the printer's canvas.
The code for Step # 2 is as following :
procedure PrintBitmap(ARect:TRect; Bitmap:TBitmap);
var
Info: PBitmapInfo;
InfoSize: dword{Integer};
Image: Pointer;
ImageSize: dword{ integer};
iReturn : integer ;
iWidth,iHeight :integer;
begin
try
with Bitmap do
begin
iReturn := 1;
GetDIBSizes( Handle, InfoSize, ImageSize );
GetMem( Info, InfoSize );
try
getMem( Image, ImageSize );
try
GetDIB(Handle, Palette, Info^, Image^);
try
with Info^.bmiHeader do
begin
SetStretchBltMode(Printer.Canvas.handle,HALFTONE);
iReturn := **StretchDIBits**(Printer.Canvas.Handle, ARect.Left, ARect.Top,
ARect.Right - ARect.Left, ARect.Bottom - ARect.Top,
0, 0, biWidth, biHeight, Image, Info^, DIB_RGB_COLORS, SRCCOPY);
end;
except on E:Exception do
begin
gobjLog.pWritetoLog(0,'RptWrks2','PrintBitmap','Exception in StretchDIBits with message '+e.Message);
end;
end
finally
FreeMem(Image, ImageSize);
end;
finally
FreeMem(Info, InfoSize);
end;
end
except on E:Exception do
begin
gobjLog.pWritetoLog(0,'RptWrks2','PrintBitmap','Exception in PrintBitMap with message '+e.Message);
end;
end;
We checked that the issue lies in the Step # 2 , as the barcode image is generated without any issue. (We commented out Step # 2 and took the output as BMP files to confirm this).
Also, we tried following workarounds :
We used TExcellentImagePrinter component to perform the resizing operation. But, issue was not resolved.
We included SETPROCESSWORKINGSETSIZE WinAPI call to reduce/refresh the current memry used by the application.
We included Sleep(3000) in the code so that the Windows is able to allocate the memory for the image. Including Sleep however reduced the frequency of occurrence of this error.
Can you please provide any suggestions?
I use this function for printing barcodes with great success. It assumes that the bitmap is 100% scaled barcode (each x-pixel is a barcode stripe), the height does not matter, it may be only 1px.
The clue is to print the barcode with fillrect and not as a bitmap:
The function just "reads" the barcode and draws it with fillrect to some canvas. If the resulting scale (xFactor = aToRect width to barcode width) is either an integer number or a big enough real number (for printers no problem) the printed barcode can be read without any problems. It also works great with PDF Printers.
You just have to generate a 100% scaled barcode to bitmap (as you already do; height may be 1px; color of the barcode must be clBlack) and pass it in the aFromBMP parameter. aToCanvas will then be your printer canvas. aToRect is the destination rect in printer canvas. aColor is the color of the destination barcode (may be everything).
procedure PrintBarCodeFromBitmap(const aFromBMP: TBitmap;
const aToCanvas: TCanvas; const aToRect: TRect;
const aColor: TColor = clBlack);
var I, xStartRect: Integer;
xFactor: Double;
xColor: TColor;
xLastBrush: TBrush;
begin
xLastBrush := TBrush.Create;
try
xLastBrush.Assign(aToCanvas.Brush);
aToCanvas.Brush.Color := aColor;
aToCanvas.Brush.Style := bsSolid;
xFactor := (aToRect.Right-aToRect.Left)/aFromBMP.Width;
xStartRect := -1;
for I := 0 to aFromBMP.Width do begin
if I < aFromBMP.Width then
xColor := aFromBMP.Canvas.Pixels[I, 0]
else
xColor := clWhite;
if (xStartRect < 0) and (xColor = clBlack) then begin
xStartRect := I;
end else if (xStartRect >= 0) and (xColor <> clBlack) then begin
aToCanvas.FillRect(
Rect(
Round(aToRect.Left+xStartRect*xFactor),
aToRect.Top,
Round(aToRect.Left+I*xFactor),
aToRect.Bottom));
xStartRect := -1;
end;
end;
finally
aToCanvas.Brush.Assign(xLastBrush);
xLastBrush.Free;
end;
end;
Finally I was able to resolve the issue using TExcellentImagePrinter.
I replaced GETDIB with LoadDIBFromTBitmap function and StretchDIBits with PrintDIBitmapXY in the above code snippet (my post).
Thanks to Joe for providing proper guidelines.