unit 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,unit1, {$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; psi =^PAVICompressOptions; // 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; 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(si0 :Hwnd;UiFlag :integer;nstreams :integer; ppavi :pointer;var ppoptions :psi ) :Boolean; stdcall; //b "avifil32.dll" (ByVal hWnd As Long, _ // ByVal uiFlags As Long, _ // ByVal nStreams As Long, _ // ByRef ppavi As Long, _ // ByRef ppOptions As Long) As Long 'TRUE if user pressed OK, False if cancel, or error if error //'This is actually the AVISaveV function aliased to be called as AVISave from VB because //'AVISave seems to be compiled using CDECL calling convention ;-( 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 TProcessNotify=Procedure(sender:TObject;Prent:Byte) of object; TAviWriter = class(TComponent) private pFile : PAVIFile; fHeight : integer; fWidth : integer; fStretch : boolean; fFrameTime : integer; fFileName : string; VideoStream : PAVISTREAM; FPstream : PAVISTREAM; Fpsi0 : psi; FBitmap :TBitmap; FOnProcess:TProcessNotify; procedure process(sender:TObject;Prent:Byte); function getRect(B:TBitmap):TRect; procedure AddVideo; 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); { Private declarations } protected { Protected declarations } public Bitmaps : TList; constructor Create(AOwner : TComponent); override; destructor Destroy; override; procedure Write; procedure EndSave; procedure WriteHeader(B:TBitmap); procedure WriteBitmap(B:TBitmap;Index:Integer); { 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 OnProcess:TProcessNotify read FOnProcess write FOnprocess; { Published declarations } end; procedure Register; implementation constructor TAviWriter.Create(AOwner : TComponent); begin inherited Create(AOwner); fHeight := screen.height div 10; fWidth := screen.width div 10; fFrameTime := 1000; fStretch := true; fFileName := ''; Bitmaps := TList.create; AVIFileInit; FBitmap :=TBitmap.Create; end; destructor TAviWriter.Destroy; begin Bitmaps.free; AviFileExit; FBitmap.Free; inherited; end; procedure TAviWriter.Write; var ExtBitmap : TBitmap; i : integer; begin 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; finally AVIFileRelease(pFile); 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; begin // Open AVI file for write if (AVIFileOpen(pFile, pchar(FileName),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); InternalGetDIBSizes(Bitmap.Handle,BitmapInfoSize, BitmapSize, pf24bit); // Set frame rate and scale StreamInfo.dwRate := 1000; StreamInfo.dwScale := fFrameTime; StreamInfo.fccType := streamtypeVIDEO; StreamInfo.fccHandler := 0; StreamInfo.dwFlags := 0; StreamInfo.dwSuggestedBufferSize := BitmapSize; 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'); process(self,0); try // Write the bitmaps to the stream. for i := 0 to Bitmaps.count - 1 do begin BitmapInfo := nil; BitmapBits := nil; try // 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, pf24bit); 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^, pf24bit); // 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; process(self,I*100 div (Bitmaps.Count-1)); end; finally AviStreamRelease(pStream); end; process(self,100); finally Bitmap.free; 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 Register; begin RegisterComponents('Custom', [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'; Function AVISaveOptions; external 'avifil32.dll' name 'avisaveoptions'; procedure TAviWriter.process(sender: TObject; Prent: Byte); begin if Assigned(FOnProcess) then FOnProcess(self,Prent); end; procedure TAviWriter.EndSave; begin AviStreamRelease(FpStream); AVIFileRelease(pFile); end; procedure TAviWriter.WriteBitmap(B: TBitmap;Index:Integer); var BitmapInfo : PBitmapInfoHeader; BitmapInfoSize : Integer; BitmapSize : longInt; BitmapBits : pointer; Samples_Written : LONG; Bytes_Written : LONG; AVIERR : integer; begin BitmapInfo := nil; BitmapBits := nil; try if fStretch then begin FBitmap.Canvas.Brush.Color:=clBlack; FBitmap.Canvas.FillRect(FBitmap.Canvas.ClipRect); FBitmap.Canvas.StretchDraw(getRect(B),B); end else try with FBitmap.Canvas do begin Brush.Color := B.Canvas.Pixels[0,0]; Brush.Style := bsSolid; FillRect(Rect(0,0,FBitmap.Width,FBitmap.Height)); Draw(0,0,B); end; except FBitmap.Canvas.StretchDraw(Rect(0,0,self.width,self.height),B); end; InternalGetDIBSizes(FBitmap.Handle, BitmapInfoSize, BitmapSize, pf24bit); if (BitmapInfoSize = 0) then raise Exception.Create('Failed to retrieve bitmap info'); GetMem(BitmapInfo, BitmapInfoSize); GetMem(BitmapBits, BitmapSize); InternalGetDIB(FBitmap.Handle, 0, BitmapInfo^, BitmapBits^, pf24bit); AVIERR :=AVIStreamWrite(FpStream, Index, 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; procedure TAviWriter.WriteHeader(B: TBitmap); var //Pstream : PAVISTREAM; StreamInfo : TAVIStreamInfo; BitmapInfo : PBitmapInfoHeader; BitmapInfoSize : Integer; BitmapSize : longInt; BitmapBits : pointer; Samples_Written : LONG; Bytes_Written : LONG; AVIERR : integer; begin if (AVIFileOpen(pFile, pchar(FileName),OF_WRITE or OF_CREATE OR OF_SHARE_EXCLUSIVE, nil)<> AVIERR_OK) then raise Exception.Create('Failed to create AVI video work file'); FBitmap.Height := self.Height; FBitmap.Width := self.Width; try FillChar(StreamInfo, sizeof(StreamInfo), 0); InternalGetDIBSizes(FBitmap.Handle,BitmapInfoSize, BitmapSize, pf24bit); StreamInfo.dwRate := 1000; StreamInfo.dwScale := fFrameTime; StreamInfo.fccType := streamtypeVIDEO; StreamInfo.fccHandler := 0; StreamInfo.dwFlags := 0; StreamInfo.dwSuggestedBufferSize := BitmapSize; StreamInfo.rcFrame.Right := self.width; StreamInfo.rcFrame.Bottom := self.height; if (AVIFileCreateStream(pFile, FpStream, StreamInfo) <> AVIERR_OK) then raise Exception.Create('Failed to create AVI video stream'); process(self,0); BitmapInfo := nil; BitmapBits := nil; try if fStretch then begin FBitmap.Canvas.Brush.Color:=clBlack; FBitmap.Canvas.FillRect(FBitmap.Canvas.ClipRect); FBitmap.Canvas.StretchDraw(getRect(B),B); end else try with FBitmap.Canvas do begin Brush.Color := B.Canvas.Pixels[0,0]; Brush.Style := bsSolid; FillRect(Rect(0,0,FBitmap.Width,FBitmap.Height)); Draw(0,0,B); end; except FBitmap.Canvas.StretchDraw(Rect(0,0,self.width,self.height),B); end; InternalGetDIBSizes(FBitmap.Handle, BitmapInfoSize, BitmapSize, pf24bit); if (BitmapInfoSize = 0) then raise Exception.Create('Failed to retrieve bitmap info'); GetMem(BitmapInfo, BitmapInfoSize); GetMem(BitmapBits, BitmapSize); InternalGetDIB(FBitmap.Handle, 0, BitmapInfo^, BitmapBits^, pf24bit); if AVISaveOptions(form1.Handle,1 ,1,FpStream,fpsi0) Then Showmessage('success'); //成功 if (AVIStreamSetFormat(FpStream, 0, BitmapInfo, BitmapInfoSize) <> AVIERR_OK) then raise Exception.Create('Failed to set AVI stream format'); AVIERR :=AVIStreamWrite(FpStream, 0, 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; finally end; end; function TAviWriter.getRect(B: TBitmap): TRect; var w, h, cw, ch: Integer; xyaspect: Double; begin W:=B.Width; H:=B.Height; cw := Width; ch := Height; if (w > cw) or (h > ch) then begin if (w > 0) and (h > 0) then begin xyaspect := w / h; if w > h then begin w := cw; h := Trunc(cw / xyaspect); if h > ch then // woops, too big begin h := ch; w := Trunc(ch * xyaspect); end; end else begin h := ch; w := Trunc(ch * xyaspect); if w > cw then // woops, too big begin w := cw; h := Trunc(cw / xyaspect); end; end; end else begin w := cw; h := ch; end; end; Result:=Rect((cw - w) div 2, (ch - h) div 2,(cw - w) div 2+W,(ch - h) div 2+H); //OffsetRect(Result, (cw - w) div 2, (ch - h) div 2); end; end.