From fe070b42d2ddea9ec14bb186b6cc0b6d11b490c3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Juha=20Vehvil=C3=A4inen?= Date: Tue, 3 Jun 2003 20:46:51 +0000 Subject: *** empty log message *** svn path=/trunk/Framestein/; revision=675 --- Source/FsAviWriter.pas | 1776 ++++++++++++++++++++++++------------------------ 1 file changed, 888 insertions(+), 888 deletions(-) (limited to 'Source/FsAviWriter.pas') 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. + -- cgit v1.2.1