RealICQClient/COM/RealOAMessenger/复件 MessageSenderUnit.pas

unit MessageSenderUnit;

{$WARN SYMBOL_PLATFORM OFF}

interface

uses
  ComObj, ActiveX, AxCtrls, Classes, RealOAMessenger_TLB, StdVcl, SysUtils,
  BlockingTCPClient, RealICQProxy, MD5, EncdDecd;

type
  TMessageSender = class(TAutoObject, IConnectionPointContainer, IMessageSender)
  private
    { Private declarations }
    FConnectionPoints: TConnectionPoints;
    FConnectionPoint: TConnectionPoint;
    FEvents: IMessageSenderEvents;
    { note: FEvents maintains a *single* event sink. For access to more
      than one event sink, use FConnectionPoint.SinkList, and iterate
      through the list of sinks. }

    FBlockingTCPClient: TBlockingTCPClient;
    FServerAddress: String;
    FServerPort: SYSINT;
    FProxyType: Shortint;
    FProxyAddress: String;
    FProxyPort: SYSINT;
    FProxyPassword: String;
    FProxyUsername: String;
    FProxyDomain: String;
    FUsername: String;
    FPassword: String;

    FLogined: Boolean;
    FMessageType: Integer;
    FAutoOpenWindow: Boolean;
    FPosition,
    FLeft,
    FTop,
    FWidth,
    FHeight: Integer;
    FTitle,
    FContent,
    FUrl: String;
    FAutoCloseTime: Integer;
    FUsers: String;

    FWaitTimes: Integer;
    
    procedure ReceivedData(Sender: TObject; RecvThread:
      TBlockingTCPClientRecvThread; RecvBytes: Integer);
    procedure Connect;
    procedure Login;
    procedure Send;
    
    procedure ProcessLoginResult(Data: Array of Byte);
    procedure ProcessSendSystemMessageResult(Data: Array of Byte);
  public
    procedure Initialize; override;
  protected
    { Protected declarations }
    property ConnectionPoints: TConnectionPoints read FConnectionPoints
      implements IConnectionPointContainer;
    procedure EventSinkChanged(const EventSink: IUnknown); override;
    function Get_ServerAddress: OleVariant; safecall;
    procedure Set_ServerAddress(Value: OleVariant); safecall;
    function Get_ServerPort: OleVariant; safecall;
    procedure Set_ServerPort(Value: OleVariant); safecall;
    function Get_ProxyType: OleVariant; safecall;
    procedure Set_ProxyType(Value: OleVariant); safecall;
    function Get_ProxyAddress: OleVariant; safecall;
    procedure Set_ProxyAddress(Value: OleVariant); safecall;
    function Get_ProxyPort: OleVariant; safecall;
    procedure Set_ProxyPort(Value: OleVariant); safecall;
    function Get_ProxyPassword: OleVariant; safecall;
    function Get_ProxyUsername: OleVariant; safecall;
    procedure Set_ProxyPassword(Value: OleVariant); safecall;
    procedure Set_ProxyUsername(Value: OleVariant); safecall;
    function Get_ProxyDomain: OleVariant; safecall;
    procedure Set_ProxyDomain(Value: OleVariant); safecall;
    function Get_Username: OleVariant; safecall;
    procedure Set_Username(Value: OleVariant); safecall;
    function Get_Password: OleVariant; safecall;
    procedure Set_Password(Value: OleVariant); safecall;
    procedure SendSystemMessage(MessageType, AutoOpenWindow, Position, Left,
      Top, Width, Height, Title, Content, Url, AutoCloseTime,
      Users: OleVariant); safecall;
  end;
  
	TRealICQLoginResultType = (	rtLoginOK = 0,
		                          rtCanUpdate = 1,
		                          rtMustUpdate = 2,
		                          rtVersionError = 3,
		                          rtAuthorizationError = 4,
		                          rtOther = 5);

implementation

uses ComServ, Windows, Forms;

procedure TMessageSender.EventSinkChanged(const EventSink: IUnknown);
begin
  FEvents := EventSink as IMessageSenderEvents;
end;

procedure TMessageSender.Initialize;
begin
  inherited Initialize;
  FConnectionPoints := TConnectionPoints.Create(Self);
  if AutoFactory.EventTypeInfo <> nil then
    FConnectionPoint := FConnectionPoints.CreateConnectionPoint(
      AutoFactory.EventIID, ckSingle, EventConnect)
  else FConnectionPoint := nil;

  FServerAddress := '';
  FServerPort := 0;
  FProxyType := 0;
  FProxyAddress := '';
  FProxyPort := 0;
  FProxyPassword := '';
  FProxyUsername := '';
  FProxyDomain := '';
  FUsername := '';
  FPassword := '';

  FLogined := False;
  FWaitTimes := 0;
end;

function TMessageSender.Get_ServerAddress: OleVariant;
begin
  Result := FServerAddress;
end;

procedure TMessageSender.Set_ServerAddress(Value: OleVariant);
begin
  FServerAddress := Value;
end;

function TMessageSender.Get_ServerPort: OleVariant;
begin
  Result := FServerPort;
end;

procedure TMessageSender.Set_ServerPort(Value: OleVariant);
begin
  FServerPort := Value;
end;

function TMessageSender.Get_ProxyType: OleVariant;
begin
  Result := FProxyType;
end;

procedure TMessageSender.Set_ProxyType(Value: OleVariant);
begin
  FProxyType := Value;
end;

function TMessageSender.Get_ProxyAddress: OleVariant;
begin
  Result := FProxyAddress;
end;

procedure TMessageSender.Set_ProxyAddress(Value: OleVariant);
begin
  FProxyAddress := Value;
end;

function TMessageSender.Get_ProxyPort: OleVariant;
begin
  Result := FProxyPort;
end;

procedure TMessageSender.Set_ProxyPort(Value: OleVariant);
begin
  FProxyPort := Value;
end;

function TMessageSender.Get_ProxyPassword: OleVariant;
begin
  Result := FProxyPassword;
end;

function TMessageSender.Get_ProxyUsername: OleVariant;
begin
  Result := FProxyUsername;
end;

procedure TMessageSender.Set_ProxyPassword(Value: OleVariant);
begin
  FProxyPassword := Value;
end;

procedure TMessageSender.Set_ProxyUsername(Value: OleVariant);
begin
  FProxyUsername := Value;
end;

function TMessageSender.Get_ProxyDomain: OleVariant;
begin
  Result := FProxyDomain;
end;

procedure TMessageSender.Set_ProxyDomain(Value: OleVariant);
begin
  FProxyDomain := Value;
end;

function TMessageSender.Get_Username: OleVariant;
begin
  Result := FUsername;
end;

procedure TMessageSender.Set_Username(Value: OleVariant);
begin
  FUsername := Value;
end;

function TMessageSender.Get_Password: OleVariant;
begin
  Result := FPassword;
end;

procedure TMessageSender.Set_Password(Value: OleVariant);
begin
  FPassword := Value;
end;

procedure TMessageSender.ReceivedData(Sender: TObject; RecvThread:
  TBlockingTCPClientRecvThread; RecvBytes: Integer);
var
  TCPClientRecvThread: TBlockingTCPClientRecvThread;
  ProtocolType: Byte;
  ProtocolLengthBytes: Array[0..1] of Byte;
  ProtocolDataBytes: Array of Byte;
  ProtocolLength: SmallInt;
begin
  try
    TCPClientRecvThread := RecvThread;
    while TCPClientRecvThread.NotProcessedBufferLength >= 3 do
    begin
      TCPClientRecvThread.CopyRecvBufferTo(ProtocolType, 0, 1);

      TCPClientRecvThread.CopyRecvBufferTo(ProtocolLengthBytes[0], 1, 2);
      CopyMemory(@ProtocolLength, @ProtocolLengthBytes[0], 2);
      if TCPClientRecvThread.NotProcessedBufferLength < ProtocolLength then Break;

      SetLength(ProtocolDataBytes, ProtocolLength - 3);
      TCPClientRecvThread.CutRecvBufferTo(ProtocolDataBytes[0], 3, ProtocolLength - 3);
      case ProtocolType of
        $02: ProcessLoginResult(ProtocolDataBytes);
        $42: begin
              ProcessSendSystemMessageResult(ProtocolDataBytes);
              Exit;
             end;
      else
        FBlockingTCPClient.Disconnect;
        FreeAndNil(FBlockingTCPClient);
        FWaitTimes := 10000;
        raise Exception.Create('数据协议不对,连接关闭');
      end;
    end;
  except
    on E: Exception do
    begin
      FBlockingTCPClient.Disconnect;
      FreeAndNil(FBlockingTCPClient);
      FWaitTimes := 10000;
      raise Exception.Create('处理TCP数据时出错：' + E.Message);
    end;
  end;
end;

//------------------------------------------------------------------------------
procedure TMessageSender.ProcessSendSystemMessageResult(Data: Array of Byte);
var
  nIndex: Integer;
  MessageSended: Boolean;
begin
  nIndex := 0;

  //取 (3)反馈类型                    1byte
  MessageSended := (Data[nIndex] = 1);
  //Inc(nIndex, 1);
  
  FBlockingTCPClient.Disconnect;
  FreeAndNil(FBlockingTCPClient);
  FWaitTimes := 10000;

  if not MessageSended then raise Exception.Create('消息发送失败');  
end;

//------------------------------------------------------------------------------
procedure TMessageSender.ProcessLoginResult(Data: Array of Byte);
var
  nIndex: Integer;
  LoginResultType: TRealICQLoginResultType;
begin
  nIndex := 0;

  //取 (3)反馈类型                    1byte
  LoginResultType := TRealICQLoginResultType(Data[nIndex]);
  //Inc(nIndex, 1);

  if (LoginResultType = rtLoginOK) or (LoginResultType = rtCanUpdate) then
  begin
    FLogined := True;
    Send;
  end
  else
  begin
    FLogined := False;
        
    FBlockingTCPClient.Disconnect;
    FreeAndNil(FBlockingTCPClient);
    FWaitTimes := 10000;

    raise Exception.Create('登录失败，错误号：' + IntToStr(Integer(LoginResultType)));
  end;
end;

procedure TMessageSender.Connect;
begin
  FLogined := False;
  if FBlockingTCPClient <> nil then FreeAndNil(FBlockingTCPClient);
  
  FBlockingTCPClient := TBlockingTCPClient.Create;
  FBlockingTCPClient.OnReceivedData := ReceivedData;
  FBlockingTCPClient.RemoteAddress := FServerAddress;
  FBlockingTCPClient.RemotePort := FServerPort;
  FBlockingTCPClient.Proxy.ProxyType := TProxyType(FProxyType);
  FBlockingTCPClient.Proxy.Address := FProxyAddress;
  FBlockingTCPClient.Proxy.Port := FProxyPort;
  FBlockingTCPClient.Proxy.Username := FProxyUsername;
  FBlockingTCPClient.Proxy.Password := FProxyPassword;
  FBlockingTCPClient.Proxy.Domain := FProxyDomain;
  FBlockingTCPClient.Connect;
end;

procedure TMessageSender.Login;
var
  EncryptedPassword: String;
  nIndex,
  UsernameLength,
  PasswordLength,
  BufferLength: SmallInt;
  InternalVersion: Word;
  SendBuffer: Array of Byte;
begin
  UsernameLength := Length(FUsername);
  EncryptedPassword := MD5Print(MD5String(FPassword));
  PasswordLength := Length(EncryptedPassword);

  BufferLength := 7 + UsernameLength + PasswordLength;

  SetLength(SendBuffer, BufferLength);
  nIndex := 0;

  //填充 (1)协议类型（0x01）            1byte
  SendBuffer[nIndex] := $01;
  Inc(nIndex, 1);

  //填充 (2)消息总长度                  2byte
  CopyMemory(@SendBuffer[nIndex], @BufferLength, 2);
  Inc(nIndex, 2);

  //填充 (3)当前客户端的内部版本号      2byte
  InternalVersion := $01;
  CopyMemory(@SendBuffer[nIndex], @InternalVersion, 2);
  Inc(nIndex, 2);

  //填充 (4)用户名长度                  1byte
  SendBuffer[nIndex] := Byte(UsernameLength);    
  Inc(nIndex, 1);

  //填充 (5)用户名                      动态长度，由(4)指定
  CopyMemory(@SendBuffer[nIndex], PChar(FUsername), UsernameLength);
  Inc(nIndex, UsernameLength);

  //填充 (6)密码长度                    1byte
  SendBuffer[nIndex] := Byte(PasswordLength);    
  Inc(nIndex, 1);

  //填充 (7)密码                        动态长度，由(6)指定
  CopyMemory(@SendBuffer[nIndex], PChar(EncryptedPassword), PasswordLength);
  //Inc(nIndex, PasswordLength);

  FBlockingTCPClient.SendBuffer(SendBuffer[0], BufferLength);
end;

procedure TMessageSender.Send;
var
  nIndex,
  BufferLength: SmallInt;
  UsersLength: Word;
  SendBuffer: Array of Byte;

  SystemMessageStr,
  DisplayMode,
  Rectangle: String;
begin
  BufferLength := 4;

  UsersLength := Length(FUsers);
  if UsersLength > 0 then
  begin
    Inc(BufferLength, 2);
    Inc(BufferLength, UsersLength);
  end;

  if FAutoOpenWindow then
    DisplayMode := '0'
  else
    DisplayMode := '1';

  if FPosition = 2 then
    Rectangle := '{' + IntToStr(FLeft) + ',' + IntToStr(FTop) + ',' + IntToStr(FWidth) + ',' + IntToStr(FHeight) + '}'
  else
    Rectangle := '{' + IntToStr(FWidth) + ',' + IntToStr(FHeight) + '}';
    
  SystemMessageStr := IntToStr(FMessageType) + Chr(9) + 
                      DisplayMode + Chr(9) +
                      FUrl + Chr(9) +
                      IntToStr(FPosition) + Chr(9) +
                      Rectangle + Chr(9) +
                      EncodeString(FTitle) + Chr(9) +
                      IntToStr(FAutoCloseTime) + Chr(9) +
                      EncodeString(FContent);
  Inc(BufferLength, Length(SystemMessageStr));

  SetLength(SendBuffer, BufferLength);
  nIndex := 0;

  //填充 (1)协议类型（0x41）            1byte
  SendBuffer[nIndex] := $41;
  Inc(nIndex, 1);

  //填充 (2)消息总长度                  2byte
  CopyMemory(@SendBuffer[nIndex], @BufferLength, 2);
  Inc(nIndex, 2);

  //填充 (3)用户类型                    1byte
  if UsersLength > 0 then
    SendBuffer[nIndex] := $0
  else
    SendBuffer[nIndex] := $1;
  Inc(nIndex, 1);

  if UsersLength > 0 then
  begin
    //填充 (4)用户名长度                  1byte
    CopyMemory(@SendBuffer[nIndex], @UsersLength, 2);
    Inc(nIndex, 2);

    //填充 (5)用户名                      动态长度，由(4)指定
    CopyMemory(@SendBuffer[nIndex], PChar(FUsers), UsersLength);
    Inc(nIndex, UsersLength);
  end;

  //填充 (6)系统消息                    动态长度
  CopyMemory(@SendBuffer[nIndex], PChar(SystemMessageStr), Length(SystemMessageStr));
  //Inc(nIndex, Length(SystemMessageStr));
  
  FBlockingTCPClient.SendBuffer(SendBuffer[0], BufferLength);
end;

procedure TMessageSender.SendSystemMessage(MessageType, AutoOpenWindow,
  Position, Left, Top, Width, Height, Title, Content, Url, AutoCloseTime,
  Users: OleVariant);
begin
  FMessageType := MessageType;
  FAutoOpenWindow := AutoOpenWindow;
  FPosition := Position;
  FLeft := Left;
  FTop := Top;
  FWidth := Width;
  FHeight := Height;
  FTitle := Title;
  FContent := Content;
  FUrl := Url;
  FAutoCloseTime := AutoCloseTime;
  FUsers := Users;

  try
    Connect;
    Login;
    while FWaitTimes < 2000 do
    begin
      Application.ProcessMessages;
      Sleep(10);

      Inc(FWaitTimes);
    end;
  finally
    if FBlockingTCPClient <> nil then FreeAndNil(FBlockingTCPClient);
  end;
end;

initialization
  TAutoObjectFactory.Create(ComServer, TMessageSender, Class_MessageSender,
    ciMultiInstance, tmApartment);
end.