bmptoavi.pas

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

      Callback.JMP := $E9;
      Callback.JmpOffset := integer(@TWriterAvi.AviSaveCallback) - integer(@Callback.JMP) - 5;


      AVIERR := AVISaveV(PChar(filename), nil, TAVISaveCallback(@Callback), nStreams, Streams, CompOptions);

      if AVIERR <> AVIERR_OK then
        if not fAbort then
        raise Exception.Create('Unable to write output file. Error ' + IntToHex(AVIERR, 8));

    end;
  finally
    if fCompStream <> nil then
      AVIStreamRelease(fCompStream);
    if fPstream <> nil then
      AVIStreamRelease(fPstream);
    if AudioStream <> nil then
      AVIStreamRelease(AudioStream);
    AudioStream := nil;
    fCompStream := nil;
    fPstream := nil;
    fWaveFileList.Clear;
    if FileExists(TempFileName) then
      Deletefile(TempFileName);
    try
      repeat
        refcount := AVIFileRelease(pfile);
      until refcount <= 0;
      pfile := nil;
    except
      pfile := nil;
    end;
    fFinalized := false;
  end;
end;


const
  BitCounts: array[pf1Bit..pf32Bit] of byte = (1, 4, 8, 16, 16, 24, 32);

function FourCCToString(f: DWord): TFourCC;
var
  S, s1: string;
  b: byte;
  c: Char;
begin
  SetLength(Result, 4);
  S := IntToHex(f, 8);
  s1 := '$' + copy(S, 7, 2);
  b := StrToInt(s1);
  c := chr(b);
  Result[1] := c;
  Result[2] := chr(StrToInt('$' + copy(S, 5, 2)));
  Result[3] := chr(StrToInt('$' + copy(S, 3, 2)));
  Result[4] := chr(StrToInt('$' + copy(S, 1, 2)));
  //strings are easier than math :)
end;

procedure TWriterAvi.Compressorlist(const List: TStrings);
var
  ii: TICINFO;
  i: DWord;
  ic: THandle;
  BitmapInfoHeader: TBitmapInfoHeader;
  Name: WideString;
  j: integer;

begin
  List.Clear;
  List.add('No Compression');

  FillChar(BitmapInfoHeader, SizeOf(BitmapInfoHeader), 0);
  with BitmapInfoHeader do
  begin
    biSize := SizeOf(BitmapInfoHeader);
    biWidth := fWidth;
    biHeight := fHeight;
    biPlanes := 1;
    biCompression := BI_RGB;
    biBitCount := BitCounts[fPixelFormat];
  end;

  ii.dwSize := SizeOf(ii);
  for i := 0 to 200 do //what's a safe number to get all?
  begin
    if ICInfo(ICTYPE_VIDEO, i, @ii) then
    begin
      ic := ICOpen(ICTYPE_VIDEO, ii.fccHandler, ICMODE_QUERY);
      try
        if ic <> 0 then
        begin
          if ICCompressQuery(ic, @BitmapInfoHeader, nil) = 0 then
          begin
            ICGetInfo(ic, @ii, SizeOf(ii));
          //can the following be done any simpler?
            Name := '';
            for j := 0 to 15 do
              Name := Name + ii.szName[j];
            List.add(FourCCToString(ii.fccHandler) + ' ' + string(Name));
          end;
        end;
      finally
        ICClose(ic);
      end;
    end;
  end;
end;

procedure TWriterAvi.SetCompression(FourCC: TFourCC);
var S: string;
  ic: THandle;
  BitmapInfoHeader: TBitmapInfoHeader;
begin
  fFourCC := '';
  if FourCC = '' then
    exit;
  FillChar(BitmapInfoHeader, SizeOf(BitmapInfoHeader), 0);
  with BitmapInfoHeader do
  begin
    biSize := SizeOf(BitmapInfoHeader);
    biWidth := fWidth;
    biHeight := fHeight;
    biPlanes := 1;
    biCompression := BI_RGB;
    biBitCount := BitCounts[fPixelFormat];
  end;
  S := FourCC;
  ic := ICLocate(ICTYPE_VIDEO, mmioStringToFOURCC(PChar(S), 0), @BitmapInfoHeader, nil,
    ICMODE_COMPRESS);
  if ic <> 0 then
  begin
    fFourCC := FourCC;
    ICClose(ic);
  end
  else
    raise Exception.Create('No compressor for ' + FourCC + ' available');
end;


procedure TWriterAvi.AddStillImage(const ABmp: TBitmap; Showtime: integer);
var i: integer;
  Samples_Written: LONG;
  Bytes_Written: LONG;
  AVIERR: HRESULT;
  Bitmap: TBitmap;
  r1, r2: TRect;
begin
  if fAbort then
    exit;
  if not fInitialized then
    raise Exception.Create('Video must be initialized.');
  if (fFourCC = '') or (not fCompOnFly) then
  begin
    AddFrame(ABmp);
    for i := 1 to (Showtime div FrameTime) do
  //might be a tad longer than showtime
    begin
               // Write empty frame to the video stream

      AVIERR :=
        AVIStreamWrite(fCompStream, fFrameCount, 1, nil, 0, 0,
        Samples_Written, Bytes_Written);
      if AVIERR <> AVIERR_OK then
        raise Exception.Create
          ('Failed to add frame to AVI. Err='
          + IntToHex(AVIERR, 8));

      inc(fFrameCount);

      if (fFrameCount mod 10 = 0) then
        if Assigned(fOnProgress) then
          fOnProgress(Self, fFrameCount, fAbort);
    end;
  end
  else
  begin
    Bitmap := TBitmap.Create;
    try

      Bitmap.PixelFormat := fPixelFormat;
    //need to force the same for all

      Bitmap.Width := Self.Width;
      Bitmap.Height := Self.Height;
      Bitmap.Canvas.Lock;
      try
        ABmp.Canvas.Lock;
        try
          if fStretch
            then Bitmap.Canvas.stretchdraw
            (Rect(0, 0, Self.Width, Self.Height), ABmp)
          else
           //center image on black background
            with Bitmap.Canvas do begin
              Brush.Color := clBlack;
              Brush.Style := bsSolid;
              FillRect(ClipRect);
              r1 := Rect(0, 0, ABmp.Width, ABmp.Height);
              r2 := r1;
              OffsetRect(r2, (Width - ABmp.Width) div 2, (Height - ABmp.Height) div 2);
              CopyRect(r2, ABmp.Canvas, r1);
            end;
        finally
          ABmp.Canvas.Unlock;
        end;

      finally
        Bitmap.Canvas.Unlock;
      end;
      for i := 0 to (Showtime div FrameTime) do
        InternalAddFrame(Bitmap, true);
    finally
      Bitmap.Free;
    end;
  end;
end;


procedure TWriterAvi.SetCompressionQuality(q: integer);
begin
  fCompressionQuality := q;
end;

procedure TWriterAvi.ShowCompressorDialog(ADialogParent: TWinControl);
var ic: THandle;
  S: string;
begin
  if fFourCC = '' then
    exit;
  S := fFourCC;
  ic := ICOpen(ICTYPE_VIDEO, mmioStringToFOURCC(PChar(S), 0), ICMODE_QUERY);
  try
    if ic <> 0 then
    begin
      if ICQueryConfigure(ic) then
        ICConfigure(ic, ADialogParent.Handle);
    end;
  finally
    ICClose(ic);
  end;
end;

procedure TWriterAvi.SetPixelFormat(const value: TPixelFormat);
begin
  if not (value in [pf1Bit, pf4Bit, pf8bit, pf24bit, pf32Bit]) then
    raise Exception.Create('Pixelformat not supported');
  fPixelFormat := value;
end;

procedure TWriterAvi.InitStreamFormat(const bm: TBitmap);
var DIB: TDIBSection;
  Bits: Pointer;
  DIBErr: integer;
  S: string;
begin
  FillChar(DIB, SizeOf(DIB), 0);
  DIBErr := GetObject(bm.Handle, SizeOf(DIB), @DIB);
  if DIBErr = 0 then
  begin
      //fire event for troubleshooting
    if Assigned(fOnBadBitmap) then
      fOnBadBitmap(Self, bm, SizeOf(DIB.dsbmih), DIB.dsbmih.biSizeImage);
    raise Exception.Create('Failed to retrieve bitmap header and pixels. Err: ' + IntToStr(GetLastError));
  end;
  if fPInInfo <> nil then
    FreeMem(fPInInfo);
  fPInInfo := nil;
  fInInfoSize := SizeOf(TBitmapInfoHeader);
  if DIB.dsbmih.biBitCount <= 8 then
    fInInfoSize := fInInfoSize + SizeOf(TRGBQuad) * (1 shl DIB.dsbmih.biBitCount);

  GetMem(fPInInfo, fInInfoSize);
  GetMem(Bits, DIB.dsbmih.biSizeImage);
  try
    if not GetDIB(bm.Handle, 0, fPInInfo^, Bits^)
      then raise Exception.Create('Failed to retrieve bitmap info');
  finally
    FreeMem(Bits);
      //fPInInfo^ needs to stay around
  end;
  FillChar(AviCompressoptions, SizeOf(AviCompressoptions), 0);
  if fFourCC <> '' then
  begin
    with AviCompressoptions do
    begin
      fccType := streamtypeVIDEO;
      S := fFourCC;
      fccHandler := mmioStringToFOURCC(PChar(S), 0);
      dwKeyFrameEvery := round(1000 / fFrameTime);
      dwQuality := fCompressionQuality;
      dwFlags := AVICOMPRESSF_KEYFRAMES or AVICOMPRESSF_VALID;
      lpFormat := fPInInfo;
      cbFormat := fInInfoSize;
    end;
    if fCompOnFly then
    begin
      if AVIMakeCompressedStream(fCompStream, fPstream, @AviCompressoptions, nil) <> AVIERR_OK then
        raise Exception.Create('Failed to create compressed stream');
    end
    else
    begin
      fCompStream := fPstream;
      fPstream := nil;
    end;
  end
  else
  begin
    fCompStream := fPstream;
    fPstream := nil;
  end;
  if (AVIStreamSetFormat(fCompStream, 0, fPInInfo, fInInfoSize) <> AVIERR_OK) then
    raise Exception.Create('Failed to set AVI stream format');
end;

procedure TWriterAvi.AddWaveFile(const filename: string; Delay: integer);
begin
  if LowerCase(ExtractFileExt(filename)) <> '.wav'
    then raise Exception.Create('WavFileName must name a file '
      + 'with the .wav extension')
  else
    fWaveFileList.AddObject(filename, TObject(Delay))
end;

procedure TWriterAvi.AddFrame(const ABmp: TBitmap);
var Bitmap: TBitmap;
  r1, r2: TRect;
begin
  if fAbort then
    exit;
  if not fInitialized then
    raise Exception.Create('Video must be initialized.');
  Bitmap := TBitmap.Create;
  try

    Bitmap.PixelFormat := fPixelFormat;
    //need to force the same for all

    Bitmap.Width := Self.Width;
    Bitmap.Height := Self.Height;
    Bitmap.Canvas.Lock;
    try
      ABmp.Canvas.Lock;
      try
        if fStretch
          then Bitmap.Canvas.stretchdraw
          (Rect(0, 0, Self.Width, Self.Height), ABmp)
        else
           //center image on black background
          with Bitmap.Canvas do begin
            Brush.Color := clBlack;
            Brush.Style := bsSolid;
            FillRect(ClipRect);
            r1 := Rect(0, 0, ABmp.Width, ABmp.Height);
            r2 := r1;
            OffsetRect(r2, (Width - ABmp.Width) div 2, (Height - ABmp.Height) div 2);
            CopyRect(r2, ABmp.Canvas, r1);
          end;
      finally
        ABmp.Canvas.Unlock;
      end;

    finally
      Bitmap.Canvas.Unlock;
    end;

    InternalAddFrame(Bitmap, true);

  finally
    Bitmap.Free;
  end;
end;

end.