Simulate infrared film

[Bummi]

via Bitmap Scanline
eliminate blue
increase green * 2
convert to gray

Call

Delphi-Quellcode:

  InfraRed(Image1.Picture.Bitmap);
  Image1.Invalidate;

May be adapted for your needs

Delphi-Quellcode:

unit EXBMP_Utils_1;
// 201011 by Thomas Wasseermann

interface

uses Windows,Classes, Graphics;



type
  pRGBTripleArray = ^TRGBTripleArray;
  TRGBTripleArray = ARRAY[0..$effffff] OF TRGBTriple;
  pRGBQuadArray = ^TRGBQuadArray;
  TRGBQuadArray = ARRAY[0..$effffff] OF TRGBQuad;


  procedure ConvertBitmapToGrayscale(const Bitmap: TBitmap);
  Procedure InfraRed(bmp:TBitmap);

implementation
  
procedure ConvertBitmapToGrayscale32(const Bitmap: TBitmap);
type
  PPixelRec = ^TPixelRec;
  TPixelRec = packed record
    B: Byte;
    G: Byte;
    R: Byte;
    Reserved: Byte;
  end;
var
  X: Integer;
  Y: Integer;
  P: PPixelRec;
  Gray: Byte;
begin
  for Y := 0 to (Bitmap.Height - 1) do
  begin
    P := Bitmap.ScanLine[Y];
    for X := 0 to (Bitmap.Width - 1) do
    begin
      Gray := Round(0.30 * P.R + 0.59 * P.G + 0.11 * P.B);
      P.R := Gray;
      P.G := Gray;
      P.B := Gray;
      Inc(P);
    end;
  end;
end;

procedure ConvertBitmapToGrayscale24(const Bitmap: TBitmap);
type
  PPixelRec = ^TPixelRec;
  TPixelRec = packed record
    B: Byte;
    G: Byte;
    R: Byte;
  end;
var
  X: Integer;
  Y: Integer;
  P: PPixelRec;
  Gray: Byte;
begin
  for Y := 0 to (Bitmap.Height - 1) do
  begin
    P := Bitmap.ScanLine[Y];
    for X := 0 to (Bitmap.Width - 1) do
    begin
      Gray := Round(0.30 * P.R + 0.59 * P.G + 0.11 * P.B);
      P.R := Gray;
      P.G := Gray;
      P.B := Gray;
      Inc(P);
    end;
  end;
end;


procedure ConvertBitmapToGrayscale(const Bitmap: TBitmap);

begin
  if Bitmap.PixelFormat = pf32Bit then ConvertBitmapToGrayscale32(Bitmap)
  else   if Bitmap.PixelFormat = pf24Bit then ConvertBitmapToGrayscale24(Bitmap);
end;




Function GetDoubleByte(i:Integer):Integer;
  Begin
    Result := i * 2;
    if Result > 255 then Result := 255;
  End;

Procedure InfraRed24(bmp:TBitmap);
var
 pscanLine : pRGBTripleArray;
 x,y:Integer;
begin
  for y  := 0 to bmp.Height - 1 do
    begin
       pscanLine := bmp.Scanline[y];
       for x := 0 to bmp.Width - 1 do
          begin
              pscanLine[x].rgbtBlue := 0;
              pscanLine[x].rgbtGreen := GetDoubleByte(pscanLine[x].rgbtGreen);
          end;
    end;
  ConvertBitmapToGrayscale(bmp);
end;

Procedure InfraRed32(bmp:TBitmap);
var
 pscanLine : pRGBQuadArray;
 x,y:Integer;
begin
  for y  := 0 to bmp.Height - 1 do
    begin
       pscanLine := bmp.Scanline[y];
       for x := 0 to bmp.Width - 1 do
          begin
              pscanLine[x].rgbBlue := 0;
              pscanLine[x].rgbGreen := GetDoubleByte(pscanLine[x].rgbGreen);
          end;
    end;
  ConvertBitmapToGrayscale(bmp);
end;


Procedure InfraRed(bmp:TBitmap);
begin
  if bmp.PixelFormat=pf32Bit  then InfraRed32(bmp)
  else   if bmp.PixelFormat=pf24Bit  then InfraRed24(bmp);
end;

end.