bmptoavi.pas

音视频控件SunAM-V1.0 音视频控件SunAM-V1.0 音视频控件SunAM-V1.0 音视频控件SunAM-V1.0

// Returns:
// True on success, False on failure.
//
// Note: The InternalGetDIBSizes function can be used to calculate the
// necessary sizes of the BitmapInfo and Bits buffers.
//

function TWriterAvi.InternalGetDIB(Bitmap: HBITMAP; Palette: Hpalette;
  var BitmapInfo; var Bits; PixelFormat: TPixelFormat): boolean;
// From graphics.pas, "optimized" for our use
var
  OldPal: Hpalette;
  DC: HDC;
begin
  InitializeBitmapInfoHeader(Bitmap, TBitmapInfoHeader(BitmapInfo), PixelFormat);
  OldPal := 0;

  DC := CreateCompatibleDC(0);
  try
    if (Palette <> 0) then
    begin
      OldPal := SelectPalette(DC, Palette, false);
      realizepalette(DC);
    end;
    GDIFlush;
    Result := (GetDIBits(DC, Bitmap, 0, abs(TBitmapInfoHeader(BitmapInfo).biHeight),
      @Bits, TBitmapInfo(BitmapInfo), DIB_RGB_COLORS) <> 0);
  finally
    if (OldPal <> 0) then
      SelectPalette(DC, OldPal, false);
    DeleteDC(DC);
  end;

end;


// -------------------
// InternalGetDIBSizes
// -------------------
// Calculates the buffer sizes nescessary for convertion of a bitmap to a DIB
// of a specified PixelFormat.
// See the GetDIBSizes API function for more info.
//
// Parameters:
// Bitmap	The handle of the source bitmap.
// InfoHeaderSize
//		The returned size of a buffer that will receive the DIB's
//		TBitmapInfo structure.
// ImageSize	The returned size of a buffer that will receive the DIB's
//		pixel data.
// PixelFormat	The pixel format of the destination DIB.
//

procedure TWriterAvi.InternalGetDIBSizes(Bitmap: HBITMAP; var InfoHeaderSize: integer;
  var ImageSize: Longint; PixelFormat: TPixelFormat);
// From graphics.pas, "optimized" for our use
var
  Info: TBitmapInfoHeader;
begin
  InitializeBitmapInfoHeader(Bitmap, Info, PixelFormat);
  // Check for palette device format
  if (Info.biBitCount > 8) then
  begin
    // Header but no palette
    InfoHeaderSize := SizeOf(TBitmapInfoHeader);
    if ((Info.biCompression and BI_BITFIELDS) <> 0) then
      inc(InfoHeaderSize, 12);
  end else
    // Header and palette
    InfoHeaderSize := SizeOf(TBitmapInfoHeader) + SizeOf(TRGBQuad) * (1 shl Info.biBitCount);
  ImageSize := Info.biSizeImage;
end;


// --------------------------
// InitializeBitmapInfoHeader
// --------------------------
// Fills a TBitmapInfoHeader with the values of a bitmap when converted to a
// DIB of a specified PixelFormat.
//
// Parameters:
// Bitmap	The handle of the source bitmap.
// Info		The TBitmapInfoHeader buffer that will receive the values.
// PixelFormat	The pixel format of the destination DIB.
//
{$IFDEF BAD_STACK_ALIGNMENT}
  // Disable optimization to circumvent optimizer bug...
{$IFOPT O+}
{$DEFINE O_PLUS}
{$O-}
{$ENDIF}
{$ENDIF}


procedure TWriterAvi.InitializeBitmapInfoHeader(Bitmap: HBITMAP; var Info: TBitmapInfoHeader;
  PixelFormat: TPixelFormat);
// From graphics.pas, "optimized" for our use
var
  DIB: TDIBSection;
  Bytes: integer;
  function AlignBit(Bits, BitsPerPixel, Alignment: Cardinal): Cardinal;
  begin
    Dec(Alignment);
    Result := ((Bits * BitsPerPixel) + Alignment) and not Alignment;
    Result := Result shr 3;
  end;
begin
  DIB.dsbmih.biSize := 0;
  Bytes := GetObject(Bitmap, SizeOf(DIB), @DIB);
  if (Bytes = 0) then
    raise Exception.Create('Invalid bitmap');
//    Error(sInvalidBitmap);

  if (Bytes >= (SizeOf(DIB.dsBm) + SizeOf(DIB.dsbmih))) and
    (DIB.dsbmih.biSize >= SizeOf(DIB.dsbmih)) then
    Info := DIB.dsbmih
  else
  begin
    FillChar(Info, SizeOf(Info), 0);
    with Info, DIB.dsBm do
    begin
      biSize := SizeOf(Info);
      biWidth := bmWidth;
      biHeight := bmHeight;
    end;
  end;
  case PixelFormat of
    pf1Bit: Info.biBitCount := 1;
    pf4Bit: Info.biBitCount := 4;
    pf8bit: Info.biBitCount := 8;
    pf24bit: Info.biBitCount := 24;
  else
//    Error(sInvalidPixelFormat);
    raise Exception.Create('Invalid pixel foramt');
    // Info.biBitCount := DIB.dsbm.bmBitsPixel * DIB.dsbm.bmPlanes;
  end;
  Info.biPlanes := 1;
  Info.biCompression := BI_RGB; // Always return data in RGB format
  Info.biSizeImage := AlignBit(Info.biWidth, Info.biBitCount, 32) * Cardinal(abs(Info.biHeight));

end;
{$IFDEF O_PLUS}
{$O+}
{$UNDEF O_PLUS}
{$ENDIF}

procedure TWriterAvi.SetWavFileName(value: string);
begin
  if LowerCase(fWavFileName) <> LowerCase(value)
    then if value <> ''
    then if LowerCase(ExtractFileExt(value)) <> '.wav'
      then raise Exception.Create('WavFileName must name a file '
          + 'with the .wav extension')
      else fWavFileName := value
    else fWavFileName := value;

end;


procedure TWriterAvi.InternalAddFrame(const Bitmap: TBitmap; Key: boolean);
var
  Samples_Written: LONG;
  Bytes_Written: LONG;
  AVIERR: integer;
  DIB: TDIBSection;
  DIBErr: integer;
  flag: DWord;
begin


      // On the first time through, set the stream format.
      // A bit roundabout so the colors can be retrieved
      // in case of pixelformats <=pf8bit, but I'd rather
      // be safe.
  if fFrameCount = 0 then
  begin
    InitStreamFormat(Bitmap);
  end;

  FillChar(DIB, SizeOf(DIB), 0);
  DIBErr := GetObject(Bitmap.Handle, SizeOf(DIB), @DIB);
  if DIBErr = 0 then
  begin
      //fire event for troubleshooting
    if Assigned(fOnBadBitmap) then
      fOnBadBitmap(Self, Bitmap, SizeOf(DIB.dsbmih), DIB.dsbmih.biSizeImage);
    raise Exception.Create('Failed to retrieve bitmap header and pixels. Err: ' + IntToStr(GetLastError));
  end;
               // Write frame to the video stream
  if Key then
    flag := AVIIF_KEYFRAME
  else
    flag := 0;
  try
    AVIERR :=
      AVIStreamWrite(fCompStream, fFrameCount, 1, DIB.dsBm.bmBits, DIB.dsbmih.biSizeImage, flag,
      Samples_Written, Bytes_Written);
  except
    AVIERR := AVIERR_ERROR; //for the DivX unhandled floating point..
  end;
  if AVIERR <> AVIERR_OK then
    raise Exception.Create('Failed to add Frame. Err: ' + IntToHex(AVIERR, 8));
  inc(fFrameCount);

  if Assigned(fOnProgress) then
    if (fFrameCount mod 20 = 0) then
      fOnProgress(Self, fFrameCount, fAbort);
end;

procedure TWriterAvi.FinalizeVideo;
begin
  fInitialized := false;
  fFinalized := true;
  //Doesn't do much anymore...
end;

procedure TWriterAvi.InitVideo;
var S, Workfile: string;
  AVIERR: HRESULT;
begin
  VideoStream := nil;
  fCompStream := nil;
  fPstream := nil;
  AudioStream := nil;
  fAbort := false;
  pfile := nil;

  if fPixelFormat = pfDevice then
  begin
    fAbort := true;
    raise Exception.Create('For adding frames on the fly the pixelformat must be <> pfDevice');
    exit;
  end;

  if fCompOnFly then
    Workfile := fFilename
  else
    Workfile := TempFileName;
  if FileExists(Workfile) then
    if not Deletefile(Workfile) then
      raise Exception.Create('Could not delete ' + Workfile + ' file might be in use. Try to close the folder if it''s open in Explorer');


  //need to start with new files,
  //otherwise the compression doesn't
  //work, and the files just get larger and larger



    // Open AVI file for write
  AVIERR := AVIFileOpen(pfile, PChar(Workfile),
    OF_WRITE or OF_CREATE, nil);
    //Shareexclusive causes nothing but trouble on an exception
  if AVIERR <> AVIERR_OK
    then
    raise Exception.Create('Failed to create AVI video file. Err: $' + IntToHex(AVIERR, 8));

    // Write the stream header.
  FillChar(fStreamInfo, SizeOf(fStreamInfo), 0);

       // Set frame rate and scale
  fStreamInfo.dwRate := 1000;
  fStreamInfo.dwScale := fFrameTime;
  fStreamInfo.fccType := streamtypeVIDEO;
  S := fFourCC;
  if S = '' then
    fStreamInfo.fccHandler := 0
  else
    fStreamInfo.fccHandler := mmioStringToFOURCC(PChar(S), 0);
  fStreamInfo.dwQuality := fCompressionQuality;
  fStreamInfo.dwFlags := 0;
  fStreamInfo.dwSuggestedBufferSize := 0;
  fStreamInfo.rcFrame.Right := Self.Width;
  fStreamInfo.rcFrame.Bottom := Self.Height;

       // Open AVI data stream
  if (AVIFileCreateStream(pfile, fPstream, fStreamInfo) <> AVIERR_OK) then
    raise Exception.Create('Failed to create AVI video stream');

  //the initialization of the compressed stream needs to
  //be deferred until the first frame comes in.
  fFrameCount := 0;
  fInitialized := true;
end;


function TWriterAvi.AviSaveCallback(i: integer): LONG; pascal;

begin
  if Assigned(fOnProgress) then fOnProgress(Self, trunc(1 / 100 * fFrameCount * i), fAbort);
  if fAbort then
    Result := AVIERR_USERABORT
  else
    Result := AVIERR_OK;
end;

procedure TWriterAvi.WriteAvi;

type
  TCallbackThunk = packed record
    POPEDX: byte;
    MOVEAX: byte;
    SelfPtr: Pointer;
    PUSHEAX: byte;
    PUSHEDX: byte;
    JMP: byte;
    JmpOffset: integer;
  end;

var
  Callback: TCallbackThunk;
  nStreams: integer;
  Streams: APAVISTREAM;
  CompOptions: APAVICompressOptions;
  AVIERR: HRESULT;
  refcount: integer;

begin
  if fAbort or (not fFinalized) then
  begin
    if fPstream <> nil then
      AVIStreamRelease(fPstream);
    if fCompStream <> nil then
      AVIStreamRelease(fCompStream);
    fCompStream := nil;
    fPstream := nil;
    fWaveFileList.Clear;
    try
      repeat
        refcount := AVIFileRelease(pfile);
      until refcount <= 0;
      pfile := nil;
    except
      pfile := nil;
    end;
    if not fFinalized then
      raise Exception.Create('Video must be finalized');
    exit;
  end;

  try
    if not fCompOnFly then
      if fWavFileName = '' then
        if fWaveFileList.Count > 0 then
          fWavFileName := fWaveFileList.Strings[0];

    if fCompOnFly then
      AddAudioMod
    else
      if WavFileName <> '' then
        AddAudio;

    if not fCompOnFly then
    begin

      if FileExists(filename) then
        if not Deletefile(filename) then
          raise Exception.Create('File ' + ExtractFileName(filename) + ' could not be deleted. It could be in use by another application.');

      if WavFileName <> ''
        then nStreams := 2
      else nStreams := 1;

      Streams[0] := fCompStream;
      Streams[1] := AudioStream;
      if fFourCC = '' then
        CompOptions[0] := nil
      else
        CompOptions[0] := @AviCompressoptions;
      CompOptions[1] := nil;

    //trick a method into a callback.
    //from SysUtils.TLanguages.Create
      Callback.POPEDX := $5A;
      Callback.MOVEAX := $B8;
      Callback.SelfPtr := Self;
      Callback.PUSHEAX := $50;
      Callback.PUSHEDX := $52;