Блог

 // experimental code
procedure TFormMain.MyThumbnailProvider( const Path: Unicodestring; Width,
 Height: Integer; out Bitmap: TBitmap );
var
   AExtension: string;
   ARect: TRect;
begin
  AExtension := LowerCase( ExtractFileExt( Path ) );
  if AExtension = '.wmf' then
  begin
    ARect.Left := 0;
    ARect.Top := 0;
    ARect.Right := Width;
    ARect.Bottom := Height;
    Image1.Picture.LoadFromFile( Path ); // added at design time to form
    Bitmap := TBitmap.Create;
    Bitmap.Width := Width;
    Bitmap.Height := Height;
    Bitmap.Canvas.StretchDraw( ARect, Image1.Picture.Graphic );
  end;
end;
  

Отредактировано

 procedure TFormMain.MyThumbnailProvider( const Path: Unicodestring; Width, Height: Integer; out Bitmap: TBitmap );
var
  ARect: TRect;
  APicture: TPicture;
  AExtension: string;
begin
  // experimental code
  if FileExists( Path ) then
  begin
    AExtension := LowerCase( ExtractFileExt( Path ) );
    if AExtension = '.wmf' then
    begin
      ARect.Left := 0;
      ARect.Top := 0;
      ARect.Right := Width;
      ARect.Bottom := Height;
      APicture := TPicture.Create;
      try
        APicture.LoadFromFile( Path );
        Bitmap := TBitmap.Create;
        Bitmap.SetSize( Width, Height );
        Bitmap.IgnorePalette := True;
        Bitmap.PixelFormat := pf24bit;
        Bitmap.Transparent := False;
        Bitmap.Canvas.Lock; **// New**
        try
          Bitmap.Canvas.StretchDraw( ARect, APicture.Graphic );
        finally
          Bitmap.Canvas.Unlock;  **// New!**
        end;
      finally
        APicture.Free;
      end;
    end;
  end;
end;
  

Кажется, это полностью устраняет проблему с рисованием! По-видимому, вам приходится блокировать и разблокировать canvas при использовании Draw или StretchDraw, потому что в потоке DC его Bitmap.canvas иногда очищается из-за механизма кэширования объектов GDI в graphics.pas.

Смотрите http://qc.embarcadero.com/wc/qcmain.aspx?d=55871

Нет, из-за этого:

 Image1.Picture.LoadFromFile( Path );
/// [...]
Bitmap.Canvas.StretchDraw( ARect, Image1.Picture.Graphic );
  

Вы можете работать только с элементами управления VCL из основного потока VCL.

В общем случае код VCL не потокобезопасен, и это относится к большинству объектов VCL, доступных для использования.

Вы сказали:

Это кажется потокобезопасным, потому что в потоке не создаются исключения, но изображения кажутся частично пустыми или отображаются неправильно?

«Отсутствие исключений» не является показателем «потокобезопасности». Это то же самое, что сказать «Я поехал на работу и не разбился, так что моя машина устойчива к авариям».

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

• На самом деле вам повезло, если вы получаете исключения из-за проблем с потоками, другие проблемы может быть сложнее отследить или даже осознать, что они возникают.
• Вы можете столкнуться с взаимоблокировками, но если это происходит в фоновом потоке, вы можете даже не осознавать этого.
• Неправильное поведение (как вы сообщаете), обычно из-за условий гонки, в которых:
  • Некоторый код будет взаимодействовать с объектом, пока он находится в несогласованном состоянии, что обычно приводит к крайне непредсказуемому поведению.
  • Данные неправильно «отбрасываются», потому что изменения одной подпрограммы немедленно перезаписывают другие.
• Низкая производительность; да, плохо реализованные многопоточные решения могут серьезно снизить производительность.

Когда вы говорите «изображения кажутся частично пустыми или неправильно отрисовываются», возникает важный вопрос: всегда ли одни и те же изображения ведут себя неправильно, одинаковым образом? Если это так, то проблема может заключаться просто в том, что элемент управления, который вы используете для загрузки изображений, имеет проблемы с этими конкретными файлами.

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

Редактировать
Тогда самым простым решением, вероятно, будет:

• Определите пользовательское значение message const, для которого вы можете реализовать обработчик сообщений.
• Внедрите обработчик сообщений для сообщения
• Измените существующий procedure TFormMain.MyThumbnailProvider , чтобы он мог синхронизироваться с основным потоком VCL, и передайте работу синхронизированному обработчику.

Следующий вызовет ваш пользовательский обработчик в основном потоке VCL и будет ждать возврата.

 procedure TFormMain.MyThumbnailProvider( const Path: Unicodestring; 
  Width, Height: Integer; out Bitmap: TBitmap );
var
  LThumnailData: TThumbnailData; //Assuming an appropriately defined record
begin
  LThumbnailData.FPath := Path;
  LThumbnailData.FWidth := Width;
  LThumbnailData.FHeight := Height;
  LThumbnailData.FBitmap := nil;
  SendMessage(Self.Handle, <Your Message Const>, 0, Longint(@LThumbnailData));
  Bitmap := LThumbnailData.FBitmap;
end;
  

ПРАВКА2
Запрошен дополнительный пример кода:
Объявление сообщения const.

 const
  //Each distinct message must have its own unique ref number.
  //It's recommended to start at WM_APP for custom numbers.
  MSG_THUMBNAILINFO = WM_APP   0;
  

Объявление типа записи. Действительно просто, но вам тоже нужен указатель.

 type
  PThumbnailData = ^TThumbnailData;
  TThumbnailData = record
    FPath: Unicodestring;
    FWidth, FHeight: Integer;
    FBitmap: TBitmap;
  end;
  

Объявляем обработчик сообщений.

 procedure MSGThumbnailInfo(var Message: TMessage); message MSG_THUMBNAILINFO;
  

Реализация обработчика сообщений.

 procedure TForm3.MSGThumbnailInfo(var Message: TMessage);
var
  LThumbnailData: PThumbnailData;
begin
  LThumbnailData := Pointer(Message.LParam);

  //The rest of your code goes here.
  //Don't forget to set LThumbnailData^.FBitmap before done.

  Message.Result := 0;
  inherited;
end;