VPF::Image.Picture.Assign(TBitMap) из TThread. - Форум программистов

Shaman2008

Дата 25.5.2015, 12:17 (ссылка)

(нет голосов)

Загрузка ...

Новичок

Профиль
Группа: Участник
Сообщений: 30
Регистрация: 21.6.2008

Репутация: нет
Всего: нет

Приветствую!
Уважаемые, подскажите, в чем проблема?
Третий день бьюсь. То ли лыжи не едут, то ли у меня какие-то проблемы.
Заблудился в "трех соснах". Проблема следующая:
При вызове метода Assign объекта TImage из потока, картинка на форме обновляется только один раз. Если же этот метод повесить просто на кнопку формы, то при каждом клике все обновляется как надо. Подскажите, где загвоздка? Что мешает обновляться изображению при каждом вызове метода Assign из потока?

Form1

Код


type
  TForm1 = class(TForm)
    Button1: TButton;
    Image1: TImage;
    procedure FormShow(Sender: TObject);
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;
  VS: TVStream;
  TC: TIsChangedThread;

implementation

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);
begin
  TC := TIsChangedThread.Create(VS, Image1);
  TC.Priority := tpNormal;
  //if VS.IsChanged then Image1.Picture.Assign(VS.GetBMScreen);
end;

procedure TForm1.FormShow(Sender: TObject);
begin
  VS := TVStream.Create;
  VS.SetScreenResolution(Screen.Width, Screen.Height);
  VS.SetStreamResolution(image1.Width, Image1.Height);
end;

MyThread

Код


type

  TIsChangedThread = class(TThread)
  private
    { Private declarations }
    fVStream: TVStream;
    fImage: TImage;
    procedure SetChangedFrame;
  protected
    procedure Execute; override;
  public
    constructor Create(var Stream: TVStream; var Image: TImage); overload;
  end;

implementation

constructor TIsChangedThread.Create(var Stream: TVStream; var Image: TImage);
begin
  FreeOnTerminate := True;
  fImage := Image;
  fVStream := Stream;
  inherited Create;
end;

procedure TIsChangedThread.Execute;
begin
  while not Terminated do begin
    if fVStream.IsChanged then begin
      Synchronize(SetChangedFrame);
    end;
    Sleep(500);
  end;
end;

procedure TIsChangedThread.SetChangedFrame;
begin
  fImage.Picture.Assign(fVStream.GetBMScreen);
end;

VStream

Код


type

  pVStream = ^TVStream;
  TVStream = class(TObject)
    private
      fDC: hDC;
      fDCWidth: integer;
      fDCHeight: integer;
      fCurScreen: Vcl.Graphics.TBitmap;
      fPrevScreen: Vcl.Graphics.TBitmap;
      fSLSize: integer;
      fStreamSLSize: integer;
      fJammedScreen: TJpegImage;
      fImageStream: TMemoryStream;
      fIsChanged: boolean;
    public
      constructor Create;
      destructor Destroy; override;
      function IsChanged: boolean;
      function GetBMScreen: Vcl.Graphics.TBitmap;
      procedure SetScreenResolution(NewWidth, NewHeight: integer);
      procedure SetStreamResolution(NewWidth, NewHeight: integer);
  end;

implementation

{ TVStream }

constructor TVStream.Create;
begin
  inherited;
  fDC := GetDC(0);
  fPrevScreen := Vcl.Graphics.TBitmap.Create;
  fPrevScreen.PixelFormat := pf24bit;
  fCurScreen := Vcl.Graphics.TBitmap.Create;
  fCurScreen.PixelFormat := pf24bit;
  fJammedScreen := TJpegImage.Create;
  fJammedScreen.Performance := jpBestSpeed;
  fJammedScreen.CompressionQuality := 50;
  fImageStream := TMemoryStream.Create;
  fIsChanged := False;
end;

destructor TVStream.Destroy;
begin
  ReleaseDC(0, fDC);
  FreeAndNil(fPrevScreen);
  FreeAndNil(fCurScreen);
  FreeAndNil(fJammedScreen);
  FreeAndNil(fImageStream);
  inherited;
end;

function TVStream.GetBMScreen: Vcl.Graphics.TBitmap;
begin
  fIsChanged := False;
  Result := fPrevScreen;
end;

function TVStream.IsChanged: boolean;
var
  i: integer;
begin
  SetStretchBltMode(fCurScreen.Canvas.Handle, HALFTONE);
  StretchBlt(fCurScreen.Canvas.Handle, 0, 0, fCurScreen.Width, fCurScreen.Height, fDC, 0, 0, fDCWidth, fDCHeight, SRCCOPY);
  for i := 0 to fCurScreen.Height - 1 do begin
    if not (CompareMem(fCurScreen.ScanLine[i], fPrevScreen.ScanLine[i], fStreamSLSize)) then begin
      Move(fCurScreen.ScanLine[i]^, fPrevScreen.ScanLine[i]^, fStreamSLSize);
      fIsChanged := True;
    end;
  end;
  Result := fIsChanged;
end;

procedure TVStream.SetStreamResolution(NewWidth, NewHeight: integer);
begin
  if ((NewWidth <= 0) or (NewHeight <= 0)) then Exit;
  fPrevScreen.SetSize(NewWidth, NewHeight);
  fCurScreen.SetSize(NewWidth, NewHeight);
  fStreamSLSize := NewWidth * 3;
end;

procedure TVStream.SetScreenResolution(NewWidth, NewHeight: integer);
begin
  if ((NewWidth <= 0) or (NewHeight <= 0)) then Exit;
  fDCWidth := NewWidth;
  fDCHeight := NewHeight;
  fSLSize := NewWidth * 3;
end;

Заранее, спасибо!

Illusion Dolphin

Дата 25.5.2015, 12:27 (ссылка)

(нет голосов)

Загрузка ...

Эксперт

Профиль
Группа: Участник Клуба
Сообщений: 1198
Регистрация: 3.5.2003

Репутация: 5
Всего: 63

TCanvas нельзя использовать в потоке.

Код


function TVStream.IsChanged: boolean;
var
  i: integer;
begin
  SetStretchBltMode(fCurScreen.Canvas.Handle, HALFTONE); //низя
  StretchBlt(fCurScreen.Canvas.Handle, 0, 0, fCurScreen.Width, fCurScreen.Height, fDC, 0, 0, fDCWidth, fDCHeight, SRCCOPY); //низя
  for i := 0 to fCurScreen.Height - 1 do begin
    if not (CompareMem(fCurScreen.ScanLine[i], fPrevScreen.ScanLine[i], fStreamSLSize)) then begin
      Move(fCurScreen.ScanLine[i]^, fPrevScreen.ScanLine[i]^, fStreamSLSize);
      fIsChanged := True;
    end;
  end;
  Result := fIsChanged;
end;

--------------------

В мире всего две бесконечности: вселенная и человеческая глупость... На счёт вселенной я не уверен.
Шифрование и организация фотографий - Photo Database 4.5

Shaman2008

Дата 25.5.2015, 13:36 (ссылка)

(нет голосов)

Загрузка ...

Новичок

Профиль
Группа: Участник
Сообщений: 30
Регистрация: 21.6.2008

Репутация: нет
Всего: нет

Цитата(Illusion Dolphin @ 25.5.2015, 12:27)

TCanvas нельзя использовать в потоке.

Подскажите, а если я сделаю так:

  ...
  fCurScreen.Canvas.Lock;
  SetStretchBltMode(fCurScreen.Canvas.Handle, HALFTONE);
  StretchBlt(fCurScreen.Canvas.Handle, 0, 0, fCurScreen.Width, fCurScreen.Height, fDC, 0, 0, fDCWidth, fDCHeight, SRCCOPY);
  fCurScreen.Canvas.Unlock;
  ...

Все работает отлично, только имеет ли смысл, в таком случае, использовать отдельный поток? В том смысле, что, я хотел бы разгрузить основой поток от действий, представленных в данном коде. Все ли верно?
Заранее, спасибо!

Это сообщение отредактировал(а) Shaman2008 - 25.5.2015, 13:45

Illusion Dolphin

Дата 25.5.2015, 14:25 (ссылка)

(нет голосов)

Загрузка ...

Эксперт

Профиль
Группа: Участник Клуба
Сообщений: 1198
Регистрация: 3.5.2003

Репутация: 5
Всего: 63

Цитата

Все работает отлично, только имеет ли смысл, в таком случае, использовать отдельный поток?

Вот это правильный вопрос. Когда я в последний раз копался по сырцам делфи ответ был что смысла нету т.к. там где-то был глобальный lock. В любом случае я бы просто постарался избежать обращения к канве.

--------------------

Shaman2008

Дата 25.5.2015, 17:42 (ссылка)

(нет голосов)

Загрузка ...

Новичок

Профиль
Группа: Участник
Сообщений: 30
Регистрация: 21.6.2008

Репутация: нет
Всего: нет

Цитата(Illusion Dolphin @ 25.5.2015, 14:25)

Спасибо огромное за ответ!
Не могли бы Вы подкинуть очень простой пример, как в данной ситуации можно избежать обращения к канве из потока? Просто хочется сделать "ближе к правде", а с потоками я пока, увы, на Вы...
Заранее благодарен.

Illusion Dolphin

Дата 25.5.2015, 21:56 (ссылка)

(нет голосов)

Загрузка ...

Эксперт

Профиль
Группа: Участник Клуба
Сообщений: 1198
Регистрация: 3.5.2003

Репутация: 5
Всего: 63

Цитата

как в данной ситуации можно избежать обращения к канве из потока?

А зачем вам она нужна? Если у вас ресайз, то его можно без канвы сделать и нет проблем.

--------------------

1 Пользователей читают эту тему (1 Гостей и 0 Скрытых Пользователей)
0 Пользователей:
« Предыдущая тема \| Delphi: Для новичков \| Следующая тема »