© BigSpeed Computing Inc. - Mastering algorithms
// *** Delphi example of secure private video chat client ***
unit uMain;
interface
uses
ActiveX, Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ShlObj, StdCtrls, ComCtrls, ToolWin, Menus, ActnList, ImgList, StrUtils, Contnrs,
ExtCtrls, Registry, Variants, ShellAPI, Buttons, IniFiles, MMSystem,
bsVidChatCln_TLB, bsErrors, Globals, uChat, uAlert, uInFile, uOutFile,
uSettings;
type
TfMain = class(TForm)
StatusBar: TStatusBar;
Timer1: TTimer;
GroupBox3: TGroupBox;
btnConnect: TButton;
btnDisconnect: TButton;
btnCancel: TButton;
btnExit: TButton;
btnAbout: TButton;
GroupBox1: TGroupBox;
lvPeers: TListView;
btnRemove: TButton;
btnChat: TButton;
btnAlert: TButton;
btnSettings: TButton;
btnMyIP: TButton;
btnMakeCall: TButton;
grpCall: TGroupBox;
btnSendFile: TButton;
pntMic: TPaintBox;
Label6: TLabel;
Label1: TLabel;
btnMuteRecording: TSpeedButton;
btnEndCall: TButton;
btnCancelCalling: TButton;
dlgOpen: TOpenDialog;
dlgSave: TSaveDialog;
lblRecording: TLabel;
lblVoiceDelay: TLabel;
lblOverloading: TLabel;
pnlCaller: TPanel;
Panel1: TPanel;
btnMutePlayback: TSpeedButton;
trkTrigger: TTrackBar;
btnLocCam: TSpeedButton;
btnRemCam: TSpeedButton;
Label2: TLabel;
trkRate: TTrackBar;
Label3: TLabel;
trkQuality: TTrackBar;
lblVideoDelay: TLabel;
cmbRate: TComboBox;
Label4: TLabel;
GroupBox2: TGroupBox;
mmLog: TMemo;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure btnExitClick(Sender: TObject);
procedure btnAboutClick(Sender: TObject);
procedure btnConnectClick(Sender: TObject);
procedure btnCancelClick(Sender: TObject);
procedure btnDisconnectClick(Sender: TObject);
procedure lvPeersChange(Sender: TObject; Item: TListItem; Change: TItemChange);
procedure btnRemoveClick(Sender: TObject);
procedure btnChatClick(Sender: TObject);
procedure btnAlertClick(Sender: TObject);
procedure FormShow(Sender: TObject);
procedure btnSettingsClick(Sender: TObject);
procedure btnMyIPClick(Sender: TObject);
procedure pntMicPaint(Sender: TObject);
procedure btnMakeCallClick(Sender: TObject);
procedure btnEndCallClick(Sender: TObject);
procedure btnCancelCallingClick(Sender: TObject);
procedure btnSendFileClick(Sender: TObject);
procedure btnMuteRecordingClick(Sender: TObject);
procedure btnMutePlaybackClick(Sender: TObject);
procedure trkTriggerChange(Sender: TObject);
procedure btnLocCamClick(Sender: TObject);
procedure trkQualityChange(Sender: TObject);
procedure btnRemCamClick(Sender: TObject);
procedure trkRateChange(Sender: TObject);
procedure cmbRateChange(Sender: TObject);
private
{ Private declarations }
CamStm: TMemoryStream;
CamBmp: TBitmap;
LocCam, RemCam: Boolean;
procedure LogMsg(aText: String);
function SelectPeer(aHandle: Integer): Boolean;
procedure LoadForm;
procedure SaveForm;
procedure SetSettings;
procedure UpdateStatus;
procedure UpdateButtons;
procedure DeletePeer(aPeer: TPeer);
//Event handlers
procedure GoError(Sender: TObject; aCode: Integer);
procedure GoSessionOpen(Sender: TObject);
procedure doSessionClosed(Sender: TObject);
procedure doSessionRejected(Sender: TObject);
procedure GoPeerConnected(Sender: TObject; aHandle: Integer);
procedure GoPeerDisconnected(Sender: TObject; aHandle: Integer);
procedure GoCallRequested(Sender: TObject; aHandle: Integer; var Ok: Wordbool; var aVoice: Wordbool; var aVideo: Wordbool);
procedure GoCallTaken(Sender: TObject; aHandle: Integer);
procedure GoCallAccepted(Sender: TObject; aHandle: Integer);
procedure GoCallRejected(Sender: TObject; aHandle, aCode: Integer);
procedure GoCallEnded(Sender: TObject; aHandle: Integer);
procedure GoHaveAlertMessage(Sender: TObject; aHandle: Integer; const aMessage: WideString);
procedure GoHaveChatMessage(Sender: TObject; aHandle: Integer; const aMessage: WideString);
procedure GoOutFileProgress(Sender: TObject; aHandle, aCountLo, aCountHi, aSizeLo, aSizeHi: Integer);
procedure GoOutFileDone(Sender: TObject; aHandle, aCode: Integer);
procedure GoInFileRequested(Sender: TObject; aHandle: Integer; var aPath: WideString; var aOkay: Wordbool);
procedure GoInFileProgress(Sender: TObject; aHandle, aCountLo, aCountHi, aSizeLo, aSizeHi: Integer);
procedure GoInFileDone(Sender: TObject; aHandle, aCode: Integer);
procedure MicBack;
procedure GoWaveRecorded(Sender: TObject; var aData: OleVariant; aSize: Integer);
procedure GoStartRecording(Sender: TObject);
procedure GoStopRecording(Sender: TObject);
procedure GoStartVoiceDelay(Sender: TObject);
procedure GoStopVoiceDelay(Sender: TObject);
procedure GoStartVideoDelay(Sender: TObject);
procedure GoStopVideoDelay(Sender: TObject);
procedure GoStartVoiceOverload(Sender: TObject);
procedure GoStopVoiceOverload(Sender: TObject);
procedure GoLocalImage(Sender: TObject; var aData: OleVariant; aSize: Integer);
procedure GoRemoteImage(Sender: TObject; var aData: OleVariant; aSize: Integer);
public
{ Public declarations }
SelPeer: TPeer;
VidCln: TbsVidChatClnX;
MyPeers: TObjectList;
procedure CheckError(aCode: Integer);
end;
var
fMain: TfMain;
//Public functions
function UN(aName: WideString): String;
function AddSlash(aPath: String): String;
function SlashOff(aPath: String): String;
function PreSlash(aPath: String): String;
implementation
uses uAbout, uAdd, uConnect, uAccept, uLocCam, uRemCam, uCall;
{$R *.DFM}
// *** Misc functions
//Add a trailing slash
function AddSlash(aPath: String): String;
begin
Result := aPath;
if RightStr(Result, 1) = '\' then Exit;
Result := Result + '\';
end;
//Remove the trailing slash
function SlashOff(aPath: String): String;
begin
Result := aPath;
if RightStr(Result, 1) <> '\' then Exit;
Delete(Result, Length(Result), 1);
end;
//Insert a leading slash
function PreSlash(aPath: String): String;
begin
Result := aPath;
if LeftStr(Result, 1) = '\' then Exit;
Result := '\' + Result;
end;
//Check for empty user name
function UN(aName: WideString): String;
begin
Result := aName;
if Result > '' then Exit;
Result := 'Guest';
end;
// *** General
procedure TfMain.LogMsg(aText: String);
begin
mmLog.Lines.Add(TimeToStr(Now) + ': ' + aText);
end;
//Retrieve a peer object by it's handle
function TfMain.SelectPeer(aHandle: Integer): Boolean;
begin
Result := False;
try
SelPeer := TPeer(VidCln.GetMoniker(aHandle));
if SelPeer = nil then Exit;
Result := True;
except
end;
end;
procedure TfMain.FormCreate(Sender: TObject);
begin
LoadForm;
MyPeers := TObjectList.Create;
CamStm := TMemoryStream.Create;
CamBmp := TBitmap.Create;
VidCln := TbsVidChatClnX.Create(nil);
VidCln.OnError := GoError;
VidCln.OnSessionOpen := GoSessionOpen;
VidCln.OnSessionClosed := doSessionClosed;
VidCln.OnSessionRejected := doSessionRejected;
VidCln.OnPeerConnected := GoPeerConnected;
VidCln.OnPeerDisconnected := GoPeerDisconnected;
VidCln.OnCallRequested := GoCallRequested;
VidCln.OnCallTaken := GoCallTaken;
VidCln.OnCallAccepted := GoCallAccepted;
VidCln.OnCallRejected := GoCallRejected;
VidCln.OnCallTerminated := GoCallEnded;
VidCln.OnWaveRecorded := GoWaveRecorded;
VidCln.OnStartRecording := GoStartRecording;
VidCln.OnStopRecording := GoStopRecording;
VidCln.OnStartVoiceDelay := GoStartVoiceDelay;
VidCln.OnStopVoiceDelay := GoStopVoiceDelay;
VidCln.OnStartVideoDelay := GoStartVideoDelay;
VidCln.OnStopVideoDelay := GoStopVideoDelay;
VidCln.OnStartVoiceOverload := GoStartVoiceOverload;
VidCln.OnStopVoiceOverload := GoStopVoiceOverload;
VidCln.OnLocalImage := GoLocalImage;
VidCln.OnRemoteImage := GoRemoteImage;
VidCln.OnHaveAlertMessage := GoHaveAlertMessage;
VidCln.OnHaveChatMessage := GoHaveChatMessage;
VidCln.OnOutFileProgress := GoOutFileProgress;
VidCln.OnOutFileDone := GoOutFileDone;
VidCln.OnInFileRequested := GoInFileRequested;
VidCln.OnInFileProgress := GoInFileProgress;
VidCln.OnInFileDone := GoInFileDone;
end;
procedure TfMain.FormDestroy(Sender: TObject);
begin
SaveForm;
MyPeers.Free;
FreeAndNil(VidCln);
CamStm.Free;
CamBmp.Free;
end;
procedure TfMain.FormShow(Sender: TObject);
begin
SetSettings;
UpdateStatus;
end;
//Initializations
procedure TfMain.LoadForm;
var
Ini: TIniFile;
begin
try
Ini := TIniFile.Create(ExtractFilePath(Application.ExeName)+'settings.ini');
except
Ini := nil;
end;
if Ini = nil then Exit;
try
with Ini do
begin
Left := ReadInteger('Last', 'Left', Left);
Top := ReadInteger('Last', 'Top', Top);
end;
finally
Ini.Free;
end;
end;
procedure TfMain.SaveForm;
var
Ini: TIniFile;
begin
try
Ini := TIniFile.Create(ExtractFilePath(Application.ExeName)+'settings.ini');
except
Ini := nil;
end;
if Ini = nil then Exit;
try
with Ini do
begin
WriteInteger('Last', 'Left', Left);
WriteInteger('Last', 'Top', Top);
end;
finally
Ini.Free;
end;
end;
//Set the component properties
procedure TfMain.SetSettings;
begin
VidCln.SecurityMode := fSettings.SecurityMode;
VidCln.PublicKey := fSettings.mmPublic.Text;
VidCln.PrivateKey := fSettings.mmPrivate.Text;
VidCln.SecretKey := fSettings.edSecret.Text;
VidCln.Fingerprints := fSettings.lstFingerprints.Items.CommaText;
VidCln.ListeningPort := StrToIntDef(fSettings.edPort.Text, 0);
VidCln.BindAddress := fSettings.edAddr.Text;
VidCln.SocksServer := Trim(fSettings.edSocksServer.Text);
VidCln.SocksPort := StrToIntDef(fSettings.edSocksPort.Text, 0);
VidCln.SocksUsername := Trim(fSettings.edSocksUser.Text);
VidCln.SocksPassword := Trim(fSettings.edSocksPass.Text);
if fSettings.radSocks5.Checked then
VidCln.SocksVersion := 5
else
VidCln.SocksVersion := 4;
UpdateStatus;
end;
//Display an error message, if any
procedure TfMain.CheckError(aCode: Integer);
begin
if aCode = 0 then Exit;
MessageBox(Handle, PChar(bsErrorDescription(aCode)), 'Error', MB_OK or MB_ICONERROR);
end;
//Update the button state and the status text
procedure TfMain.UpdateStatus;
begin
if VidCln.SessionOpen then
begin
//already connected
btnConnect.Enabled := False;
btnCancel.Enabled := False;
btnDisconnect.Enabled := True;
StatusBar.Panels[0].Text := ' Session open: ' + VidCln.ServerAddress + ':' + IntToStr(VidCln.ServerPort);
if VidCln.Username > '' then
StatusBar.Panels[1].Text := ' User: ' + VidCln.Username
else
StatusBar.Panels[1].Text := ' User: not signed in';
end
else
begin
StatusBar.Panels[1].Text := '';
StatusBar.Panels[2].Text := '';
if VidCln.SessionOpening then
begin
//now connecting
btnConnect.Enabled := False;
btnCancel.Enabled := True;
btnDisconnect.Enabled := False;
StatusBar.Panels[0].Text := ' Connecting to the server';
end
else
begin
//not connected
btnConnect.Enabled := True;
btnCancel.Enabled := False;
btnDisconnect.Enabled := False;
StatusBar.Panels[0].Text := ' Session closed';
end;
end;
UpdateButtons;
end;
procedure TfMain.UpdateButtons;
var
Pr: TPeer;
begin
if VidCln = nil then Exit; //we are closing
Pr := nil;
if lvPeers.SelCount > 0 then
Pr := TPeer(lvPeers.Selected.Data);
btnAlert.Enabled := lvPeers.Items.Count > 0;
btnChat.Enabled := lvPeers.SelCount > 0;
btnSendFile.Enabled := lvPeers.SelCount > 0;
btnRemove.Enabled := lvPeers.SelCount > 0;
btnMakeCall.Enabled := False;
if Pr <> nil then
if (VidCln.GetCallingPeer = 0) and (VidCln.GetCallPeer = 0) then
btnMakeCall.Enabled := True;
btnCancelCalling.Enabled := VidCln.GetCallingPeer <> 0;
btnEndCall.Enabled := VidCln.GetCallPeer <> 0;
btnMuteRecording.Enabled := btnEndCall.Enabled;
btnMutePlayback.Enabled := btnEndCall.Enabled;
btnLocCam.Enabled := btnEndCall.Enabled;
btnRemCam.Enabled := btnEndCall.Enabled;
end;
procedure TfMain.lvPeersChange(Sender: TObject; Item: TListItem;
Change: TItemChange);
begin
if Change <> ctState then Exit;
UpdateButtons;
end;
procedure TfMain.DeletePeer(aPeer: TPeer);
begin
if aPeer = nil then Exit;
lvPeers.Items.Delete(aPeer.ListItem.Index);
aPeer.fChat.Free;
aPeer.fOutFile.Free;
aPeer.fInFile.Free;
MyPeers.Remove(aPeer);
end;
// <<< Events
procedure TfMain.GoError(Sender: TObject; aCode: Integer);
begin
MessageBox(0, PChar('Error code: ' + IntToStr(aCode)), 'Error!', MB_OK or MB_ICONERROR or MB_SYSTEMMODAL);
end;
//server is just connected
procedure TfMain.GoSessionOpen(Sender: TObject);
begin
UpdateStatus;
LogMsg('Connected to the server ' + VidCln.ServerAddress + ':' + IntToStr(VidCln.ServerPort));
end;
//server is just disconnected
procedure TfMain.doSessionClosed(Sender: TObject);
begin
UpdateStatus;
LogMsg('Disconnected from the server');
end;
//Unsuccessful connection
procedure TfMain.doSessionRejected(Sender: TObject);
begin
LogMsg('Cannot open a session to' + fConnect.edHost.Text + ':' + fConnect.edPort.Text + ' Error- ' + bsErrorDescription(VidCln.LastError));
ShowMessage('Cannot open the session!'#13#13'Error: ' + bsErrorDescription(VidCln.LastError));
UpdateStatus;
end;
//A new peer is just connected
procedure TfMain.GoPeerConnected(Sender: TObject; aHandle: Integer);
var
LI: TListItem;
Pr: TPeer;
begin
Pr := TPeer.Create;
MyPeers.Add(Pr);
Pr.Handle := aHandle;
Pr.Username := UN(VidCln.GetPeerName(Pr.Handle));
Application.CreateForm(TfChat, Pr.fChat);
TfChat(Pr.fChat).Peer := Pr;
Pr.fChat.Caption := 'Chat with ' + Pr.Username;
Application.CreateForm(TfOutFile, Pr.fOutFile);
TfOutFile(Pr.fOutFile).Peer := Pr;
Application.CreateForm(TfInFile, Pr.fInFile);
TfInFile(Pr.fInFile).Peer := Pr;
LI := lvPeers.Items.Add;
LI.Data := Pointer(Pr);
Pr.ListItem := LI;
LI.Caption := UN(Pr.Username);
LI.Subitems.Add(VidCln.GetPeerAddress(aHandle));
LI.Subitems.Add(IntToStr(VidCln.GetPeerPort(aHandle)));
LI.Subitems.Add('Online');
VidCln.SetMoniker(aHandle, Integer(Pr));
if lvPeers.Items.Count = 1 then
lvPeers.Items[0].Selected := True;
UpdateStatus;
LogMsg('New peer at ' + LI.SubItems[0] + ':' + LI.SubItems[1]);
end;
//A peer is just disconnected
procedure TfMain.GoPeerDisconnected(Sender: TObject; aHandle: Integer);
var
Pr: TPeer;
begin
Pr := TPeer(VidCln.GetMoniker(aHandle));
if Pr = nil then Exit;
LogMsg('Disconnected peer ' + Pr.ListItem.Caption + ' ' + Pr.ListItem.SubItems[0] + ':' + IntToStr(VidCln.GetPeerPort(aHandle)));
DeletePeer(Pr);
// GoCallEnded(Self, aHandle);
end;
// *** uploading ***
procedure TfMain.btnSendFileClick(Sender: TObject);
var
Pr: TPeer;
begin
Pr := TPeer(lvPeers.Selected.Data);
if VidCln.GetOutgoingFile(Pr.Handle) = '' then
begin
//start new transfer
if not dlgOpen.Execute then Exit;
if not VidCln.RequestOutFile(Pr.Handle, dlgOpen.FileName) then
ShowMessage(Format('Cannot make a call, code: %d',[VidCln.LastError]));
Pr.fOutFile.Caption := 'Sending file to ' + Pr.Username;
end;
(Pr.fOutFile as TfOutFile).pnlFile.Caption := ExtractFileName(dlgOpen.FileName);
(Pr.fOutFile as TfOutFile).pnlStatus.Caption := 'Handshaking...';
(Pr.fOutFile as TfOutFile).btnCancel.Enabled := True;
ShowForm(Pr.fOutFile);
LogMsg(UN(Pr.Username) + ': Start outgoing file transfer ' + dlgOpen.FileName);
end;
//New progress information is available for the upload operation (client module)
procedure TfMain.GoOutFileProgress(Sender: TObject; aHandle, aCountLo, aCountHi, aSizeLo, aSizeHi: Integer);
begin
if not SelectPeer(aHandle) then Exit;
with SelPeer.fOutFile as TfOutFile do
pnlStatus.Caption := IntToStr(aCountLo) + '/' + IntToStr(aSizeLo);
end;
//The upload operation is completed (client module)
procedure TfMain.GoOutFileDone(Sender: TObject; aHandle, aCode: Integer);
begin
if not SelectPeer(aHandle) then Exit;
with SelPeer.fOutFile as TfOutFile do
begin
if aCode = 0 then
pnlStatus.Caption := 'Completed successfully'
else
pnlStatus.Caption := 'Finished with error ' + IntToStr(aCode);
btnCancel.Enabled := False;
end;
LogMsg(UN(SelPeer.Username) + ': finished outgoing file transfer - ' + bsErrorDescription(aCode));
end;
//A request to upload a file is received
procedure TfMain.GoInFileRequested(Sender: TObject; aHandle: Integer; var aPath: WideString; var aOkay: Wordbool);
var
S: String;
begin
aOkay := False;
if not SelectPeer(aHandle) then Exit;
S := 'User ' + UN(VidCln.GetPeerName(aHandle)) + ' is asking to send file ' + aPath + #13'Accept?';
if MessageBox(0, PChar(S), 'Reeceiving file', MB_YESNO or MB_ICONQUESTION or MB_SYSTEMMODAL) <> MRYES then Exit;
aOkay := True;
aPath := ExtractFilePath(Application.ExeName) + 'Received files\' + aPath;
with SelPeer.fInFile as TfInFile do
begin
Caption := 'Receiving file from ' + SelPeer.Username;
pnlFile.Caption := ExtractFileName(aPath);
pnlStatus.Caption := 'Handshaking...';
btnCancel.Enabled := True;
end;
ShowForm(SelPeer.fInFile);
LogMsg(UN(SelPeer.Username) + ': Start incoming file transfer ' + aPath);
end;
//New progress information is available for the upload operation (client module)
procedure TfMain.GoInFileProgress(Sender: TObject; aHandle, aCountLo, aCountHi, aSizeLo, aSizeHi: Integer);
begin
if not SelectPeer(aHandle) then Exit;
with SelPeer.fInFile as TfInFile do
pnlStatus.Caption := IntToStr(aCountLo) + '/' + IntToStr(aSizeLo);
end;
//The incoming upload operation is completed
procedure TfMain.GoInFileDone(Sender: TObject; aHandle, aCode: Integer);
begin
if not SelectPeer(aHandle) then Exit;
with SelPeer.fInFile as TfInFile do
begin
if aCode = 0 then
pnlStatus.Caption := 'Completed successfully'
else
pnlStatus.Caption := 'Finished with error ' + IntToStr(aCode);
btnCancel.Enabled := False;
end;
LogMsg(UN(SelPeer.Username) + ': finished incoming file transfer - ' + bsErrorDescription(aCode));
end;
// <<< Calls
procedure TfMain.GoCallRequested(Sender: TObject; aHandle: Integer; var Ok: Wordbool; var aVoice: Wordbool; var aVideo: Wordbool);
var
Pr: TPeer;
begin
Pr := TPeer(VidCln.GetMoniker(aHandle));
if Pr = nil then Exit;
LogMsg('Call is requested from ' + UN(Pr.Username));
sndPlaySound('C:\Windows\Media\ringout.wav', SND_NODEFAULT);
sndPlaySound('C:\Windows\Media\ringout.wav', SND_NODEFAULT Or SND_ASYNC);
SetForegroundWindow(Handle);
fAccept.Peer := Pr;
if fAccept.ShowModal <> mrOk then Exit;
Ok := True;
aVoice := fAccept.chkUseVoice.Checked;
aVideo := fAccept.chkUseVideo.Checked;
end;
procedure TfMain.GoCallTaken(Sender: TObject; aHandle: Integer);
var
Pr: TPeer;
begin
Pr := TPeer(VidCln.GetMoniker(aHandle));
if Pr = nil then Exit;
Pr.ListItem.SubItems[2] := 'Talking';
pnlCaller.Caption := UN(VidCln.GetPeerName(aHandle));
VidCln.TriggerLevel := trkTrigger.Position;
UpdateButtons;
LocCam := False;
RemCam := False;
LogMsg(Format('Call from %s is taken', [UN(Pr.Username)]));
end;
procedure TfMain.GoCallAccepted(Sender: TObject; aHandle: Integer);
var
Pr: TPeer;
begin
Pr := TPeer(VidCln.GetMoniker(aHandle));
if Pr = nil then Exit;
Pr.ListItem.SubItems[2] := 'Talking';
// MessageBox(0, 'Call was accepted', 'Acceped Call', MB_OK);
pnlCaller.Caption := UN(VidCln.GetPeerName(aHandle));
VidCln.TriggerLevel := trkTrigger.Position;
UpdateButtons;
LocCam := False;
RemCam := False;
LogMsg(Format('Call from %s is accepted', [UN(Pr.Username)]));
end;
procedure TfMain.GoCallRejected(Sender: TObject; aHandle, aCode: Integer);
var
Pr: TPeer;
begin
Pr := TPeer(VidCln.GetMoniker(aHandle));
if Pr = nil then Exit;
Pr.ListItem.SubItems[2] := 'Online';
MessageBox(0, PChar('Call is rejected from ' + UN(Pr.Username) + ' Code:' + IntToStr(aCode)), 'Rejected Call', MB_OK);
LogMsg('Call is rejected from ' + UN(Pr.Username) + ' Code:' + IntToStr(aCode));
UpdateButtons;
end;
procedure TfMain.GoCallEnded(Sender: TObject; aHandle: Integer);
var
Pr: TPeer;
begin
Pr := TPeer(VidCln.GetMoniker(aHandle));
if Pr = nil then Exit;
if fAccept.Visible then
if fAccept.Peer = Pr then
fAccept.ModalResult := mrCancel;
Pr.ListItem.SubItems[2] := 'Online';
pnlCaller.Caption := '';
// MessageBox(0, PChar('Call is ended from ' + UN(Pr.Username)), 'Terminated Call', MB_OK);
LogMsg('Call is ended from ' + UN(Pr.Username));
UpdateButtons;
end;
// >>> Calls
// <<< ALerts
//Send an alert message
procedure TfMain.btnAlertClick(Sender: TObject);
var
i: Integer;
begin
fAlert.mmText.Text := '';
if lvPeers.SelCount > 0 then
begin
fAlert.raSingle.Caption := 'User ' + lvPeers.Selected.Caption;
fAlert.raSingle.Enabled := True;
fAlert.raSingle.Checked := True;
end
else
begin
fAlert.raAll.Checked := True;
fAlert.raSingle.Caption := 'Single user';
fAlert.raSingle.Enabled := False;
end;
if fAlert.ShowModal <> mrOk then Exit;
if fAlert.raSingle.Checked then
VidCln.SendAlertMessage(TPeer(lvPeers.Selected.Data).Handle, fAlert.mmText.Text)
else
begin
for i := lvPeers.Items.Count-1 downto 0 do
VidCln.SendAlertMessage(TPeer(lvPeers.Items[i].Data).Handle, fAlert.mmText.Text);
end;
end;
//An alert message is received
procedure TfMain.GoHaveAlertMessage(Sender: TObject; aHandle: Integer; const aMessage: WideString);
begin
MessageBox(0, PChar(String(aMessage)), PChar('Alert from ' + UN(VidCln.GetPeerName(aHandle))), MB_OK or MB_ICONWARNING or MB_SYSTEMMODAL);
end;
// >>> ALerts
// <<< Chat
//Open a chat session
procedure TfMain.btnChatClick(Sender: TObject);
begin
ShowForm(TPeer(lvPeers.Selected.Data).fChat);
end;
//A chat message is received
procedure TfMain.GoHaveChatMessage(Sender: TObject; aHandle: Integer; const aMessage: WideString);
begin
if not SelectPeer(aHandle) then Exit;
TfChat(SelPeer.fChat).HaveChatMessage(aMessage);
end;
// >>> Chat
procedure TfMain.MicBack;
begin
pntMic.Canvas.Brush.Color := clBlack;
pntMic.Canvas.FillRect(pntMic.ClientRect);
pntMic.Canvas.Pen.Color := $ff;
pntMic.Canvas.MoveTo(10, 2);
pntMic.Canvas.LineTo(10, pntMic.ClientHeight-4);
pntMic.Canvas.MoveTo(10, pntMic.ClientHeight div 2);
pntMic.Canvas.LineTo(pntMic.ClientWidth-6, pntMic.ClientHeight div 2);
pntMic.Canvas.Font.Color := $ff;
pntMic.Canvas.TextOut(2,-2, '+');
pntMic.Canvas.TextOut(12,-2, 'max');
pntMic.Canvas.TextOut(2,pntMic.ClientHeight-16, '-');
pntMic.Canvas.TextOut(12,pntMic.ClientHeight-16, 'min');
pntMic.Canvas.TextOut(2,pntMic.ClientHeight div 2 - 7, '0');
end;
// <<< Misc button clicks
//Open a new session
procedure TfMain.btnConnectClick(Sender: TObject);
begin
if fConnect.ShowModal <> mrOk then Exit;
if not VidCln.OpenSession(
fConnect.edHost.Text,
StrToIntDef(fConnect.edPort.Text, 0),
fConnect.edUsername.Text,
fConnect.edPassword.Text) then
ShowMessage('Cannot initiate a new session: ' + IntToStr(VidCln.LastError));
UpdateStatus;
end;
//Cancel the session call
procedure TfMain.btnCancelClick(Sender: TObject);
begin
if not VidCln.SessionOpening then Exit;
VidCln.CloseSession;
end;
//Close an open session
procedure TfMain.btnDisconnectClick(Sender: TObject);
begin
VidCln.CloseSession;
UpdateStatus;
end;
//Remove a connected peer
procedure TfMain.btnRemoveClick(Sender: TObject);
var
Pr: TPeer;
begin
if lvPeers.SelCount = 0 then Exit;
Pr := TPeer(lvPeers.Selected.Data);
GoCallEnded(Self, Pr.Handle);
VidCln.DisconnectPeer(Pr.Handle);
// DeletePeer(Pr);
end;
procedure TfMain.btnSettingsClick(Sender: TObject);
begin
if fSettings.ShowModal <> mrOk then Exit;
SetSettings;
end;
procedure TfMain.btnExitClick(Sender: TObject);
begin
Application.Terminate;
end;
procedure TfMain.btnAboutClick(Sender: TObject);
begin
fAbout.ShowModal;
end;
//Show my IP
procedure TfMain.btnMyIPClick(Sender: TObject);
begin
ShowMessage(VidCln.LocalIPList);
end;
procedure TfMain.pntMicPaint(Sender: TObject);
begin
MicBack;
end;
procedure TfMain.GoWaveRecorded(Sender: TObject; var aData: OleVariant; aSize: Integer);
var
Data: Pointer;
zl, cl, i: Integer;
cnt, stp: Integer;
pb: PChar;
function GetLevel: Integer;
begin
Result := Byte((pb+cnt)^);
if Result >= 128 then
Result := Result - 128
else
Result := Result - 127;
Result := Result div 4;
end;
begin
Data := VarArrayLock(aData);
if Data = nil then Exit;
if aSize < 128 then
stp := 1
else
stp := aSize div 128;
pntMic.Canvas.Lock;
try
MicBack;
zl := pntMic.ClientHeight div 2;
pb := Data;
cnt := 0;
pntMic.Canvas.Pen.Color := $ff00;
pntMic.Canvas.MoveTo(10, zl + GetLevel);
for i := 1 to 127 do
begin
Inc(cnt, stp);
if cnt > aSize then Break;
cl := zl + GetLevel;
pntMic.Canvas.LineTo(i+10, cl);
end;
except
end;
pntMic.Canvas.Unlock;
VarArrayUnlock(aData);
end;
procedure TfMain.GoStartRecording(Sender: TObject);
begin
lblRecording.Visible := True;
end;
procedure TfMain.GoStopRecording(Sender: TObject);
begin
lblRecording.Visible := False;
MicBack;
end;
procedure TfMain.GoStartVoiceDelay(Sender: TObject);
begin
lblVoiceDelay.Visible := True;
end;
procedure TfMain.GoStopVoiceDelay(Sender: TObject);
begin
lblVoiceDelay.Visible := False;
end;
procedure TfMain.GoStartVideoDelay(Sender: TObject);
begin
lblVideoDelay.Visible := True;
end;
procedure TfMain.GoStopVideoDelay(Sender: TObject);
begin
lblVideoDelay.Visible := False;
end;
procedure TfMain.GoStartVoiceOverload(Sender: TObject);
begin
lblOverloading.Visible := True;
end;
procedure TfMain.GoStopVoiceOverload(Sender: TObject);
begin
lblOverloading.Visible := False;
end;
procedure TfMain.GoLocalImage(Sender: TObject; var aData: OleVariant; aSize: Integer);
var
Data: Pointer;
begin
Data := VarArrayLock(aData);
if Data = nil then Exit;
CamStm.Clear;
CamStm.WriteBuffer(Data^, aSize);
CamStm.Position := 0;
CamBmp.LoadFromStream(CamStm);
if fLocCam.ClientWidth <> CamBmp.Width then
fLocCam.ClientWidth := CamBmp.Width;
if fLocCam.ClientHeight <> CamBmp.Height then
fLocCam.ClientHeight := CamBmp.Height;
if not LocCam then
begin
LocCam := True;
fLocCam.Show;
end;
fLocCam.Canvas.Draw(0, 0, CamBmp);
VarArrayUnlock(aData);
end;
procedure TfMain.GoRemoteImage(Sender: TObject; var aData: OleVariant; aSize: Integer);
var
Data: Pointer;
begin
Data := VarArrayLock(aData);
if Data = nil then Exit;
CamStm.Clear;
CamStm.WriteBuffer(Data^, aSize);
CamStm.Position := 0;
CamBmp.LoadFromStream(CamStm);
if fRemCam.ClientWidth <> CamBmp.Width then
fRemCam.ClientWidth := CamBmp.Width;
if fRemCam.ClientHeight <> CamBmp.Height then
fRemCam.ClientHeight := CamBmp.Height;
if not RemCam then
begin
RemCam := True;
fRemCam.Show;
end;
fRemCam.Canvas.Draw(0, 0, CamBmp);
VarArrayUnlock(aData);
end;
procedure TfMain.btnMakeCallClick(Sender: TObject);
begin
fCall.Peer := TPeer(lvPeers.Selected.Data);
if fCall.ShowModal <> mrOk then Exit;
if VidCln.MakeCall(TPeer(lvPeers.Selected.Data).Handle, fCall.chkUseVoice.Checked, fCall.chkUseVideo.Checked) then
lvPeers.Selected.SubItems[2] := 'Calling'
else
ShowMessage(Format('Cannot make a call, code: %d',[VidCln.LastError]));
UpdateButtons;
end;
procedure TfMain.btnCancelCallingClick(Sender: TObject);
begin
if VidCln.GetCallingPeer = 0 then Exit;
VidCln.CancelCalling(VidCln.GetCallingPeer);
UpdateButtons;
end;
procedure TfMain.btnEndCallClick(Sender: TObject);
var
i: Integer;
begin
VidCln.TerminateCall(0); //end the conversation with all peers
pnlCaller.Caption := '';
for i := lvPeers.Items.Count-1 downto 0 do
lvPeers.Items[i].SubItems[2] := 'Online';
UpdateButtons;
end;
procedure TfMain.btnMuteRecordingClick(Sender: TObject);
begin
VidCln.MuteRecording := btnMuteRecording.Down;
end;
procedure TfMain.btnMutePlaybackClick(Sender: TObject);
begin
VidCln.MutePlayback := btnMutePlayback.Down;
end;
procedure TfMain.trkTriggerChange(Sender: TObject);
begin
VidCln.TriggerLevel := trkTrigger.Position;
end;
procedure TfMain.btnLocCamClick(Sender: TObject);
begin
ShowForm(fLocCam);
end;
procedure TfMain.trkQualityChange(Sender: TObject);
begin
VidCln.ImageQuality := trkQuality.Position;
end;
procedure TfMain.btnRemCamClick(Sender: TObject);
begin
ShowForm(fRemCam);
end;
procedure TfMain.trkRateChange(Sender: TObject);
begin
VidCln.RefreshRate := trkRate.Position;
end;
procedure TfMain.cmbRateChange(Sender: TObject);
begin
VidCln.SamplingRate := StrToIntDef(cmbRate.Text, 16000);
end;
end.
© BigSpeed Computing Inc. - Mastering algorithms