telefoon.pas

ACM_VOIP_VCL VOIP

    except 
      on e: Exception do
      begin
        factive := False;
        ACMIn1.Close;
        ACMOut1.Close;
        if assigned(fsoundclose) then fsoundclose(self);
        if assigned(fcodecerror) then fcodecerror(self, e.Message) 
        else
          ShowMessage(e.Message);
      end;
    end;
  end 
  else 
    factive := False
end;

procedure Ttelefoon.setip(const Value: string);
begin
  if assigned(nm) then
  begin
    fip := Value;
    nm.remotehost := Value
  end
end;

procedure Ttelefoon.setactive(const Value: boolean);
begin
  begin
    if not Value then ftimer.Enabled := False;
    if not (Value and factive) then
      if Value = True then 
        try 
          factive := True;
          start  
        except 
        end 
      else 
      begin 
        stop;
        factive := False 
      end;
  end
end;

procedure Ttelefoon.setport(const Value: integer);
begin
  if assigned(nm) then
  begin
    fport := Value;
    nm.remoteport := Value
  end;
end;

procedure Ttelefoon.setauthor(const Value: string);
begin
  fauthor := '[e-mail]';
end;

procedure Ttelefoon.setversion(const Value: string);
begin
  fversie := 'Version 0.90';
end;

procedure Ttelefoon.ACMIn1BufferFull(Sender: TObject; Data: Pointer;
  Size: integer);
var 
  k: Tmemorystream;
  p: pointer;
  s: integer;
  h: boolean;
  oldsize: integer;
begin
  k := tmemorystream.Create;
  k.Clear;
  oldsize := size;
  try
    if assigned(fselfsound) then
    begin
      fselfsound(p, size, h);
      if h and (size > 0) then 
      begin 
        k.Write(p^, size);
        freemem(p) 
      end 
      else 
        k.Write(Data^, oldsize)
    end 
    else
      k.Write(Data^, size);
    if not fmute then if (random(1200) > fsyncfactor) or (not fsync) then nm.Sendstream(k);
  finally
    k.Clear;
    k.Free
  end
end;

procedure Ttelefoon.setlocalport(const Value: integer);
begin
  if assigned(nm) then
  begin
    flocal := Value;
    nm.localport := Value
  end;
end;

procedure Ttelefoon.nmStatus(Sender: TComponent; status: string);
begin
  if assigned(fstatus) then fstatus(Sender, status)
end;

procedure Ttelefoon.nmDataSend(Sender: TObject);
begin
  if assigned(fverzonden) then fverzonden(Sender, timetostr(time))
end;

procedure Ttelefoon.stop;
begin
  ACMIn1.Close;
  ACMOut1.Close;
  if assigned(fsoundclose) then fsoundclose(self);
end;

procedure Ttelefoon.ping(ip, naam: string);
var 
  a: array[1..60] of char;
  s: string;
  i: integer;
  tip, pingport: string;
begin
  try
    tip := '';
    pingport := '';
    i := 1;
    while (i <= length(ip)) and (ip[i] <> ':') do
    begin
      tip := tip + ip[i];
      i := i + 1
    end;
    nmping.remotehost := tip;
    if ip[i] = ':' then
    begin
      i := i + 1;
      while (i <= length(ip)) and (ip[i] <> ':') do i := i + 1;
      if ip[i] = ':' then
      begin
        i := i + 1;
        while i <= length(ip) do
        begin
          pingport := pingport + ip[i];
          i := i + 1
        end
      end;
      try
        if trim(pingport) <> '' then fpingremote := StrToInt(pingport);
      except
      end;
    end;
    nmping.LocalPort := fpinglocal;
    nmping.remoteport := fpingremote;
    if trim(flocalip) = '' then vernieuwlocal;
    s := 'I' + flocalip + 'P' + IntToStr(flocal) + 'V' + IntToStr(Ord(fverbinding)) +
      'Q' + IntToStr(fpingremote);
    if factive then s := s + 'AT' 
    else 
      s := s + 'AF';
    if fanswer then s := s + 'OT' 
    else 
      s := s + 'OF';
    if length(naam) > 20 then setlength(naam, 20);
    s := s + 'N' + naam;
    s := s + '@';
    for i := 1 to length(s) do a[i] := s[i];
    nmping.sendbuffer(a, 60)
  except
  end;
end;

procedure Ttelefoon.beller(var s: string);
var 
  a, b: string;
  e, f: integer;
  g: string;
begin
  gip := fip;
  gport := fport;
  gconnect := fverbinding;
  Gzelf := fzelf;
  e := 1;
  g := '';
  f := 0;
  b := '';
  while (e <= length(s)) and (f <> 5) do
  begin
    if (f = 1) and (s[e] <> 'P') then gip := gip + s[e];
    if (f = 2) and (s[e] <> 'V') then b := b + s[e];
    if (f = 3) and (s[e] <> 'Z') then gconnect := Tverbinding(StrToInt(s[e]));
    if (f = 4) and (e < length(s)) and (s[e] <> '@') then if s[e] = 'T' then gzelf := True 
      else 
        gzelf := False;
    if s[e] = 'I' then 
    begin 
      gip := '';
      f := 1 
    end;
    if s[e] = 'P' then 
    begin 
      gport := 0;
      f := 2 
    end;
    if s[e] = 'V' then 
    begin 
      f := 3;
      try 
        gport := StrToInt(b) 
        except 
      end 
    end;
    if s[e] = 'Z' then 
    begin 
      gzelf := False;
      f := 4 
    end;
    if s[e] = '@' then f := 5;
    if f < 5 then g := g + s[e];
    e := e + 1
  end;
  s := g;
  if fauto and (not factive) then
  begin
    fip := gip;
    fport := gport;
    fverbinding := gconnect;
    fzelf := gzelf;
    if local_ip = '' then vernieuwlocal;
    nm.RemoteHost := fip;
    nm.RemotePort := fport;
  end;
end;

procedure Ttelefoon.placecall(ip: string);
var 
  i: integer;
  tip, poort: string;
  voorpunt: boolean;
begin
  tip := '';
  poort := '';
  i := 1;
  voorpunt := True;
  while i <= length(ip) do
  begin
    if voorpunt and (ip[i] <> ':') then tip := tip + ip[i];
    if (not voorpunt) and (ip[i] <> ':') then poort := poort + ip[i];
    if (not voorpunt) and (ip[i] = ':') then i := 1000;
    if ip[i] = ':' then voorpunt := False;
    i := i + 1
  end;
  fip := tip;
  try
    if trim(poort) <> '' then fport := StrToInt(poort);
  except
    fport := 8000
  end;
  if trim(ip) <> '' then remote_ip := fip;
  calling := True
end;

procedure Ttelefoon.setbellen(const Value: boolean);
var 
  k: Tmemorystream;
  s: string;
begin
  if Value then
  begin
    if not factive then
    begin
      if trim(local_ip) = '' then vernieuwlocal;
      nm.remotehost := fip;
      nm.RemotePort := fport;
      k := tmemorystream.Create;
      try
        s := 'I' + flocalip + 'P' + IntToStr(flocal) + 'V' + IntToStr(Ord(fverbinding)) + 'Z';
        if fzelf then s := s + 'T' 
        else 
          s := s + 'F';
        s := s + '@';
        k.SetSize(messagesize);
        k.Write(s[1], length(s));
        nm.Sendstream(k);
      finally
        k.Clear;
        k.Free
      end;
      if not fbellen then ftimer.Enabled := True;
      fbellen := True;
      active := True;
    end 
    else 
      ShowMessage('U are already in a call')
  end 
  else
  begin
    fbellen := False;
    if active then
    begin
      try
        active := False;
        k := tmemorystream.Create;
        s := '~Connection ended.@';
        k.SetSize(messagesize);
        k.Write(s[1], length(s));
        nm.Sendstream(k);
        if assigned(fended) then fended(self, s)
        finally
          k.Clear;
        k.Free;
      end
    end;
  end
end;


procedure Ttelefoon.sendmessage(s: string);
var 
  k: tmemorystream;
begin
  if factive then
  begin
    s := '&&' + s + '@';
    k := tmemorystream.Create;
    if length(s) < messagesize then
      try
        k.SetSize(messagesize);
        setlength(s, messagesize);
        k.Write(s[1], length(s));
        nm.Sendstream(k);
      finally
        k.Clear;
        k.Free
      end
  end
end;

procedure Ttelefoon.showbericht(s: string);
var 
  P: string;
  i: integer;
  einde: boolean;
  conn: boolean;
  rej: boolean;
begin
  einde := False;
  p := '';
  i := 1;
  conn := False;
  rej := False;
  while i <= length(s) do
  begin
    if s[i] = '~' then 
    begin 
      einde := True;
      calling := False;
      active := False 
    end;
    if s[i] = '^' then 
    begin 
      conn := True;
      s[i] := ' ' 
    end;
    if s[i] = '|' then 
    begin 
      rej := True;
      calling := False;
      active := False;
      s[i] := ' ' 
    end;
    if (s[i] <> '@') and (s[i] <> '~') then p := p + s[i] 
    else if s[i] = '@' then i := 1000;
    i := i + 1;
  end;
  if rej then ftimer.Enabled := False;
  if conn then ftimer.Enabled := False;
  p := trim(p);
  if conn and assigned(faccepted) then faccepted(self, p) 
  else if einde then
  begin
    if assigned(fended) then fended(self, p) 
    else 
      ShowMessage(p)
  end 
  else if rej then
  begin
    if assigned(frejected) then frejected(self, p) 
    else 
      ShowMessage(p)
  end 
  else if assigned(fsms) then fsms(self, p) 
  else 
    ShowMessage(p);
end;

procedure Ttelefoon.answer;
begin
  active := True
end;

procedure Ttelefoon.setvolume(Value: integer);
var 
  res: mmresult;
  v: dword;
  a: integer;
begin
  if active then
  begin
    a := Value * 655 - 1;
    a := a * 65536 + a;
    v := dword(a);
    fvolume := Value;
    waveoutsetvolume(acmout1.FWaveOutHandle, v);
  end
end;

function Ttelefoon.getvolume: integer;
var 
  v: pdword;
  res: mmresult;
  negatief: boolean;
  b, c: integer;
begin
  Result := fvolume;
  if active then
  begin
    res := 0;

    res := waveOutGetVolume(acmout1.FWaveOutHandle, @v);
    c := integer(v);
    if c < 0 then negatief := True 
    else 
      negatief := False;
    c := trunc(c / 65536);
    if negatief then c := c + 65536;
    c := trunc(c / 655);
    if integer(res) <> 0 then Result := 0 
    else 
      Result := integer(c)
  end
end;


function Ttelefoon.getmikevolume: integer;
var 
  v: pdword;
  res: mmresult;
  negatief: boolean;
  b, c: integer;
begin
  Result := fvolume;
  if active then
  begin
    res := 0;
    res := waveOutGetVolume(acmin1.FWaveinHandle, @v);
    c := integer(v);
    if c < 0 then negatief := True 
    else 
      negatief := False;
    c := trunc(c / 65536);
    if negatief then c := c + 65536;
    c := trunc(c / 655);
    if integer(res) <> 0 then Result := 0 
    else 
      Result := integer(c)
  end
end;




procedure Ttelefoon.setlocalpingport(const Value: integer);
begin
  fpinglocal := Value;
  if assigned(nmping) then nmping.localport := Value
end;

function Ttelefoon.test: integer;
var 
  p: pdword;
  res: mmresult;
begin
  res := waveOutGetPlaybackRate(acmout1.FWaveOutHandle, @p);
  Result := integer(p)
end;

procedure Ttelefoon.setremotepingport(const Value: integer);
begin
  fpingremote := Value;
  if assigned(nmping) then nmping.RemotePort := Value
end;

procedure Ttelefoon.answerincomming;
begin
  active := True;
  ftimer.Enabled := False;
  sendmessage('^Connected')
end;

procedure Ttelefoon.rejectincomming;
var 
  k: tmemorystream;
  s: string;
begin
  try
    ftimer.Enabled := False;
    k := tmemorystream.Create;
    s := '|Call rejected@';
    k.SetSize(messagesize);
    k.Write(s[1], length(s));
    nm.Sendstream(k);
  finally
    k.Clear;
    k.Free;
  end
end;

function Ttelefoon.getwait: integer;
begin
  Result := trunc(fwait / 1000);
end;

procedure Ttelefoon.setwait(Value: integer);
begin
  fwait := Value * 1000;
end;


function Ttelefoon.getsoundinlevel: longint;
var 
  left, right: dword;
begin
  Result := 0;
  left := 11;
  right := 10;
  if factive then
    if fmix.mixer.getmeter(1,2,left, right) then Result := trunc((left + right) / 2);
  if left <> right then Result := -1
end;


procedure Register;
begin
  RegisterComponents('remko', [TTelefoon]);
end;

end.