Changeset 521 for GraphicTest/Packages/bgrabitmap/bgrareadbmp.pas
- Timestamp:
- Apr 17, 2019, 12:58:41 AM (5 years ago)
- Location:
- GraphicTest
- Files:
-
- 2 edited
Legend:
- Unmodified
- Added
- Removed
-
GraphicTest
- Property svn:ignore
-
old new 8 8 GraphicTest.lps 9 9 GraphicTest.dbg 10 heaptrclog.trc
-
- Property svn:ignore
-
GraphicTest/Packages/bgrabitmap/bgrareadbmp.pas
r494 r521 24 24 - direct access to pixels with TBGRABitmap 25 25 - vertical shrink option with MinifyHeight,WantedHeight,OutputHeight (useful for thumbnails) 26 01/2017 by circular: 27 - support for OS/2 1.x format 28 - support for headerless files 26 29 } 27 30 … … 37 40 type 38 41 TBMPTransparencyOption = (toAuto, toTransparent, toOpaque); 42 TBitMapInfoHeader = BMPcomn.TBitMapInfoHeader; 43 TBitMapFileHeader = BMPcomn.TBitMapFileHeader; 44 TOS2BitmapHeader = packed record 45 bcSize: DWORD; 46 bcWidth: Word; 47 bcHeight: Word; 48 bcPlanes: Word; 49 bcBitCount: Word; 50 end; 51 TMinimumBitmapHeader = packed record 52 Size:longint; 53 Width:longint; 54 Height:longint; 55 Planes:word; 56 BitCount:word; 57 end; 58 TBitmapSubFormat = (bsfWithFileHeader, bsfHeaderless, bsfHeaderlessWithMask); 59 TReadScanlineProc = procedure(Row : Integer; Stream : TStream) of object; 60 TWriteScanlineProc = procedure(Row : Integer; Img : TFPCustomImage) of object; 61 TProgressProc = procedure(Percent: integer; var ShouldContinue: boolean) of object; 62 39 63 40 64 { TBGRAReaderBMP } 41 65 42 TBGRAReaderBMP = class (T FPCustomImageReader)66 TBGRAReaderBMP = class (TBGRAImageReader) 43 67 Private 44 68 DeltaX, DeltaY : integer; // Used for the never-used delta option in RLE 45 69 TopDown : boolean; // If set, bitmap is stored top down instead of bottom up 46 continue : boolean; // needed for onprogress event47 Rect : TRect;48 70 Procedure FreeBufs; // Free (and nil) buffers. 49 71 protected 50 72 ReadSize : Integer; // Size (in bytes) of 1 scanline. 51 BFI : TBitMapInfoHeader; // The header as read from the stream. 73 BFH: TBitMapFileHeader; // The file header 74 BFI: TBitMapInfoHeader; // The header as read from the stream. 75 FPaletteEntrySize: integer; // 4 for Windows, 3 for OS/2 1.x 52 76 FPalette : PFPcolor; // Buffer with Palette entries. (useless now) 53 77 FBGRAPalette : PBGRAPixel; … … 62 86 FBufferStream: TStream; 63 87 FHasAlphaValues: boolean; 88 FMaskData: PByte; 89 FMaskDataSize: integer; 64 90 // SetupRead will allocate the needed buffers, and read the colormap if needed. 65 91 procedure SetupRead(nPalette, nRowBits: Integer; Stream : TStream); virtual; … … 74 100 procedure WriteScanLine(Row : Integer; Img : TFPCustomImage); virtual; 75 101 procedure WriteScanLineBGRA(Row : Integer; Img : TFPCustomImage); virtual; 102 procedure ReadMaskLine({%H-}Row : Integer; Stream : TStream); virtual; 103 procedure SkipMaskLine({%H-}Row : Integer; Stream : TStream); virtual; 104 procedure WriteMaskLine(Row : Integer; Img : TFPCustomImage); virtual; 76 105 // required by TFPCustomImageReader 77 106 procedure InternalRead (Stream:TStream; Img:TFPCustomImage); override; … … 81 110 function GetNextBufferByte: byte; 82 111 procedure MakeOpaque(Img: TFPCustomImage); 112 procedure LoadMask(Stream:TStream; Img:TFPCustomImage; var ShouldContinue: boolean); 113 procedure MainProgressProc(Percent: integer; var ShouldContinue: boolean); 114 procedure ImageVerticalLoop(Stream:TStream; Img:TFPCustomImage; 115 ReadProc, SkipProc: TReadScanlineProc; WriteProc: TWriteScanlineProc; 116 ProgressProc: TProgressProc; var ShouldContinue: boolean); 83 117 public 84 118 MinifyHeight,WantedHeight: integer; 119 Hotspot: TPoint; 120 Subformat: TBitmapSubFormat; 85 121 constructor Create; override; 86 122 destructor Destroy; override; … … 88 124 property OutputHeight: integer read FOutputHeight; 89 125 property TransparencyOption: TBMPTransparencyOption read FTransparencyOption write FTransparencyOption; 90 end; 126 function GetQuickInfo(AStream: TStream): TQuickImageInfo; override; 127 function GetBitmapDraft(AStream: TStream; {%H-}AMaxWidth, AMaxHeight: integer; out AOriginalWidth,AOriginalHeight: integer): TBGRACustomBitmap; override; 128 end; 129 130 function MakeBitmapFileHeader(AData: TStream): TBitMapFileHeader; 91 131 92 132 implementation 93 133 94 type 95 TWriteScanlineProc = procedure (Row : Integer; Img : TFPCustomImage) of object; 96 134 uses math; 135 136 function MakeBitmapFileHeader(AData: TStream): TBitMapFileHeader; 137 var header: PBitMapInfoHeader; 138 headerSize: integer; 139 extraSize: integer; 140 os2header: TOS2BitmapHeader; 141 begin 142 AData.Position := 0; 143 headerSize := LEtoN(AData.ReadDWord); 144 if headerSize = sizeof(TOS2BitmapHeader) then //OS2 1.x 145 begin 146 AData.ReadBuffer({%H-}os2header,sizeof(os2header)); 147 if LEtoN(os2header.bcBitCount) in [1,2,4,8] then 148 begin 149 extraSize := 3*(1 shl LEtoN(os2header.bcBitCount)); 150 end else 151 extraSize := 0; 152 result.bfType:= Word('BM'); 153 result.bfSize := NtoLE(Integer(sizeof(TBitMapFileHeader) + AData.Size)); 154 result.bfReserved:= 0; 155 result.bfOffset := NtoLE(Integer(sizeof(TBitMapFileHeader) + headerSize + extraSize)); 156 end else 157 begin 158 if (headerSize < 16) or (headerSize > AData.Size) or (headerSize > 1024) then 159 raise exception.Create('Invalid header size'); 160 getmem(header, headerSize); 161 try 162 fillchar(header^, headerSize,0); 163 header^.Size := NtoLE(headerSize); 164 AData.ReadBuffer((PByte(header)+4)^, headerSize-4); 165 if LEtoN(header^.Compression) = BI_BITFIELDS then 166 extraSize := 4*3 167 else if LEtoN(header^.BitCount) in [1,2,4,8] then 168 begin 169 if header^.ClrUsed > 0 then 170 extraSize := 4*header^.ClrUsed 171 else 172 extraSize := 4*(1 shl header^.BitCount); 173 end else 174 extraSize := 0; 175 result.bfType:= Word('BM'); 176 result.bfSize := NtoLE(Integer(sizeof(TBitMapFileHeader) + AData.Size)); 177 result.bfReserved:= 0; 178 result.bfOffset := NtoLE(Integer(sizeof(TBitMapFileHeader) + headerSize + extraSize)); 179 finally 180 freemem(header); 181 end; 182 end; 183 end; 97 184 98 185 function RGBAToFPColor(Const RGBA: TColorRGBA) : TFPcolor; 99 100 186 begin 101 187 with Result, RGBA do … … 125 211 inherited create; 126 212 FTransparencyOption := toTransparent; 213 Subformat:= bsfWithFileHeader; 127 214 end; 128 215 … … 134 221 end; 135 222 223 function TBGRAReaderBMP.GetQuickInfo(AStream: TStream): TQuickImageInfo; 224 var headerSize: dword; 225 os2header: TOS2BitmapHeader; 226 minHeader: TMinimumBitmapHeader; 227 totalDepth: integer; 228 headerPos: int64; 229 begin 230 fillchar({%H-}result, sizeof(result), 0); 231 headerPos := AStream.Position; 232 if AStream.Read({%H-}headerSize, sizeof(headerSize)) <> sizeof(headerSize) then exit; 233 headerSize := LEtoN(headerSize); 234 235 //check presence of file header 236 if (headerSize and $ffff) = BMmagic then 237 begin 238 headerPos += sizeof(TBitMapFileHeader); 239 AStream.Position := headerPos; 240 if AStream.Read(headerSize, sizeof(headerSize)) <> sizeof(headerSize) then exit; 241 headerSize := LEtoN(headerSize); 242 end; 243 244 AStream.Position := headerPos; 245 246 if headerSize = sizeof(TOS2BitmapHeader) then //OS2 1.x 247 begin 248 if AStream.Read({%H-}os2header, sizeof(os2header)) <> sizeof(os2header) then exit; 249 result.width := LEtoN(os2header.bcWidth); 250 result.height := LEtoN(os2header.bcHeight); 251 result.colorDepth := LEtoN(os2header.bcBitCount); 252 result.alphaDepth := 0; 253 end 254 else 255 if headerSize >= sizeof(minHeader) then 256 begin 257 if AStream.Read({%H-}minHeader, sizeof(minHeader)) <> sizeof(minHeader) then exit; 258 result.width := LEtoN(minHeader.Width); 259 result.height := LEtoN(minHeader.Height); 260 totalDepth := LEtoN(minHeader.BitCount); 261 if totalDepth > 24 then 262 begin 263 result.colorDepth:= 24; 264 result.alphaDepth:= 8; 265 end else 266 begin 267 result.colorDepth := totalDepth; 268 result.alphaDepth:= 0; 269 end; 270 end else 271 begin 272 result.width := 0; 273 result.height:= 0; 274 result.colorDepth:= 0; 275 result.alphaDepth:= 0; 276 end; 277 end; 278 279 function TBGRAReaderBMP.GetBitmapDraft(AStream: TStream; AMaxWidth, 280 AMaxHeight: integer; out AOriginalWidth, AOriginalHeight: integer): TBGRACustomBitmap; 281 var 282 bmpFormat: TBGRAReaderBMP; 283 prevStreamPos: Int64; 284 begin 285 bmpFormat:= TBGRAReaderBMP.Create; 286 bmpFormat.Subformat:= Subformat; 287 bmpFormat.MinifyHeight := AMaxHeight*2; 288 result := BGRABitmapFactory.Create; 289 prevStreamPos := AStream.Position; 290 try 291 result.LoadFromStream(AStream, bmpFormat); 292 AOriginalWidth:= result.Width; 293 AOriginalHeight:= bmpFormat.OriginalHeight; 294 finally 295 bmpFormat.Free; 296 AStream.Position := prevStreamPos; 297 end; 298 end; 299 136 300 procedure TBGRAReaderBMP.FreeBufs; 137 138 301 begin 139 302 If (LineBuf<>Nil) then … … 233 396 var 234 397 ColInfo: ARRAY OF TColorRGBA; 235 i: Integer; 398 ColInfo3: packed array of TColorRGB; 399 i,colorPresent: Integer; 236 400 237 401 begin … … 262 426 SetLength(ColInfo, nPalette); 263 427 if BFI.ClrUsed>0 then 264 Stream.Read(ColInfo[0],BFI.ClrUsed*SizeOf(TColorRGBA)) 265 else // Seems to me that this is dangerous. 266 Stream.Read(ColInfo[0],nPalette*SizeOf(TColorRGBA)); 428 colorPresent:= min(BFI.ClrUsed,nPalette) 429 else 430 colorPresent:= nPalette; 431 if FPaletteEntrySize = 3 then 432 begin 433 setlength(ColInfo3, nPalette); 434 Stream.Read(ColInfo3[0],colorPresent*SizeOf(TColorRGB)); 435 for i := 0 to colorPresent-1 do 436 ColInfo[i].RGB := ColInfo3[i]; 437 end 438 else 439 begin 440 Stream.Read(ColInfo[0],colorPresent*SizeOf(TColorRGBA)); 441 end; 267 442 for i := 0 to High(ColInfo) do 268 443 begin … … 282 457 283 458 Var 284 PrevSourceRow,SourceRow, i, pallen, SourceRowDelta, SourceLastRow: Integer;459 i, pallen : Integer; 285 460 BadCompression : boolean; 286 461 WriteScanlineProc: TWriteScanlineProc; 287 SourceRowAdd: integer; 288 SourceRowAcc,SourceRowMod: integer; 289 SourceRowAccAdd: integer; 290 OutputLastRow, OutputRow, OutputRowDelta: integer; 291 292 prevPercent, percent, percentAdd : byte; 293 percentMod : longword; 294 percentAcc, percentAccAdd : longword; 295 296 begin 297 Rect.Left:=0; Rect.Top:=0; Rect.Right:=0; Rect.Bottom:=0; 298 continue:=true; 299 Progress(psStarting,0,false,Rect,'',continue); 300 if not continue then exit; 301 Stream.Read(BFI,SizeOf(BFI)); 302 {$IFDEF ENDIAN_BIG} 303 SwapBMPInfoHeader(BFI); 304 {$ENDIF} 462 headerSize: longword; 463 os2header: TOS2BitmapHeader; 464 shouldContinue: boolean; 465 466 begin 467 shouldContinue:=true; 468 Progress(psStarting,0,false,EmptyRect,'',shouldContinue); 469 if not shouldContinue then exit; 470 471 headerSize := LEtoN(Stream.ReadDWord); 472 fillchar({%H-}BFI,SizeOf(BFI),0); 473 if headerSize = sizeof(TOS2BitmapHeader) then 474 begin 475 fillchar({%H-}os2header,SizeOf(os2header),0); 476 Stream.Read(os2header.bcWidth,min(SizeOf(os2header),headerSize)-sizeof(DWord)); 477 BFI.Size := 16; 478 BFI.Width := LEtoN(os2header.bcWidth); 479 BFI.Height := LEtoN(os2header.bcHeight); 480 BFI.Planes := LEtoN(os2header.bcPlanes); 481 BFI.BitCount := LEtoN(os2header.bcBitCount); 482 FPaletteEntrySize:= 3; 483 end else 484 begin 485 Stream.Read(BFI.Width,min(SizeOf(BFI),headerSize)-sizeof(DWord)); 486 {$IFDEF ENDIAN_BIG} 487 SwapBMPInfoHeader(BFI); 488 {$ENDIF} 489 BFI.Size := headerSize; 490 FPaletteEntrySize:= 4; 491 end; 305 492 { This will move past any junk after the BFI header } 306 493 Stream.Position:=Stream.Position-SizeOf(BFI)+BFI.Size; … … 339 526 32: 340 527 SetupRead(0,Width*8*4,Stream); 341 end; 342 end; 528 else raise exception.Create('Invalid bit depth ('+inttostr(BFI.BitCount)+')'); 529 end; 530 end; 531 if Subformat = bsfHeaderlessWithMask then BFI.Height := BFI.Height div 2; 343 532 Try 344 533 { Note: it would be better to Fill the image palette in setupread instead of creating FPalette. … … 350 539 if pallen>0 then 351 540 begin 541 if FPalette = nil then raise exception.Create('Internal error: palette object not initialized'); 352 542 Img.Palette.Count:=pallen; 353 543 for i:=0 to pallen-1 do 354 544 Img.Palette.Color[i]:=FPalette[i]; 355 545 end; 356 if MinifyHeight < BFI.Height then FOutputHeight:= MinifyHeight else 357 if WantedHeight <> 0 then FOutputHeight:= WantedHeight else 358 FOutputHeight:= 0; 359 360 percent:=0; 361 percentAdd := 100 div BFI.Height; 362 percentAcc:=BFI.Height div 2; 363 percentAccAdd := 100 mod BFI.Height; 364 percentMod:=BFI.Height; 365 366 DeltaX:=-1; DeltaY:=-1; 367 if TopDown then 368 begin 369 SourceRowDelta := 1; 370 SourceRow := 0; 371 SourceLastRow := BFI.Height-1; 372 end else 373 begin 374 SourceRowDelta := -1; 375 SourceRow := BFI.Height-1; 376 SourceLastRow := 0; 377 end; 378 OutputRowDelta:= SourceRowDelta; 379 if (OutputHeight <= 0) or (OutputHeight = BFI.Height) then 380 begin 381 SourceRowAdd := SourceRowDelta; 382 SourceRowAcc := 0; 383 SourceRowAccAdd := 0; 384 SourceRowMod := 1; 385 OutputRow := SourceRow; 386 OutputLastRow := SourceLastRow; 387 Img.SetSize(BFI.Width,BFI.Height); 388 end else 389 begin 390 SourceRowAdd := (BFI.Height div OutputHeight)*SourceRowDelta; 391 SourceRowAcc := OutputHeight div 2; 392 SourceRowAccAdd := BFI.Height mod OutputHeight; 393 SourceRowMod := OutputHeight; 394 If TopDown then 395 begin 396 OutputRow := 0; 397 OutputLastRow := OutputHeight-1; 398 end 399 else 400 begin 401 OutputRow := OutputHeight-1; 402 OutputLastRow := 0; 403 end; 404 Img.SetSize(BFI.Width,OutputHeight); 405 end; 546 if (MinifyHeight > 0) and (MinifyHeight < BFI.Height) then FOutputHeight:= MinifyHeight else 547 if WantedHeight > 0 then FOutputHeight:= WantedHeight else 548 FOutputHeight:= BFI.Height; 549 550 if (BFI.Compression=BI_RLE8) or(BFI.Compression=BI_RLE4) then InitReadBuffer(Stream,2048); 551 FHasAlphaValues:= false; 552 553 Img.SetSize(BFI.Width,FOutputHeight); 554 406 555 if Img is TBGRACustomBitmap then 407 556 WriteScanlineProc := @WriteScanLineBGRA else 408 557 WriteScanlineProc := @WriteScanLine; 409 PrevSourceRow := SourceRow-SourceRowDelta; 410 if (BFI.Compression=BI_RLE8) or(BFI.Compression=BI_RLE4) then InitReadBuffer(Stream,2048); 411 FHasAlphaValues:= false; 412 while SourceRow <> SourceLastRow+SourceRowDelta do 413 begin 414 while PrevSourceRow <> SourceRow do 415 begin 416 inc(PrevSourceRow, SourceRowDelta); 417 if PrevSourceRow = SourceRow then 418 ReadScanLine(PrevSourceRow,Stream) 419 else 420 SkipScanLine(PrevSourceRow,Stream); 421 end; 422 WriteScanLineProc(OutputRow,Img); 423 if OutputRow = OutputLastRow then break; 424 if not continue then exit; 425 426 inc(OutputRow,OutputRowDelta); 427 inc(SourceRow,SourceRowAdd); 428 inc(SourceRowAcc,SourceRowAccAdd); 429 if SourceRowAcc >= SourceRowMod then 430 begin 431 dec(SourceRowAcc,SourceRowMod); 432 Inc(SourceRow,SourceRowDelta); 433 end; 434 435 prevPercent := percent; 436 inc(percent,percentAdd); 437 inc(percentAcc,percentAccAdd); 438 if percentAcc>=percentMod then inc(percent); 439 if percent<>prevPercent then Progress(psRunning,percent,false,Rect,'',continue); 440 end; 441 if not FHasAlphaValues and (TransparencyOption = toAuto) and (BFI.BitCount = 32) then 442 MakeOpaque(Img); 443 Progress(psEnding,100,false,Rect,'',continue); 558 559 ImageVerticalLoop(Stream, Img, @ReadScanLine, @SkipScanLine, WriteScanlineProc, 560 @MainProgressProc, shouldContinue); 561 562 if shouldContinue then 563 begin 564 if not FHasAlphaValues and (TransparencyOption = toAuto) and (BFI.BitCount = 32) then 565 MakeOpaque(Img); 566 if (BFI.Compression=BI_RLE8) or(BFI.Compression=BI_RLE4) then CloseReadBuffer; 567 568 if Subformat = bsfHeaderlessWithMask then LoadMask(Stream,Img, shouldContinue); 569 570 Progress(psEnding,100,false,EmptyRect,'',shouldContinue); 571 end; 572 444 573 finally 445 if (BFI.Compression=BI_RLE8) or(BFI.Compression=BI_RLE4) then CloseReadBuffer;446 574 FreeBufs; 447 575 end; … … 729 857 for Column:=0 to img.Width-1 do 730 858 begin 731 PDest^:= BGRA((PSrc )^,(PSrc+1)^,(PSrc+2)^,(PSrc+3)^);859 PDest^:= BGRA((PSrc+2)^,(PSrc+1)^,(PSrc)^,(PSrc+3)^); 732 860 if PDest^.alpha <> 0 then FHasAlphaValues:= true; 733 861 inc(PDest); … … 750 878 end; 751 879 880 procedure TBGRAReaderBMP.ReadMaskLine(Row: Integer; Stream: TStream); 881 begin 882 FillChar(FMaskData^, FMaskDataSize, 0); 883 Stream.Read(FMaskData^, FMaskDataSize); 884 end; 885 886 procedure TBGRAReaderBMP.SkipMaskLine(Row: Integer; Stream: TStream); 887 begin 888 Stream.Position := Stream.Position+FMaskDataSize; 889 end; 890 891 procedure TBGRAReaderBMP.WriteMaskLine(Row: Integer; Img: TFPCustomImage); 892 var x, maskPos: integer; 893 bit: byte; 894 bmp: TBGRACustomBitmap; 895 pimg: PBGRAPixel; 896 begin 897 if Img is TBGRACustomBitmap then 898 bmp := TBGRACustomBitmap(Img) 899 else 900 exit; 901 902 maskPos := 0; 903 bit := $80; 904 pimg := bmp.ScanLine[Row]; 905 for x := 0 to bmp.Width-1 do 906 begin 907 if (FMaskData[maskPos] and bit) <> 0 then //if AND mask is non zero, value is kept 908 begin 909 if pimg^.alpha = 255 then 910 begin 911 pimg^.alpha := 0; 912 if dword(pimg^) <> 0 then 913 begin 914 bmp.NeedXorMask; 915 bmp.XorMask.SetPixel(x,Row,pimg^); 916 end; 917 end; 918 end; 919 inc(pimg); 920 bit := bit shr 1; 921 if bit = 0 then 922 begin 923 bit := $80; 924 inc(maskPos); 925 end; 926 end; 927 end; 928 752 929 function TBGRAReaderBMP.InternalCheck (Stream:TStream) : boolean; 753 754 var 755 {%H-}BFH:TBitMapFileHeader; 756 begin 757 stream.Read({%H-}BFH,SizeOf(BFH)); 758 {$IFDEF ENDIAN_BIG} 759 SwapBMPFileHeader(BFH); 760 {$ENDIF} 761 With BFH do 762 Result:=(bfType=BMmagic); // Just check magic number 930 begin 931 fillchar(BFH, sizeof(BFH), 0); 932 if Subformat in [bsfHeaderless,bsfHeaderlessWithMask] then 933 begin 934 result := true; 935 Hotspot := Point(0,0); 936 end else 937 begin 938 if stream.Read(BFH,SizeOf(BFH)) <> sizeof(BFH) then 939 begin 940 result := false; 941 exit; 942 end; 943 Hotspot := Point(LEtoN(PWord(@BFH.bfReserved)^),LEtoN((PWord(@BFH.bfReserved)+1)^)); 944 {$IFDEF ENDIAN_BIG} 945 SwapBMPFileHeader(BFH); 946 {$ENDIF} 947 With BFH do 948 Result:=(bfType=BMmagic); // Just check magic number 949 end; 763 950 end; 764 951 … … 814 1001 end; 815 1002 1003 procedure TBGRAReaderBMP.LoadMask(Stream: TStream; Img: TFPCustomImage; var ShouldContinue: boolean); 1004 begin 1005 if Img is TBGRACustomBitmap then TBGRACustomBitmap(Img).DiscardXorMask; 1006 FMaskDataSize := ((Img.Width+31) div 32)*4; //padded to dword 1007 getmem(FMaskData, FMaskDataSize); 1008 try 1009 ImageVerticalLoop(Stream,Img, @ReadMaskLine, @SkipMaskLine, @WriteMaskLine, nil, ShouldContinue); 1010 finally 1011 freemem(FMaskData); 1012 FMaskData := nil; 1013 FMaskDataSize := 0; 1014 end; 1015 end; 1016 1017 procedure TBGRAReaderBMP.MainProgressProc(Percent: integer; 1018 var ShouldContinue: boolean); 1019 begin 1020 Progress(psRunning,Percent,false,EmptyRect,'',ShouldContinue); 1021 end; 1022 1023 procedure TBGRAReaderBMP.ImageVerticalLoop(Stream: TStream; 1024 Img: TFPCustomImage; ReadProc, SkipProc: TReadScanlineProc; 1025 WriteProc: TWriteScanlineProc; ProgressProc: TProgressProc; 1026 var ShouldContinue: boolean); 1027 var 1028 prevPercent, percent, percentAdd : byte; 1029 percentMod : longword; 1030 percentAcc, percentAccAdd : longword; 1031 PrevSourceRow,SourceRow, SourceRowDelta, SourceLastRow: integer; 1032 SourceRowAdd: integer; 1033 SourceRowAcc,SourceRowMod: integer; 1034 SourceRowAccAdd: integer; 1035 OutputLastRow, OutputRow, OutputRowDelta: integer; 1036 begin 1037 if OutputHeight <= 0 then exit; 1038 1039 percent:=0; 1040 percentAdd := 100 div BFI.Height; 1041 percentAcc:=BFI.Height div 2; 1042 percentAccAdd := 100 mod BFI.Height; 1043 percentMod:=BFI.Height; 1044 1045 DeltaX:=-1; DeltaY:=-1; 1046 if TopDown then 1047 begin 1048 SourceRowDelta := 1; 1049 SourceRow := 0; 1050 SourceLastRow := BFI.Height-1; 1051 end else 1052 begin 1053 SourceRowDelta := -1; 1054 SourceRow := BFI.Height-1; 1055 SourceLastRow := 0; 1056 end; 1057 OutputRowDelta:= SourceRowDelta; 1058 1059 SourceRowAdd := (BFI.Height div OutputHeight)*SourceRowDelta; 1060 SourceRowAcc := OutputHeight div 2; 1061 SourceRowAccAdd := BFI.Height mod OutputHeight; 1062 SourceRowMod := OutputHeight; 1063 If TopDown then 1064 begin 1065 OutputRow := 0; 1066 OutputLastRow := OutputHeight-1; 1067 end 1068 else 1069 begin 1070 OutputRow := OutputHeight-1; 1071 OutputLastRow := 0; 1072 end; 1073 1074 PrevSourceRow := SourceRow-SourceRowDelta; 1075 1076 while ShouldContinue and (SourceRow <> SourceLastRow+SourceRowDelta) do 1077 begin 1078 while PrevSourceRow <> SourceRow do 1079 begin 1080 inc(PrevSourceRow, SourceRowDelta); 1081 if PrevSourceRow = SourceRow then 1082 ReadProc(PrevSourceRow,Stream) 1083 else 1084 SkipProc(PrevSourceRow,Stream); 1085 end; 1086 WriteProc(OutputRow,Img); 1087 if OutputRow = OutputLastRow then break; 1088 1089 inc(OutputRow,OutputRowDelta); 1090 inc(SourceRow,SourceRowAdd); 1091 inc(SourceRowAcc,SourceRowAccAdd); 1092 if SourceRowAcc >= SourceRowMod then 1093 begin 1094 dec(SourceRowAcc,SourceRowMod); 1095 Inc(SourceRow,SourceRowDelta); 1096 end; 1097 1098 prevPercent := percent; 1099 inc(percent,percentAdd); 1100 inc(percentAcc,percentAccAdd); 1101 if percentAcc>=percentMod then inc(percent); 1102 if (percent<>prevPercent) and Assigned(ProgressProc) then ProgressProc(percent, ShouldContinue); 1103 end; 1104 end; 816 1105 817 1106 initialization
Note:
See TracChangeset
for help on using the changeset viewer.