utest.pas

Extracting Header and Data from Jpeg Images

unit utest;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls,jpeg, ToolWin, ComCtrls, ExtCtrls;
const
 PixelCountMax = 32768;
type
    ByteRA0 = array [0..0] of byte;
    Bytep0 = ^ByteRA0;
        ByteRA = array [1..1] of byte;
    Bytep = ^ByteRA;
  pRGBTripleArray = ^TRGBTripleArray;
  TRGBTripleArray = ARRAY[0..PixelCountMax-1] OF TRGBTriple;
  TForm1 = class(TForm)
    OpenDialog1: TOpenDialog;
    Image1: TImage;
    ToolBar1: TToolBar;
    ViewJPEG: TButton;
    ExtractRedBtn: TButton;
    HeaderINfo: TButton;
    Memo1: TMemo;
    Splitter1: TSplitter;
    procedure ExtractRed(Sender: TObject);
    procedure ViewJPEGClick(Sender: TObject);
    procedure HeaderINfoClick(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.ExtractRed(Sender: TObject);
var
  Stream: TMemoryStream;
  Jpg: TJPEGImage;
  lBuff   : bYTEp0;
  BMP: TBitmap;
  lInc,J,I: integer;
  lROw: pRGBTripleArray;
  infp: file;
begin
     showmessage('This Procedure will extract the red data from a JPEG and save it as filename.raw');
     if not OpenDialog1.execute then exit;
 //extract bmp file
    FileMode := 0; //Read only
    Stream := TMemoryStream.Create;
    try
      Stream := TMemoryStream.Create;
      Stream.LoadFromFile(OpenDialog1.FileName);
      Stream.Seek(0, soFromBeginning);
      Jpg := TJPEGImage.Create;
      try
        Jpg.LoadFromStream(Stream);
        BMP := TBitmap.create;
        try
           BMP.Height := JPG.Height;
           BMP.Width := JPG.Width;
           BMP.PixelFormat := pf24bit;
           BMP.Canvas.Draw(0,0, JPG);
           getmem(lBuff, BMP.Height*BMP.Width);
           lInc := 0;
           FOR j := BMP.Height-1 DOWNTO 0 DO BEGIN
               lRow := BMP.Scanline[j];
               FOR i := 0 TO BMP.Width - 1 DO BEGIN
                   lBuff[lInc] := lRow[i].rgbtRed;
                   lRow[i].rgbtBlue := 0; //only display red data
                   lRow[i].rgbtGreen := 0; //only display red data
                   inc(lInc);
               END; //for i.. each column
           END; //for j...each row
           Image1.Picture.Graphic := BMP;
           Form1.Caption := 'JPEG Demo '+inttostr(BMP.width)+'x'+inttostr(BMP.height);
           //AssignFile(infp, OpenDialog1.FileName);
           AssignFile(infp,changefileext(OpenDialog1.FileName,'.RAW'));
           Rewrite(infp,1);
           BlockWrite(infp,lBuff^,BMP.Height*BMP.Width);
           CloseFile(infp);
           freemem(lBuff);(**)
           //crashes here
        finally
               BMP.Free;
        end; //try..finally bmp
      finally //try..finally
        Jpg.Free;
      end; //try..finally jpg
    finally
      Stream.Free;
    end; //try..finally
end;

procedure TForm1.ViewJPEGClick(Sender: TObject);
begin
  // Get rid of old and create new
  showmessage('This Procedure will display a lossy JPEG');
  if not OpenDialog1.execute then exit;
  try
    Image1.Picture.LoadFromFile(OpenDialog1.Filename);
  except
    on EInvalidGraphic do
      Image1.Picture.Graphic := nil;
  end;
end;

FUNCTION GetFileSize(CONST Filename:  STRING):  INTEGER;
  VAR
    FileStream:  TFileStream;
BEGIN
  TRY
    FileStream := TFileStream.Create(Filename, fmOpenRead + fmShareDenyNone);
    RESULT := FileStream.Size;
    FileStream.Free;
  EXCEPT
    RESULT := 0
  END
END {GetFileSize};

procedure TForm1.HeaderINfoClick(Sender: TObject);
label
     666 {EOF};
  var
    lRawRA: bytep;
    lSz,k,Code,Si,lIncX,lIncY,lInc,lPredA,lPredB,lCurrentByteVal,lCurrentBitPos,btS1,btS2, btMarkerType,
    DHTnLi,DHTtcth,SOFprecision,lMaxHufSi,lMaxHufVal,SOSpttrans, SOFnf,SOFarrayPos,SOSns,SOSarrayPos,SOSss,SOSse,SOSahal:integer;//byte;
    lImgStart,lRawSz,lRawPos,lItems,SOFydim, SOFxdim: integer;
    {lEOFX,}lSOI,lSegmentLength,lSegmentEnd,lI: integer;
    lHdrOK: boolean;
    lStr: string;
    lInFile: File;
procedure ReadByte(var lByte: integer);
begin
     inc(lRawPos);
     lByte := lRawRA[lRawPos];
end;


function ReadWord: word;
var
   lbtL1, lbtL2: byte;
begin
     inc(lRawPos);
     lbtL1 := lRawRA[lRawPos];
     inc(lRawPos);
     lbtL2 := lRawRA[lRawPos];
     result := (256 * lbtL1 + lbtL2)
end;
begin
    showmessage('This Procedure will display a JPEG header');
    if not OpenDialog1.execute then exit;

    lRawSz := GetFileSize(OpenDialog1.filename);
    lRawPos := 0;
    if lRawSz < 32 then goto 666;
    SOFxdim:= 1;
    SOFydim := 1;
    SOSpttrans := 0;
    lHdrOK := false;
    SOFnf := 0;
    SOSns := 0;
    Memo1.Lines.Clear;
    assignfile(lInFile,OpenDialog1.filename);
    reset(lInFile,1);
    GetMem( lRawRA, lRawSz);
    BlockRead(lInFile, lRawRA^, lRawSz);
    closefile(lInFile);
    ReadByte(btS1);
    ReadByte(btS1);
    repeat
      repeat
            if lRawPos <= lRawSz then ReadByte(btS1);
            if btS1 <> $FF then begin
               goto 666;
            end;
            if lRawPos <= lRawSz then  ReadByte( btMarkerType);
            case btMarkerType of //only process segments with length fields
                 $0,$1,$D0..$D7,$FF:
                                     btMarkerType := 0; //0&FF = fillers, $1=TEM,$D0..D7=resync
            end;
      until (lRawPos >= lRawSz) or (btMarkerType <> 0);
      lSegmentLength := ReadWord;
      lSegmentEnd := lRawPos+(lSegmentLength - 2);
      if lSegmentEnd > lRawSz then goto 666;
       //Memo1.Lines.Add( inttohex(btMarkerType,2){':'+inttostr( lSegmentLength )+'@'+inttostr(positon)+' '});
      case btMarkerType of
           $0: ; //filler - ignore
           $C0..$C3,$C5..$CB,$CD..$CF: begin //read SOF FrameHeader
             ReadByte(SOFprecision);
             SOFydim := ReadWord;
             SOFxdim:= ReadWord;
             ReadByte(SOFnf);
             Memo1.Lines.Add( 'SOF: type = x'+inttohex(btMarkerType,2)+ ' precision:'+inttostr(SOFprecision)+' X*Y: '+inttostr(SOFxdim)+'*'+inttostr(SOFydim)+' nFrames: '+inttostr(SOFnf));
             case btMarkerType of
                  $C0:  Memo1.Lines.Add( '  Baseline DCT [Huffman]');
                  $C1:  Memo1.Lines.Add( '  Extended sequential DCT [Huffman]');
                  $C2:  Memo1.Lines.Add( '  Progressive DCT [Huffman]');
                  $C3:  Memo1.Lines.Add( '  Lossless (sequential) [Huffman]');
                  $C5:  Memo1.Lines.Add( '  Differential sequential DCT [Huffman]');
                  $C6:  Memo1.Lines.Add( '  Differential progressive DCT [Huffman]');
                  $C7:  Memo1.Lines.Add( '  Differential lossless (sequential) [Huffman]');
                  $C8:  Memo1.Lines.Add( '  Reserved for JPEG extentions [arithmetic]');
                  $C9:  Memo1.Lines.Add( '  Extended sequential DCT [arithmetic]');
                  $CA:  Memo1.Lines.Add( '  Progressive DCT [arithmetic]');
                  $CB:  Memo1.Lines.Add( '  Lossless (sequential) [arithmetic]');
                  $CD:  Memo1.Lines.Add( '  Differential sequential DCT [arithmetic]');
                  $CE:  Memo1.Lines.Add( '  Differential progressive DCT [arithmetic]');
                  $CF:  Memo1.Lines.Add( '  Differential lossless (sequential) [arithmetic]');
             end;
             lRawPos := (lSegmentEnd);
           end; //SOF FrameHeader
           $C4: begin //DHT Huffman
              Memo1.Lines.Add( 'DHT: HuffmanTable'+inttostr(lSegmentLength)+':');
              lRawPos := (lSegmentEnd);
           end; //DHT Huffman
           $CC: begin //undefined
              Memo1.Lines.Add( 'DAC: Define Arthimetic Table');
              lRawPos := (lSegmentEnd);
           end; //undefined
           $DA: begin //read SOS Scan Header
             ReadByte(SOSns);
             SOSarrayPos := lRawPos;
             if SOSns > 0 then begin
                 for lInc := 1 to SOSns do begin
                     ReadByte( btS1); //component identifier 1=Y,2=Cb,3=Cr,4=I,5=Q
                     ReadByte(btS2); //horizontal and vertical sampling factors
                 end;
             end;
             ReadByte(SOSss); //predictor selection B.3
             ReadByte( SOSse);
             ReadByte( SOSahal); //lower 4bits= pointtransform
             SOSpttrans := SOSahal and 16;
             Memo1.Lines.Add('SOS: StartOfScan Predictor: '+inttostr(SOSss)+' PointTransform: '+inttostr(SOSahal));
             lRawPos := (lSegmentEnd);
           end; //SOS - Scan Header
           $DB: begin //DQT
              Memo1.Lines.Add( 'DQT: Define Quantization Table');
              lRawPos := (lSegmentEnd);
           end; //DQT
           $FE: begin //comment
              lStr := '';
              if lSegmentLength > 2 then
                 for lInc := (lSegmentLength-2) downto 1 do begin
                     readbyte(btS1);
                     lStr := lStr+chr(bts1);
                 end;
              Memo1.Lines.Add( 'COMMENT: '+lStr);
              lRawPos := (lSegmentEnd);
           end; //comment
           else begin //skip marker segment;
                lRawPos := (lSegmentEnd);
           end;
      end; //case markertype
    until (lRawPos >= lRawSz) or (btMarkerType = $DA); {hexDA=Start of scan}
    lHdrOK := true; //errors goto label 666, so are NOT OK
    lImgStart := lRawPos;
666:
    if not lHdrOK then
       showmessage('Unable to read this file - is it really a JPEG image?');


end;

end.