teevideo.pas

BCB第三方组件

end;

Destructor TVideoTool.Destroy;
begin
  if IsRecording then
     StopRecording;

  Clean;
  inherited;
end;

procedure TVideoTool.Clean;
var RefCount : Integer;
begin
  if Assigned(IPInInfo) then
  begin
    FreeMem(IPInInfo);
    IPInInfo:=nil;
  end;

  if Assigned(IFile) then
  try
    repeat
      RefCount:=AVIFileRelease(IFile);
    until RefCount<=0;
  except
    IFile:=nil;
  end;

  IFile:=nil;

  if FFourCC<>'' then
  if Assigned(ICompStream) then
  begin
    //AVICheck(AVIStreamRelease(ICompStream));
    ICompStream:=nil;
  end;

  if FFourCC='' then
  if Assigned(IPStream) then
  begin
    AVICheck(AVIStreamRelease(IPStream));
    IPStream:=Nil;
  end;

  AVIFileExit;
end;

const
  BitCounts: Array[pf1Bit..pf32Bit] of Byte =
              {$IFDEF CLX}
               (1, 8, 16, 32);
              {$ELSE}
               (1, 4, 8, 16, 16, 24, 32);
              {$ENDIF}

  ICTYPE_VIDEO = $63646976; {vidc}
  ICMODE_COMPRESS = 1;
  ICMODE_QUERY = 4;

  ICM_USER = (DRV_USER + $0000);
  ICM_RESERVED_LOW = (DRV_USER + $1000);
  ICM_RESERVED_HIGH = (DRV_USER + $2000);
  ICM_RESERVED = ICM_RESERVED_LOW;
  ICM_COMPRESS_QUERY = (ICM_USER + 6); // query support for compress
  ICM_CONFIGURE = (ICM_RESERVED + 10); // show the configure dialog
  ICMF_CONFIGURE_QUERY = $00000001;


function ICCompressQuery(hic: THandle; lpbiInput, lpbiOutput: PBitmapInfoHeader): DWord;
begin
  Result := ICSendMessage(hic, ICM_COMPRESS_QUERY, DWord(lpbiInput), DWord(lpbiOutput));
end;

function FourCCToString(const f: DWord): String;
var
  S, s1: string;
  b: byte;
  c: Char;
begin
  result:='    ';
  S := IntToHex(f, 8);
  s1 := '$' + copy(S, 7, 2);
  b := StrToInt(s1);
  c := chr(b);
  Result[1] := c;
  Result[2] := chr(StrToInt('$' + copy(S, 5, 2)));
  Result[3] := chr(StrToInt('$' + copy(S, 3, 2)));
  Result[4] := chr(StrToInt('$' + copy(S, 1, 2)));
end;

procedure TVideoTool.PrepareBitmapHeader(var Header:TBitmapInfoHeader);
begin
  ZeroMemory(@Header, SizeOf(Header));

  with Header do
  begin
    biSize := SizeOf(BitmapInfoHeader);

    if Assigned(ParentChart) then
    begin
      biWidth := ParentChart.Width;
      biHeight := ParentChart.Height;
    end;

    biPlanes := 1;
    biCompression := BI_RGB;
    biBitCount := BitCounts[VideoBitmapFormat];
    biSizeImage := 0;
    biXPelsPerMeter :=1;
    biYPelsPerMeter :=1;
    biClrUsed :=0;
    biClrImportant :=0;
  end;
end;

procedure TVideoTool.GetCompressors(const List:TStrings);
const
  AllValid = False;

var
  ii: TICINFO;
  i: DWord;
  ic: THandle;
  BitmapInfoHeader: TBitmapInfoHeader;
  Name: WideString;
  j: integer;
begin
  List.Clear;
  List.Add(TeeMsg_NoCompression);

  PrepareBitmapHeader(BitmapInfoHeader);

  ii.dwSize := SizeOf(ii);

  i:=0;

  while ICInfo(ICTYPE_VIDEO, i, @ii) do
  begin
    try
      ic:=ICOpen(ICTYPE_VIDEO, ii.fccHandler, ICMODE_QUERY);

      try
        if ic <> 0 then
        begin
          if AllValid or (ICCompressQuery(ic, @BitmapInfoHeader, nil) = 0) then
          begin
            ICGetInfo(ic, @ii, SizeOf(ii));

            Name := '';
            for j := 0 to 15 do
                Name := Name + ii.szName[j];

            List.Add(FourCCToString(ii.fccHandler) + ' ' + String(Name));
          end;
        end;

      finally
        ICClose(ic);
      end;

    except
    end;

    Inc(i);
  end;
end;

function ICQueryConfigure(hic: THandle): BOOL;
begin
  Result := ICSendMessage(hic, ICM_CONFIGURE, DWord(-1), ICMF_CONFIGURE_QUERY) = 0;
end;

function ICConfigure(hic: THandle; HWND: HWND): DWord;
begin
  Result := ICSendMessage(hic, ICM_CONFIGURE, HWND, 0);
end;

procedure TVideoTool.ShowCompressorOptions(Parent:TWinControl);
var ic: THandle;
  S: string;
begin
  if FFourCC = '' then
     Exit;

  S := FFourCC;

  ic := ICOpen(ICTYPE_VIDEO, mmioStringToFOURCC(PChar(S), 0), ICMODE_QUERY);
  try
    if ic <> 0 then
    begin
      if ICQueryConfigure(ic) then
         ICConfigure(ic, {$IFDEF CLX}QWidget_winId{$ENDIF}(Parent.Handle));
    end;
  finally
    ICClose(ic);
  end;
end;

procedure TVideoTool.SetCompression(const Value:String);
var
  S: String;
  ic: THandle;
  BitmapInfoHeader: TBitmapInfoHeader;
begin
  Exit;

  FFourCC:=Value;
  PrepareBitmapHeader(BitmapInfoHeader);

  S:=FFourCC;
  ic:=ICLocate(ICTYPE_VIDEO, mmioStringToFOURCC(PChar(S), 0),
               @BitmapInfoHeader, nil, ICMODE_COMPRESS);

  if ic <> 0 then
     ICClose(ic)
  else
     raise Exception.Create('No compressor for ' + FFourCC + ' available');
end;

procedure LoadProcAddresses;
begin
  {$IFNDEF CLR}
  if (VFWHandle > 0) and (not Assigned(ICInfo)) then
  begin
    ICInfo:=GetProcAddress(VFWHandle, 'ICInfo');
    ICOpen:=GetProcAddress(VFWHandle, 'ICOpen');
    ICSendMessage:=GetProcAddress(VFWHandle, 'ICSendMessage');
    ICGetInfo:=GetProcAddress(VFWHandle, 'ICGetInfo');
    ICClose:=GetProcAddress(VFWHandle, 'ICClose');
    ICLocate:=GetProcAddress(VFWHandle, 'ICLocate');
  end;

  if (AVIFilHandle > 0) and (not Assigned(AVIFileInit)) then
  begin
    AVIFileInit:=GetProcAddress(AVIFilHandle, 'AVIFileInit');
    AVIFileExit:=GetProcAddress(AVIFilHandle, 'AVIFileExit');
    AVIFileOpen:=GetProcAddress(AVIFilHandle, 'AVIFileOpen');
    AVIFileCreateStream:=GetProcAddress(AVIFilHandle, 'AVIFileCreateStreamA');
    AVIStreamWrite:=GetProcAddress(AVIFilHandle, 'AVIStreamWrite');
    AVIMakeCompressedStream:=GetProcAddress(AVIFilHandle, 'AVIMakeCompressedStream');
    AVIStreamSetFormat:=GetProcAddress(AVIFilHandle, 'AVIStreamSetFormat');
    AVIFileRelease:=GetProcAddress(AVIFilHandle, 'AVIFileRelease');
    AVIStreamRelease:=GetProcAddress(AVIFilHandle, 'AVIStreamRelease');

    AVIFileInfo:=GetProcAddress(AVIFilHandle, 'AVIFileInfoA');
    AVIFileGetStream:=GetProcAddress(AVIFilHandle, 'AVIFileGetStream');
    AVIStreamGetFrameOpen:=GetProcAddress(AVIFilHandle, 'AVIStreamGetFrameOpen');
    AVIStreamGetFrame:=GetProcAddress(AVIFilHandle, 'AVIStreamGetFrame');
    AVIStreamGetFrameClose:=GetProcAddress(AVIFilHandle, 'AVIStreamGetFrameClose');
    AVIStreamStart:=GetProcAddress(AVIFilHandle, 'AVIStreamStart');
    AVIStreamLength:=GetProcAddress(AVIFilHandle, 'AVIStreamLength');
    AVIStreamInfo:=GetProcAddress(AVIFilHandle, 'AVIStreamInfoA');
  end;
  {$ENDIF}
end;

{$IFNDEF CLR}
procedure ClearProcAddresses;
begin
  ICInfo:=nil;
  ICOpen:=nil;
  ICSendMessage:=nil;
  ICGetInfo:=nil;
  ICClose:=nil;
  ICLocate:=nil;
end;
{$ENDIF}

procedure CloseVFW;
begin
  {$IFNDEF CLR}
  if VFWHandle > 0 then
  begin
    FreeLibrary(VFWHandle);
    VFWHandle:=0;
  end;

  if AVIFilHandle > 0 then
  begin
    FreeLibrary(AVIFilHandle);
    AVIFilHandle:=0;
  end;

  ClearProcAddresses;
  {$ENDIF}
end;

function InitVideoForWindows:Boolean;
{$IFNDEF D5}
var OldError: Integer;
{$ENDIF}
begin
{$IFDEF CLR}
  //CloseVFW;
  result:=True;
{$ELSE}

  result:=False;

  if (VFWHandle=0) or (AVIFilHandle=0) then
  begin

    {$IFNDEF D5}
    OldError:=SetErrorMode(SEM_NOOPENFILEERRORBOX);
    try
    {$ENDIF}
      VFWHandle:={$IFDEF D5}SafeLoadLibrary{$ELSE}LoadLibrary{$ENDIF}(PChar(VFW_Name));
      AVIFilHandle:={$IFDEF D5}SafeLoadLibrary{$ELSE}LoadLibrary{$ENDIF}(PChar(AVIFil_Name));

      if (VFWHandle > 0) and (AVIFilHandle > 0) then
      begin
        LoadProcAddresses;
        Result:=True;
      end
      else
      begin
        if VFWHandle > 0 then FreeLibrary(VFWHandle);
        if AVIFilHandle > 0 then FreeLibrary(AVIFilHandle);
      end;
    {$IFNDEF D5}
    finally
      SetErrorMode(OldError);
    end;
    {$ENDIF}
  end;

{$ENDIF}
end;

{ TVideoTool }

Constructor TVideoTool.Create(AOwner: TComponent);
begin
  inherited;

  InitVideoForWindows;

  FDuration:=50;
  FQuality:=8000;
end;

class function TVideoTool.Description: String;
begin
  result:=TeeMsg_VideoTool;
end;

procedure TVideoToolEditor.FormCreate(Sender: TObject);
begin
  Align:=alClient;
  CBCompress.Add(TeeMsg_NoCompression);
  CBCompress.ItemIndex:=0;
end;

procedure TVideoToolEditor.FormShow(Sender: TObject);
begin
  Label2.Caption:=IntToStr(SBMsec.Position);
  CBQuality.ItemIndex:=0;
  BEdit.Enabled:=False;

  Video:=TVideoTool(Tag);

  if Assigned(Video) then
  with Video do
  begin
     // Pending: obtain ItemIndex from "Compression" property FourCC
    CBCompress.ItemIndex:=0;

    EFile.Text:=FileName;
    SBMsec.Position:=FrameDuration;

    case CompressionQuality of
     10000 : CBQuality.ItemIndex:=0;
      9000 : CBQuality.ItemIndex:=1;
      8000 : CBQuality.ItemIndex:=2;
      6000 : CBQuality.ItemIndex:=3;
      4000 : CBQuality.ItemIndex:=4;
    end;

    BStart.Enabled:=(FileName<>'') and (not IsRecording);
    BStop.Enabled:=IsRecording;

    SetLabelFrame;

    if IsRecording then
       SetupProgress;
  end;
end;

procedure TVideoToolEditor.SetupProgress;
begin
  OldNewFrame:=Video.OnNewFrame;
  Video.OnNewFrame:=VideoNewFrame;
end;

procedure TVideoToolEditor.SBMsecChange(Sender: TObject);
begin
  Video.FrameDuration:=SBMsec.Position;
  Label2.Caption:=IntToStr(Video.FrameDuration);
end;

procedure TVideoToolEditor.VideoNewFrame(Sender: TObject);
begin
  if Assigned(OldNewFrame) then
     OldNewFrame(Sender);

  SetLabelFrame;
end;

procedure TVideoToolEditor.SetLabelFrame;
begin
  LFrame.Caption:=IntToStr(Video.FrameCount);
end;

procedure TVideoToolEditor.BStartClick(Sender: TObject);
begin
  Video.StartRecording(EFile.Text);
  BStart.Enabled:=False;
  BStop.Enabled:=True;
  SetupProgress;
end;

procedure TVideoToolEditor.SpeedButton1Click(Sender: TObject);
begin
  OpenDialog1.FileName:=EFile.Text;

  if OpenDialog1.Execute then
     EFile.Text:=OpenDialog1.FileName;
end;

procedure TVideoToolEditor.EFileChange(Sender: TObject);
begin
  BStart.Enabled:=EFile.Text<>'';
end;

procedure TVideoToolEditor.BStopClick(Sender: TObject);
begin
  Video.StopRecording;

  Video.OnNewFrame:=OldNewFrame;

  BStop.Enabled:=False;
  BStart.Enabled:=True;
end;

procedure TVideoToolEditor.CBQualityChange(Sender: TObject);
begin
  case CBQuality.ItemIndex of
    0: Video.CompressionQuality:=10000;
    1: Video.CompressionQuality:=9000;
    2: Video.CompressionQuality:=8000;
    3: Video.CompressionQuality:=6000;
    4: Video.CompressionQuality:=4000;
  end;
end;

procedure TVideoToolEditor.CBCompressChange(Sender: TObject);
begin
  if CBCompress.ItemIndex>0 then
     Video.Compression:=Copy(CBCompress.CurrentItem,1,4)
  else
     Video.Compression:='';

  BEdit.Enabled:=CBCompress.ItemIndex>0;
end;

procedure TVideoToolEditor.BEditClick(Sender: TObject);
begin
  Video.ShowCompressorOptions(Self);
end;

class function TVideoTool.GetEditorClass: String;
begin
  result:='TVideoToolEditor';
end;

procedure TVideoToolEditor.FormDestroy(Sender: TObject);
begin
  if Assigned(Video) then
     Video.OnNewFrame:=OldNewFrame;
end;

procedure TVideoToolEditor.CBCompressDropDown(Sender: TObject);
begin
  if Assigned(Video) and (not CompressFilled) then
  begin
    Screen.Cursor:=crHourGlass;
    try
      Video.GetCompressors(CBCompress.Items);
    finally
      Screen.Cursor:=crDefault;
    end;

    CBCompress.ItemIndex:=0;
    CompressFilled:=True;
  end;
end;

initialization
  RegisterTeeTools([TVideoTool]);
  RegisterClass(TVideoToolEditor);
finalization
  CloseVFW;
  UnRegisterTeeTools([TVideoTool]);
end.