Delphi Bitmap to Mpeg1- Mpeg2

Delphi'de kod yazma ile ilgili sorularınızı bu foruma yazabilirsiniz.
Cevapla
ekremkocak
Üye
Mesajlar: 24
Kayıt: 31 Oca 2015 03:24

Delphi Bitmap to Mpeg1- Mpeg2

Mesaj gönderen ekremkocak »

Kod: Tümünü seç

unit MpegStream;

interface

uses  Classes, SysUtils, Graphics,Dialogs, SyncObjs;

const
  Zig_Zag_Scan:array[0..64-1] of Smallint=(
      0,  1,  8, 16,  9,  2, 3,  10,
     17, 24, 32, 25, 18, 11, 4,   5,
     12, 19, 26, 33, 40, 48, 41, 34,
     27, 20, 13,  6,  7, 14, 21, 28,
     35, 42, 49, 56, 57, 50, 43, 36,
     29, 22, 15, 23, 30, 37, 44, 51,
     58, 59, 52, 45, 38, 31, 39, 46,
     53, 60, 61, 54, 47, 55, 62, 63
   );

  QMatrix_Intra: array[0..64-1] of smallint = (
     8,  16, 19, 22, 26, 27, 29, 34,
     16, 16, 22, 24, 27, 29, 34, 37,
     19, 22, 26, 27, 29, 34, 34, 38,
     22, 22, 26, 27, 29, 34, 37, 40,
     22, 26, 27, 29, 32, 35, 40, 48,
     26, 27, 29, 32, 35, 40, 48, 58,
     26, 27, 29, 34, 38, 46, 56, 69,
     27, 29, 35, 38, 46, 56, 69, 83
  );

 coe:array[0..8-1,0..8-1] of Smallint=(
   (4096,    4096,    4096,    4096,    4096,    4096,    4096,   4096),
	 (5681,    4816,    3218,    1130,   -1130,   -3218,   -4816,  -5681),
   (5352,    2217,   -2217,   -5352,   -5352,   -2217,    2217,   5352),
   (4816,   -1130,   -5681,   -3218,    3218,    5681,    1130,  -4816),
	 (4096,   -4096,   -4096,    4096,    4096,   -4096,   -4096,   4096),
   (3218,   -5681,    1130,    4816,   -4816,   -1130,    5681,  -3218),
   (2217,   -5352,    5352,   -2217,   -2217,    5352,   -5352,   2217),
	 (1130,   -3218,    4816,   -5681,    5681,   -4816,    3218,  -1130)
  );




type
  PVLCtable=^TVLCtable;
  TVLCtable = record
      code: integer;
      len : byte;
  end;


type
   TRGBTriple = packed record
    rgbtBlue : Byte;
    rgbtGreen: Byte;
    rgbtRed  : Byte;
  end;


  PRGBArray = ^TRGBArray;
  TRGBArray = array[0..32768-1] of TRGBTriple;

 
type
  TOnGetBitmap = procedure(Bitmap:TBitmap) of Object;

  TMpegStream = class(TThread)
  private
   FLock: TCriticalSection;
   PictureRate : Integer;
   QScale      : Integer;
   GopSize     : Integer;
   PictureCount: Integer;
   Width       : Integer;
   Height      : Integer;
   Capturing   : boolean;
   FOnGetBitmap: TOnGetBitmap;
   Dct_Pred    :array[0..3-1] of Integer;
   Mpeg1:boolean;
  protected
    BitmapData:array of array of  TRGBTriple;
    procedure Execute; override;
    procedure GetBitmap; dynamic;
  public
    Procedure EncodeYMatrix(vblock:integer;  hblock:integer);
    procedure EncodeCRMatrix(vblock:integer;  hblock:integer);
    procedure EncodeCBMatrix(vblock:integer;  hblock:integer);
    procedure EncodeIntraBlk(Block:array of Smallint;cc:integer);
    procedure EncodeDC(tab:array of TVLCtable;val:integer);
    procedure EncodeAC(run,signed_level:integer);
    procedure EncodeDct(Block:array of Smallint;mode:integer);

    procedure WriteSequenceHeader();
    procedure WriteGOPHeader();
    procedure WritePictureHeader();
    procedure WriteSequenceEnd();
    procedure WriteSeqExt();
    procedure WriteSeqdispExt();
    procedure WritePictcodExt();

    function StartCapture(): boolean;
    function PauseCapture(): boolean;
    function StopCapture(): boolean;

    constructor Create(FileName:String;MpegVersion:boolean=true);
    destructor Destroy; override;
  published
    property OnGetBitmap: TOnGetBitmap read FOnGetBitmap write FOnGetBitmap ;
  end;

var

  DClumtab: array [0..Pred(12)] of TVLCtable = (
    (code:$0004;len:3),(code:$0000;len:2),(code:$0001;len:2),(code:$0005;len:3),(code:$0006;len:3),(code:$000e;len:4),
    (code:$001e;len:5),(code:$003e;len:6),(code:$007e;len:7),(code:$00fe;len:8),(code:$01fe;len:9),(code:$01ff;len:9)
  );

 DCchromtab: array [0..Pred(12)] of TVLCtable = (
    (code:$0000;len:2),(code:$0001;len:2),(code:$0002;len:2),(code:$0006;len:3),(code:$000e;len:4),(code:$001e;len:5),
    (code:$003e;len:6),(code:$007e;len:7),(code:$00fe;len:8),(code:$01fe;len:9),(code:$03fe;len:10),(code:$03ff;len:10)
  );

 dct_code_tab1: array [0..Pred(2),0..Pred(40)] of TVLCtable = (
  ((code:$03;len:2),(code:$04;len:4),(code:$05;len:5),(code:$06;len:7),(code:$26;len:8),(code:$21;len:8),
   (code:$0a;len:10),(code:$1d;len:12),(code:$18;len:12),(code:$13;len:12),(code:$10;len:12),(code:$1a;len:13),
   (code:$19;len:13),(code:$18;len:13),(code:$17;len:13),(code:$1f;len:14),(code:$1e;len:14),(code:$1d;len:14),
   (code:$1c;len:14),(code:$1b;len:14),(code:$1a;len:14),(code:$19;len:14),(code:$18;len:14),(code:$17;len:14),
   (code:$16;len:14),(code:$15;len:14),(code:$14;len:14),(code:$13;len:14),(code:$12;len:14),(code:$11;len:14),
   (code:$10;len:14),(code:$18;len:15),(code:$17;len:15),(code:$16;len:15),(code:$15;len:15),(code:$14;len:15),
   (code:$13;len:15),(code:$12;len:15),(code:$11;len:15),(code:$10;len:15)),
  ((code:$03;len:3),(code:$06;len:6),(code:$25;len:8),(code:$0c;len:10),(code:$1b;len:12),(code:$16;len:13),
   (code:$15;len:13),(code:$1f;len:15),(code:$1e;len:15),(code:$1d;len:15),(code:$1c;len:15),(code:$1b;len:15),
   (code:$1a;len:15),(code:$19;len:15),(code:$13;len:16),(code:$12;len:16),(code:$11;len:16),(code:$10;len:16),
   (code:$00;len:0),(code:$00;len:0),(code:$00;len:0),(code:$00;len:0),(code:$00;len:0),(code:$00;len:0),
   (code:$00;len:0),(code:$00;len:0),(code:$00;len:0),(code:$00;len:0),(code:$00;len:0),(code:$00;len:0),
   (code:$00;len:0),(code:$00;len:0),(code:$00;len:0),(code:$00;len:0),(code:$00;len:0),(code:$00;len:0),
   (code:$00;len:0),(code:$00;len:0),(code:$00;len:0),(code:$00;len:0))
   );

 dct_code_tab2: array [0..Pred(30),0..Pred(5)] of TVLCtable = (
  ((code:$05;len:4),(code:$04;len:7),(code:$0b;len:10),(code:$14;len:12),(code:$14;len:13)),
  ((code:$07;len:5),(code:$24;len:8),(code:$1c;len:12),(code:$13;len:13),(code:$00;len:0)),
  ((code:$06;len:5),(code:$0f;len:10),(code:$12;len:12),(code:$00;len:0),(code:$00;len:0)),
  ((code:$07;len:6),(code:$09;len:10),(code:$12;len:13),(code:$00;len:0),(code:$00;len:0)),
  ((code:$05;len:6),(code:$1e;len:12),(code:$14;len:16),(code:$00;len:0),(code:$00;len:0)),
  ((code:$04;len:6),(code:$15;len:12),(code:$00;len:0),(code:$00;len:0),(code:$00;len:0)),
  ((code:$07;len:7),(code:$11;len:12),(code:$00;len:0),(code:$00;len:0),(code:$00;len:0)),
  ((code:$05;len:7),(code:$11;len:13),(code:$00;len:0),(code:$00;len:0),(code:$00;len:0)),
  ((code:$27;len:8),(code:$10;len:13),(code:$00;len:0),(code:$00;len:0),(code:$00;len:0)),
  ((code:$23;len:8),(code:$1a;len:16),(code:$00;len:0),(code:$00;len:0),(code:$00;len:0)),
  ((code:$22;len:8),(code:$19;len:16),(code:$00;len:0),(code:$00;len:0),(code:$00;len:0)),
  ((code:$20;len:8),(code:$18;len:16),(code:$00;len:0),(code:$00;len:0),(code:$00;len:0)),
  ((code:$0e;len:10),(code:$17;len:16),(code:$00;len:0),(code:$00;len:0),(code:$00;len:0)),
  ((code:$0d;len:10),(code:$16;len:16),(code:$00;len:0),(code:$00;len:0),(code:$00;len:0)),
  ((code:$08;len:10),(code:$15;len:16),(code:$00;len:0),(code:$00;len:0),(code:$00;len:0)),
  ((code:$1f;len:12),(code:$00;len:0),(code:$00;len:0),(code:$00;len:0),(code:$00;len:0)),
  ((code:$1a;len:12),(code:$00;len:0),(code:$00;len:0),(code:$00;len:0),(code:$00;len:0)),
  ((code:$19;len:12),(code:$00;len:0),(code:$00;len:0),(code:$00;len:0),(code:$00;len:0)),
  ((code:$17;len:12),(code:$00;len:0),(code:$00;len:0),(code:$00;len:0),(code:$00;len:0)),
  ((code:$16;len:12),(code:$00;len:0),(code:$00;len:0),(code:$00;len:0),(code:$00;len:0)),
  ((code:$1f;len:13),(code:$00;len:0),(code:$00;len:0),(code:$00;len:0),(code:$00;len:0)),
  ((code:$1e;len:13),(code:$00;len:0),(code:$00;len:0),(code:$00;len:0),(code:$00;len:0)),
  ((code:$1d;len:13),(code:$00;len:0),(code:$00;len:0),(code:$00;len:0),(code:$00;len:0)),
  ((code:$1c;len:13),(code:$00;len:0),(code:$00;len:0),(code:$00;len:0),(code:$00;len:0)),
  ((code:$1b;len:13),(code:$00;len:0),(code:$00;len:0),(code:$00;len:0),(code:$00;len:0)),
  ((code:$1f;len:16),(code:$00;len:0),(code:$00;len:0),(code:$00;len:0),(code:$00;len:0)),
  ((code:$1e;len:16),(code:$00;len:0),(code:$00;len:0),(code:$00;len:0),(code:$00;len:0)),
  ((code:$1d;len:16),(code:$00;len:0),(code:$00;len:0),(code:$00;len:0),(code:$00;len:0)),
  ((code:$1c;len:16),(code:$00;len:0),(code:$00;len:0),(code:$00;len:0),(code:$00;len:0)),
  ((code:$1b;len:16),(code:$00;len:0),(code:$00;len:0),(code:$00;len:0),(code:$00;len:0))
  );

var

   outbfr:Byte;
   outcnt:Integer=8;
   bytecnt:Integer=0;
   myFile    : TFileStream;

   Buffer:array[0..65519-1] of byte;
   BufPtr:integer=0;
   BufferSize:Integer=4096;

implementation

function bitcount():Integer;
begin
  Result:= 8*bytecnt + (8-outcnt);
end;

procedure SetBits(val:Integer;n:Integer);
var
  I:Integer;
  Mask:longint;
begin
 mask := 1 shl (n-1);
 i:=0;
 while i<n do
 begin
   outbfr :=outbfr shl 1;
   if (val and mask)<>0 then
      outbfr:=outbfr or 1;
   mask :=mask shr  1;
   Dec(outcnt);
   if (outcnt=0) then
   begin
     if BufPtr=BufferSize then
     begin
       myFile.Write(Buffer[0],BufferSize);
       BufPtr:=0;
     end;
     Buffer[BufPtr]:=outbfr;
     Inc(BufPtr);
     outcnt := 8;
     Inc(bytecnt);
    end;
    inc(i)
  end;
end;

procedure alignbits();
begin
  if (outcnt<>8) then
     SetBits(0,outcnt);
end;

procedure TMpegStream.GetBitmap();
var
 SrcRow : pRGBArray;
 X,Y    : Integer;
 Bitmap:Tbitmap;
begin
  FLock.Enter;
  try
    SetLength(BitmapData,0,0);
    Bitmap :=TBitmap.Create;
    try
    if Assigned(FOnGetBitmap) then FOnGetBitmap(Bitmap);
      Width:= Bitmap.Width;
      Height:=Bitmap.Height;
      SetLength(BitmapData,Width,Height);
      for y := 0 to Bitmap.Height - 1 do
      begin
        SrcRow := Bitmap.ScanLine[y];
        for x := 0 to Bitmap.Width - 1 do
        begin
          BitmapData[x,y].rgbtRed  :=  SrcRow[x].rgbtRed;
          BitmapData[x,y].rgbtGreen:=  SrcRow[x].rgbtGreen;
          BitmapData[x,y].rgbtBlue :=  SrcRow[x].rgbtBlue;
        end;
      end;
    finally
      Bitmap.Free;
    end;
  finally
    FLock.Leave;
  end;
end;



constructor TMpegStream.Create(FileName:String;MpegVersion:boolean=true);
begin
  inherited Create(True);
  myFile  := TFileStream.Create(FileName,fmCreate);
  Mpeg1:=MpegVersion;
  Capturing:=False;
  FLock := TCriticalSection.Create;
  FreeOnTerminate := True;
  PictureRate:=25;
  PictureCount:=0;
  GopSize:=29;
  QScale:=8;
  Dct_Pred[0]:=128;
  Dct_Pred[1]:=128;
  Dct_Pred[2]:=128;
end;


procedure TMpegStream.Execute;
var
 I:Integer;
begin
  GetBitmap();

  WriteSequenceHeader();
  if  Mpeg1=false then
  begin
    WriteSeqext();
   // WriteSeqdispext();
  end;
  While  not(Terminated) do
  begin
    for I:=0 to GopSize-1 do
    begin
      GetBitmap();
      if(PictureCount mod GopSize = 0) then
      begin
        WriteGOPHeader();
      end;
        WritePictureHeader();
        Inc(PictureCount);
     end;
   end;
    WriteSequenceEnd();
    if myFile <>nil then myFile.Free;
end;

destructor TMpegStream.Destroy;
begin
  FLock.Free;
  Inherited;
end;

function TMpegStream.StartCapture(): boolean;
begin
  Capturing:=True;
  Resume;
end;

function TMpegStream.PauseCapture(): boolean;
begin
  Suspend;
end;

function TMpegStream.StopCapture(): boolean;
begin
  Capturing:=False;
  Terminate;
end;

procedure TMpegStream.WriteSequenceHeader();
begin
  alignbits();
  SetBits($000001b3,32);
  SetBits(Width,12); //* horizontal_size_value */
  SetBits(Height,12); //* vertical_size_value */
  SetBits(1, 4);   //aspect ratio: 12 is 4/3  13 is 19/9
  SetBits(3, 4);   //frame rate: 4 is 29.97
  SetBits($FFFF, 16);   //bit rate (18 1s)
  SetBits($3,2);        //always 1
  SetBits(1, 1);   // VBV buffer
  SetBits(20, 10);   // VBV buffer
  SetBits(1,1);  // no constrained parameter
  SetBits(0,1);  // no load intra quantiser matrix
  SetBits(0,1);  // no load non-intra quantiser matrix
end;

procedure  TMpegStream.WriteSeqext();
Begin
  alignbits();
  SetBits($00001B5,32); // extension_start_code */
  SetBits(1,4); // extension_start_code_identifier */
  SetBits(8,8); // profile_and_level_indication */
  SetBits(0,1); // progressive sequence */
  SetBits(1,2); // chroma_format */
  SetBits(0,2); // horizontal_size_extension */
  SetBits(0,2); // vertical_size_extension */
  SetBits(0,12); // bit_rate_extension */
  SetBits(1,1); // marker_bit */
  SetBits(0,8); // vbv_buffer_size_extension */
  SetBits(0,1); // low_delay  -- currently not implemented */
  SetBits(0,2); // frame_rate_extension_n */
  SetBits(0,5); // frame_rate_extension_d */
end;

procedure TMpegStream.WriteSeqdispext();
begin
 { alignbits();
  SetBits($00001B5,32); // extension_start_code */
  SetBits(DISP_ID,4); // extension_start_code_identifier */
  SetBits(video_format,3); // video_format */
  SetBits(1,1); // colour_description */
  SetBits(color_primaries,8); // colour_primaries */
  SetBits(transfer_characteristics,8); // transfer_characteristics */
  SetBits(matrix_coefficients,8); // matrix_coefficients */
  SetBits(display_horizontal_size,14); // display_horizontal_size */
  SetBits(1,1); // marker_bit */
  SetBits(display_vertical_size,14); // display_vertical_size */
  }
end;

procedure TMpegStream.WritePictcodExt();
begin
  alignbits();
  SetBits($00001B5,32); // extension_start_code */
  SetBits(8,4); // extension_start_code_identifier */
  SetBits(15,4); // forward_horizontal_f_code */
  SetBits(15,4); // forward_vertical_f_code */
  SetBits(15,4); // backward_horizontal_f_code */
  SetBits(15,4); // backward_vertical_f_code */
  SetBits(1,2); // intra_dc_precision */
  SetBits(3,2); // picture_structure */
  SetBits(1,1); // top_field_first */
  SetBits(1,1); // frame_pred_frame_dct */
  SetBits(0,1); // concealment_motion_vectors  -- currently not implemented */
  SetBits(0,1); // q_scale_type */
  SetBits(1,1); // intra_vlc_format */
  SetBits(1,1); // alternate_scan */
  SetBits(0,1); // repeat_first_field */
  SetBits(0,1); // chroma_420_type */
  SetBits(0,1); // progressive_frame */
  SetBits(0,1); // composite_display_flag */
end;

procedure TMpegStream.WriteGOPHeader();
begin
   alignbits();
   SetBits($000001b8,32);   // group_start_code
   SetBits(0,1);           // time_code
   SetBits(((PictureCount div PictureRate) div 60) div 24, 5);		// Stunden
	 SetBits(((PictureCount div PictureRate) div 60) mod 24, 6);		// Minuten
	 SetBits(1, 1);		//
	 SetBits((PictureCount div PictureRate) mod 60, 6);			// Sekunden
	 SetBits(PictureCount mod PictureRate, 6);					// picture_time_code
	 SetBits(1, 1);		// closed_gop (1)
	 SetBits(0, 1);		// broken_link (0)
  // SetBits($0, 5);		// zero_padding
end;

procedure TMpegStream.WritePictureHeader();
var
 hblock, vblock:integer;
 begin
   alignbits();
   SetBits($00000100,32);
   SetBits(PictureCount mod GopSize,10); //temperal sequence #
   SetBits($1,3); //picture I type
   SetBits(0, 16);  //vbv delay
   SetBits(0, 1);  //no additional fields

 // if (mpeg1=false) then putpictcodext();

   for hblock:=0 to ((Height-1) div 16) do
   begin
     for vblock:=0 to ((Width-1) div 16) do
     begin
      if  vblock=0  then
      begin
        alignbits();

        if mpeg1 or (Height<=2800)then
          SetBits($00000101+hblock,32)
        else
        begin
         SetBits($00000101+(hblock and 127),32);
         SetBits(hblock shr 7,3);
        end;
        SetBits(QScale,5);
        SetBits( 0,1);
        Dct_Pred[0]:=(128);
        Dct_Pred[1]:=(128);
        Dct_Pred[2]:=(128);
      end;

      SetBits( 1, 1);
        if(QScale <> 1.0) then
        begin
		      SetBits( 1, 2);					// macroblock_type (I-Block, intra-q)
		      SetBits( round(QScale), 5);	// nochmals quantizer_scale wie im Slice
	      end
	      else
		      SetBits(1, 1);
          EncodeYMatrix(vblock,hblock);
          EncodeCBMatrix(vblock,hblock);
          EncodeCRMatrix(vblock,hblock);
      end;
  end;
end;


procedure TMpegStream.WriteSequenceEnd();
begin
  alignbits();
  SetBits($000001b7,32);
end;


Procedure TMpegStream.EncodeYMatrix(vblock:integer;  hblock:integer);
var
   i,j,k1,k2,pos:integer;
   tempdouble:double;
   Y:Array[0..16-1,0..16-1] of Smallint;
   Block:array[0..64-1] of Smallint;
begin
  FillChar(Block[0], Length(Block),0);
  for i:=0 to 16-1 do
  begin
    for j:=0 to 16-1 do
    begin
      tempdouble :=  (219.0*(0.59*(BitmapData[vblock*16 + j,hblock*16 + i].rgbtRed) +
                             0.30* (BitmapData[vblock*16 + j,hblock*16 + i].rgbtGreen) +
                             0.11* (BitmapData[vblock*16 + j,hblock*16 + i].rgbtBlue)) / 255.0 )+ 16.0;
      Y[i,j] := Round(tempdouble);
      end;
   end;

   for k1:=0 to 2-1 do
    for k2:=0 to 2-1 do
    begin
     pos:=0;
     for i:=0 to 8-1 do
       for j:=0 to 8-1 do
       begin
         Block[pos] :=( Y[(k1*8 + i),(k2*8 + j)]);
         inc(pos);
       end;
       EncodeDct(Block,0);  // block 8x8  dct y matrix
   end;
end;

procedure TMpegStream.EncodeCBMatrix(vblock:integer;  hblock:integer);
var
  i,j,pos:integer;
  tempdouble:double;
  Block:array[0..64-1] of Smallint;
begin
    FillChar(Block[0], Length(Block),0);
    pos:=0;
    for i:=0 to 8-1 do
      for j:=0 to 8-1 do
      begin
         tempdouble := (224.0*(-0.17*(BitmapData[vblock*16 + j*2,hblock*16 + i*2].rgbtRed) -
                                0.33*(BitmapData[vblock*16 + j*2,hblock*16 + i*2].rgbtGreen) +
                                0.50*(BitmapData[vblock*16 + j*2,hblock*16 + i*2].rgbtBlue)) / 255.0) + 128.0;

        Block[pos] := ROUND(tempdouble);
        inc(pos);
       end;

      EncodeDct(Block,1);  // block 8x8  dct cb matrix
end;

procedure TMpegStream.EncodeCRMatrix(vblock:integer;  hblock:integer);
var
  i,j,pos:integer;
  tempdouble:double;
  Block:array[0..64-1] of Smallint;
begin
     FillChar(Block[0], Length(Block),0);
     pos:=0;
     for i:=0 to 8-1 do
      for j:=0 to 8-1 do
      begin
         tempdouble := (224.0*(0.50*(BitmapData[vblock*16 + j*2,hblock*16 + i*2].rgbtRed) -
                               0.42*(BitmapData[vblock*16 + j*2,hblock*16 + i*2].rgbtGreen) -
                               0.08*(BitmapData[vblock*16 + j*2,hblock*16 + i*2].rgbtBlue)) / 255.0) + 128.0;
        Block[pos] := ROUND(tempdouble);
        inc(pos);
      end;
 EncodeDct(Block,2); // block 8x8  dct cr matrix
end;



procedure TMpegStream.EncodeDct(Block:array of Smallint;mode:integer);
var
  i,j,x,y:integer;
  value:array[0..8-1] of integer;
begin
  for j:=0 to 8-1 do
  begin
       for y:=0 to 8-1 do
       begin
       value[y]:=0;
            for x:=0 to 8-1 do
            value[y] :=value[y]+ integer(coe[y][x]*block[j+(x*8)]); //
       end;
     for y:=0  to 8-1 do
     Block[j+(y*8)] :=Smallint(value[y] shr 12);
  end;
     i:=0;
     while i<64 do
     begin
          for y:=0 to 8-1 do
          begin
          value[y] := 0;
              for x:=0 to 8-1 do
              value[y] := value[y]+ integer((coe[y][x]*Block[i+x])); //
          end;
          for y:=0 to 8-1 do
          Block[i+y] := round(Smallint(value[y] shr 15));
      inc(i,8);
     end;

       for y:=0 to 64-1 do
       if y=0 then
         Block[y] := round( Block[y] /  8.0)   // block 8x8 quantization
       else
         Block[y] := round( (Block[y]* 8.0) / (QScale *QMATRIX_INTRA[y])) ;

  Encodeintrablk(Block,mode);   // mode y cb cr to encode
end;


 // DC Encode function
procedure TMpegStream.EncodeDC(tab:array of TVLCtable;val:integer);
var
  absval, size:integer;
begin
  size := 0;
  absval:=0;
  if val<0 then
  absval:=-val else absval:=val;
  while (absval>= 1) do
  begin
    absval :=absval shr 1;
    inc(size);
  end;
 SetBits(tab[size].code,tab[size].len);

  if (size<>0) then
  begin
    if (val>=0) then
      absval := val
    else
      absval := val + (1 shl size) - 1;
   SetBits(absval,size);

  end;
end;

 // AC Encode function
procedure TMpegStream.EncodeAC(run,signed_level:integer);
var
 level, len,code:integer;
  ptab:pVLCtable;
begin
  if signed_level<0  then
    level := -signed_level else level := signed_level;

  len := 0;
  if (run<2) and (level<41) then
  begin
     ptab := @dct_code_tab1[run][level-1];
     code:=ptab.code;
     len := ptab.len;
  end
  else if (run<32) and (level<6)  then
  begin
     ptab := @dct_code_tab2[run-2][level-1];
     code:=ptab.code;
     len := ptab.len;
  end;

  if (len<>0)then
  begin
  SetBits(code,len);
    if signed_level<0 then
       signed_level:=1
       else
       signed_level:=0;

   SetBits(signed_level,1);
  end
  else
  begin
   SetBits($1,6);
   SetBits(run,6);
   
     if  Mpeg1 then begin
      if (signed_level>127) then
       SetBits(0,8);
      if (signed_level<-127)then
       SetBits(128,8);
     SetBits(signed_level,8);
    end else
     SetBits(signed_level,12);
  end;
end;


procedure TMpegStream.EncodeIntraBlk(Block:array of Smallint;cc:integer);
var
 n, run, signed_level:integer;
 Dct_Diff:integer;
begin

   Dct_Diff := Block[0] - Dct_Pred[cc];
   Dct_Pred[cc]:=Block[0];
   
  if (cc=0)  then
    EncodeDC(DClumtab,Dct_Diff)
  else
    EncodeDC(DCchromtab,Dct_Diff);

  run := 0;
  for n:=1 to 64-1 do
  begin
    signed_level :=Block[zig_zag_scan[n]];
    if (signed_level<>0) then
    begin
       EncodeAC(run,signed_level);
       run := 0;
    end
    else
      inc(run);
  end;

  SetBits(2,2)
end;


end.
ekremkocak
Üye
Mesajlar: 24
Kayıt: 31 Oca 2015 03:24

Re: Delphi Bitmap to Mpeg1- Mpeg2

Mesaj gönderen ekremkocak »

Kod: Tümünü seç

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, MpegStream, Menus, ExtCtrls;

CONST
  PixelCountMax = 32768;

TYPE
  pRGBTripleArray = ^TRGBTripleArray;
  TRGBTripleArray = ARRAY[0..PixelCountMax-1] OF TRGBTriple;


type
  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    Button3: TButton;
    CheckBox1: TCheckBox;
    Image1: TImage;
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure Button3Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
     procedure GetBitmap(Bitmap:Tbitmap);

  end;

var
  Form1: TForm1;

  MpegStream1:TMpegStream;

implementation

{$R *.dfm}

function GenerateRandomColor(const Mix: TColor = clWhite): TColor;
var
  Red, Green, Blue: Integer;
begin
  Red := Random(256);
  Green := Random(256);
  Blue := Random(256);

  Red := (Red + GetRValue(ColorToRGB(Mix))) div 2;      
  Green := (Green + GetGValue(ColorToRGB(Mix))) div 2;
  Blue := (Blue + GetBValue(ColorToRGB(Mix))) div 2;
  Result := RGB(Red, Green, Blue);
end;

procedure TForm1.GetBitmap(Bitmap:Tbitmap);
var
  i  :  INTEGER;
  j  :  INTEGER;
  Row:  pRGBTripleArray;
begin
  Bitmap.PixelFormat := pf24bit;
  Bitmap.Width  := 640;
  Bitmap.Height := 480;

  FOR j := 0 TO Bitmap.Height-1 DO
  BEGIN
    Row := Bitmap.Scanline[j];
    FOR i := 0 TO Bitmap.Width-1 DO
    BEGIN
      WITH Row[i] DO
      BEGIN
        rgbtRed   := GenerateRandomColor(); // yellow pixels
        rgbtGreen := GenerateRandomColor();
        rgbtBlue  :=  GenerateRandomColor();
      END
    END
  END;

   Bitmap.Canvas.Brush.Style := bsClear;
   Bitmap.Canvas.Font.Size  := 24;
   Bitmap.Canvas.Font.Color := clRed;
   Bitmap.Canvas.Font.Style := [fsBold];
   Bitmap.Canvas.Font.Name := 'Courier New';
   Bitmap.Canvas.TextOut(10,20,FormatDateTime('yyyy-mm-dd - hh:nn:ss', Now));

   Image1.Picture.Bitmap.Assign(Bitmap);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
 MpegStream1.StartCapture;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  MpegStream1:=TMpegStream.Create('test1.mpg',CheckBox1.Checked);
  MpegStream1.OnGetBitmap:=Form1.GetBitmap;
end;

procedure TForm1.Button3Click(Sender: TObject);
begin
   MpegStream1.StopCapture;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
   MpegStream1.PauseCapture;
end;

initialization
  Randomize;

end.
Cevapla