Аналог StretchBlt

[darkwellroad]

Сообщение от vlad1389

Если ты так уверен, что ошибок ни где нет, то как ты объяснишь ошибку, из за которой создал этот топик? Сама по себе появилась? Ошибка в твоём коде. В том, что ты предоставил, я ошибок не вижу. Значит ошибка в том коде, который ты не предоставил.

В том то и дело, что я не понимаю, что я делаю не так. Все компоненты очищаю. В debug никаких ошибок в помине нет. Даже try-except ни в одной функции нету. Просто появляется ошибка EOutOfResources - Error creating window device context. Грешу в сторону ReleaseDc. Приложение многопоточное. Представьте себе 100 потоков, которые 5 раз за каждый цикл работают со StretchBlt.

[vlad1389]

Даже try-except ни в одной функции нету

Плохо. Отличный способ выловить ошибку

[darkwellroad]

Сообщение от vlad1389

Плохо. Отличный способ выловить ошибку

В каждом потоке ловлю.

procedure Thread.DecChThread(Sender: TObject);
var
  E: Exception;
begin
  Dec(ChThCount);
  if WorkC = True then
    begin
      E := ((Sender as TThread).FatalException as Exception);
      if E <> nil then
        ThreadError(E.ClassName + ' сообщает об ошибке ' + E.Message);
      Inc(ThreadErrCount);
      Thread.Create.FreeOnTerminate := True
    end;
  if ChThCount = 0 then
    CheckFormObject;
  Synchronize(SyncCount);
end;

[Пепел Феникса]

ну вы можете использовать DIBitmap, и работать с пикселями напрямую и самостоятельно написать Resize.

вообще любопытно, какая ОС?

[darkwellroad]

Сообщение от Пепел Феникса

ну вы можете использовать DIBitmap, и работать с пикселями напрямую и самостоятельно написать Resize.

вообще любопытно, какая ОС?

10-ка

[min@y™]

Если юзаешь VCL, почему бы не пользоваться TCanvas.StretchDraw()?
Попробуй, а вдруг?

[darkwellroad]

Написал свою мини-функцию. Работает отлично. Все только то, что мне нужно. Без всяких там. Пользуйтесь, кому нужно. Также хочу услышать вашу критику:

procedure TForm1.Button1Click(Sender: TObject);
var
  I, X, Y, Black, White: Integer;
  AttitudeX, AttitudeY: Real;
begin
  AttitudeX := Image1.Width / Image2.Width;
  AttitudeY := Image1.Height / Image2.Height;
  for I := 0 to Image2.Height * Image2.Width - 1 do
    begin
      Black := 0;
      White := 0;
      for X:= round(I div Image2.Height * AttitudeY) to round((I div Image2.Height) * AttitudeY + AttitudeY) do
        for Y:= round(I mod Image2.Width * AttitudeX) to round((I mod Image2.Width) * AttitudeX + AttitudeX) do
          if Image1.Canvas.Pixels[X, Y] = clBlack then
            Inc(Black)
          else
            Inc(White);
      if White <= Black then
        Image2.Canvas.Pixels[I mod Image2.Width, I div Image2.Height] := clBlack
      else
        Image2.Canvas.Pixels[I mod Image2.Width, I div Image2.Height] := clWhite;
    end;
end;

Можно конечно еще поиграться с некоторыми параметрами, типо сглаживание и так далее. Пока не отлаживал на картинках разного размера, только проверил уменьшение и увеличение. Для более сильного сглаживания использую trunc вместо round и прибавляю к циклам по 1:

procedure TForm1.Button1Click(Sender: TObject);
var
  I, X, Y, Black, White: Integer;
  AttitudeX, AttitudeY: Real;
begin
  AttitudeX := Image1.Width / Image2.Width;
  AttitudeY := Image1.Height / Image2.Height;
  for I := 0 to Image2.Height * Image2.Width - 1 do
    begin
      Black := 0;
      White := 0;
      for Y := trunc(I div Image2.Height * AttitudeY) to trunc((I div Image2.Height) * AttitudeY + AttitudeY) + 1 do
        for X := trunc(I mod Image2.Width * AttitudeX) to trunc((I mod Image2.Width) * AttitudeX + AttitudeX) + 1 do
          if Image1.Canvas.Pixels[X, Y] = clBlack then
            Inc(Black)
          else
            Inc(White);
      if White <= Black then
        Image2.Canvas.Pixels[I mod Image2.Width, I div Image2.Height] := clBlack
      else
        Image2.Canvas.Pixels[I mod Image2.Width, I div Image2.Height] := clWhite;
    end;
end;

[min@y™]

Canvas.Pixels[...]

гениально!

[darkwellroad]

Сообщение от min@y™

гениально!

Дай порадоваться) Давно с этой фигней маюсь.

[Пепел Феникса]

доступ к пискелям по одному это узкое место вашего кода.