1160 lines
28 KiB
Plaintext
1160 lines
28 KiB
Plaintext
{ Copyright (c) RealThinClient components
|
|
- http://www.realthinclient.com }
|
|
|
|
unit rdChat;
|
|
|
|
interface
|
|
|
|
{$INCLUDE rtcDefs.inc}
|
|
|
|
uses
|
|
Windows, Messages, SysUtils,
|
|
Classes, Graphics, Controls, Forms,
|
|
Dialogs, StdCtrls, ComCtrls, ExtCtrls, Clipbrd,
|
|
|
|
ShellAPI,
|
|
|
|
rtcInfo, Buttons, Menus,
|
|
|
|
rtcpFileTrans,
|
|
rtcpDesktopControl,
|
|
rtcpChat, rtcpChatUI, rtcPortalMod;
|
|
|
|
const
|
|
RTC_CHAT_MAXDISPLAY:integer=2048;
|
|
|
|
type
|
|
TChatMsgType = (RTC_MSG_SELF, RTC_MSG_FRIEND,
|
|
RTC_MSG_LOGIN, RTC_MSG_LOGOUT, RTC_MSG_ERROR);
|
|
|
|
TRdUserChatField=class(TPanel)
|
|
private
|
|
FNamePanel:TPanel;
|
|
FNameLabel:TLabel;
|
|
|
|
FTextPanel:TPanel;
|
|
FTextLabel:TLabel;
|
|
FTextLabel2:TLabel;
|
|
|
|
FUser: String;
|
|
FText, FText2: String;
|
|
FCursor: String;
|
|
FTitleColor: TColor;
|
|
FPrefix: string;
|
|
FBackColor: TColor;
|
|
|
|
procedure SetText(const Value: String);
|
|
procedure SetUser(const Value: String);
|
|
procedure SetCursor(const Value: string);
|
|
procedure SetTitleColor(const Value: TColor);
|
|
procedure SetPrefix(const Value: string);
|
|
procedure SetBackColor(const Value: TColor);
|
|
|
|
public
|
|
constructor Create(AOwner:TComponent); override;
|
|
destructor Destroy; override;
|
|
|
|
procedure UpdateEvents(MouseUp:TMouseEvent);
|
|
|
|
procedure UpdateSize;
|
|
|
|
procedure NewLine;
|
|
|
|
property User:String read FUser write SetUser;
|
|
|
|
property Text:String read FText write SetText;
|
|
property Prefix:string read FPrefix write SetPrefix;
|
|
property Cursor:string read FCursor write SetCursor;
|
|
property TitleColor:TColor read FTitleColor write SetTitleColor;
|
|
property BackColor:TColor read FBackColor write SetBackColor;
|
|
end;
|
|
|
|
TrdChatForm = class(TForm)
|
|
pMain: TPanel;
|
|
pSplit: TSplitter;
|
|
pBox: TScrollBox;
|
|
mChatLog: TRichEdit;
|
|
pTitle: TPanel;
|
|
cTitle: TLabel;
|
|
Panel2: TPanel;
|
|
btnClose: TSpeedButton;
|
|
btnMinimize: TSpeedButton;
|
|
btnOnTop: TSpeedButton;
|
|
myBox: TPanel;
|
|
pTimer: TTimer;
|
|
Panel3: TPanel;
|
|
pRight: TPanel;
|
|
pBottom: TPanel;
|
|
pSize2: TPanel;
|
|
pSize1: TPanel;
|
|
pLeft: TPanel;
|
|
pTop: TPanel;
|
|
pSize4: TPanel;
|
|
pSize3: TPanel;
|
|
Panel12: TPanel;
|
|
btnLockChatBoxes: TSpeedButton;
|
|
btnClearHistory: TSpeedButton;
|
|
btnHideHistory: TSpeedButton;
|
|
btnDesktop: TSpeedButton;
|
|
btnHideTyping: TSpeedButton;
|
|
CopyPastePopupMenu: TPopupMenu;
|
|
Copy1: TMenuItem;
|
|
Paste1: TMenuItem;
|
|
HistoryPopupMenu: TPopupMenu;
|
|
miSaveHistory: TMenuItem;
|
|
miLoadHistory: TMenuItem;
|
|
dlgSaveHistory: TSaveDialog;
|
|
dlgLoadHistory: TOpenDialog;
|
|
miCopyHistory: TMenuItem;
|
|
myUI: TRtcPChatUI;
|
|
|
|
procedure FormCreate(Sender: TObject);
|
|
procedure FormKeyPress(Sender: TObject; var Key: Char);
|
|
procedure FormResize(Sender: TObject);
|
|
procedure FormClose(Sender: TObject; var Action: TCloseAction);
|
|
procedure FormDestroy(Sender: TObject);
|
|
procedure btnCloseClick(Sender: TObject);
|
|
procedure btnMinimizeClick(Sender: TObject);
|
|
procedure pTitleMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
|
|
procedure pTitleMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
|
|
procedure pTitleMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
|
|
procedure btnOnTopClick(Sender: TObject);
|
|
procedure pTimerTimer(Sender: TObject);
|
|
procedure Panel3MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
|
|
procedure Panel3MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
|
|
procedure Panel3MouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
|
|
procedure btnLockChatBoxesClick(Sender: TObject);
|
|
procedure btnHideHistoryClick(Sender: TObject);
|
|
procedure btnClearHistoryClick(Sender: TObject);
|
|
procedure btnDesktopClick(Sender: TObject);
|
|
procedure btnHideTypingClick(Sender: TObject);
|
|
procedure CopyPasteMouseEvent(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
|
|
procedure Copy1Click(Sender: TObject);
|
|
procedure Paste1Click(Sender: TObject);
|
|
procedure miSaveHistoryClick(Sender: TObject);
|
|
procedure miLoadHistoryClick(Sender: TObject);
|
|
procedure miCopyHistoryClick(Sender: TObject);
|
|
|
|
procedure myUIUserJoined(Sender: TRtcPChatUI);
|
|
procedure myUIUserLeft(Sender: TRtcPChatUI);
|
|
procedure myUIMessage(Sender: TRtcPChatUI);
|
|
procedure myUIError(Sender: TRtcPChatUI);
|
|
procedure myUIInit(Sender: TRtcPChatUI);
|
|
procedure myUILogOut(Sender: TRtcPChatUI);
|
|
procedure myUIOpen(Sender: TRtcPChatUI);
|
|
procedure myUIClose(Sender: TRtcPChatUI);
|
|
procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
|
|
|
|
protected
|
|
{ Private declarations }
|
|
FReady:boolean;
|
|
|
|
FMe:TrdUserChatField;
|
|
FLastUser: string;
|
|
FLastColor:integer;
|
|
FOtherCnt:integer;
|
|
FOthers:TRtcInfo;
|
|
|
|
FOnTop:boolean;
|
|
FLockBoxes:boolean;
|
|
FHideTyping:boolean;
|
|
FHideHistory:boolean;
|
|
|
|
function TopLoc(const user:string):integer;
|
|
procedure UpdateAllSizes;
|
|
function NextFreeColor:TColor;
|
|
|
|
procedure AddMessage(const uname, text: string; msgType:TChatMsgType; Color:TColor);
|
|
procedure AddUser(const uname:string);
|
|
procedure RemUser(const uname:string);
|
|
|
|
procedure Open_Form(const mode:string);
|
|
procedure Close_Form(const mode:string);
|
|
|
|
procedure CreateParams(Var params: TCreateParams); override;
|
|
|
|
{$IFNDEF RtcViewer}
|
|
// declare our DROPFILES message handler
|
|
procedure AcceptFiles( var msg : TMessage ); message WM_DROPFILES;
|
|
{$ENDIF}
|
|
|
|
public
|
|
PFileTrans:TRtcPFileTransfer;
|
|
PDesktopControl:TRtcPDesktopControl;
|
|
|
|
procedure NotOnTop;
|
|
|
|
property UI:TRtcPChatUI read myUI;
|
|
end;
|
|
|
|
implementation
|
|
|
|
{$R *.dfm}
|
|
|
|
var
|
|
CChatFriendName:TColor = clGray;
|
|
CChatMyName:TColor = clGray;
|
|
CChatSystem:TColor = clRed;
|
|
CChatLogin:TColor = clGreen;
|
|
CChatLogout:TColor = clMaroon;
|
|
|
|
{ TRdUserChatField }
|
|
|
|
constructor TRdUserChatField.Create(AOwner: TComponent);
|
|
begin
|
|
inherited;
|
|
|
|
FUser:='';
|
|
FText:='';
|
|
FText2:='';
|
|
FCursor:='';
|
|
FPrefix:='';
|
|
|
|
FTitleColor:=clGray;
|
|
FBackColor:=clWhite;
|
|
|
|
FNamePanel := TPanel.Create(nil);
|
|
with FNamePanel do
|
|
begin
|
|
Parent := self;
|
|
Align := alTop;
|
|
BorderWidth := 2;
|
|
|
|
ParentColor := False;
|
|
Color:= FTitleColor;
|
|
end;
|
|
|
|
FNameLabel := TLabel.Create(nil);
|
|
with FNameLabel do
|
|
begin
|
|
Parent := FNamePanel;
|
|
Align := alTop;
|
|
Font.Size := 10;
|
|
|
|
ParentColor := False;
|
|
ParentFont := False;
|
|
Transparent := False;
|
|
|
|
Color := FTitleColor;
|
|
Font.Color := clWhite;
|
|
|
|
WordWrap:=False;
|
|
Caption:= 'NameLabel';
|
|
end;
|
|
|
|
FTextPanel := TPanel.Create(nil);
|
|
with FTextPanel do
|
|
begin
|
|
Parent := self;
|
|
Align := alTop;
|
|
BorderWidth := 4;
|
|
|
|
ParentColor := False;
|
|
ParentFont := False;
|
|
Color := FBackColor;
|
|
|
|
BevelOuter := bvLowered;
|
|
end;
|
|
|
|
FTextLabel2:= TLabel.Create(nil);
|
|
with FTextLabel2 do
|
|
begin
|
|
Visible:=False;
|
|
|
|
Parent := FTextPanel;
|
|
Align := alTop;
|
|
|
|
Font.Size := 10;
|
|
|
|
ParentColor := False;
|
|
ParentFont := False;
|
|
Transparent := False;
|
|
|
|
Color := FBackColor;
|
|
Font.Color := clBlack;
|
|
|
|
WordWrap := True;
|
|
end;
|
|
|
|
FTextLabel:= TLabel.Create(nil);
|
|
with FTextLabel do
|
|
begin
|
|
Parent := FTextPanel;
|
|
Align := alTop;
|
|
|
|
Font.Size := 10;
|
|
|
|
ParentColor := False;
|
|
ParentFont := False;
|
|
Transparent := False;
|
|
|
|
Color := FBackColor;
|
|
Font.Color := clBlack;
|
|
|
|
WordWrap := True;
|
|
end;
|
|
end;
|
|
|
|
destructor TRdUserChatField.Destroy;
|
|
begin
|
|
FNameLabel.Free;
|
|
FTextLabel.Free;
|
|
FTextLabel2.Free;
|
|
FNamePanel.Free;
|
|
FTextPanel.Free;
|
|
inherited;
|
|
end;
|
|
|
|
procedure TRdUserChatField.UpdateEvents(MouseUp:TMouseEvent);
|
|
begin
|
|
FTextLabel2.OnMouseUp := MouseUp;
|
|
FTextLabel.OnMouseUp := MouseUp;
|
|
end;
|
|
|
|
procedure TRdUserChatField.NewLine;
|
|
begin
|
|
FText2:=FText;
|
|
FText:='';
|
|
if FText2<>'' then
|
|
begin
|
|
if not FTextLabel2.Visible then
|
|
begin
|
|
FTextLabel2.AutoSize:=False;
|
|
FTextLabel2.Align:=alTop;
|
|
FTextLabel2.Top:=0;
|
|
FTextLabel2.Caption:=FText2;
|
|
FTextLabel2.Visible:=True;
|
|
FTextLabel2.AutoSize:=True;
|
|
end
|
|
else
|
|
FTextLabel2.Caption:=FText2;
|
|
FTextLabel.Caption:=FPrefix+FText+FCursor;
|
|
end
|
|
else
|
|
begin
|
|
FTextLabel2.Visible:=False;
|
|
FTextLabel.Caption:=FPrefix+FText+FCursor;
|
|
end;
|
|
end;
|
|
|
|
procedure TRdUserChatField.SetCursor(const Value: string);
|
|
begin
|
|
FCursor := Value;
|
|
FTextLabel.Caption:=FPrefix+FText+FCursor;
|
|
end;
|
|
|
|
procedure TRdUserChatField.SetPrefix(const Value: string);
|
|
begin
|
|
FPrefix := Value;
|
|
FTextLabel.Caption:=FPrefix+FText+FCursor;
|
|
end;
|
|
|
|
procedure TRdUserChatField.SetText(const Value: String);
|
|
begin
|
|
FText := Value;
|
|
FTextLabel.Caption:=FPrefix+FText+FCursor;
|
|
end;
|
|
|
|
procedure TRdUserChatField.SetTitleColor(const Value: TColor);
|
|
begin
|
|
FTitleColor := Value;
|
|
FNamePanel.Color := FTitleColor;
|
|
FNameLabel.Color := FTitleColor;
|
|
FTextLabel2.Font.Color := FTitleColor;
|
|
end;
|
|
|
|
procedure TRdUserChatField.SetBackColor(const Value: TColor);
|
|
begin
|
|
FBackColor := Value;
|
|
FTextPanel.Color := FBackColor;
|
|
FTextLabel.Color := FBackColor;
|
|
FTextLabel2.Color := FBackColor;
|
|
end;
|
|
|
|
procedure TRdUserChatField.SetUser(const Value: String);
|
|
begin
|
|
FUser := Value;
|
|
FNameLabel.Caption:=FUser;
|
|
end;
|
|
|
|
procedure TRdUserChatField.UpdateSize;
|
|
begin
|
|
FTextLabel2.Font.Color:=FTitleColor;
|
|
FTextLabel2.Color:=FBackColor;
|
|
|
|
FTextLabel.Font.Color:=clBlack;
|
|
FTextLabel.Color:=FBackColor;
|
|
|
|
FNameLabel.Font.Color:=clWhite;
|
|
FNameLabel.Color:=FTitleColor;
|
|
|
|
FTextLabel2.AutoSize:=False;
|
|
FTextLabel2.AutoSize:=True;
|
|
|
|
FTextLabel.AutoSize:=False;
|
|
FTextLabel.AutoSize:=True;
|
|
|
|
FTextPanel.AutoSize:=False;
|
|
FTextPanel.AutoSize:=True;
|
|
|
|
FNameLabel.AutoSize:=False;
|
|
FNameLabel.AutoSize:=True;
|
|
|
|
FNamePanel.AutoSize:=False;
|
|
FNamePanel.AutoSize:=True;
|
|
|
|
AutoSize:=False;
|
|
AutoSize:=True;
|
|
end;
|
|
|
|
{ TrdChatForm }
|
|
|
|
{$IFNDEF RtcViewer}
|
|
procedure TrdChatForm.AcceptFiles( var msg : TMessage );
|
|
const
|
|
cnMaxFileNameLen = 1024;
|
|
var
|
|
i,
|
|
nCount : integer;
|
|
acFileName : array [0..cnMaxFileNameLen] of char;
|
|
myFileName : string;
|
|
begin
|
|
// find out how many files we're accepting
|
|
nCount := DragQueryFile( msg.WParam,
|
|
$FFFFFFFF,
|
|
acFileName,
|
|
cnMaxFileNameLen );
|
|
|
|
try
|
|
// query Windows one at a time for the file name
|
|
for i := 0 to nCount-1 do
|
|
begin
|
|
DragQueryFile( msg.WParam, i, acFileName, cnMaxFileNameLen );
|
|
|
|
if assigned(PFileTrans) then
|
|
begin
|
|
myFileName:=acFileName;
|
|
PFileTrans.Send(myUI.UserName, myFileName);
|
|
end;
|
|
end;
|
|
finally
|
|
// let Windows know that you're done
|
|
DragFinish( msg.WParam );
|
|
end;
|
|
end;
|
|
{$ENDIF}
|
|
|
|
procedure TrdChatForm.CreateParams(Var params: TCreateParams);
|
|
begin
|
|
inherited CreateParams( params );
|
|
params.ExStyle := params.ExStyle or WS_EX_APPWINDOW;
|
|
params.WndParent := GetDeskTopWindow;
|
|
end;
|
|
|
|
procedure TrdChatForm.FormCreate(Sender: TObject);
|
|
begin
|
|
FReady:=False;
|
|
|
|
FOnTop:=False;
|
|
FLockBoxes:=False;
|
|
FHideTyping:=False;
|
|
FHideHistory:=False;
|
|
|
|
FOthers:=nil;
|
|
FOtherCnt:=0;
|
|
pTimer.Enabled:=False;
|
|
|
|
// This is absolutely needed! Without this, the RichEdit won't scroll
|
|
// to the end automatically! Don't ask me why though...
|
|
mChatLog.HideSelection := False;
|
|
mChatLog.HideScrollBars := True;
|
|
end;
|
|
|
|
function TrdChatForm.TopLoc(const user:string): integer;
|
|
var
|
|
a:integer;
|
|
xTop:integer;
|
|
uname:string;
|
|
pan:TRdUserChatField;
|
|
begin
|
|
xTop:=MaxLongint;
|
|
if assigned(FOthers) then
|
|
for a:=FOthers.FieldCount-1 downto 0 do
|
|
begin
|
|
uname:=FOthers.FieldName[a];
|
|
if (uname<>user) and FOthers.asBoolean[uname] then
|
|
begin
|
|
pan:=TRdUserChatField(FOthers.asPtr[uname]);
|
|
if assigned(pan) then
|
|
if length(pan.Text)=0 then
|
|
if pan.Top<xTop then
|
|
xTop:=pan.Top;
|
|
end;
|
|
end;
|
|
Result:=xTop;
|
|
end;
|
|
|
|
procedure TrdChatForm.FormKeyPress(Sender: TObject; var Key: Char);
|
|
var
|
|
s:string;
|
|
begin
|
|
if assigned(myUI.Module) and assigned(FMe) and assigned(FOthers) then
|
|
begin
|
|
if ActiveControl=mChatLog then
|
|
myBox.SetFocus;
|
|
|
|
if Key=^V then
|
|
begin
|
|
s:=Clipboard.asText;
|
|
if Copy(s,length(s),1)=#10 then Delete(s,length(s),1);
|
|
if Copy(s,length(s),1)=#13 then Delete(s,length(s),1);
|
|
if s<>'' then
|
|
begin
|
|
if length(FMe.Text)>0 then
|
|
begin
|
|
AddMessage(myUI.Module.Client.LoginUsername, FMe.Text,RTC_MSG_SELF,clBlack);
|
|
if FHideTyping then
|
|
myUI.Send(FMe.Text);
|
|
FMe.NewLine;
|
|
end;
|
|
{ add one space if we are sending a single character from clipboard,
|
|
to differentiate from the case where a user has pressed a key. }
|
|
if length(s)=1 then
|
|
s:=s+' ';
|
|
if length(s)<=RTC_CHAT_MAXDISPLAY then
|
|
FMe.Text:=s
|
|
else
|
|
FMe.Text:=Copy(s,1,RTC_CHAT_MAXDISPLAY)+' ...';
|
|
FMe.NewLine;
|
|
AddMessage(myUI.Module.Client.LoginUsername,s,RTC_MSG_SELF, clBlack);
|
|
myUI.Send(s);
|
|
end;
|
|
end
|
|
else if Key=#8 then
|
|
begin
|
|
if length(FMe.Text)>0 then
|
|
begin
|
|
FMe.Text:=Copy(FMe.Text,1,length(FMe.Text)-1);
|
|
if not FHideTyping then
|
|
myUI.Send(#8)
|
|
else if length(FMe.Text)=0 then
|
|
myUI.Send(#0); // clear "<typing a message ...>" text
|
|
end;
|
|
end
|
|
else if Key=#13 then
|
|
begin
|
|
if length(FMe.Text)>0 then
|
|
begin
|
|
AddMessage(myUI.Module.Client.LoginUsername,FMe.Text,RTC_MSG_SELF, clBlack);
|
|
if FHideTyping then
|
|
myUI.Send(FMe.Text);
|
|
end;
|
|
FMe.NewLine;
|
|
if not FHideTyping then
|
|
myUI.Send(#13);
|
|
end
|
|
else if Key>=#32 then
|
|
begin
|
|
FMe.Text:=FMe.Text+Key;
|
|
if not FHideTyping then
|
|
myUI.Send(Key)
|
|
else if length(FMe.Text)=1 then
|
|
myUI.Send(#1); // send "<typing a message ...>" text
|
|
end;
|
|
end
|
|
else
|
|
MessageBeep(0);
|
|
Key:=#0;
|
|
end;
|
|
|
|
procedure TrdChatForm.FormResize(Sender: TObject);
|
|
begin
|
|
UpdateAllSizes;
|
|
end;
|
|
|
|
procedure TrdChatForm.UpdateAllSizes;
|
|
var
|
|
a:integer;
|
|
uname:string;
|
|
pan:TRdUserChatField;
|
|
begin
|
|
if assigned(FMe) then
|
|
FMe.UpdateSize;
|
|
if assigned(FOthers) then
|
|
for a:=0 to FOthers.FieldCount-1 do
|
|
begin
|
|
uname:=FOthers.FieldName[a];
|
|
if FOthers.asBoolean[uname] then
|
|
begin
|
|
pan:=TRdUserChatField(FOthers.asPtr[uname]);
|
|
if assigned(pan) then
|
|
pan.UpdateSize;
|
|
end;
|
|
end;
|
|
mChatLog.Refresh;
|
|
end;
|
|
|
|
procedure TrdChatForm.AddMessage(const uname, text: string; msgType:TChatMsgType; Color:TColor);
|
|
begin
|
|
mChatLog.Lines.BeginUpdate;
|
|
mChatLog.Paragraph.FirstIndent := 0;
|
|
case msgType of
|
|
RTC_MSG_SELF:
|
|
begin
|
|
if FLastUser<>uname then
|
|
begin
|
|
FLastUser:=uname;
|
|
mChatLog.SelAttributes.Color:=CChatMyName;
|
|
mChatLog.SelAttributes.Style:=[];
|
|
mChatLog.Lines.Add(uname + ':');
|
|
end;
|
|
mChatLog.SelAttributes.Color:=Color;
|
|
mChatLog.SelAttributes.Style:=[];
|
|
mChatLog.Lines.Add(' '+text);
|
|
end;
|
|
RTC_MSG_FRIEND:
|
|
begin
|
|
if FLastUser<>uname then
|
|
begin
|
|
FLastUser:=uname;
|
|
mChatLog.SelAttributes.Color:=CChatFriendName;
|
|
mChatLog.SelAttributes.Style:=[];
|
|
mChatLog.Lines.Add(uname + ':');
|
|
end;
|
|
mChatLog.SelAttributes.Color:=Color;
|
|
mChatLog.SelAttributes.Style:=[fsBold];
|
|
mChatLog.Lines.Add(' '+text);
|
|
end;
|
|
RTC_MSG_ERROR:
|
|
begin
|
|
FLastUser:='';
|
|
mChatLog.SelAttributes.Color:=Color;
|
|
mChatLog.SelAttributes.Style:=[fsBold];
|
|
mChatLog.Lines.Add(uname + ' '+ text);
|
|
click;
|
|
end;
|
|
RTC_MSG_LOGIN:
|
|
begin
|
|
FLastUser:='';
|
|
mChatLog.SelAttributes.Color:=Color;
|
|
mChatLog.SelAttributes.Style:=[];
|
|
mChatLog.Lines.Add(uname +' '+ text);
|
|
end;
|
|
RTC_MSG_LOGOUT:
|
|
begin
|
|
FLastUser:='';
|
|
mChatLog.SelAttributes.Color:=Color;
|
|
mChatLog.SelAttributes.Style:=[];
|
|
mChatLog.Lines.Add(uname +' '+ text);
|
|
end;
|
|
end;
|
|
mChatLog.Lines.EndUpdate;
|
|
end;
|
|
|
|
procedure TrdChatForm.FormClose(Sender: TObject; var Action: TCloseAction);
|
|
begin
|
|
Action:=caFree;
|
|
end;
|
|
|
|
procedure TrdChatForm.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
|
|
begin
|
|
CanClose:=myUI.CloseAndClear;
|
|
end;
|
|
|
|
procedure TrdChatForm.myUILogOut(Sender: TRtcPChatUI);
|
|
begin
|
|
Close;
|
|
end;
|
|
|
|
procedure TrdChatForm.FormDestroy(Sender: TObject);
|
|
begin
|
|
pTimer.Enabled:=False;
|
|
if assigned(FOthers) then
|
|
begin
|
|
FOthers.Free;
|
|
FOthers:=nil;
|
|
end;
|
|
end;
|
|
|
|
function TrdChatForm.NextFreeColor: TColor;
|
|
begin
|
|
case FLastColor of
|
|
0:Result:=clMaroon;
|
|
1:Result:=clNavy;
|
|
2:Result:=clGreen;
|
|
3:Result:=clPurple;
|
|
else Result:=clTeal;
|
|
end;
|
|
Inc(FLastColor);
|
|
if FLastColor>4 then FLastColor:=0;
|
|
end;
|
|
|
|
procedure TrdChatForm.btnCloseClick(Sender: TObject);
|
|
begin
|
|
Close;
|
|
end;
|
|
|
|
procedure TrdChatForm.btnMinimizeClick(Sender: TObject);
|
|
begin
|
|
WindowState:=wsMinimized;
|
|
end;
|
|
|
|
procedure TrdChatForm.btnOnTopClick(Sender: TObject);
|
|
begin
|
|
FOnTop:=not FOnTop;
|
|
if FOnTop then
|
|
begin
|
|
btnOnTop.Caption:='Normal';
|
|
FormStyle:=fsStayonTop;
|
|
end
|
|
else
|
|
begin
|
|
FormStyle:=fsNormal;
|
|
btnOnTop.Caption:='To Top';
|
|
end;
|
|
{$IFNDEF RtcViewer}
|
|
if assigned(FOthers) then
|
|
// tell Windows that you're
|
|
// accepting drag and drop files
|
|
DragAcceptFiles( Handle, True );
|
|
{$ENDIF}
|
|
end;
|
|
|
|
procedure TrdChatForm.btnLockChatBoxesClick(Sender: TObject);
|
|
begin
|
|
FLockBoxes:=not FLockBoxes;
|
|
if FLockBoxes then
|
|
btnLockChatBoxes.Caption:='Unlock Boxes'
|
|
else
|
|
btnLockChatBoxes.Caption:='Lock Chat Boxes';
|
|
end;
|
|
|
|
procedure TrdChatForm.pTimerTimer(Sender: TObject);
|
|
begin
|
|
// Disable the Timer for the blinking cursor Chat when loses focus September 18 2007, Alejandro Romero Parra
|
|
If GetForegroundWindow = self.WindowHandle then
|
|
Begin
|
|
if assigned(FMe) and assigned(FOthers) then
|
|
if FMe.Cursor='|' then
|
|
FMe.Cursor:=' '
|
|
else
|
|
FMe.Cursor:='|';
|
|
End
|
|
Else
|
|
FMe.Cursor:=' ';
|
|
end;
|
|
|
|
var
|
|
LMouseX,LMouseY:integer;
|
|
LMouseD:boolean=False;
|
|
|
|
procedure TrdChatForm.pTitleMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
|
|
begin
|
|
LMouseD:=True;
|
|
LMouseX:=X;LMouseY:=Y;
|
|
end;
|
|
|
|
procedure TrdChatForm.pTitleMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
|
|
begin
|
|
if LMouseD then
|
|
SetBounds(Left+X-LMouseX,Top+Y-LMouseY,Width,Height);
|
|
end;
|
|
|
|
procedure TrdChatForm.pTitleMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
|
|
begin
|
|
LMouseD:=False;
|
|
end;
|
|
|
|
var
|
|
LMouseX2,LMouseY2:integer;
|
|
LMouseD2:boolean=False;
|
|
|
|
procedure TrdChatForm.Panel3MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
|
|
begin
|
|
LMouseX2:=X;
|
|
LMouseY2:=Y;
|
|
LMouseD2:=True;
|
|
end;
|
|
|
|
procedure TrdChatForm.Panel3MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
|
|
begin
|
|
if LMouseD2 then
|
|
begin
|
|
if Sender=pRight then
|
|
SetBounds(Left,Top,Width+X-LMouseX2,Height)
|
|
else if Sender=pBottom then
|
|
SetBounds(Left,Top,Width,Height+Y-LMouseY2)
|
|
else if Sender=pLeft then
|
|
SetBounds(Left+X-LMouseX2,Top,Width-X+LMouseX2,Height)
|
|
else if Sender=pTop then
|
|
SetBounds(Left,Top+Y-LMouseY2,Width,Height-Y+LMouseY2)
|
|
else if (Sender=pSize1) or (Sender=pSize2) then
|
|
SetBounds(Left,Top,Width+X-LMouseX2,Height+Y-LMouseY2)
|
|
else
|
|
SetBounds(Left+X-LMouseX2,Top+Y-LMouseY2,Width-X+LMouseX2,Height-Y+LMouseY2);
|
|
end;
|
|
end;
|
|
|
|
procedure TrdChatForm.Panel3MouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
|
|
begin
|
|
LMouseD2:=False;
|
|
end;
|
|
|
|
procedure TrdChatForm.btnHideHistoryClick(Sender: TObject);
|
|
begin
|
|
FHideHistory:=not FHideHistory;
|
|
if FHideHistory then
|
|
begin
|
|
pMain.Visible:=False;
|
|
pSplit.Visible:=False;
|
|
btnHideHistory.Caption:='Show History';
|
|
end
|
|
else
|
|
begin
|
|
pMain.Visible:=True;
|
|
pSplit.Visible:=True;
|
|
pMain.Top:=pTitle.Height;
|
|
pSplit.Top:=pMain.Top+pMain.Height;
|
|
btnHideHistory.Caption:='Hide History';
|
|
end;
|
|
end;
|
|
|
|
procedure TrdChatForm.btnClearHistoryClick(Sender: TObject);
|
|
begin
|
|
FLastUser:='';
|
|
mChatLog.Lines.BeginUpdate;
|
|
mChatLog.Lines.Clear;
|
|
mChatLog.Lines.EndUpdate;
|
|
end;
|
|
|
|
procedure TrdChatForm.btnDesktopClick(Sender: TObject);
|
|
begin
|
|
if assigned(PDesktopControl) then
|
|
PDesktopControl.Open(myUI.UserName);
|
|
end;
|
|
|
|
procedure TrdChatForm.NotOnTop;
|
|
begin
|
|
if FOnTop then
|
|
btnOnTopClick(btnOnTop);
|
|
end;
|
|
|
|
procedure TrdChatForm.btnHideTypingClick(Sender: TObject);
|
|
begin
|
|
FHideTyping:=not FHideTyping;
|
|
if FHideTyping then
|
|
begin
|
|
if length(FMe.Text)>0 then
|
|
begin
|
|
AddMessage(myUI.Module.Client.LoginUsername, FMe.Text,RTC_MSG_SELF, clBlack);
|
|
FMe.NewLine;
|
|
myUI.Send(#13);
|
|
end;
|
|
btnHideTyping.Caption:='Show my Typing';
|
|
end
|
|
else
|
|
begin
|
|
if length(FMe.Text)>0 then
|
|
begin
|
|
AddMessage(myUI.Module.Client.LoginUsername, FMe.Text,RTC_MSG_SELF, clBlack);
|
|
myUI.Send(FMe.Text);
|
|
FMe.NewLine;
|
|
end;
|
|
btnHideTyping.Caption:='Hide my Typing';
|
|
end;
|
|
end;
|
|
|
|
var
|
|
PopupField:TLabel;
|
|
|
|
procedure TrdChatForm.CopyPasteMouseEvent(Sender: TObject; Button: TMouseButton;
|
|
Shift: TShiftState; X, Y: Integer);
|
|
var
|
|
P:TPoint;
|
|
begin
|
|
If (Button = mbRight) and (Sender is TLabel) then
|
|
begin
|
|
GetCursorPos(P);
|
|
PopupField:=TLabel(Sender);
|
|
CopyPastePopupMenu.Popup(P.X,P.Y);
|
|
end;
|
|
end;
|
|
|
|
procedure TrdChatForm.Copy1Click(Sender: TObject);
|
|
begin
|
|
ClipBoard.AsText:=PopupField.Caption;
|
|
end;
|
|
|
|
procedure TrdChatForm.Paste1Click(Sender: TObject);
|
|
Var
|
|
i: Integer;
|
|
Text: String;
|
|
begin
|
|
If Clipboard.HasFormat(CF_TEXT) and (Clipboard.AsText <> '') then
|
|
Begin
|
|
Text := Clipboard.AsText;
|
|
For i := 1 to length(Text) do
|
|
FormKeyPress(nil, Text[i]);
|
|
End;
|
|
end;
|
|
|
|
procedure TrdChatForm.miSaveHistoryClick(Sender: TObject);
|
|
begin
|
|
If dlgSaveHistory.Execute then
|
|
Begin
|
|
mChatLog.Lines.BeginUpdate;
|
|
mChatLog.Lines.SaveToFile(dlgSaveHistory.FileName);
|
|
mChatLog.Lines.EndUpdate;
|
|
End;
|
|
end;
|
|
|
|
procedure TrdChatForm.miLoadHistoryClick(Sender: TObject);
|
|
begin
|
|
If dlgLoadHistory.Execute then
|
|
begin
|
|
mChatLog.Lines.BeginUpdate;
|
|
mChatLog.Lines.LoadFromFile(dlgLoadHistory.FileName);
|
|
mChatLog.Lines.EndUpdate;
|
|
End;
|
|
end;
|
|
|
|
procedure TrdChatForm.miCopyHistoryClick(Sender: TObject);
|
|
begin
|
|
Clipboard.AsText:=mChatLog.Lines.Text;
|
|
end;
|
|
|
|
procedure TrdChatForm.AddUser(const uname: string);
|
|
var
|
|
pan:TRdUserChatField;
|
|
begin
|
|
pan:=TRdUserChatField(FOthers.asPtr[uname]);
|
|
if not assigned(pan) then
|
|
begin
|
|
Inc(FOtherCnt);
|
|
pan:=TRdUserChatField.Create(self);
|
|
pan.Parent:=pBox;
|
|
pan.Align:=alTop;
|
|
pan.UpdateEvents(CopyPasteMouseEvent);
|
|
|
|
FOthers.asPtr[uname]:=pan;
|
|
FOthers.asBoolean[uname]:=True;
|
|
|
|
pan.TitleColor:=NextFreeColor;
|
|
pan.BackColor:=$E0E0E0;
|
|
pan.Text:='';
|
|
pan.Cursor:='~';
|
|
pan.User:=uname;
|
|
pan.UpdateSize;
|
|
if not FLockBoxes then
|
|
if pan.Top>TopLoc(uname) then
|
|
pan.Top:=TopLoc(uname);
|
|
|
|
AddMessage(uname, 'has JOINED the Chat.', RTC_MSG_LOGIN, pan.TitleColor);
|
|
end
|
|
else if not FLockBoxes then
|
|
if pan.Top>TopLoc(uname) then
|
|
pan.Top:=TopLoc(uname);
|
|
end;
|
|
|
|
procedure TrdChatForm.myUIUserJoined(Sender: TRtcPChatUI);
|
|
begin
|
|
AddUser(myUI.Recv_User);
|
|
end;
|
|
|
|
procedure TrdChatForm.RemUser(const uname: string);
|
|
var
|
|
pan:TRdUserChatField;
|
|
begin
|
|
if assigned(FOthers) then // and (uname<>LoginName) then
|
|
begin
|
|
pan:=TrdUserChatField(FOthers.asPtr[uname]);
|
|
if assigned(pan) then
|
|
begin
|
|
Dec(FOtherCnt);
|
|
if length(pan.Text)>0 then
|
|
AddMessage(uname, pan.Text, RTC_MSG_FRIEND, pan.TitleColor);
|
|
AddMessage(uname, 'has LEFT the Chat.', RTC_MSG_LOGOUT, CChatLogout);
|
|
pan.Visible:=False;
|
|
pan.Parent:=nil;
|
|
pan.Free;
|
|
FOthers.asBoolean[uname]:=False;
|
|
FOthers.asPtr[uname]:=nil;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TrdChatForm.myUIUserLeft(Sender: TRtcPChatUI);
|
|
begin
|
|
RemUser(myUI.Recv_User);
|
|
end;
|
|
|
|
procedure TrdChatForm.myUIMessage(Sender: TRtcPChatUI);
|
|
var
|
|
pan:TRdUserChatField;
|
|
uname, text:string;
|
|
begin
|
|
uname:=myUI.Recv_User;
|
|
text:=myUI.Recv_Message;
|
|
|
|
// if we are not the Host, we will also be receiving our messages
|
|
if uname=myUI.Module.Client.LoginUsername then Exit;
|
|
|
|
// If we are not the Host, we will not be notified about a new user
|
|
// if the user was already inside the chat when we arrived.
|
|
AddUser(uname);
|
|
|
|
if GetForegroundWindow<>Handle then
|
|
begin
|
|
if WindowState=wsMinimized then
|
|
begin
|
|
WindowState:=wsNormal;
|
|
BringToFront;
|
|
BringWindowToTop(Handle);
|
|
MessageBeep(0);
|
|
end;
|
|
end;
|
|
|
|
pan:=TRdUserChatField(FOthers.asPtr[uname]);
|
|
if assigned(pan) then
|
|
begin
|
|
if text=#1 then
|
|
pan.Cursor:='Typing ...'
|
|
else if text=#0 then
|
|
pan.Cursor:='~'
|
|
else if text=#8 then
|
|
begin
|
|
if length(pan.Text)>0 then
|
|
pan.Text:=Copy(pan.Text,1,length(pan.Text)-1);
|
|
end
|
|
else if text=#13 then
|
|
begin
|
|
if length(pan.Text)>0 then
|
|
AddMessage(uname,pan.Text,RTC_MSG_FRIEND,pan.TitleColor);
|
|
pan.NewLine;
|
|
end
|
|
else if length(text)=1 then
|
|
pan.Text:=pan.Text+text
|
|
else if length(text)>0 then
|
|
begin
|
|
pan.Cursor:='~';
|
|
if length(pan.Text)>0 then
|
|
begin
|
|
AddMessage(uname,pan.Text,RTC_MSG_FRIEND,pan.TitleColor);
|
|
pan.NewLine;
|
|
end;
|
|
if length(text)<=RTC_CHAT_MAXDISPLAY then
|
|
pan.Text:=text
|
|
else
|
|
pan.Text:=Copy(pan.Text,1,RTC_CHAT_MAXDISPLAY)+'...';
|
|
AddMessage(uname,text,RTC_MSG_FRIEND,pan.TitleColor);
|
|
pan.NewLine;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TrdChatForm.Open_Form(const mode: string);
|
|
begin
|
|
btnDesktop.Visible:=Assigned(PDesktopControl);
|
|
|
|
Left:=Screen.Width-Width;
|
|
Top:=Screen.Height-Height-40;
|
|
|
|
Caption:=mode+myUI.UserName+' - Chat';
|
|
cTitle.Caption:=mode+'Chat - '+myUI.UserName;
|
|
|
|
FLastUser:='';
|
|
FLastColor:=0;
|
|
|
|
if not assigned(FOthers) then
|
|
FOthers:=TRtcInfo.Create;
|
|
|
|
if not assigned(FMe) then
|
|
begin
|
|
FMe:=TRdUserChatField.Create(self);
|
|
FMe.Parent:=myBox;
|
|
FMe.Align:=alTop;
|
|
FMe.UpdateEvents(CopyPasteMouseEvent);
|
|
FMe.Top:=0;
|
|
|
|
FMe.TitleColor:=clGray;
|
|
FMe.BackColor:=clWhite;
|
|
end;
|
|
|
|
FMe.Prefix:='';
|
|
FMe.Cursor:='|';
|
|
FMe.Text:='';
|
|
FMe.User:=myUI.Module.Client.LoginUsername;
|
|
UpdateAllSizes;
|
|
|
|
pTimer.Enabled:=True;
|
|
|
|
{$IFNDEF RtcViewer}
|
|
// tell Windows that you're
|
|
// accepting drag and drop files
|
|
DragAcceptFiles( Handle, True );
|
|
{$ENDIF}
|
|
|
|
FReady:=True;
|
|
end;
|
|
|
|
procedure TrdChatForm.myUIInit(Sender: TRtcPChatUI);
|
|
begin
|
|
if not FReady then Open_Form('(Init) ');
|
|
end;
|
|
|
|
procedure TrdChatForm.myUIOpen(Sender: TRtcPChatUI);
|
|
begin
|
|
Open_Form('');
|
|
end;
|
|
|
|
procedure TrdChatForm.Close_Form(const mode: string);
|
|
var
|
|
a:integer;
|
|
user:string;
|
|
begin
|
|
Caption:=mode+myUI.UserName+' - Chat';
|
|
cTitle.Caption:=mode+'Chat - '+myUI.UserName;
|
|
|
|
if assigned(FOthers) then
|
|
begin
|
|
for a:=FOthers.Count-1 downto 0 do
|
|
begin
|
|
user:=FOthers.FieldName[a];
|
|
RemUser(user);
|
|
end;
|
|
|
|
FOthers.Free;
|
|
FOthers:=nil;
|
|
end;
|
|
|
|
FMe.Prefix:='';
|
|
FMe.Cursor:='|';
|
|
FMe.Text:='';
|
|
FMe.Cursor:=' ';
|
|
pTimer.Enabled:=False;
|
|
|
|
{$IFNDEF RtcViewer}
|
|
// tell Windows that you're
|
|
// accepting drag and drop files
|
|
DragAcceptFiles( Handle, False );
|
|
{$ENDIF}
|
|
|
|
FReady:=False;
|
|
end;
|
|
|
|
procedure TrdChatForm.myUIClose(Sender: TRtcPChatUI);
|
|
begin
|
|
Close_Form('(Closed) ');
|
|
if WindowState=wsMinimized then Close;
|
|
end;
|
|
|
|
procedure TrdChatForm.myUIError(Sender: TRtcPChatUI);
|
|
begin
|
|
Close_Form('(DISCONNECTED) ');
|
|
// we disconnected. can not use this chat window anymore.
|
|
myUI.Module:=nil;
|
|
if WindowState=wsMinimized then Close;
|
|
end;
|
|
|
|
end.
|