unit Client;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ExtCtrls, DSPack, DirectShow9, StdCtrls, DSUtil,
IdBaseComponent, IdComponent, IdTCPConnection, IdTCPClient, jpeg, Menus, IdTCPServer;
type
TClientForm = class(TForm)
FilterGraph: TFilterGraph;
Grabber: TSampleGrabber;
Filter: TFilter;
VideoWindow: TVideoWindow;
VideoPanel: TPanel;
Panel1: TPanel;
Image: TImage;
Button1: TButton;
Button2: TButton;
edtIPAddress: TEdit;
TCPClient: TIdTCPClient;
procedure GrabberBuffer(sender: TObject; SampleTime: Double; pBuffer: Pointer; BufferLen: Integer);
procedure FormCreate(Sender: TObject);
procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
procedure AboutClick(Sender: TObject);
procedure ConnectServerClick(Sender: TObject);
procedure DeconnectServerClick(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
procedure OnSelectDevice(sender: TObject);
end;
var
ClientForm: TClientForm;
SysDev: TSysDevEnum;
implementation
uses
About, Connect;
{$R *.dfm}
procedure TClientForm.GrabberBuffer(sender: TObject; SampleTime: Double; pBuffer: Pointer; BufferLen: Integer);
var
hr: HRESULT;
BIHeaderPtr: PBitmapInfoHeader;
MediaType: TAMMediaType;
BitMapHandle: HBitmap;
DIBPtr: Pointer;
jpg: TJpegImage;
memStream: TMemoryStream;
begin
Image.Canvas.Lock;
try
hr := Grabber.SampleGrabber.GetConnectedMediaType(MediaType);
if hr <> S_OK then
Exit;
try
if IsEqualGUID(MediaType.majortype, MEDIATYPE_Video) then
begin
BIHeaderPtr := nil;
if IsEqualGUID(MediaType.formattype, FORMAT_VideoInfo) then
if MediaType.cbFormat = SizeOf(TVideoInfoHeader) then
BIHeaderPtr := @(PVideoInfoHeader(MediaType.pbFormat)^.bmiHeader);
if not Assigned(BIHeaderPtr) then
Exit;
BitmapHandle := CreateDIBSection(0, PBitmapInfo(BIHeaderPtr)^, DIB_RGB_COLORS, DIBPtr, 0, 0);
if BitmapHandle <> 0 then
begin
if DIBPtr = nil then
Exit;
if BufferLen > Integer(BIHeaderPtr^.biSizeImage) then
BufferLen := BIHeaderPtr^.biSizeImage;
Move(pBuffer^, DIBPtr^, BufferLen);
Image.Picture.Bitmap.Handle := BitmapHandle;
end;
end;
finally
FreeMediaType(@MediaType);
end;
memStream := TMemoryStream.Create;
jpg := TJpegImage.Create;
jpg.Assign(Image.Picture.Bitmap);
jpg.CompressionQuality := 10;
jpg.JPEGNeeded;
jpg.Compress;
jpg.SaveToStream(memStream);
jpg.Free;
if ClientForm.TCPClient.Connected then
begin
try
ClientForm.TCPClient.WriteInteger(memStream.Size);
ClientForm.TCPClient.WriteBuffer(memStream.Memory^, memStream.Size, True);
except
end;
end;
memStream.Free;
finally
Image.Canvas.Unlock;
end;
end;
procedure TClientForm.FormCreate(Sender: TObject);
var
i: Integer;
Device: TMenuItem;
begin
SysDev := TSysDevEnum.Create(CLSID_VideoInputDeviceCategory);
end;
procedure TClientForm.OnSelectDevice(sender: TObject);
begin
FilterGraph.ClearGraph;
FilterGraph.Active := False;
Filter.BaseFilter.Moniker := SysDev.GetMoniker(TMenuItem(Sender).tag);
FilterGraph.Active := True;
with FilterGraph as ICaptureGraphBuilder2 do
CheckDSError(RenderStream(@PIN_CATEGORY_PREVIEW, nil, Filter as IBaseFilter, Grabber as IBaseFilter, VideoWindow as IbaseFilter));
FilterGraph.Play;
end;
procedure TClientForm.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
SysDev.Free;
FilterGraph.ClearGraph;
FilterGraph.Active := False;
if ClientForm.TCPClient.Connected then
ClientForm.TCPClient.Disconnect;
end;
procedure TClientForm.AboutClick(Sender: TObject);
begin
AboutForm.Show;
end;
procedure TClientForm.ConnectServerClick(Sender: TObject);
begin
ConnectForm.Show;
end;
procedure TClientForm.DeconnectServerClick(Sender: TObject);
begin
if ClientForm.TCPClient.Connected then
ClientForm.TCPClient.Disconnect;
end;
procedure TClientForm.Button1Click(Sender: TObject);
begin
FilterGraph.ClearGraph;
FilterGraph.Active := False;
Filter.BaseFilter.Moniker := SysDev.GetMoniker(TMenuItem(Sender).tag);
FilterGraph.Active := True;
with FilterGraph as ICaptureGraphBuilder2 do
CheckDSError(RenderStream(@PIN_CATEGORY_PREVIEW, nil, Filter as IBaseFilter, Grabber as IBaseFilter, VideoWindow as IbaseFilter));
end;
procedure TClientForm.Button2Click(Sender: TObject);
begin
if edtIPAddress.Text <> '' then
begin
TCPClient.Host := edtIPAddress.Text;
try
if not TCPClient.Connected then
TCPClient.Connect;
except
ShowMessage('连接错误!');
end;
end;
end;
end.