////////////////////////////////////////////////////////////////////// // // // sysAviWriter.pas: AVI output unit // // // // Author(s): // // Elliott Shevin, shevine@aol.com, wrote a component called // // AviWriter, which was itself based on code from Anders // // Melander. This unit is a de-componentized version of // // AviWriter which supports writing frames intermittently (i.e. // // keeping the AVI stream open over a period of time, rather than // // converting a bunch of stills into an AVI all at once), // // modified by Michael Noland (joat), michael@bottledlight.com // // // // Notes: // // Currently does not support audio capture in the AVI in any // // meaningful way. // // Needs replacing with a version that supports video // // compression and audio encoding. // // // ////////////////////////////////////////////////////////////////////// ////////////////////////////////////////////////////////////////////// unit sysAviWriter; /////////////////////////////////////////////////// ////////////////////////////////////////////////////////////////////// ////////////////////////////////////////////////////////////////////// interface //////////////////////////////////////////////////////////// ////////////////////////////////////////////////////////////////////// uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, Math, StdCtrls, ActiveX, comctrls, nexus, AddressSpace; ////////////////////////////////////////////////////////////////////// var captureFilename: string; captureRate: integer; captureIndex, captureTarget: single; captureToggleKey: integer; capturing: boolean; ////////////////////////////////////////////////////////////////////// procedure aviStartCapture(filename: string); procedure aviAddFrame(bitmap: TBitmap); procedure aviCompleteFile; //////////////////////////////////////////////////////////////////////////////// // // // 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: uint32; dwFlags: uint32; dwCaps: uint32; dwStreams: uint32; dwSuggestedBufferSize: uint32; dwWidth: uint32; dwHeight: uint32; dwScale: uint32; dwRate: uint32; // dwRate / dwScale == samples/second dwLength: uint32; dwEditCount: uint32; szFileType: array[0..63] of WideChar; end; PAVIFileInfoW = ^TAVIFileInfoW; ////////////////////////////////////////////////////////////////////// // TAVIStreamInfo dwFlag values const AVISF_DISABLED = $00000001; AVISF_VIDEO_PALCHANGES= $00010000; AVISF_KNOWN_FLAGS = $00010001; ////////////////////////////////////////////////////////////////////// type TAVIStreamInfoA = record fccType: uint32; fccHandler: uint32; dwFlags: uint32; // Contains AVITF_* flags dwCaps: uint32; wPriority: uint16; wLanguage: uint16; dwScale: uint32; dwRate: uint32; // dwRate / dwScale == samples/second dwStart: uint32; dwLength: uint32; // In units above... dwInitialFrames: uint32; dwSuggestedBufferSize: uint32; dwQuality: uint32; dwSampleSize: uint32; rcFrame: TRect; dwEditCount: uint32; dwFormatChangeCount: uint32; szName: array[0..63] of AnsiChar; end; TAVIStreamInfo = TAVIStreamInfoA; PAVIStreamInfo = ^TAVIStreamInfo; { TAVIStreamInfoW record } TAVIStreamInfoW = record fccType: uint32; fccHandler: uint32; dwFlags: uint32; // Contains AVITF_* flags dwCaps: uint32; wPriority: uint16; wLanguage: uint16; dwScale: uint32; dwRate: uint32; // dwRate / dwScale == samples/second dwStart: uint32; dwLength: uint32; // In units above... dwInitialFrames: uint32; dwSuggestedBufferSize: uint32; dwQuality: uint32; dwSampleSize: uint32; rcFrame: TRect; dwEditCount: uint32; dwFormatChangeCount: uint32; 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: uint32; fccHandler: uint32; dwKeyFrameEvery: uint32; dwQuality: uint32; dwBytesPerSecond: uint32; dwFlags: uint32; lpFormat: pointer; cbFormat: uint32; lpParms: pointer; cbParms: uint32; dwInterleaveEvery: uint32; end; PAVICompressOptions = ^TAVICompressOptions; // Palette change data record const RIFF_PaletteChange: DWORD = 1668293411; type TAVIPalChange = packed record bFirstEntry: byte; bNumEntries: byte; wFlags: uint16; peNew: array[0..255] 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; ////////////////////////////////////////////////////////////////////// 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' ) streamTypeMPEG = $4745504D; // DWORD( 'M', 'P', 'E', 'G' ) ////////////////////////////////////////////////////////////////////// ////////////////////////////////////////////////////////////////////// implementation /////////////////////////////////////////////////////// ////////////////////////////////////////////////////////////////////// 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'; ////////////////////////////////////////////////////////////////////// var TempFileName: string; FFileName: string; // FWavFileName: string; VideoStream: PAVISTREAM; AudioStream: PAVISTREAM; numFrames: integer; BitmapBits: pointer; PFile: PAVIFile; PStream: PAVIStream; BitmapInfo: PBitmapInfoHeader; BitmapInfoSize: integer; BitmapSize: integer; MBitmap: TBitmap; ////////////////////////////////////////////////////////////////////// // 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. procedure InitializeBitmapInfoHeader(Bitmap: HBITMAP; var Info: TBitmapInfoHeader; PixelFormat: TPixelFormat); var DIB: TDIBSection; size: 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; size := GetObject(Bitmap, SizeOf(DIB), @DIB); if (size >= (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; pf15bit: Info.biBitCount := 15; pf16bit: Info.biBitCount := 16; pf24bit: Info.biBitCount := 24; pf32bit: Info.biBitCount := 32; end; Info.biPlanes := 1; Info.biCompression := BI_RGB; Info.biSizeImage := AlignBit(Info.biWidth, Info.biBitCount, 32) * Cardinal(Abs(Info.biHeight)); 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. function InternalGetDIB(Bitmap: HBITMAP; Palette: HPALETTE; var BitmapInfo; var Bits; PixelFormat: TPixelFormat): boolean; 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 InternalGetDIBSizes(Bitmap: HBITMAP; var InfoHeaderSize: Integer; var ImageSize: longInt; PixelFormat: TPixelFormat); 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; ////////////////////////////////////////////////////////////////////// procedure aviStartCapture(filename: string); var StreamInfo: TAVIStreamInfo; tempdir: string; l: integer; begin MBitmap := TBitmap.Create; MBitmap.Width := 240; MBitmap.Height := 160; MBitmap.PixelFormat := pf15bit; MBitmap.Canvas.Font.Name := 'Fixedsys'; MBitmap.Canvas.Font.Color := clBlack; MBitmap.Canvas.Font.Size := 9; { MBitmap.Canvas.TextFlags := MBitmap.Canvas.TextFlags and not ETO_OPAQUE; MBitmap.Canvas.brush.Style := bsClear;} FFilename := filename; DeleteFile(filename); AVIFileInit; // Create a temporary file 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'; AudioStream := nil; VideoStream := nil; // Set the fields in the stream header FillChar(StreamInfo, sizeof(StreamInfo), 0); StreamInfo.dwScale := Max(1000 div Max(captureRate, 1), 1); StreamInfo.dwRate := 1000; StreamInfo.fccType := streamTypeVIDEO; StreamInfo.fccHandler := 0; StreamInfo.dwFlags := 0; StreamInfo.dwSuggestedBufferSize := 0; StreamInfo.rcFrame.Right := 240; StreamInfo.rcFrame.Bottom := 160; // Open AVI file for write AVIFileOpen(PFile, PChar(TempFileName), OF_WRITE or OF_CREATE OR OF_SHARE_EXCLUSIVE, nil); // Open AVI data stream AVIFileCreateStream(PFile, PStream, StreamInfo); numFrames := 0; end; ////////////////////////////////////////////////////////////////////// procedure aviCompleteFile; var nstreams: integer; Streams: APAVISTREAM; CompOptions: APAVICompressOptions; begin if numFrames > 0 then begin FreeMem(BitmapBits, BitmapSize); FreeMem(BitmapInfo, BitmapInfoSize); end; MBitmap.Free; // Create the editable VideoStream CreateEditableStream(VideoStream, PStream); AviStreamRelease(PStream); // Create the output file //if FWavFileName <> '' then nstreams := 2 else nstreams := 1; Streams[0] := VideoStream; Streams[1] := AudioStream; CompOptions[0] := nil; CompOptions[1] := nil; AVISaveV(PChar(FFileName), nil, nil, nStreams, Streams, CompOptions); if Assigned(VideoStream) then AviStreamRelease(VideoStream); if Assigned(AudioStream) then AviStreamRelease(AudioStream); while AviFileRelease(pFile) > 0 do ; DeleteFile(TempFileName); AviFileExit; end; ////////////////////////////////////////////////////////////////////// procedure aviAddFrame(bitmap: TBitmap); var Samples_Written: LONG; Bytes_Written: LONG; color: uint16; x, y: integer; src, dest: Puint16; begin for y := 0 to 159 do begin src := bitmap.ScanLine[y]; dest := MBitmap.ScanLine[y]; for x := 0 to 239 do begin color := src^; dest^ := (color shr 10) and 31 + (color and 31) shl 10 + color and (31 shl 5); // dest^ := src^; Inc(dest); Inc(src); end; end; // MBitmap.Canvas.Draw(0, 0, Bitmap); MBitmap.Canvas.TextOut(238-MBitmap.Canvas.TextWidth('Mappy VM'), 158-MBitmap.Canvas.TextHeight('Mappy VM'), 'Mappy VM'); if numFrames = 0 then begin BitmapInfo := nil; BitmapBits := nil; // Determine size of DIB InternalGetDIBSizes(MBitmap.Handle, BitmapInfoSize, BitmapSize, pf16bit); // Get DIB header and pixel buffers GetMem(BitmapInfo, BitmapInfoSize); GetMem(BitmapBits, BitmapSize); end; // Acquire the image data InternalGetDIB(MBitmap.Handle, 0, BitmapInfo^, BitmapBits^, pf16bit); // On the first time through, set the stream format if numFrames = 0 then AVIStreamSetFormat(PStream, 0, BitmapInfo, BitmapInfoSize); // Write the frame to the video stream AVIStreamWrite(PStream, numFrames, 1, BitmapBits, BitmapSize, AVIIF_KEYFRAME, Samples_Written, Bytes_Written); Inc(numFrames); end; ////////////////////////////////////////////////////////////////////// { procedure AddAudio; var InputFile: PAVIFILE; hr: longword; InputStream: PAVIStream; avisClip: TAVISTREAMINFO; l, selstart: DWORD; pastecode: integer; begin // Open the audio file hr := AVIFileOpen(InputFile, PChar(FWavFileName), 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;} ////////////////////////////////////////////////////////////////////// end. //////////////////////////////////////////////////////////////////////