Einzelnen Beitrag anzeigen

ByTheTime

Registriert seit: 24. Sep 2011
Ort: Frankfurt
297 Beiträge
 
Delphi XE2 Architect
 
#1

WebCam via Stream senden

  Alt 18. Sep 2012, 21:47
Moin DP,
ich habe mir mal hier einen Anreiz geholt, wie ich das Bild einer WebCam via Stream senden könnte, allerdings bleibe ich an einer Stelle hängen (Ich möchte erstmal den Stream beim Server anzeigen lassen, dannach bastel ich weiter...):

Client:
Delphi-Quellcode:
procedure TFormMain.FormActivate(Sender: TObject);
var
  DeviceList: TStringList;
begin
  if fActivated then
    Exit;

  fActivated := true;

  DeviceList := TStringList.Create;
  fVideoImage.GetListOfDevices(DeviceList);

  if not DeviceList.Count < 1 then
  begin
    fVideoImage.VideoStart(DeviceList[0]);
    Timer1.Enabled := true;
  end;
end;

procedure TFormMain.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  fVideoImage.VideoStop;
end;

procedure TFormMain.FormCreate(Sender: TObject);
begin
  fActivated := false;
  fVideoImage := TVideoImage.Create;
  fVideoImage.SetDisplayCanvas(PaintBox1.Canvas); //Brauche ich das überhaupt? Oder wie kriege ich das Bild dann in die SendStream Prcedure rein?
end;

procedure TFormMain.SendStream(pic: TBitmap);
var
  MStream: TMemoryStream;
  pOutBuf: pointer;
  cbOutSize: integer;
begin
  pOutBuf := nil;
  cbOutSize := 0;

  MStream := TMemoryStream.Create;
  try
    pic.SaveToStream(MStream);
    ZCompress(MStream.memory, MStream.size, pOutBuf, cbOutSize, zcMax);
  finally
    MStream.Free;
  end;

  if (pOutBuf <> nil) and (cbOutSize > 0) then
  begin
    IdTCPClient1.Socket.Write(pOutBuf, cbOutSize, 0);
    FreeMem(pOutBuf);
  end;
end;

procedure TFormMain.Timer1Timer(Sender: TObject);
begin
  //via Timer Einzelbilder senden (1-2 Sek. Intervall)
  SendStream(); //Hier komm ihch nicht weiter! Das soll ja ein Bild in Form von TBitmap übergeben werden, aber wie, bzw. wo nehme ich es her?
end;

Server:
Delphi-Quellcode:

// Kompression

procedure CompressBitmap_Slow(bmp: TBitmap; var Data: string);
var
  ms: TMemoryStream;
  buf: pointer;
  size: integer;
begin
  ms := TMemoryStream.Create;
  bmp.SaveToStream(ms);
  ZCompress(ms.Memory, ms.size, buf, size);
  SetLength(Data, size);
  Move(buf^, Data[1], size);
  FreeMem(buf);
  ms.Free;
end;

procedure CompressBitmap(bmp: TBitmap; var Data: string);
var
  cs: TZCompressionStream;
  ms: TMemoryStream;
begin
  ms := TMemoryStream.Create;
  cs := TZCompressionStream.Create(ms, zcDefault);
  bmp.SaveToStream(cs);
  cs.Free;
  SetLength(Data, ms.size);
  Move(ms.Memory^, Data[1], ms.size);
  ms.Free;
end;

procedure UnCompressBitmap(const Data: string; bmp: TBitmap);
var
  ms: TMemoryStream;
  buf: pointer;
  size: integer;
  outsize: integer;
begin
  try
    size := 0;
    outsize := Length(Data) * 3;
    ZDecompress(@Data[1], Length(Data), buf, outsize, size);
  except
    on E: Exception do
    begin
      E.Message := Format('Error Decompressing Buffer (Len = %d):'#13#10'%s',
        [Length(Data), E.Message]);
      raise;
    end;
  end;
  ms := TMemoryStream.Create;
  ms.Write(buf^, outsize);
  FreeMem(buf);
  ms.Position := 0;
  Assert(bmp <> nil);
  bmp.LoadFromStream(ms);
  ms.Free;
end;

{------ MAIN ------}

procedure TForm1.IdTCPServer1Execute(AContext: TIdContext);
var
  Data: string;
  FStream: TMemoryStream;
  bmp: TBitmap;
begin
  FStream := TMemoryStream.Create;

  try
    AContext.Connection.Socket.ReadStream(FStream);
    FStream.Position := 0;
  finally
    try
      FStream.Read(Data, 1000000);
    finally
      bmp.LoadFromStream(FStream);
      FStream.Free;
    end;
  end;

  UnCompressBitmap(Data, bmp);
  PaintBox1.Canvas.Create(bmp); //Bin mir da nicht sicher, was ist mit data?
end;
Also in der PaintBox bekomme ich ein Bild, also funktioeniert das schonmal, jetzt weiß ich aber nicht was das mit TBitmap bei der SendStream-Procedure auf sich hat

Danke,

Lukas
Lukas
  Mit Zitat antworten Zitat