diff options
Diffstat (limited to 'Source/FsAviWriter.pas')
-rw-r--r-- | Source/FsAviWriter.pas | 1776 |
1 files changed, 888 insertions, 888 deletions
diff --git a/Source/FsAviWriter.pas b/Source/FsAviWriter.pas index 6373846..ec7e3bf 100644 --- a/Source/FsAviWriter.pas +++ b/Source/FsAviWriter.pas @@ -1,888 +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. - +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.
+
|