diff options
Diffstat (limited to 'Source/FsAviWriter.pas')
| -rw-r--r-- | Source/FsAviWriter.pas | 888 |
1 files changed, 888 insertions, 0 deletions
diff --git a/Source/FsAviWriter.pas b/Source/FsAviWriter.pas new file mode 100644 index 0000000..6373846 --- /dev/null +++ b/Source/FsAviWriter.pas @@ -0,0 +1,888 @@ +unit FsAviWriter; + +// +// FSAviWriter - Framestein modified version of AviWriter. +// + +///////////////////////////////////////////////////////////////////////////// +// // +// AviWriter -- a component to create rudimentary AVI files // +// by Elliott Shevin, with large pieces of code // +// stolen from Anders Melander // +// version 1.0. Please send comments, suggestions, and advice // +// to shevine@aol.com. // +///////////////////////////////////////////////////////////////////////////// +// // +// AviWriter will build an AVI file containing one stream of any // +// number of TBitmaps, plus a single WAV file. // +// // +// Properties: // +// Bitmaps : A TList of pointers to TBitmap objects which become // +// frames of the AVI video stream. The component // +// allocates and frees the TList, but the caller // +// is responsible for managing the TBitmaps themselves. // +// Manipulate the list as you would any other TList. // +// At least one bitmap is required. // +// Height, Width: // +// The dimensions of the AVI video, in pixels. // +// FrameTime: // +// The duration of each video frame, in milliseconds. // +// Stretch: If TRUE, each TBitmap on the Bitmaps list is // +// stretches to the dimensions specified in Height // +// and Width. If FALSE, each TBitmap is copied from // +// its upper left corner without stretching. // +// FileName: The name of the AVI file to be written. // +// WAVFileName: // +// The name of a WAV file which will become the audio // +// stream for the AVI. Optional. // +// // +// Method: // +// Write: Creates the AVI file named by FileName. // +///////////////////////////////////////////////////////////////////////////// +// Wish List: // +// I'd like to be able to enhance this component in two ways, but // +// don't know how. Please send ideas to shevine@aol.com. // +// 1. So far, it's necessary to transform the video stream into // +// and AVI file on disk. I'd prefer to do this in memory. // +// 2. MIDI files for audio. // +///////////////////////////////////////////////////////////////////////////// + +interface + +uses + Windows,Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, + StdCtrls, DIB, +{$ifdef VER90} + ole2; +{$else} + ActiveX; +{$endif} + +//////////////////////////////////////////////////////////////////////////////// +// // +// Video for Windows // +// // +//////////////////////////////////////////////////////////////////////////////// +// // +// Adapted from Thomas Schimming's VFW.PAS // +// (c) 1996 Thomas Schimming, schimmin@iee1.et.tu-dresden.de // +// (c) 1998,99 Anders Melander // +// // +//////////////////////////////////////////////////////////////////////////////// +// // +// Ripped all COM/ActiveX stuff and added some AVI stream functions. // +// // +//////////////////////////////////////////////////////////////////////////////// + +type + + { TAVIFileInfoW record } + + LONG = Longint; + PVOID = Pointer; + +// TAVIFileInfo dwFlag values +const + AVIF_HASINDEX = $00000010; + AVIF_MUSTUSEINDEX = $00000020; + AVIF_ISINTERLEAVED = $00000100; + AVIF_WASCAPTUREFILE = $00010000; + AVIF_COPYRIGHTED = $00020000; + AVIF_KNOWN_FLAGS = $00030130; + + AVIERR_UNSUPPORTED = $80044065; // MAKE_AVIERR(101) + AVIERR_BADFORMAT = $80044066; // MAKE_AVIERR(102) + AVIERR_MEMORY = $80044067; // MAKE_AVIERR(103) + AVIERR_INTERNAL = $80044068; // MAKE_AVIERR(104) + AVIERR_BADFLAGS = $80044069; // MAKE_AVIERR(105) + AVIERR_BADPARAM = $8004406A; // MAKE_AVIERR(106) + AVIERR_BADSIZE = $8004406B; // MAKE_AVIERR(107) + AVIERR_BADHANDLE = $8004406C; // MAKE_AVIERR(108) + AVIERR_FILEREAD = $8004406D; // MAKE_AVIERR(109) + AVIERR_FILEWRITE = $8004406E; // MAKE_AVIERR(110) + AVIERR_FILEOPEN = $8004406F; // MAKE_AVIERR(111) + AVIERR_COMPRESSOR = $80044070; // MAKE_AVIERR(112) + AVIERR_NOCOMPRESSOR = $80044071; // MAKE_AVIERR(113) + AVIERR_READONLY = $80044072; // MAKE_AVIERR(114) + AVIERR_NODATA = $80044073; // MAKE_AVIERR(115) + AVIERR_BUFFERTOOSMALL = $80044074; // MAKE_AVIERR(116) + AVIERR_CANTCOMPRESS = $80044075; // MAKE_AVIERR(117) + AVIERR_USERABORT = $800440C6; // MAKE_AVIERR(198) + AVIERR_ERROR = $800440C7; // MAKE_AVIERR(199) + +type + TAVIFileInfoW = record + dwMaxBytesPerSec, // max. transfer rate + dwFlags, // the ever-present flags + dwCaps, + dwStreams, + dwSuggestedBufferSize, + + dwWidth, + dwHeight, + + dwScale, + dwRate, // dwRate / dwScale == samples/second + dwLength, + + dwEditCount: DWORD; + + szFileType: array[0..63] of WideChar; // descriptive string for file type? + end; + PAVIFileInfoW = ^TAVIFileInfoW; + +// TAVIStreamInfo dwFlag values +const + AVISF_DISABLED = $00000001; + AVISF_VIDEO_PALCHANGES= $00010000; + AVISF_KNOWN_FLAGS = $00010001; + +type + TAVIStreamInfoA = record + fccType, + fccHandler, + dwFlags, // Contains AVITF_* flags + dwCaps: DWORD; + wPriority, + wLanguage: WORD; + dwScale, + dwRate, // dwRate / dwScale == samples/second + dwStart, + dwLength, // In units above... + dwInitialFrames, + dwSuggestedBufferSize, + dwQuality, + dwSampleSize: DWORD; + rcFrame: TRect; + dwEditCount, + dwFormatChangeCount: DWORD; + szName: array[0..63] of AnsiChar; + end; + TAVIStreamInfo = TAVIStreamInfoA; + PAVIStreamInfo = ^TAVIStreamInfo; + + { TAVIStreamInfoW record } + + TAVIStreamInfoW = record + fccType, + fccHandler, + dwFlags, // Contains AVITF_* flags + dwCaps: DWORD; + wPriority, + wLanguage: WORD; + dwScale, + dwRate, // dwRate / dwScale == samples/second + dwStart, + dwLength, // In units above... + dwInitialFrames, + dwSuggestedBufferSize, + dwQuality, + dwSampleSize: DWORD; + rcFrame: TRect; + dwEditCount, + dwFormatChangeCount: DWORD; + szName: array[0..63] of WideChar; + end; + + PAVIStream = pointer; + PAVIFile = pointer; + TAVIStreamList = array[0..0] of PAVIStream; + PAVIStreamList = ^TAVIStreamList; + TAVISaveCallback = function (nPercent: integer): LONG; stdcall; + + TAVICompressOptions = packed record + fccType : DWORD; + fccHandler : DWORD; + dwKeyFrameEvery : DWORD; + dwQuality : DWORD; + dwBytesPerSecond : DWORD; + dwFlags : DWORD; + lpFormat : pointer; + cbFormat : DWORD; + lpParms : pointer; + cbParms : DWORD; + dwInterleaveEvery : DWORD; + end; + PAVICompressOptions = ^TAVICompressOptions; + +const + ICMF_CHOOSE_KEYFRAME = $0001; // show KeyFrame Every box + ICMF_CHOOSE_DATARATE = $0002; // show DataRate box + ICMF_CHOOSE_PREVIEW = $0004; // allow expanded preview dialog + +// Palette change data record +const + RIFF_PaletteChange: DWORD = 1668293411; +type + TAVIPalChange = packed record + bFirstEntry : byte; + bNumEntries : byte; + wFlags : WORD; + peNew : array[byte] of TPaletteEntry; + end; + PAVIPalChange = ^TAVIPalChange; + + APAVISTREAM = array[0..1] of PAVISTREAM; + APAVICompressOptions = array[0..1] of PAVICompressOptions; + PAPAVICompressOptions = ^APAVICompressOptions; + +procedure AVIFileInit; stdcall; +procedure AVIFileExit; stdcall; +function AVIFileOpen(var ppfile: PAVIFile; szFile: PChar; uMode: UINT; lpHandler: pointer): HResult; stdcall; +function AVIFileCreateStream(pfile: PAVIFile; var ppavi: PAVISTREAM; var psi: TAVIStreamInfo): HResult; stdcall; +function AVIStreamSetFormat(pavi: PAVIStream; lPos: LONG; lpFormat: pointer; cbFormat: LONG): HResult; stdcall; +function AVIStreamReadFormat(pavi: PAVIStream; lPos: LONG; lpFormat: pointer; var cbFormat: LONG): HResult; stdcall; +function AVIStreamWrite(pavi: PAVIStream; lStart, lSamples: LONG; lpBuffer: pointer; cbBuffer: LONG; dwFlags: DWORD; var plSampWritten: LONG; var plBytesWritten: LONG): HResult; stdcall; +function AVIStreamRelease(pavi: PAVISTREAM): ULONG; stdcall; +function AVIFileRelease(pfile: PAVIFile): ULONG; stdcall; +function AVIFileGetStream(pfile: PAVIFile; var ppavi: PAVISTREAM; fccType: DWORD; lParam: LONG): HResult; stdcall; +function CreateEditableStream(var ppsEditable: PAVISTREAM; psSource: PAVISTREAM): HResult; stdcall; +function AVISaveV(szFile: PChar; pclsidHandler: PCLSID; lpfnCallback: TAVISaveCallback; + nStreams: integer; pavi: APAVISTREAM; lpOptions: APAVICompressOptions): HResult; stdcall; +function AVISaveOptions(hwnd: HWND; uiFlags: UINT; nStreams: integer; + ppavi: APAVISTREAM; plpOptions: PAPAVICOMPRESSOPTIONS): Boolean; stdcall; external 'avifil32.dll'; +function AVIMakeCompressedStream(var ppaviCompressed: PAVISTREAM; + ppaviSource: PAVISTREAM; plpOptions: APAVICompressOptions; + pclsidHandler: PCLSID): HResult; stdcall; external 'avifil32.dll'; + +const + AVIERR_OK = 0; + + AVIIF_LIST = $01; + AVIIF_TWOCC = $02; + AVIIF_KEYFRAME = $10; + + streamtypeVIDEO = $73646976; // DWORD( 'v', 'i', 'd', 's' ) + streamtypeAUDIO = $73647561; // DWORD( 'a', 'u', 'd', 's' ) + + +type + TPixelFormat = (pfDevice, pf1bit, pf4bit, pf8bit, pf15bit, pf16bit, + pf24bit, pf32bit, pfCustom); + +type + TAviWriter = class(TComponent) + private + TempFileName : string; + pFile : PAVIFile; + fHeight : integer; + fWidth : integer; + fStretch : boolean; + fFrameTime : integer; + fFileName : string; + fWavFileName : string; + VideoStream : PAVISTREAM; + AudioStream : PAVISTREAM; + + Pstream : PAVISTREAM; + StreamInfo : TAVIStreamInfo; + + CompOptions : APAVICompressOptions; + cmp1, cmp2 : TAviCompressOptions; + + procedure AddVideo; + procedure AddAudio; + procedure InternalGetDIBSizes(Bitmap: HBITMAP; var InfoHeaderSize: Integer; + var ImageSize: longInt; PixelFormat: TPixelFormat); + function InternalGetDIB(Bitmap: HBITMAP; Palette: HPALETTE; + var BitmapInfo; var Bits; PixelFormat: TPixelFormat): Boolean; + procedure InitializeBitmapInfoHeader(Bitmap: HBITMAP; var Info: TBitmapInfoHeader; + PixelFormat: TPixelFormat); + procedure SetWavFileName(value : string); + { Private declarations } + protected + { Protected declarations } + public + Bitmaps : TList; + FramePos : Longint; + Prepared : Boolean; + fps : Integer; + constructor Create(AOwner : TComponent); override; + destructor Destroy; override; + procedure Write; + procedure Prepare; + procedure AddFrame(const DIB: TDIB); + procedure Finish; + { Public declarations } + published + property Height : integer read fHeight write fHeight; + property Width : integer read fWidth write fWidth; + property FrameTime: integer read fFrameTime write fFrameTime; + property Stretch : boolean read fStretch write fStretch; + property FileName : string read fFileName write fFileName; + property WavFileName : string read fWavFileName write SetWavFileName; + { Published declarations } + end; + +procedure Register; + +implementation + +uses + mainunit, + progressunit; + +function MAKEFOURCC(ch0, ch1, ch2, ch3: Char): Cardinal; +begin + Result := + (DWORD(BYTE(ch0))) or (DWORD(BYTE(ch1)) shl 8) or + (DWORD(BYTE(ch2)) shl 16) or (DWORD(BYTE(ch3)) shl 24 ); +end; + +constructor TAviWriter.Create(AOwner : TComponent); +var + tempdir : string; + l : integer; +begin + inherited Create(AOwner); + fHeight := screen.height div 10; + fWidth := screen.width div 10; + fFrameTime := 1000; + fStretch := true; + fFileName := ''; + Bitmaps := TList.create; + AVIFileInit; + + setlength(tempdir,MAX_PATH + 1); + l := GetTempPath(MAX_PATH,pchar(tempdir)); + setlength(tempdir,l); + if copy(tempdir,length(tempdir),1) <> '\' + then tempdir := tempdir + '\'; + TempFileName := tempdir + '~AWTemp.avi'; + Prepared := False; + + CompOptions[0] := @cmp1; + CompOptions[1] := @cmp2; + + FillChar(cmp1, Sizeof(cmp1), 0); + FillChar(cmp2, Sizeof(cmp1), 0); + + cmp1.fccType := streamtypeVIDEO; + cmp1.fccHandler := MakeFourCC('m','j','p','g'); +// cmp1.dwQuality := + + fps := 25; +end; + +destructor TAviWriter.Destroy; +begin + Bitmaps.free; + AviFileExit; + inherited; +end; + +procedure TAviWriter.Write; +var + Bitmap : TBitmap; + ExtBitmap : TBitmap; + nstreams : integer; + i : integer; + Streams : APAVISTREAM; + CompOptions : APAVICompressOptions; + AVIERR : integer; + refcount : integer; +begin + AudioStream := nil; + VideoStream := nil; + + // If no bitmaps are on the list, raise an error. + if Bitmaps.count < 1 then + raise Exception.Create('No bitmaps on the Bitmaps list'); + + // If anything on the Bitmaps TList is not a bitmap, raise + // an error. + for i := 0 to Bitmaps.count - 1 do begin + ExtBitmap := Bitmaps[i]; + if not(ExtBitmap is TBitmap) + then raise Exception.Create('Bitmaps[' + inttostr(i) + + '] is not a TBitmap'); + end; + + try + AddVideo; + + if WavFileName <> '' + then AddAudio; + + // Create the output file. + if WavFileName <> '' + then nstreams := 2 + else nstreams := 1; + + Streams[0] := VideoStream; + Streams[1] := AudioStream; + CompOptions[0] := nil; + CompOptions[1] := nil; + + AVIERR := AVISaveV(pchar(FileName), + nil, // File handler + nil, // Callback + nStreams, // Number of streams
Streams,
CompOptions); // Compress options for VideoStream
if AVIERR <> AVIERR_OK then
raise Exception.Create('Unable to write output file');
finally
if assigned(VideoStream)
then AviStreamRelease(VideoStream);
if assigned(AudioStream) + then AviStreamRelease(AudioStream);
try
repeat + refcount := AviFileRelease(pFile); + until refcount <= 0; + except + end; + + DeleteFile(TempFileName); + end; +end; + +procedure TAviWriter.AddVideo; +var + Pstream : PAVISTREAM; + StreamInfo : TAVIStreamInfo; + BitmapInfo : PBitmapInfoHeader; + BitmapInfoSize : Integer; + BitmapSize : longInt; + BitmapBits : pointer; + Bitmap : TBitmap; + ExtBitmap : TBitmap; + Samples_Written : LONG; + Bytes_Written : LONG; + AVIERR : integer; + i : integer; + startpos : DWORD; + len : DWORD; +begin + + // Open AVI file for write + if (AVIFileOpen(pFile, pchar(TempFileName), + OF_WRITE or OF_CREATE OR OF_SHARE_EXCLUSIVE, nil) + <> AVIERR_OK) + then + raise Exception.Create('Failed to create AVI video work file'); + + // Allocate the bitmap to which the bitmaps on the Bitmaps Tlist + // will be copied. + Bitmap := TBitmap.create; + Bitmap.Height := self.Height; + Bitmap.Width := self.Width; + + // Write the stream header. + try + FillChar(StreamInfo, sizeof(StreamInfo), 0); + + // Set frame rate and scale + StreamInfo.dwRate := 1000; + StreamInfo.dwScale := fFrameTime; + StreamInfo.fccType := streamtypeVIDEO; + StreamInfo.fccHandler := 0; + StreamInfo.dwFlags := 0; + StreamInfo.dwSuggestedBufferSize := 0; + StreamInfo.rcFrame.Right := self.width; + StreamInfo.rcFrame.Bottom := self.height; + + // Open AVI data stream + if (AVIFileCreateStream(pFile, pStream, StreamInfo) <> AVIERR_OK) then + raise Exception.Create('Failed to create AVI video stream'); + + try + // Write the bitmaps to the stream. + for i := 0 to Bitmaps.count - 1 do begin + try + BitmapInfo := nil; + BitmapBits := nil; + + // Copy the bitmap from the list to the AVI bitmap, + // stretching if desired. If the caller elects not to + // stretch, use the first pixel in the bitmap as a + // background color in case either the height or + // width of the source is smaller than the output. + // If Draw fails, do a StretchDraw. + ExtBitmap := Bitmaps[i]; + if fStretch + then Bitmap.Canvas.StretchDraw + (Rect(0,0,self.width,self.height),ExtBitmap) + else try + with Bitmap.Canvas do begin + Brush.Color := ExtBitmap.Canvas.Pixels[0,0]; + Brush.Style := bsSolid; + FillRect(Rect(0,0,Bitmap.Width,Bitmap.Height)); + Draw(0,0,ExtBitmap); + end; + except + Bitmap.Canvas.StretchDraw + (Rect(0,0,self.width,self.height),ExtBitmap); + end; + + // Determine size of DIB + InternalGetDIBSizes(Bitmap.Handle, BitmapInfoSize, BitmapSize, pf8bit); + if (BitmapInfoSize = 0) then + raise Exception.Create('Failed to retrieve bitmap info'); + + // Get DIB header and pixel buffers + GetMem(BitmapInfo, BitmapInfoSize); + GetMem(BitmapBits, BitmapSize); + InternalGetDIB + (Bitmap.Handle, 0, BitmapInfo^, BitmapBits^, pf8bit); + + // On the first time through, set the stream format. + if i = 0 then + if (AVIStreamSetFormat(pStream, 0, BitmapInfo, BitmapInfoSize) <> AVIERR_OK) then + raise Exception.Create('Failed to set AVI stream format'); + + // Write frame to the video stream + AVIERR := + AVIStreamWrite(pStream, i, 1, BitmapBits, BitmapSize, AVIIF_KEYFRAME, + Samples_Written, Bytes_Written); + if AVIERR <> AVIERR_OK then + raise Exception.Create + ('Failed to add frame to AVI. Err=' + + inttohex(AVIERR,8)); + finally + if (BitmapInfo <> nil) then + FreeMem(BitmapInfo); + if (BitmapBits <> nil) then + FreeMem(BitmapBits); + end; + end; + + // Create the editable VideoStream from pStream. + if CreateEditableStream(VideoStream,pStream) <> AVIERR_OK then + raise Exception.Create + ('Could not create Video Stream'); + finally + AviStreamRelease(pStream); + end; + + finally + Bitmap.free; + end; +end; + +procedure TAviWriter.AddAudio; +var + InputFile : PAVIFILE; + hr : integer; + InputStream : PAVIStream; + avisClip : TAVISTREAMINFO; + l, selstart : DWORD; + pastecode : integer; +begin + // Open the audio file. + hr := AVIFileOpen(InputFile, pchar(WavFileName),OF_READ, nil); + case hr of + 0: ; + AVIERR_BADFORMAT : raise Exception.Create('The file could not be read, indicating a corrupt file or an unrecognized format.'); + AVIERR_MEMORY : raise Exception.Create('The file could not be opened because of insufficient memory.'); + AVIERR_FILEREAD : raise Exception.Create('A disk error occurred while reading the audio file.'); + AVIERR_FILEOPEN : raise Exception.Create('A disk error occurred while opening the audio file.'); + REGDB_E_CLASSNOTREG : raise Exception.Create('According to the registry, the type of audio file specified in AVIFileOpen does not have a handler to process it.'); + else raise Exception.Create('Unknown error opening audio file'); + end; + + // Open the audio stream. + try + if (AVIFileGetStream(InputFile, InputStream, 0, 0) <> AVIERR_OK) then + raise Exception.Create('Unable to get audio stream'); + + try + // Create AudioStream as a copy of InputStream + if (CreateEditableStream(AudioStream,InputStream) <> AVIERR_OK) then + raise Exception.Create('Failed to create editable AVI audio stream'); + finally + AviStreamRelease(InputStream); + end; + + finally + AviFileRelease(InputFile); + end; +end; + +// -------------- +// InternalGetDIB +// -------------- +// Converts a bitmap to a DIB of a specified PixelFormat. +// +// Parameters: +// Bitmap The handle of the source bitmap. +// Pal The handle of the source palette. +// BitmapInfo The buffer that will receive the DIB's TBitmapInfo structure. +// A buffer of sufficient size must have been allocated prior to +// calling this function. +// Bits The buffer that will receive the DIB's pixel data. +// A buffer of sufficient size must have been allocated prior to +// calling this function. +// PixelFormat The pixel format of the destination DIB. +// +// Returns: +// True on success, False on failure. +// +// Note: The InternalGetDIBSizes function can be used to calculate the +// nescessary sizes of the BitmapInfo and Bits buffers. +// +function TAviWriter.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; + 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 TAviWriter.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 TAviWriter.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 TAviWriter.SetWavFileName(value : string); +begin + if lowercase(fWavFileName) <> lowercase(value) + then if lowercase(ExtractFileExt(value)) <> '.wav' + then raise Exception.Create('WavFileName must name a file ' + + 'with the .wav extension') + else fWavFileName := value; +end; + + +procedure Register; +begin + RegisterComponents('Labrz', [TAviWriter]); +end; + + procedure AVIFileInit; stdcall; external 'avifil32.dll' name 'AVIFileInit'; + procedure AVIFileExit; stdcall; external 'avifil32.dll' name 'AVIFileExit'; + function AVIFileOpen; external 'avifil32.dll' name 'AVIFileOpenA'; + function AVIFileCreateStream; external 'avifil32.dll' name 'AVIFileCreateStreamA'; + function AVIStreamSetFormat; external 'avifil32.dll' name 'AVIStreamSetFormat'; + function AVIStreamReadFormat; external 'avifil32.dll' name 'AVIStreamReadFormat'; + function AVIStreamWrite; external 'avifil32.dll' name 'AVIStreamWrite'; + function AVIStreamRelease; external 'avifil32.dll' name 'AVIStreamRelease'; + function AVIFileRelease; external 'avifil32.dll' name 'AVIFileRelease'; + function AVIFileGetStream; external 'avifil32.dll' name 'AVIFileGetStream'; + function CreateEditableStream; external 'avifil32.dll' name 'CreateEditableStream'; + function AVISaveV; external 'avifil32.dll' name 'AVISaveV'; + +procedure TAviWriter.Prepare; +begin + if Prepared then begin + main.Post('Finishing previous file..'); + Finish; + end; + + AudioStream := nil; + VideoStream := nil; + + if (AVIFileOpen(pFile, pchar(TempFileName), + OF_WRITE or OF_CREATE or OF_SHARE_EXCLUSIVE, nil) <> AVIERR_OK) then + raise Exception.Create('Failed to create AVI video work file'); + + FillChar(StreamInfo, sizeof(StreamInfo), 0); + + // Set frame rate and scale + StreamInfo.dwRate := fps*1000; + StreamInfo.dwScale := fFrameTime; + StreamInfo.fccType := streamtypeVIDEO; + StreamInfo.fccHandler := 0; + StreamInfo.dwFlags := 0; + StreamInfo.dwSuggestedBufferSize := 0; + StreamInfo.rcFrame.Right := self.width; + StreamInfo.rcFrame.Bottom := self.height; + + // Open AVI data stream + if (AVIFileCreateStream(pFile, pStream, StreamInfo) <> AVIERR_OK) then + raise Exception.Create('Failed to create AVI video stream'); + + FramePos := 0; + Prepared := True; +end; + +procedure TAviWriter.AddFrame(const DIB: TDIB); +var + Samples_Written : LONG; + Bytes_Written : LONG; + AVIERR : integer; +begin + if not Prepared then begin + main.Post('fs.avi: internal error, not prepared to add frame.'); + Exit; + end; + + // On the first time through, set the stream format. + if FramePos = 0 then begin + if (AVIStreamSetFormat(pStream, 0, DIB.BitmapInfo, DIB.BitmapInfoSize) <> AVIERR_OK) then + raise Exception.Create('Failed to set AVI stream format'); + end; + + // Write frame to the video stream + AVIERR := AVIStreamWrite(pStream, FramePos, 1, DIB.PBits, DIB.Size, AVIIF_KEYFRAME, + Samples_Written, Bytes_Written); + + Inc(FramePos); + + if AVIERR <> AVIERR_OK then + raise Exception.Create('Failed to add frame to AVI. Err='+ + inttohex(AVIERR,8)); +end; + +function avisavecallback(nPercent: UINT): ULONG; stdcall; +begin +// Write('fs.avi: '+IntToStr(nPercent)+'%'+#13); + Progress.pb1.Position := nPercent; + Result := AVIERR_OK; +end; + +procedure TAviWriter.Finish; +var + nstreams: Integer; + Streams : APAVISTREAM; + AVIERR : integer; + refcount : integer; +begin + if not Prepared then begin + main.Post('fs.avi: nothing to write.'); + Exit; + end; + + if CreateEditableStream(VideoStream,pStream) <> AVIERR_OK then + raise Exception.Create('Could not create Video Stream'); + + AviStreamRelease(pStream); + + nstreams := 1; + + Streams[0] := VideoStream; + Streams[1] := nil;//AudioStream; + + if AVISaveOptions(0, ICMF_CHOOSE_PREVIEW, nStreams, Streams, @CompOptions) then begin + + Progress.Show; + + AVIERR := AVISaveV(pchar(FileName), + nil, // File handler + @avisavecallback, // Callback + nStreams, // Number of streams
Streams,
CompOptions); // Compress options for VideoStream
Progress.Hide;
// I get some strange error but the file is always ok so... screw it
{
if AVIERR <> AVIERR_OK then
raise Exception.Create('Error on write - check output file.');
}
if assigned(VideoStream)
then AviStreamRelease(VideoStream);
if assigned(AudioStream) + then AviStreamRelease(AudioStream);
try
repeat + refcount := AviFileRelease(pFile); + until refcount <= 0; + except + end; + + DeleteFile(TempFileName); + + Prepared := False; + end; +end; + +end. + |