scrcam.pas

根据CamStudio1.0翻译过来的delphi开发包

// Screen Cam Component (recording screen activity to video)
// for Delphi 7
// Developed 2003 by Christian & Alexander Grau ([e-mail])
// see README.TXT for license details

unit scrcam;

interface

uses  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, vfw, mmsystem, flashwnd;

type
  TScreenCamEvent = procedure (Sender: TObject) of object;

  TRecordAVIThread = class;

  TICINFOS = array[0..31] of TICINFO;

  TScreenCam = class(TObject)
  private
    FOwner: TComponent;
    bits: integer;
    nColors: integer;
    compfccHandler: DWORD;
    strCodec: string;
    recordstate: boolean;
    maxxScreen, maxyScreen: integer;
    initialtime: DWORD;
    FActualmspF : real;
    FSkippedFrames : integer;
    FComputedFrameNo, FActualFrameNo : integer;
    actualwidth, actualheight: integer;
    FOnUpdate, FOnStart, FOnStop, FOnError: TScreenCamEvent;
    FrecordAVIThread: TRecordAVIThread;
    FPlaybackFPS : integer; // MSPF=MillisecondsPerFrame
    FmspFRecord  : integer;
    FKeyFramesEvery: integer;
    FselectedCompressor: integer;
    FCompressionQuality: integer;
    FCompressorCount: integer;
    FcompressorInfo: TICINFOS;
    Frecordcursor: boolean;
    FFrame: TFlashingWnd;
    FFlashingRect: boolean;
    FCursor: hcursor;
    Fautopan: boolean;
    function captureScreenFrame(left, top, width, height: integer): PBITMAPINFOHEADER;
    procedure ThreadDone(Sender: TObject);
    function recordVideo(aForm: tcustomForm; szFilename: string): integer;
    procedure DrawFlashingRect(bDraw: boolean);
  public
    constructor create(owner: TComponent); virtual;
    destructor destroy; override;
    function startRecording(Form: tcustomForm; szFilename: string): boolean;
    procedure stopRecording;
    procedure getCompressorsInfo;
    procedure compressorAbout(compressor: byte; wnd: hwnd);
    procedure compressorHasFeatures(compressor: byte; var hasAbout: boolean; var hasConfig: boolean);
    procedure compressorConfigure(compressor: byte; wnd: hwnd);
    procedure AutoSetRate(val: integer; var framerate: integer; var delayms: integer);
    // report values (read-only)
    property ComputedFrameNo : integer read FComputedFrameNo;
    property AcutalFrameNo : integer read FActualFrameNo;
    property ActualmspF: real read FActualmspF;      // actual FPS rate = should be Playback-fps rate on fast machines!
    property SkippedFrames : integer read FSkippedFrames;
    property colors: integer read nColors;
    property codec: string read strCodec;
    property width: integer read actualWidth;
    property height: integer read actualHeight;
    property compressorCount: integer read FCompressorCount;
    property compressorInfo: TICINFOS read FCompressorInfo;
  protected
  published
    // options
    property FPSPlayback: integer read FPlaybackFPS write FPlaybackFPS;  // = FPS Playback rate
    property msPFRecord: integer read FmsPFRecord write FmsPFRecord;  // = FPS Record rate
    property KeyFramesEvery: integer read FKeyFramesEvery write FKeyFramesEvery;     // key frame rate
    property compressionQuality: integer read FCompressionQuality write FCompressionQuality; // 1 - 10000
    property SelectedCompressor: integer read FSelectedCompressor write FSelectedCompressor;
    property recordCursor: boolean read FRecordCursor write FRecordCursor;
    property flashingRect: boolean read FFlashingRect write FFlashingRect;
    property autoPan: boolean read FAutopan write FAutopan;
    // events
    property OnError: TScreenCamEvent read FOnError write FOnError;
    property OnUpdate: TScreenCamEvent read FOnUpdate write FOnUpdate;
    property OnStart: TScreenCamEvent read FOnStart write FOnStart;
    property OnStop: TScreenCamEvent read FOnStop write FOnStop;
  end;


  TRecordAVIThread = class(TThread)
  private
    FScrCam: TScreenCam;
    FFps: integer;
    FszFilename: string;
    FForm: TCustomForm;
  protected
    procedure Execute; override;
  public
    FlashCol: COLORREF;
    FlashLeft,
    FlashTop,
    FlashWidth,
    FlashHeight: integer;
    constructor Create(scrcam: TScreenCam; Form: tcustomForm; fps: integer; szFilename: string);
    procedure FlashPaintBorder;
    procedure FlashsetupRegion;
  end;



implementation

const
  hWndGlobal = 0;


procedure TScreenCam.DrawFlashingRect(bDraw: boolean);
begin
  (*if (bDraw) then
    FFrame.PaintBorder(RGB(255,255,180))
  else
  	FFrame.PaintBorder(RGB(0,255,80));
  *)
  if (bDraw) then
    FrecordAVIThread.flashcol:=RGB(255,255,180)
  else
  	FrecordAVIThread.flashcol:=RGB(0,255,80);
  FrecordAVIThread.synchronize(FrecordAVIThread.FlashPaintBorder);
end;


constructor TScreenCam.create(owner: TComponent);
var
  hScreenDC: HDC;
begin
  FOwner:=owner;
  recordstate:=FALSE;
  FcompressorCount:=0;
  FSelectedCompressor:=-1;

	hScreenDC := GetDC(0);
	bits := GetDeviceCaps(hScreenDC, BITSPIXEL );
	nColors := bits;
	maxxScreen := GetDeviceCaps(hScreenDC,HORZRES);
	maxyScreen := GetDeviceCaps(hScreenDC,VERTRES);
	ReleaseDC(0, hScreenDC);

	compfccHandler := mmioFOURCC('M', 'S', 'V', 'C');

  FmsPFRecord:=100;
  FPlaybackFPS:=10;
  FKeyFramesEvery:=5; // every 5 frames keyframe
  FcompressionQuality:=6550;
  FSelectedCompressor:=-1;
  FRecordCursor:=TRUE;
  FFrame:=TFlashingWnd.create(owner);
  FFlashingRect:=TRUE;
  FCursor:=LoadCursor(0, IDC_ARROW);
  FAutopan:=FALSE;
  FRecordAVIThread:=NIL;
end;

destructor TScreenCam.destroy;
begin
  FFrame.free;
end;


procedure TScreenCam.compressorAbout(compressor: byte; wnd: hwnd);
var
  ic: hic;
begin
  if compressor >= FCompressorCount then exit;
	ic := ICOpen(FCompressorInfo[compressor].fccType, FCompressorInfo[compressor].fccHandler, ICMODE_QUERY);
	if (ic <> 0) then
  begin
  	ICAbout(ic, wnd);
    ICClose(ic);
  end;
end;

procedure TScreenCam.compressorConfigure(compressor: byte; wnd: hwnd);
var
  ic: hic;
begin
  if compressor >= FCompressorCount then exit;
	ic := ICOpen(FCompressorInfo[compressor].fccType, FCompressorInfo[compressor].fccHandler, ICMODE_QUERY);
	if (ic <> 0) then
  begin
  	ICConfigure(ic, wnd);
    ICClose(ic);
  end;
end;


procedure TScreenCam.compressorHasFeatures(compressor: byte; var hasAbout: boolean; var hasConfig: boolean);
var
  ic: hic;
begin
  hasAbout:=FALSE;
  hasConfig:=FALSE;
  if compressor >= FCompressorCount then exit;
	ic := ICOpen(FCompressorInfo[compressor].fccType, FCompressorInfo[compressor].fccHandler, ICMODE_QUERY);
	if (ic <> 0)  then
  begin
  	hasAbout:=ICQueryAbout(ic);
  	hasConfig:=ICQueryConfigure(ic);    
    ICClose(ic);
  end;
end;


function Bitmap2Ddb( hbitmap: HBITMAP; bits: longword ): THANDLE;
var
	hdib: THANDLE;
  ahdc: HDC;
	bitmap: windows.TBITMAP;
	wLineLen: longword;
	dwSize: DWORD;
	wColSize: DWORD;
	lpbi: PBITMAPINFOHEADER;
	lpBits: PBYTE;
begin
	GetObject(hbitmap,sizeof(BITMAP),@bitmap) ;

	// DWORD align the width of the DIB
	// Figure out the size of the colour table
	// Calculate the size of the DIB
	//
	wLineLen := (bitmap.bmWidth*bits+31)div 32 * 4;
  if (bits <= 8) then wColSize:=sizeof(RGBQUAD)* (1 SHL bits)
    else wColSize:=0;
	dwSize := sizeof(BITMAPINFOHEADER) + wColSize +
		wLineLen*bitmap.bmHeight;

	//
	// Allocate room for a DIB and set the LPBI fields
	//
	hdib := GlobalAlloc(GHND,dwSize); //allocate bitmap handle
	if (hdib=0) then
  begin
		result:=hdib;
    exit;
  end;

	lpbi := GlobalLock(hdib) ;  // lock bitmap handle and get back pointer

	lpbi^.biSize := sizeof(BITMAPINFOHEADER) ;
	lpbi^.biWidth := bitmap.bmWidth ;
	lpbi^.biHeight := bitmap.bmHeight ;
	lpbi^.biPlanes := 1 ;
	lpbi^.biBitCount := bits ;
	lpbi^.biCompression := BI_RGB ;
	lpbi^.biSizeImage := dwSize - sizeof(BITMAPINFOHEADER) - wColSize ;
	lpbi^.biXPelsPerMeter := 0 ;
	lpbi^.biYPelsPerMeter := 0 ;
  if bits <= 8 then lpbi^.biClrUsed := 1 SHL bits
    else lpbi^.biClrUsed:=0;
	lpbi^.biClrImportant := 0 ;

	//
	// Get the bits from the bitmap and stuff them after the LPBI
	//
	lpBits := pointer(longword(lpbi)+lpbi^.biSize+wColSize) ;

	ahdc := CreateCompatibleDC(0) ;

  // retrieve the bits of hbitmap and copy them into the buffer lpBits using the specified format in lpbi
  if GetDIBits(ahdc,hbitmap,0,bitmap.bmHeight,lpBits,PBITMAPINFO(lpbi)^, DIB_RGB_COLORS) = 0 then
  begin
    messagebox(0, 'Error retrieving bitmap bits', 'Error', mb_ok);
  end;

  if bits <= 8 then	lpbi^.biClrUsed := (1 SHL bits)
    else lpbi^.biClrUsed:=0;

	DeleteDC(ahdc) ;
	GlobalUnlock(hdib);

	result:=hdib ;
end;


function TScreenCam.captureScreenFrame(left, top, width, height: integer): PBITMAPINFOHEADER;
var
	hScreenDC: HDC;
  hMemDC: HDC;
  hbm: HBITMAP;
  oldbm: HBITMAP;
  pBM_HEADER: PBITMAPINFOHEADER;
  xpoint, highlightPoint: TPOINT;
  hcur: HCURSOR;
  aniconinfo: ICONINFO;
	ret: BOOL;
begin
  hScreenDC:=GetDC(0);

	//if flashing rect
	if (FflashingRect) AND (FRecordAVIThread <> NIL) then
  begin
    if Fautopan then
    begin
      //FFrame.SetUpRegion(left,top,width,height);
      FRecordAVIThread.flashLeft:=left;
      FRecordAVIThread.flashTop:=top;
      FRecordAVIThread.flashWidth:=width;
      FRecordAVIThread.flashHeight:=height;
      FrecordAVIThread.synchronize(FrecordAVIThread.FlashSetupRegion);
    end;
  	DrawFlashingRect( TRUE );
  end;

  hMemDC:=CreateCompatibleDC(hScreenDC);

  hbm := CreateCompatibleBitmap(hScreenDC, width, height);
 	oldbm := SelectObject(hMemDC, hbm);
	BitBlt(hMemDC, 0, 0, width, height, hScreenDC, left, top, SRCCOPY); // bit block transfer from  hScreenDC to hMemdc

	//Get Cursor Pos
	GetCursorPos( xPoint );
  hcur:= windows.getCursor;
	dec(xPoint.x, left);
	dec(xPoint.y, top);

	//Draw the Cursor
	if (FrecordCursor) then
  begin
		ret	:= GetIconInfo( hcur,  aniconinfo );
		if (ret) then
    begin
			dec(xPoint.x, aniconinfo.xHotspot);
			dec(xPoint.y, aniconinfo.yHotspot);

			//need to delete the hbmMask and hbmColor bitmaps
			//otherwise the program will crash after a while after running out of resource
			if (aniconinfo.hbmMask <> 0) then DeleteObject(aniconinfo.hbmMask);
			if (aniconinfo.hbmColor <> 0) then DeleteObject(aniconinfo.hbmColor);
    end;
		DrawIcon( hMemDC,  xPoint.x,  xPoint.y, fcursor); // hcur
	end;

	SelectObject(hMemDC,oldbm);
	pBM_HEADER := GlobalLock(Bitmap2Ddb(hbm, bits));	// lock bitmap handle and get pointer
	//LPBITMAPINFOHEADER pBM_HEADER = (LPBITMAPINFOHEADER)GlobalLock(Bitmap2Dib(hbm, 24));
	if (pBM_HEADER = NIL) then
  begin
		MessageBox(0,'Error capturing a frame!','Error',MB_OK OR MB_ICONEXCLAMATION);
		result:=NIL; exit;
	end;

	DeleteObject(hbm);
	DeleteDC(hMemDC);

	//if flashing rect
	if (FflashingRect) AND (FRecordAVIThread <> NIL) then
  	DrawFlashingRect( FALSE );

	ReleaseDC(0, hScreenDC) ;

  result:=pBM_HEADER;
end;

procedure FreeFrame(var alpbi: PBITMAPINFOHEADER);
begin
	if (alpbi=NIL) then exit;

	GlobalFreePtr(alpbi);
	//GlobalFree(alpbi);
	alpbi := 0;
end;


procedure TScreenCam.getCompressorsInfo;
var
  ic: hic;
 	first_alpbi: PBITMAPINFOHEADER;
  i: integer;
begin
  first_alpbi:=captureScreenFrame(0,0,320,200);
  FcompressorCount:=0;
  for i:=0 to 31 do
  begin
   	ICInfo(ICTYPE_VIDEO, i, @FCompressorInfo[FCompressorCount]);
 		ic := ICOpen(FCompressorInfo[FCompressorCount].fccType, FCompressorInfo[FCompressorCount].fccHandler, ICMODE_QUERY);
		if (ic <> 0) then
    begin
			if (ICERR_OK=ICCompressQuery(ic, first_alpbi, NIL)) then
      begin
				ICGetInfo(ic, @FCompressorInfo[FCompressorCount], sizeof(TICINFO));
    		inc(FCompressorCount);
      end;
			ICClose(ic);
    end;
  end;
	FreeFrame(first_alpbi);
end;


function TScreenCam.recordVideo(aForm: tcustomForm; szFilename: string): integer;
var
	alpbi: PBitmapInfoHeader;
	strhdr: TAVIStreamInfo;