unit1.~pas

delphi 编的一个语音的聊天系统.还是能用的,要是有错误请多多指教

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ExtCtrls,VFW, IdBaseComponent, IdComponent, IdUDPBase,
  IdUDPClient,jpeg, IdUDPServer, IdSocketHandle, ComCtrls, ACMIn,
  ACMConvertor, ACMOut, IdTCPConnection, IdTCPClient;

const
 Host = '218.9.85.124';
 LoginPort = 9001;
 Login = 'Login';
 OutLogin = 'OutLogin';
 Status = 'Status';

type
  TForm1 = class(TForm)
    Panel1: TPanel;
    Button1: TButton;
    Button2: TButton;
    Panel2: TPanel;
    StatusBar: TStatusBar;
    Button3: TButton;
    ACMConvertor: TACMConvertor;
    ACMIn: TACMIn;
    Panel3: TPanel;
    Image: TImage;
    UDPServer: TIdUDPServer;
    ACMOut: TACMOut;
    TCPClient: TIdTCPClient;
    RadioButton1: TRadioButton;
    RadioButton2: TRadioButton;
    Button4: TButton;
    GroupBox1: TGroupBox;
    Label1: TLabel;
    Timer: TTimer;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
    procedure ACMInBufferFull(Sender: TObject; Data: Pointer;
      Size: Integer);
    procedure UDPServerUDPRead(Sender: TObject; AData: TStream;
      ABinding: TIdSocketHandle);
    procedure FormCreate(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure Button4Click(Sender: TObject);
    procedure TimerTimer(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;
  CapWnd:THandle;
  CapParms:TcaptureParms;
  BMPINFO:TBitmapInfo;
  AudioFormat:TACMWaveFormat;
  DataPort:Integer=0;
  SelectServer:Integer=1;
implementation

{$R *.dfm}
function  FrameCallBack(hWnd: HWND; lpVHdr: PVIDEOHDR): LongInt;stdcall;
var  hd:Thandle;
     jpg:TJpegImage;
     memStream :TMemoryStream;
     Bitmap:TBitmap;
begin
   Bitmap:=TBitmap.Create;
   Bitmap.Width :=BMPINFO.bmiHeader.biWidth;      // New size of Bitmap
   Bitmap.Height:=BMPINFO.bmiHeader.biHeight;
   hd:= DrawDibOpen;
   DrawDibDraw(HD,Bitmap.canvas.handle,0,0,BMPINFO.BmiHeader.biwidth,BMPINFO.bmiheader.biheight,@BMPINFO.bmiHeader,
                   lpVHdr^.lpData,0,0,BMPINFO.bmiHeader.biWidth,BMPINFO.bmiHeader.biheight,0);
   DrawDibClose(hd);
   memStream := TMemoryStream.Create;
   jpg := TJpegImage.Create;
   jpg.Assign(Bitmap);
   jpg.CompressionQuality := 30;
   jpg.JPEGNeeded;
   jpg.Compress;
   jpg.SaveToStream(memStream);
   jpg.Free;
   if memStream.Size>Form1.UDPServer.BufferSize then
        Form1.UDPServer.SendBuffer(Host,DataPort,memStream.Memory^,Form1.UDPServer.BufferSize)
   else
        Form1.UDPServer.SendBuffer(Host,DataPort,memStream.Memory^,memStream.Size);
   memStream.Free;
   Bitmap.Free;
end;


procedure TForm1.Button1Click(Sender: TObject);
var
RecvInfo:string;
begin
try
TCPClient.Host:=Host;
with TCPClient do
begin
Connect(3000);
WriteLn('10000');
RecvInfo:=AllData;
DataPort:=StrToInt(Copy(RecvInfo,1,Length(RecvInfo)-2));
TCPClient.Disconnect;
end;
except
StatusBar.Panels[0].Text:='服务器关闭，无法发布';
exit;
end;
Button1.Enabled:=False;
Button2.Enabled:=True;
IF DataPort=8001 then StatusBar.Panels[0].Text:='登陆频道1发布视频' else IF DataPort=8002 then StatusBar.Panels[0].Text:='登陆频道2发布视频' else StatusBar.Panels[0].Text:='频道已满，无法发布';
      CapWnd := capCreateCaptureWindow('VIDEO',
            WS_VISIBLE or WS_CHILD,
            1,
            1,
            panel1.Width-1,
            panel1.Height-2,
            panel1.handle,
            0);
      if CapWnd = 0 then exit;
      CapSetCallbackOnFrame(CapWnd,FrameCallBack);
      CapParms.dwRequestMicroSecPerFrame:=1000000 div 25;
      CapParms.fLimitEnabled:=FALSE;
      CapParms.fCaptureAudio:=False;
      CapParms.fMCIControl:=False;
      CapParms.fYield:=TRUE;
      CapParms.vKeyAbort:=VK_ESCAPE;
      CapParms.fAbortLeftMouse:=False;
      CapParms.fAbortRightMouse:=FALSE;
      CapCaptureSetSetup(capWnd,@CapParms,sizeof(TCAPTUREPARMS));
      CapPreviewRate(capWnd,25);
      CapCaptureSequenceNoFile(capWnd);
      CapDriverConnect(CapWnd,0);
      capGetVideoFormat(capWnd, @BMPINFO,sizeof(TBitmapInfo));
      CapPreviewScale(capWnd,TRUE);
      CapOverlay(capWnd,true);
      CapPreview(capWnd,true);
      ACMIn.Open(AudioFormat);
end;


procedure TForm1.Button2Click(Sender: TObject);
begin
try
TCPClient.Host:=Host;
with TCPClient do
begin
Connect(3000);
WriteLn('2'+IntToStr(DataPort));
TCPClient.Disconnect;
end;
except
end;
Button1.Enabled:=True;
Button2.Enabled:=False;
capCaptureAbort(CapWnd);
capDriverDisconnect(CapWnd);
ACMIn.Close;
end;

procedure TForm1.Button3Click(Sender: TObject);
begin
Button3.Enabled:=False;
Button4.Enabled:=True;
UDPServer.Send(Host,LoginPort,IntToStr(SelectServer)+OutLogin);
if RadioButton1.Checked then SelectServer:=1 else SelectServer:=2;
RadioButton1.Enabled:=False;
RadioButton2.Enabled:=False;
UDPServer.Send(Host,LoginPort,IntToStr(SelectServer)+Login);
ACMOut.Open(AudioFormat);
Label1.Caption:='对方视频';
Timer.Enabled:=True;
end;

procedure TForm1.ACMInBufferFull(Sender: TObject; Data: Pointer;
  Size: Integer);
var
mdata:array[1..2048] of char;
 k:integer;
begin
for k:=1 to size do mdata[k]:=pchar(dword(data)+dword(k-1))^;
UDPServer.SendBuffer(Host,DataPort,mdata,size);
end;

procedure TForm1.UDPServerUDPRead(Sender: TObject; AData: TStream;
  ABinding: TIdSocketHandle);
var
  Buf:Array[0..9] of byte;
  jpg:TJpegImage;
  memStream:TMemoryStream;
begin
AData.Read(Buf,Sizeof(Buf));
if (Buf[6]=$4A) and (Buf[7]=$46) and (Buf[8]=$49) and (Buf[9]=$46) then
begin
   try
       AData.Seek(0,0);
       jpg := TJpegImage.Create;
       jpg.LoadFromStream(Adata);
       Image.Picture.Bitmap.Assign(jpg);
       jpg.Free;
    except
    end;
       Image.Refresh;
    end
    else
    begin
memStream:=TMemoryStream.Create;
memStream.LoadFromStream(AData);
ACMOut.Play(memStream.Memory,memStream.Size);
memStream.Free;
end;
end;

procedure TForm1.FormCreate(Sender: TObject);
var
RC : TRect;
begin
   with AudioFormat.Format do
   begin
     wFormatTag:=1;
     nChannels:=1;
     wBitsPerSample:=8;
     nSamplesPerSec:=8000;
     nBlockAlign:=1;
     nAvgBytesPerSec:=8000;
     cbSize:=SizeOf(TACMWaveFormat);
   end;

  RC := Image.Canvas.ClipRect ;
  Image.Canvas.Brush.Color := clBlack ;
  Image.Canvas.FillRect(RC);

end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
try
TCPClient.Host:=Host;
with TCPClient do
begin
Connect(3000);
WriteLn('2'+IntToStr(DataPort));
TCPClient.Disconnect;
end;
except
end;
UDPServer.Send(Host,LoginPort,IntToStr(SelectServer)+OutLogin);
end;

procedure TForm1.Button4Click(Sender: TObject);
var
RC : TRect;
begin
RadioButton1.Enabled:=True;
RadioButton2.Enabled:=True;
Button3.Enabled:=True;
Button4.Enabled:=False;
UDPServer.Send(Host,LoginPort,IntToStr(SelectServer)+OutLogin);
  RC := Image.Canvas.ClipRect ;
  Image.Canvas.Brush.Color := clBlack ;
  Image.Canvas.FillRect(RC);
  Label1.Caption:='';
Timer.Enabled:=False;  
end;

procedure TForm1.TimerTimer(Sender: TObject);
begin
UDPServer.Send(Host,LoginPort,IntToStr(SelectServer)+Status);
end;

end.