bufferudp.pas

DELPHI实现的快速屏幕截图并发送源代码

unit BufferUDP;

interface

uses
  Windows, SysUtils, Classes, WinSock, syncobjs;

type // Main class
  TUDPDataEvent = procedure(Sender: TObject; const Buffer: Pointer; const RecvSize:Integer; const Peer: string; const Port: Integer) of object;
  TUDPSender = class(TComponent)
  private
    { Private declarations }
    FHandle: TSocket;
    FActive: Boolean;
    FRemoteIP: String;
    FRemoteHost: String;
    FRemotePort: Word;
    CS: TCriticalSection;
    Procedure SetActive(const Value: Boolean);
    Procedure SetRemoteIP(const Value: String);
    Procedure SetRemoteHost(const Value: String);
    Procedure SetRemotePort(const Value: Word);
  protected
    { Protected declarations }
  public
    { Public declarations }
    Class function ResolveHost(const psHost: string; var psIP: string): u_long; virtual;
    Class function ResolveIP(const psIP: string): string; virtual;
    Constructor Create(AOwner: TComponent); override;
    Destructor Destroy; override;
    Procedure Connect;
    Procedure Disconnect;
    Function SendBuf(var Buffer; BufSize: Integer): Integer;
    property Handle: TSocket read FHandle;
  published
    { Published declarations }
    property Active: Boolean read FActive write SetActive default False;
    property RemoteIP: String read FRemoteIP write SetRemoteIP;
    property RemoteHost: String read FRemoteHost write SetRemoteHost;
    property RemotePort: Word read FRemotePort write SetRemotePort;
  end;

  TUDPReceiver = class;

  TUDPReceiverThread = class(TThread)
  protected
    FReceiver: TUDPReceiver;
    FBuffer: Pointer;
    FRecvSize: Integer;
    FPeer: string;
    FPort: Integer;
    FBufSize: Integer;
    procedure SetBufSize(const Value: Integer);
  public
    procedure Execute; override;
    procedure UDPRead;
  published
    Property BufSize: Integer read FBufSize write SetBufSize;
    Property Receiver: TUDPReceiver read FReceiver write FReceiver;
  end;

  TUDPReceiver = class(TComponent)
  private
    { Private declarations }
    FHandle: TSocket;
    FActive: Boolean;
    FPort: Word;
    FBufferSize: Integer;
    FMulticastIP : String;
//    FUDPBuffer: Pointer;
    FOnUDPData: TUDPDataEvent;
    FUDPReceiverThread: TUDPReceiverThread;
    Procedure SetActive(const Value: Boolean);
    Procedure SetPort(const Value: Word);
    Procedure SetBufferSize(const Value: Integer);
    procedure SetMulticastIP(const Value: String);
  protected
    { Protected declarations }
  public
    { Public declarations }
    Class Function BindMulticast(const Socket: TSocket; const IP:String): LongInt; virtual;
    Constructor Create(AOwner: TComponent); override;
    Destructor Destroy; override;
    Procedure Connect;
    Procedure Disconnect;
    procedure DoUDPRead(const Buffer: Pointer; const RecvSize:Integer; const Peer: string; const Port: Integer); virtual;
    property Handle: TSocket read FHandle;
  published
    { Published declarations }
    property Active: Boolean read FActive write SetActive default False;
    property Port: Word read FPort write SetPort;
    property BufferSize: Integer read FBufferSize write SetBufferSize default 65000;
    property OnUDPData: TUDPDataEvent read FOnUDPData write FOnUDPData;
    property MulticastIP: String read FMulticastIP write SetMulticastIP;
  end;

type // exception
  EBufferUDP = Exception;

procedure Register;

resourcestring
  EUDPNOTACTIVE = 'UDP Socket not connected';
  EUDPACTIVED = 'UDP Socket already connected';
  EWSAError = 'Socket Error : %d';
  EUNABLERESOLVEHOST = 'Unable to resolve host: %s';
  EUNABLERESOLVEIP = 'Unable to resolve IP: %s';
  EZEROBYTESEND = '0 bytes were sent.';
  EPACKAGETOOBIG = 'Package Size Too Big: %d';
  ENOREMOTESIDE = 'Remote Host/IP not identified!';
  ESIZEOUTOFBOUNDARY = 'Size value is out of boundary!';
  EWSAENOBUFS        = 'An operation on a socket could not be performed because the system lacked sufficient buffer space or because a queue was full.';
  EWSANOTINITIALISED = 'A successful WSAStartup must occur before using this function.';
  EWSAENETDOWN       = 'The network subsystem has failed.';
  EWSAEFAULT         = 'optval is not in a valid part of the process address space or optlen argument is too small.';
  EWSAEINPROGRESS    = 'A blocking Windows Sockets 1.1 call is in progress, or the service provider is still processing a callback function.';
  EWSAEINVAL         = 'level is not valid, or the information in optval is not valid.';
  EWSAENETRESET      = 'Connection has timed out when SO_KEEPALIVE is set.';
  EWSAENOPROTOOPT    = 'The option is unknown or unsupported for the specified provider.';
  EWSAENOTCONN       = 'Connection has been reset when SO_KEEPALIVE is set.';
  EWSAENOTSOCK       = 'The descriptor is not a socket.';
  EWSAUNKNOW         = 'Unknow socket error.';
implementation

procedure Register;
begin
  RegisterComponents('Samples', [TUDPSender, TUDPReceiver]);
end;

Type
  TIMR = Packed Record
    imr_multiaddr: LongInt;
    imr_interface: LongInt;
  End;

{ TUDPSender }

procedure TUDPSender.Connect;
Var
  Faddr: TSockAddrIn;
begin
  CS.Enter;
  try
    If FActive then
      Raise EBufferUDP.CreateRes(@EUDPACTIVED);

    If ((FRemoteHost='') and (FRemoteIP='')) then
      Raise EBufferUDP.CreateRes(@ENOREMOTESIDE);

    If Not (csDesigning in ComponentState) then
    Begin
      FHandle:= WinSock.Socket(PF_INET, SOCK_DGRAM, IPPROTO_IP);
      If FHandle = INVALID_SOCKET then
        Raise EBufferUDP.CreateResFmt(@EWSAError, [WSAGetLastError]);

      with faddr do begin
        sin_family := PF_INET;
        sin_port := WinSock.htons(FRemotePort);
    //    sin_addr.s_addr := WinSock.ResolveHost(fsHost, fsPeerAddress);
        if length(FRemoteIP) > 0 then begin
          sin_addr.s_addr := WinSock.inet_addr(PChar(FRemoteIP));
        end;
      end;
      WinSock.connect(FHandle, faddr, Sizeof(faddr));
    End;

    FActive:= True;
  finally
    CS.Leave;
  end;
end;

constructor TUDPSender.Create(AOwner: TComponent);
begin
  inherited;
  CS:= TCriticalSection.Create;
  FActive:= False;
  FHandle := INVALID_SOCKET;
//  FReceiveTimeout := -1;
end;

destructor TUDPSender.Destroy;
begin
  Active:= False;
  CS.Free;
  inherited;
end;

procedure TUDPSender.Disconnect;
Var
  OldHandle: TSocket;
begin
  CS.Enter;
  try
    If FActive then
    Begin
      OldHandle:= FHandle;
      FHandle:= INVALID_SOCKET;
      CloseSocket(OldHandle);
    End;
  finally
    FActive:= False;
    CS.Leave;
  end;
end;

class function TUDPSender.ResolveHost(const psHost: string;
  var psIP: string): u_long;
Var
  pa: PChar;
  sa: TInAddr;
  aHost: PHostEnt;
begin
  psIP := psHost;
  // Sometimes 95 forgets who localhost is
  if CompareText(psHost, 'LOCALHOST') = 0 then
  begin
    sa.S_un_b.s_b1 := #127;
    sa.S_un_b.s_b2 := #0;
    sa.S_un_b.s_b3 := #0;
    sa.S_un_b.s_b4 := #1;
    psIP := '127.0.0.1';
    Result := sa.s_addr;
  end else begin
    // Done if is tranlated (ie There were numbers}
    Result := inet_addr(PChar(psHost));
    // If no translation, see if it resolves}
    if Result = u_long(INADDR_NONE) then begin
      aHost := Winsock.GetHostByName(PChar(psHost));
      if aHost = nil then
      begin
        Result:= 0;
        psIP:= '';
        Exit;
        //Raise EBufferUDP.CreateResFmt(@EUNABLERESOLVEHOST, [psHost]);
      end else
      begin
        pa := aHost^.h_addr_list^;
        sa.S_un_b.s_b1 := pa[0];
        sa.S_un_b.s_b2 := pa[1];
        sa.S_un_b.s_b3 := pa[2];
        sa.S_un_b.s_b4 := pa[3];
        psIP:= String(inet_ntoa(sa));
        //psIP := TInAddrToString(sa);
      end;
      Result := sa.s_addr;
    end;
  end;
end;

class function TUDPSender.ResolveIP(const psIP: string): string;
var
  i: Integer;
  P: PHostEnt;
begin
  result := '';
  if CompareText(psIP, '127.0.0.1') = 0 then
  begin
    result := 'LOCALHOST';
  end else
  begin
    i := Winsock.inet_addr(PChar(psIP));
    P := Winsock.GetHostByAddr(@i, 4, PF_INET);
    If P = nil then
    Begin
      Result:= '';
      Exit;
      // Raise EBufferUDP.CreateResFmt(@EUNABLERESOLVEIP, [psIP]);
      //CheckForSocketError2(SOCKET_ERROR, [WSANO_DATA]);
    End else
    Begin
      result := P.h_name;
    End;
  end;
end;

Function TUDPSender.SendBuf(var Buffer; BufSize: Integer): Integer;
begin
  CS.Enter;
  try
    Result:= 0;
    If BufSize<=0 then
      Exit;