Changeset 333
- Timestamp:
- Mar 31, 2021, 7:21:45 PM (4 years ago)
- Location:
- tools/Image resize
- Files:
-
- 2 edited
- 2 moved
Legend:
- Unmodified
- Added
- Removed
-
tools/Image resize/ImageResize.lpi
r280 r333 37 37 </Unit0> 38 38 <Unit1> 39 <Filename Value=" uformmain.pas"/>39 <Filename Value="UFormMain.pas"/> 40 40 <IsPartOfProject Value="True"/> 41 41 <ComponentName Value="FormMain"/> 42 42 <HasResources Value="True"/> 43 43 <ResourceBaseClass Value="Form"/> 44 <UnitName Value="UFormMain"/>45 44 </Unit1> 46 45 <Unit2> -
tools/Image resize/UFormMain.lfm
r332 r333 1 1 object FormMain: TFormMain 2 2 Left = 534 3 Height = 3 123 Height = 359 4 4 Top = 388 5 Width = 4 175 Width = 480 6 6 Caption = 'Image resize' 7 ClientHeight = 3 128 ClientWidth = 4 179 DesignTimePPI = 1 257 ClientHeight = 359 8 ClientWidth = 480 9 DesignTimePPI = 144 10 10 OnShow = FormShow 11 LCLVersion = '2.0.1 0.0'11 LCLVersion = '2.0.12.0' 12 12 object ButtonResize: TButton 13 Left = 1 614 Height = 3 315 Top = 1 616 Width = 9813 Left = 18 14 Height = 38 15 Top = 18 16 Width = 113 17 17 Caption = 'Resize' 18 18 OnClick = ButtonResizeClick 19 ParentFont = False 19 20 TabOrder = 0 20 21 end 21 22 object ButtonAlpha: TButton 22 Left = 1 623 Height = 3 324 Top = 6425 Width = 1 4423 Left = 18 24 Height = 38 25 Top = 74 26 Width = 166 26 27 Caption = 'Alpha channel' 27 28 OnClick = ButtonAlphaClick 29 ParentFont = False 28 30 TabOrder = 1 29 31 end 32 object ButtonTile: TButton 33 Left = 18 34 Height = 38 35 Top = 126 36 Width = 153 37 Caption = 'Process tile' 38 OnClick = ButtonTileClick 39 TabOrder = 2 40 end 30 41 end -
tools/Image resize/UFormMain.pas
r332 r333 7 7 uses 8 8 Classes, SysUtils, Forms, Controls, Graphics, Dialogs, ExtCtrls, StdCtrls, 9 Math, LazFileUtils, UPixelPointer ;9 Math, LazFileUtils, UPixelPointer, Process; 10 10 11 11 type … … 14 14 15 15 TFormMain = class(TForm) 16 ButtonTile: TButton; 16 17 ButtonAlpha: TButton; 17 18 ButtonResize: TButton; 18 19 procedure ButtonAlphaClick(Sender: TObject); 19 20 procedure ButtonResizeClick(Sender: TObject); 21 procedure ButtonTileClick(Sender: TObject); 20 22 procedure FormShow(Sender: TObject); 21 23 private 22 24 function SwapColors(Color: Cardinal): Cardinal; 23 procedure UseAlpha(SourceName: string; BBC: Boolean); 25 procedure UseAlphaFile(SourceName: string; BBC: Boolean); 26 procedure UseAlphaBitmap(SrcBitmap, DstBitmap: TBitmap; BBC: Boolean = False); 27 procedure RestoreAlphaBitmap(SrcBitmap, DstBitmap: TBitmap; BBC: Boolean = False); 28 procedure ResizeRect(SrcBitmap, DstBitmap: TBitmap; SrcRect, DstRect: TRect); 29 procedure ResizeRectXbrz(SrcBitmap, DstBitmap: TBitmap); 30 procedure ProcessBitmapRect(SrcBitmap, DstBitmap: TBitmap; SrcRect, DstRect: TRect); 31 procedure ResizeAuxPos(SrcBitmap, DstBitmap: TBitmap; SrcRect, DstRect: TRect); 24 32 public 25 33 procedure ResizeImage(SourceName: string; SourceSize: TPoint; Count: TPoint; … … 52 60 var 53 61 NewSize: TPoint; 54 begin 62 OldSize: TPoint; 63 OldFileName: string; 64 NewFileName: string; 65 I: Integer; 66 const 67 //Files: array[0..0] of string = ('Cities66x32.png'); 68 Files: array[0..0] of string = ('Cities96x48.png'); 69 //Files: array[0..0] of string = ('Terrain96x48.png'); 70 //Files: array[0..1] of string = ('Cities66x32.png', 'Terrain66x32.png'); 71 //Files: array[0..1] of string = ('Cities96x48.png', 'Terrain96x48.png'); 72 TileCount: array[0..1] of TPoint = ((X: 8; Y: 2), (X: 9; Y: 21)); 73 //TileCount: array[0..0] of TPoint = ((X: 9; Y: 21)); 74 begin 75 //OldSize := Point(66, 48); 76 OldSize := Point(96, 72); 77 //NewSize := Point(96, 72); 78 //NewSize := Point(66, 48); 55 79 NewSize := Point(144, 108); 56 //ResizeImage('../../trunk/Graphics/Cities66x32.png', Point(66, 48), Point(8, 2), 57 // 'Cities144x72.png', NewSize); 58 //ResizeImage('../../trunk/Graphics/Terrain66x32.png', Point(66, 48), Point(9, 21), 59 // 'Terrain144x72.png', NewSize); 60 { 61 ResizeImage('../../trunk/Graphics/Cities96x48.png', Point(96, 72), Point(8, 2), 62 'Cities144x72.png', NewSize); 63 ResizeImage('../../trunk/Graphics/Terrain96x48.png', Point(96, 72), Point(9, 21), 64 'Terrain144x72.png', NewSize); 65 } ResizeImage('../../branches/AlphaChannel/Graphics/Cities96x48.png', Point(96, 72), Point(8, 2), 66 'Cities144x72.png', NewSize); 67 ResizeImage('../../branches/AlphaChannel/Graphics/Terrain96x48.png', Point(96, 72), Point(9, 21), 68 'Terrain144x72.png', NewSize); 80 //NewSize := Point(192, 144); 81 82 for I := 0 to Length(Files) - 1 do begin 83 OldFileName := Files[I]; 84 NewFileName := '_' + OldFileName; 85 ResizeImage(OldFileName, OldSize, TileCount[I], NewFileName, NewSize); 86 end; 87 end; 88 89 procedure TFormMain.ButtonTileClick(Sender: TObject); 90 var 91 Ptr: TPixelPointer; 92 X, Y: Integer; 93 Bitmap: TBitmap; 94 begin 95 Bitmap := TBitmap.Create; 96 Bitmap.LoadFromFile('tile.bmp'); 97 98 Bitmap.BeginUpdate; 99 Ptr := PixelPointer(Bitmap); 100 for Y := 0 to Bitmap.Height - 1 do begin 101 for X := 0 to Bitmap.Width - 1 do begin 102 if Ptr.Pixel^.ARGB <> 0 then begin 103 if ((X + Y) mod 2) = 0 then 104 Ptr.Pixel^.ARGB := $ff7f007f 105 else Ptr.Pixel^.ARGB := $ff000000; 106 end else Ptr.Pixel^.ARGB := $ff7f007f; 107 Ptr.NextPixel; 108 end; 109 Ptr.NextLine; 110 end; 111 Bitmap.EndUpdate; 112 113 Bitmap.SaveToFile('tile_.bmp'); 114 Bitmap.Free; 69 115 end; 70 116 … … 81 127 I := 0; 82 128 for I := 0 to Length(Files) - 1 do 83 UseAlpha ('../../trunk/Graphics/' + Files[I], False);84 UseAlpha ('../../trunk/Help/AdvTree.png', False);85 //UseAlpha ('../../trunk/Graphics/Templates.png', True);129 UseAlphaFile('../../trunk/Graphics/' + Files[I], False); 130 UseAlphaFile('../../trunk/Help/AdvTree.png', False); 131 //UseAlphaFile('../../trunk/Graphics/Templates.png', True); 86 132 end; 87 133 … … 103 149 end; 104 150 105 procedure TFormMain.UseAlpha (SourceName: string; BBC: Boolean);151 procedure TFormMain.UseAlphaFile(SourceName: string; BBC: Boolean); 106 152 var 107 153 ImageSrc: TImage; … … 124 170 ImageSrc := TImage.Create(nil); 125 171 ImageSrc.Picture.LoadFromFile(SourceName); 126 Size := Point(ImageSrc.Picture.Bitmap.Width,127 ImageSrc.Picture.Bitmap.Height);128 ImageSrc.Picture.Bitmap.BeginUpdate(True);129 172 ImageDest := TImage.Create(nil); 130 173 ImageDest.Picture.Bitmap.PixelFormat := pf32bit; 131 ImageDest.Picture.Bitmap.SetSize(Size.X, Size.Y); 132 ImageDest.Picture.Bitmap.BeginUpdate(True); 174 175 UseAlphaBitmap(ImageSrc.Picture.Bitmap, ImageDest.Picture.Bitmap, BBC); 176 177 ImageDest.Picture.SaveToFile(ExtractFileName(SourceName)); 178 ImageSrc.Free; 179 ImageDest.Free; 180 BitmapSet.Free; 181 end; 182 183 procedure TFormMain.UseAlphaBitmap(SrcBitmap, DstBitmap: TBitmap; BBC: Boolean); 184 var 185 X, Y: Integer; 186 PtrSrc: PPixel32; 187 PtrDest: PPixel32; 188 C: TPixel32; 189 Size: TPoint; 190 Trans, Amp1, Amp2, Value: Integer; 191 Color1, Color2: TPixel32; 192 BitmapSet: TBitmapSet; 193 BitmapDesc: TBitmapDesc; 194 I: Integer; 195 begin 196 Size := Point(SrcBitmap.Width, SrcBitmap.Height); 197 SrcBitmap.BeginUpdate(True); 198 DstBitmap.SetSize(Size.X, Size.Y); 199 DstBitmap.BeginUpdate(True); 133 200 for Y := 0 to Size.Y - 1 do 134 201 for X := 0 to Size.X - 1 do begin 135 PtrSrc := ImageSrc.Picture.Bitmap.ScanLine[Y] + X * 4;136 PtrDest := ImageDest.Picture.Bitmap.ScanLine[Y] + X * 4;202 PtrSrc := SrcBitmap.ScanLine[Y] + X * 4; 203 PtrDest := DstBitmap.ScanLine[Y] + X * 4; 137 204 C.ARGB := PtrSrc^.ARGB and $ffffff; 138 205 //C.ARGB := SwapColors(C.ARGB); … … 177 244 end; 178 245 } 179 ImageSrc.Picture.Bitmap.EndUpdate; 180 ImageDest.Picture.Bitmap.EndUpdate; 181 ImageDest.Picture.SaveToFile(ExtractFileName(SourceName)); 182 ImageSrc.Free; 183 ImageDest.Free; 184 BitmapSet.Free; 246 SrcBitmap.EndUpdate; 247 DstBitmap.EndUpdate; 248 end; 249 250 procedure TFormMain.RestoreAlphaBitmap(SrcBitmap, DstBitmap: TBitmap; 251 BBC: Boolean); 252 var 253 X, Y: Integer; 254 Size: TPoint; 255 PtrSrc: PPixel32; 256 PtrDest: PPixel32; 257 C: TPixel32; 258 A: Cardinal; 259 Alpha: Byte; 260 const 261 AlphaThreshold = $80; 262 begin 263 Size := Point(SrcBitmap.Width, SrcBitmap.Height); 264 SrcBitmap.BeginUpdate(True); 265 SrcBitmap.PixelFormat := pf32bit; 266 DstBitmap.SetSize(Size.X, Size.Y); 267 DstBitmap.BeginUpdate(True); 268 for Y := 0 to Size.Y - 1 do 269 for X := 0 to Size.X - 1 do begin 270 PtrSrc := SrcBitmap.ScanLine[Y] + X * 4; 271 PtrDest := DstBitmap.ScanLine[Y] + X * 4; 272 C.ARGB := PtrSrc^.ARGB; 273 //C.ARGB := SwapColors(C.ARGB); 274 if BBC then begin 275 PtrDest^.R := C.R; 276 PtrDest^.G := C.G; 277 PtrDest^.B := 0; //C.B; 278 PtrDest^.A := 255 - C.B; // blue channel = transparency 279 end else begin 280 Alpha := C.A; 281 if Alpha < AlphaThreshold then begin 282 PtrDest^.RGB := $7f007f 283 end 284 else begin 285 A := C.ARGB and $ffffff; 286 PtrDest^.RGB := SwapRedBlue(A); 287 end; 288 end; 289 end; 290 SrcBitmap.EndUpdate; 291 DstBitmap.EndUpdate; 292 end; 293 294 procedure TFormMain.ResizeRect(SrcBitmap, DstBitmap: TBitmap; SrcRect, DstRect: TRect); 295 var 296 X, Y: Integer; 297 SrcPtr: PCardinal; 298 DestPtr: PCardinal; 299 begin 300 SrcBitmap.BeginUpdate(True); 301 DstBitmap.BeginUpdate(True); 302 for Y := 0 to DstRect.Height - 1 do begin 303 for X := 0 to DstRect.Width - 1 do begin 304 SrcPtr := SrcBitmap.ScanLine[SrcRect.Top + Trunc(Y / DstRect.Height * SrcRect.Height)]; 305 DestPtr := DstBitmap.ScanLine[DstRect.Top + Y]; 306 SrcPtr := SrcPtr + SrcRect.Left + Trunc(X / DstRect.Width * SrcRect.Width); 307 DestPtr := DestPtr + DstRect.Left + X; 308 DestPtr^ := SrcPtr^; 309 //ImageDest.Picture.Bitmap.Canvas.Pixels[XX * (DestSize.X + 1) + 1 + X, 310 // YY * (DestSize.Y + 1) + 1 + Y] := 311 //ImageSrc.Picture.Bitmap.Canvas.Pixels[XX * (SourceSize.X + 1) + 1 + Trunc(X / DestSize.X * SourceSize.X), 312 // YY * (SourceSize.Y + 1) + 1 + Trunc(Y / DestSize.Y * SourceSize.Y)]; 313 end; 314 end; 315 SrcBitmap.EndUpdate; 316 DstBitmap.EndUpdate; 317 end; 318 319 procedure ExecuteProgram(Executable: string; Parameters: array of string); 320 var 321 Process: TProcess; 322 I: Integer; 323 begin 324 try 325 Process := TProcess.Create(nil); 326 Process.Executable := Executable; 327 for I := 0 to Length(Parameters) - 1 do 328 Process.Parameters.Add(Parameters[I]); 329 Process.Options := [poNoConsole, poWaitOnExit]; 330 Process.Execute; 331 finally 332 Process.Free; 333 end; 334 end; 335 336 procedure TFormMain.ResizeRectXbrz(SrcBitmap, DstBitmap: TBitmap); 337 var 338 Png: TPortableNetworkGraphic; 339 const 340 XbrzScaleExe = 'xbrzscale'; // https://github.com/atheros/xbrzscale 341 begin 342 SrcBitmap.SaveToFile('Input.bmp'); 343 ExecuteProgram(XbrzScaleExe, ['3', 'Input.bmp', 'Output.png']); 344 Png := TPortableNetworkGraphic.Create; 345 Png.PixelFormat := pf32bit; 346 Png.LoadFromFile('Output.png'); 347 Png.PixelFormat := pf32bit; 348 Png.SaveToFile('Output2.png'); 349 DstBitmap.SaveToFile('xxx1.bmp'); 350 BitmapStretchRect(DstBitmap, Bounds(0, 0, DstBitmap.Width, DstBitmap.Height), 351 Png, Rect(0, 0, Png.Width, Png.Height)); 352 BitmapSwapRedBlue(DstBitmap); 353 DstBitmap.SaveToFile('xxx.bmp'); 354 Png.Free; 355 end; 356 357 procedure TFormMain.ProcessBitmapRect(SrcBitmap, DstBitmap: TBitmap; SrcRect, 358 DstRect: TRect); 359 var 360 Src, Dst: TBitmap; 361 Alpha: TBitmap; 362 Alpha2: TBitmap; 363 begin 364 Src := TBitmap.Create; 365 Src.SetSize(SrcRect.Width, SrcRect.Height); 366 Src.Canvas.CopyRect(Bounds(0, 0, SrcRect.Width, SrcRect.Height), SrcBitmap.Canvas, 367 SrcRect); 368 Dst := TBitmap.Create; 369 Dst.SetSize(DstRect.Width, DstRect.Height); 370 Dst.PixelFormat := Src.PixelFormat; 371 //Dst.Canvas.Brush.Style := bsSolid; 372 //Dst.Canvas.Brush.Color := $757575; 373 //Dst.Canvas.FillRect(0, 0, Dst.Width, Dst.Height); 374 FillRectBitmap(Dst, $ff000000); 375 376 Alpha := TBitmap.Create; 377 Alpha.PixelFormat := pf32bit; 378 Alpha.SetSize(Src.Width, Src.Height); 379 UseAlphaBitmap(Src, Alpha); 380 381 Alpha2 := TBitmap.Create; 382 Alpha2.PixelFormat := pf32bit; 383 Alpha2.SetSize(Dst.Width, Dst.Height); 384 FillRectBitmap(Alpha2, $00000000); 385 //Alpha2.Canvas.Brush.Style := bsSolid; 386 //Alpha2.Canvas.Brush.Color := $000000; 387 //Alpha2.Canvas.FillRect(0, 0, 0, 0); 388 389 ResizeRectXbrz(Alpha, Alpha2); 390 391 RestoreAlphaBitmap(Alpha2, Dst); 392 393 Dst.SaveToFile('Dst.bmp'); 394 DstBitmap.Canvas.CopyRect(DstRect, Dst.Canvas, Bounds(0, 0, DstRect.Width, DstRect.Height)); 395 DstBitmap.SaveToFile('DstBitmap.bmp'); 396 Src.Free; 397 Dst.Free; 398 Alpha.Free; 399 Alpha2.Free; 400 end; 401 402 function FindPosition(Bitmap: TBitmap; x, y, xmax, ymax: Integer; Mark: TColor): TPoint; 403 var 404 xp, yp: Integer; 405 begin 406 xp := 0; 407 while (xp < xmax) and (Bitmap.Canvas.Pixels[x + 1 + xp, y] <> Mark) do 408 Inc(xp); 409 yp := 0; 410 while (yp < ymax) and (Bitmap.Canvas.Pixels[x, y + 1 + yp] <> Mark) do 411 Inc(yp); 412 Result := Point(xp, yp); 413 end; 414 415 procedure TFormMain.ResizeAuxPos(SrcBitmap, DstBitmap: TBitmap; SrcRect, 416 DstRect: TRect); 417 var 418 P: TPoint; 419 const 420 MarkColor: TColor = $00ffff; 421 begin 422 P := FindPosition(SrcBitmap, SrcRect.Left, SrcRect.Top, SrcRect.Width, SrcRect.Height, MarkColor); 423 P := Point(Round(P.X * DstRect.Width / SrcRect.Width), 424 Round(P.Y * DstRect.Height / SrcRect.Height)); 425 DstBitmap.Canvas.Pixels[DstRect.Left + P.X, DstRect.Top] := MarkColor; 426 DstBitmap.Canvas.Pixels[DstRect.Left, DstRect.Top + P.Y] := MarkColor; 185 427 end; 186 428 … … 190 432 ImageSrc: TImage; 191 433 ImageDest: TImage; 192 XX, YY: Integer; 193 X, Y: Integer; 194 SrcPtr: PCardinal; 195 DestPtr: PCardinal; 434 X, Y: Integer; 196 435 begin 197 436 ImageSrc := TImage.Create(nil); … … 205 444 206 445 ImageSrc.Picture.Bitmap.BeginUpdate(True); 207 ImageDest.Picture.Bitmap.BeginUpdate(True);446 //ImageDest.Picture.Bitmap.BeginUpdate(True); 208 447 //ImageDest.Picture.Bitmap.Canvas.Brush.Style := bsSolid; 209 448 //ImageDest.Picture.Bitmap.Canvas.Brush.Color := $757575; 210 449 //ImageDest.Picture.Bitmap.Canvas.FillRect(0, 0, ImageDest.Picture.Bitmap.Width, ImageDest.Picture.Bitmap.Height); 211 XX := 0; 212 YY := 0; 213 for YY := 0 to Count.Y - 1 do 214 for XX := 0 to Count.X - 1 do begin 215 for Y := 0 to DestSize.Y - 1 do 216 for X := 0 to DestSize.X - 1 do begin 217 SrcPtr := ImageSrc.Picture.Bitmap.ScanLine[YY * (SourceSize.Y + 1) + 1 + Trunc(Y / DestSize.Y * SourceSize.Y)]; 218 DestPtr := ImageDest.Picture.Bitmap.ScanLine[YY * (DestSize.Y + 1) + 1 + Y]; 219 SrcPtr := SrcPtr + XX * (SourceSize.X + 1) + 1 + Trunc(X / DestSize.X * SourceSize.X); 220 DestPtr := DestPtr + XX * (DestSize.X + 1) + 1 + X; 221 DestPtr^ := SrcPtr^; 222 //ImageDest.Picture.Bitmap.Canvas.Pixels[XX * (DestSize.X + 1) + 1 + X, 223 // YY * (DestSize.Y + 1) + 1 + Y] := 224 //ImageSrc.Picture.Bitmap.Canvas.Pixels[XX * (SourceSize.X + 1) + 1 + Trunc(X / DestSize.X * SourceSize.X), 225 // YY * (SourceSize.Y + 1) + 1 + Trunc(Y / DestSize.Y * SourceSize.Y)]; 226 end; 450 for Y := 0 to Count.Y - 1 do 451 for X := 0 to Count.X - 1 do begin 452 ProcessBitmapRect(ImageSrc.Picture.Bitmap, ImageDest.Picture.Bitmap, 453 Bounds(X * (SourceSize.X + 1) + 1, Y * (SourceSize.Y + 1) + 1, SourceSize.X, SourceSize.Y), 454 Bounds(X * (DestSize.X + 1) + 1, Y * (DestSize.Y + 1) + 1, DestSize.X, DestSize.Y)); 455 ResizeAuxPos(ImageSrc.Picture.Bitmap, ImageDest.Picture.Bitmap, 456 Bounds(X * (SourceSize.X + 1), Y * (SourceSize.Y + 1), SourceSize.X, SourceSize.Y), 457 Bounds(X * (DestSize.X + 1), Y * (DestSize.Y + 1), DestSize.X, DestSize.Y)); 227 458 end; 228 459 ImageSrc.Picture.Bitmap.EndUpdate; 229 ImageDest.Picture.Bitmap.EndUpdate;460 //ImageDest.Picture.Bitmap.EndUpdate; 230 461 ImageDest.Picture.SaveToFile(DestName); 231 462 ImageSrc.Free; -
tools/Image resize/UPixelPointer.pas
r280 r333 9 9 TColor32 = type Cardinal; 10 10 TColor32Component = (ccBlue, ccGreen, ccRed, ccAlpha); 11 12 { TPixel32 } 13 11 14 TPixel32 = packed record 15 private 16 procedure SetRGB(AValue: Cardinal); 17 public 18 function GetRGB: Cardinal; 19 property RGB: Cardinal read GetRGB write SetRGB; 12 20 case Integer of 13 21 0: (B, G, R, A: Byte); … … 37 45 38 46 function PixelPointer(Bitmap: TRasterImage; BaseX: Integer = 0; BaseY: Integer = 0): TPixelPointer; inline; 39 47 function SwapRedBlue(Color: TColor32): TColor32; 48 procedure BitmapCopyRect(DstBitmap: TRasterImage; DstRect: TRect; SrcBitmap: TRasterImage; SrcPos: TPoint); 49 procedure BitmapStretchRect(DstBitmap: TRasterImage; DstRect: TRect; 50 SrcBitmap: TRasterImage; SrcRect: TRect); 51 procedure BitmapFill(Bitmap:TRasterImage; Color: TColor32); 52 procedure BitmapFillRect(Bitmap:TRasterImage; Color: TColor32; Rect: TRect); 53 procedure BitmapSwapRedBlue(Bitmap:TRasterImage); 40 54 41 55 implementation 56 57 { TPixel32 } 58 59 function TPixel32.GetRGB: Cardinal; 60 begin 61 Result := ARGB and $ffffff; 62 end; 63 64 procedure TPixel32.SetRGB(AValue: Cardinal); 65 begin 66 R := (AValue shr 16) and $ff; 67 G := (AValue shr 8) and $ff; 68 B := (AValue shr 0) and $ff; 69 end; 42 70 43 71 { TPixelPointer } … … 74 102 begin 75 103 Pixel := Pointer(Line) + X * BytesPerPixel; 104 end; 105 106 procedure BitmapCopyRect(DstBitmap: TRasterImage; DstRect: TRect; 107 SrcBitmap: TRasterImage; SrcPos: TPoint); 108 var 109 SrcPtr, DstPtr: TPixelPointer; 110 X, Y: Integer; 111 begin 112 SrcBitmap.BeginUpdate(True); 113 DstBitmap.BeginUpdate(True); 114 SrcPtr := PixelPointer(SrcBitmap, SrcPos.X, SrcPos.Y); 115 DstPtr := PixelPointer(DstBitmap, DstRect.Left, DstRect.Top); 116 for Y := 0 to DstRect.Height - 1 do begin 117 for X := 0 to DstRect.Width - 1 do begin 118 DstPtr.Pixel^.ARGB := SrcPtr.Pixel^.ARGB; 119 SrcPtr.NextPixel; 120 DstPtr.NextPixel; 121 end; 122 SrcPtr.NextLine; 123 DstPtr.NextLine; 124 end; 125 SrcBitmap.EndUpdate; 126 DstBitmap.EndUpdate; 127 end; 128 129 procedure BitmapStretchRect(DstBitmap: TRasterImage; DstRect: TRect; 130 SrcBitmap: TRasterImage; SrcRect: TRect); 131 var 132 SrcPtr, DstPtr: TPixelPointer; 133 SubPtr: TPixelPointer; 134 X, Y: Integer; 135 XX, YY: Integer; 136 R: TRect; 137 C: TColor32; 138 begin 139 if (DstRect.Width = SrcRect.Width) and (DstRect.Height = SrcRect.Height) then begin 140 BitmapCopyRect(DstBitmap, DstRect, SrcBitmap, Point(SrcRect.Left, SrcRect.Top)); 141 Exit; 142 end; 143 SrcBitmap.BeginUpdate(True); 144 DstBitmap.BeginUpdate(True); 145 SrcPtr := PixelPointer(SrcBitmap, SrcRect.Left, SrcRect.Top); 146 DstPtr := PixelPointer(DstBitmap, DstRect.Left, DstRect.Top); 147 for Y := 0 to DstRect.Height - 1 do begin 148 for X := 0 to DstRect.Width - 1 do begin 149 R := Rect(Trunc(X * SrcRect.Width / DstRect.Width), 150 Trunc(Y * SrcRect.Height / DstRect.Height), 151 Trunc((X + 1) * SrcRect.Width / DstRect.Width), 152 Trunc((Y + 1) * SrcRect.Height / DstRect.Height)); 153 DstPtr.SetXY(X, Y); 154 SrcPtr.SetXY(R.Left, R.Top); 155 C := SrcPtr.Pixel^.ARGB; 156 DstPtr.Pixel^.ARGB := C; 157 for YY := 0 to R.Height - 1 do begin 158 for XX := 0 to R.Width - 1 do begin 159 DstPtr.Pixel^.ARGB := C; 160 DstPtr.NextPixel; 161 end; 162 DstPtr.NextLine; 163 end; 164 end; 165 end; 166 SrcBitmap.EndUpdate; 167 DstBitmap.EndUpdate; 168 end; 169 170 procedure BitmapFill(Bitmap: TRasterImage; Color: TColor32); 171 var 172 X, Y: Integer; 173 Ptr: TPixelPointer; 174 begin 175 Bitmap.BeginUpdate(True); 176 Ptr := PixelPointer(Bitmap); 177 for Y := 0 to Bitmap.Height - 1 do begin 178 for X := 0 to Bitmap.Width - 1 do begin 179 Ptr.Pixel^.ARGB := Color; 180 Ptr.NextPixel; 181 end; 182 Ptr.NextLine; 183 end; 184 Bitmap.EndUpdate; 185 end; 186 187 procedure BitmapFillRect(Bitmap: TRasterImage; Color: TColor32; Rect: TRect); 188 var 189 X, Y: Integer; 190 Ptr: TPixelPointer; 191 begin 192 Bitmap.BeginUpdate(True); 193 Ptr := PixelPointer(Bitmap, Rect.Left, Rect.Top); 194 for Y := 0 to Rect.Height - 1 do begin 195 for X := 0 to Rect.Width - 1 do begin 196 Ptr.Pixel^.ARGB := Color; 197 Ptr.NextPixel; 198 end; 199 Ptr.NextLine; 200 end; 201 Bitmap.EndUpdate; 202 end; 203 204 procedure BitmapSwapRedBlue(Bitmap: TRasterImage); 205 var 206 X, Y: Integer; 207 Ptr: TPixelPointer; 208 begin 209 Bitmap.BeginUpdate(True); 210 Ptr := PixelPointer(Bitmap); 211 for Y := 0 to Bitmap.Height - 1 do begin 212 for X := 0 to Bitmap.Width - 1 do begin 213 Ptr.Pixel^.ARGB := SwapRedBlue(Ptr.Pixel^.ARGB); 214 Ptr.NextPixel; 215 end; 216 Ptr.NextLine; 217 end; 218 Bitmap.EndUpdate; 76 219 end; 77 220 … … 86 229 end; 87 230 231 function SwapRedBlue(Color: TColor32): TColor32; 232 begin 233 Result := (Color and $ff00ff00) or ((Color and $ff) shl 16) or ((Color shr 16) and $ff); 234 end; 235 88 236 89 237 end.
Note:
See TracChangeset
for help on using the changeset viewer.