Bitmaps only displayed corerectly if they have certain widths
Original Reporter info from Mantis: crlab @neurolabusc1
-
Reporter name: Chris Rorden
Original Reporter info from Mantis: crlab @neurolabusc1
- Reporter name: Chris Rorden
Description:
Hello-
This problem affects Lazarus for Linux but not Windows. Bitmap images are only displayed if they have widths 25..32, 57..64, 89..96 etc. In other words (width and 31) must not be in the range 1..24. If the width is unsupported (e.g. a 65 pixel wide image), horizontal white stripes appear on the image.
I have written a web page that describes this problem and others, including a sample program. I am also offering a cash bounty for a solution:
http://www.sph.sc.edu/comd/rorden/mricron/bounty/
I would also like to advertise this reward at
http://wiki.lazarus.freepascal.org/index.php/Bounties
but it does not seem possible to create new accounts (I receive the message 'you have not specified a valid username, regardless of the user name or browser).
Steps to reproduce:
unit MainUnit1;
{$IFDEF Unix}
//The IntfGraphics are required for Unix, optional for Windows
//I think my usage IntfGraphics is less elegant, but it is universal
{$DEFINE UseIntfGraphics}
{$ENDIF}
interface
uses
{$IFDEF UseIntfGraphics} IntfGraphics,FPImage,{$ENDIF}
Classes, SysUtils, LCLType, LResources, Forms, Controls, Graphics, Dialogs,
Buttons, StdCtrls, ExtCtrls,ClipBrd,ComCtrls, Spin;
{ TForm1 }
type
SingleRA = array [1..1] of Single;
Singlep = ^SingleRA;
ByteRA = array [1..1] of byte;
Bytep = ^ByteRA;
TForm1 = class(TForm)
draw128: TSpeedButton;
copybtn: TSpeedButton;
draw256: TSpeedButton;
Image1: TImage;
ScrollBox1: TScrollBox;
SpinEdit1: TSpinEdit;
ToolBar1: TToolBar;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure Image1MouseDown(Sender: TOBject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure Image1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer
);
procedure MouseRollonScroll(Sender: TObject; Shift: TShiftState; Pos: Tpoint; var Resp: boolean);
procedure draw128click(Sender: TObject);
procedure draw256click(Sender: TObject);
procedure CopyBtnClick(Sender: TObject);
procedure Image1MouseUp(Sender: TOBject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
private
published
public
end;
var
Form1: TForm1;
{$IFDEF UseIntfGraphics} gIntfImg: TLazIntfImage; {$ENDIF}
implementation
{ TForm1 }
const
gDown : boolean = False;//tracks if mouse button is down
type
//we must redefine TRGBquad, as order of bytes is RGB for Lazarus, BGR for Delphi
TRGBquad = PACKED RECORD
rgbRed,rgbGreen,rgbBlue,rgbreserved: byte;
end;
RGBQuadRA = array [1..1] of TRGBQuad;
RGBQuadp = ^RGBQuadRA;
LongIntRA = array [1..1] of LongInt;
LongIntp = ^LongIntRA;
procedure DrawBMP( lx, ly: integer; lRGBBuff: RGBQuadp);
{$IFDEF UseIntfGraphics}
//This version of DrawBMP works on both Windows and Linux
//However, it requires calling 'loadfrombitmap', so is not as elegant as the Windows-only solution below
var
ImgHandle,ImgMaskHandle: HBitmap;
px, py,lPos: Integer;
CurColor: TFPColor;
lLongBuff: LongIntp;
TempBitmap: TBitmap;
begin
gIntfImg.Width := lx;
gIntfImg.Height := ly;
TempBitmap:=TBitmap.Create;
TempBitmap.PixelFormat := pf32bit ;
TempBitmap.Transparent := False;
lLongBuff := LongIntp(lRGBBuff);
lPos:= 0;
for py:=0 to ly-1 do begin
for px:=0 to lx-1 do begin
inc(lPos);
gIntfImg.TColors[px,py]:=lLongBuff^[lPos];
end;
end;
gIntfImg.CreateBitmap(ImgHandle,ImgMaskHandle,false);
TempBitmap.Handle:=ImgHandle;
TempBitmap.MaskHandle:=ImgMaskHandle;
Form1.Image1.Picture.Bitmap := TempBitmap;
TempBitmap.Free;
end;
{$ELSE}
var
x, y,lPos: Integer;
TempBitmap: TBitmap;
lLongBuff: LongIntp;
begin
TempBitmap := TBitmap.Create;
try
lLongBuff := LongIntp(lRGBBuff);
TempBitmap.PixelFormat := pf32bit ;
TempBitmap.Transparent := False;
TempBitmap.Height := ly;
TempBitmap.Width := lx;
lPos := 0;
for y:=0 to ly-1 do begin
for x:=0 to lx-1 do begin
inc(lPos);
TempBitmap.Canvas.Pixels[x,y] := lLongBuff^[lPos];
end;
end;
Form1.Image1.Picture.Bitmap := TempBitmap;
//Form1.Image1.Canvas.Draw(0,0,Bitmap);
finally
TempBitmap.Free;
end;
end;
{$ENDIF}
procedure GenerateBMP (lX,lY: integer);
var
lPos,lXp,lYp: integer;
lRGB : TRGBQuad;
lRGBBuff: RGBQuadp;
begin
//initialize RGB values - note rgbreserved not used by Lazarus
lRGB.rgbRed := 0;
lRGB.rgbgreen := 0;
lRGB.rgbblue := 0;
lRGB.rgbreserved := 0;
GetMem ( lRGBBuff , lX*lY*sizeof(TRGBquad));
lPos := 0;
if odd(random(2)) then begin
for lXp := 0 to lX-1 do
for lYp := 0 to lY-1 do begin
inc(lPos);
lRGB.rgbgreen := 255-(lXp and 240);
lRGB.rgbRed := 255-(lYp and 240);
lRGBBuff^[lPos] := lRGB;
end;
end else begin
for lXp := 0 to lX-1 do
for lYp := 0 to lY-1 do begin
inc(lPos);
lRGB.rgbblue := lXp and 240;
lRGB.rgbRed := lYp and 240;
lRGBBuff^[lPos] := lRGB;
end;
end;
lRGB.rgbgreen := 0;
lRGB.rgbRed := 255;
lPos := 0;
DrawBMP(lX,lY,lRGBBuff);
Freemem(lRGBBuff);
end;
procedure TForm1.draw128click(Sender: TObject);
begin
GenerateBMP(128,128);
end;
procedure TForm1.draw256click(Sender: TObject);
begin
GenerateBMP(SpinEdit1.value,256);
Form1.caption := inttostr(spinedit1.value)+ ' and 32 = '+inttostr(spinedit1.value and 31);
end;
procedure TForm1.CopyBtnClick(Sender: TObject);
begin
Clipboard.Assign(Image1.Picture.Bitmap);
// Image1.Picture.Bitmap.SaveToClipboardFormat(2);
end;
procedure TForm1.Image1MouseUp(Sender: TOBject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
gDown := false;
end;
procedure TForm1.MouseRollonScroll(Sender: TObject; Shift: TShiftState; Pos: TPoint; var Resp: boolean);
begin
Form1.caption := 'mouse roll '+inttostr(Pos.X)+' '+inttostr(Pos.Y);
end;
procedure TForm1.FormCreate(Sender: TObject);
{$IFDEF UseIntfGraphics} var lBMPname: string; lBitmap: TBitmap;{$ENDIF}
begin
{$IFDEF UseIntfGraphics}
lBMPname := (extractfiledir(paramstr(0))+pathdelim+'mini.bmp');
if not fileexists(lBMPname) then begin
showmessage('Unable to find 24-bit BMP format image named '+lBMPname);
end;
lBitmap:=TBitmap.Create;
lBitmap.LoadFromFile(lBMPname);
gIntfImg:=TLazIntfImage.Create(0,0);
gIntfImg.LoadFromBitmap( lBitmap.Handle, lBitmap.MaskHandle);
lBitmap.Free;
{$ENDIF}
Form1.DoubleBuffered := true;
Scrollbox1.DoubleBuffered := true;
Scrollbox1.OnMouseWheelDown:= @MouseRollonScroll;
Scrollbox1.OnMouseWheelUp:= @MouseRollonScroll;
Form1.OnMouseWheelDown:= @MouseRollonScroll;
Form1.OnMouseWheelUp:= @MouseRollonScroll;
draw256click(nil);
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
{$IFDEF UseIntfGraphics} gIntfImg.Free;{$ENDIF}
end;
procedure TForm1.Image1MouseDown(Sender: TOBject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
var
lImage: TImage;
begin
lImage := Sender as TImage;
lImage.Canvas.Pen.Color := clRed;
lImage.Canvas.Pen.Width := 3;
lImage.Canvas.MoveTo(X,Y);
gDown := True;
end;
procedure TForm1.Image1MouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
var
lImage: TImage;
begin
lImage := Sender as TImage;
if gDown then
lImage.Canvas.LineTo(X,Y);
end;
initialization
{$I mainunit1.lrs}
end.
Mantis conversion info:
- Mantis ID: 2022
- OS: Linux
- OS Build: SUSE 10
- Platform: x86
- Version: 0.9.15 (SVN)
- Target version: 0.9.18