TThread operacja na pliku - błędy Nieprawidłowe dojście itp.

0

Witam wszystkich mam problem z jedną z procedur która jest w klasie TThread. Poniżej przedstawiam całą procedurę:

procedure TPrestaProductPictureAdd.AddWatermarkJpg(oldFile: string; newFile: string; Watermark: TPicture; WaterMark_Transparency: Byte = 70);
var
  CurrentPicture: TBitmap;
  PictureWatermark, L: TBitmap;
  jpg: TJpegImage;
  NewHeight: Integer;
  NewWidth: Integer;
  X, Y: Integer;
begin
  jpg := TJpegImage.Create;
  try
    try
      jpg.Loadfromfile(oldFile);
      CurrentPicture := TBitmap.Create;
      Try
        { Tworzy płutno z zawartością JPG }
        CurrentPicture.Width := jpg.Width;
        CurrentPicture.Height := jpg.Height;
        CurrentPicture.Canvas.Draw(0, 0, jpg);

        { Wstawianie znaku wodnego }
        PictureWatermark := TBitmap.Create;
        Try
          If Assigned(Watermark.Graphic) then
            If not Watermark.Graphic.Empty then
            Begin
              PictureWatermark.Width := Watermark.Width;
              PictureWatermark.Height := Watermark.Height;
              PictureWatermark.Canvas.Draw(0, 0, Watermark.Graphic);

              NewHeight := Round(CurrentPicture.Height * 0.5);
              NewWidth := Round(CurrentPicture.Height * 0.5) * PictureWatermark.Width div PictureWatermark.Height;
              if NewWidth > CurrentPicture.Width then
              begin
                NewWidth := Round(CurrentPicture.Width * 0.5);
                NewHeight := NewWidth * PictureWatermark.Height div PictureWatermark.Width;
              end;

              L := TBitmap.Create;
              Try
                L.Width := NewWidth;
                L.Height := NewHeight;
                L.TransparentColor := clWhite;
                L.Transparent := True;

                L.Canvas.StretchDraw(Rect(0, 0, NewWidth, NewHeight), PictureWatermark);

                X := (CurrentPicture.Width - L.Width) div 2;
                Y := (CurrentPicture.Height - L.Height) div 2;

                DrawTransparency(CurrentPicture.Canvas, X, Y, L, WaterMark_Transparency);
              Finally
                L.Free;
              end;
            end;
        Finally
          PictureWatermark.Free;
        End;
        jpg.Assign(CurrentPicture);
        jpg.SaveToFile(newFile);
      finally
        CurrentPicture.Free;
      end;
    except
      raise;
    end;
  finally
    jpg.Free;
  end;
end;
 

Gdy uruchamiam wątek z programu głównego to co 3,4 odpalenie procedury dostaję takie błędy:

  1. Nieprawidłowe dojście. (ten jest najczęściej)
  2. Niemożna utworzyć pliku, który już istnieje.
  3. Out of memory

//FastMM4 potem zgłasza mi: EOutOfResources x2 oraz UnicodeString x2

Czy operacja na pliku typu zapis / odczyt powinny być zsynchronizowane po przez np. Synchronize(ZapiszJPG)?

0

Czy operacja na pliku typu zapis / odczyt powinny być zsynchronizowane po przez np. Synchronize(ZapiszJPG)?

Najlepiej by było, gdybyś umożliwił tylko jednemu wątkowi naraz korzystać z pliku, a pozostałe niech czekają;

Jeśli o sam kod chodzi to wypadałoby go poprawić, nie tylko jeśli chodzi o synchronizację:

  • słowa kluczowe piszemy wyłącznie małymi literami,
  • stosujesz mieszane nazewnictwo parametrów, więc użyj jednego - np. prefiksu A i sensownych nazw w stylu AOldFilename, ANewFilename, AWatermark i ATransparency, przy czym dwa pierwsze zgrupuj, skoro są tego samego typu,
  • jeżeli potrzebujesz trzymać czegoś wymiary 2D, to użyj do tego jednej zmiennej, np. TPoint,
  • jeżeli chcesz nadać całkiem nowy rozmiar grafice, która przechowywana jest w obiekcie jakiejkolwiek klasy dziedziczącej z TGraphic to używaj metody SetSize,
  • zmienną L da się nazwać sensowniej,
  • jeżeli w sekcji Except nie wykonujesz żadnego własnego kodu i tylko wołasz Raise, cała ta sekcja nie jest w ogóle potrzebna - bez tej sekcji i instrukcji Raise wyjątek sam automatycznie zostanie przekazany wyżej.
1
furious programming napisał(a):
  • jeżeli w sekcji Except nie wykonujesz żadnego własnego kodu i tylko wołasz Raise, cała ta sekcja nie jest w ogóle potrzebna - bez tej sekcji i instrukcji Raise wyjątek sam automatycznie zostanie przekazany wyżej.

z wątkami to tak nie działa - po prostu wywali wątek i tyle :p

0

@abrakadaber - owszem, ten punkt dopisałem później (jako ogólną wskazówkę), żeby w ogóle nie używać Except tylko z Raise, bo to w każdym przypadku sensu nie ma.

0

Dziękuję za odpowiedź w bloku except jest tylko raise bo cała resztę kodu usunąłem aby znaleźć co powoduje błąd dlatego to wygląda jak wygląda :)

Całą tą procedurę wywołuję po przez synchronize co powoduje oczywiście chwilowe zamrożenia aplikacji ale błędy nadal te same, więc nie w tym rzecz. Wywala albo na Save albo na Load. Dziś spróbuję jeszcze odpalić tą procedurę w wątku głównym zamiast pobocznym aplikacji zobaczymy co się stanie.

Dodam że żaden inny program ani wątek nie korzysta z plików które są ładowane do procedury.

0

Dodam że żaden inny program ani wątek nie korzysta z plików które są ładowane do procedury.

Skoro nic innego nie korzysta w tym samym czasie z pliku to ta metoda również powinna źle działać, jeśli wywoła się ją z głównego wątku;


Mam pytanie np. do @abrakadaber - zwykle metody zapisujące dane z obiektów do plików korzystają wewnętrznie ze strumieni plikowych; Strumienie te tworzone są jedynie z flagą fmCreate; Przykład metody TGraphic.SaveToFile z Lazarusa:

procedure TGraphic.SaveToFile(const Filename: string);
var
  Stream: TStream;
begin
  Stream := TFileStreamUTF8.Create(Filename, fmCreate);
  try
    SaveToStream(Stream);
  finally
    Stream.Free;
  end;
end;

Czy takie utworzenie strumienia blokuje możliwość odczytu danych z pliku innemu wątkowi/procesowi? Czy konieczne jest używanie flagi fmShareDenyNone (dla braku ograniczeń) lub fmShareDenyWrite (aby zablokować tylko możliwość zapisu)? Ja zwykle korzystam w takim przypadku z poniższej konfiguracji:

fsOutput := TFileStream.Create(FFileName, fmCreate or fmShareDenyWrite);

Ale nie zastanawiałem się nad tym, czy faktycznie możliwość odczytu w tym samym czasie jest dozwolona; Choć i tak było by to głupie, bo inny wątek/proces czytałby sieczkę, stąd fmShareExclusive też mogło by być;

Edit: A zresztą, sprawdzę sobie.

1

w Delphi fmCreate to fmCreate: Integer = $FF00; (w D7 było fmCreate = $FFFF) natomiast fmOpenxxx to pierwszy bajt a fmSharexxx to drugi bajt. Jedynie fmShareCompat = 0. Więc fmCreate tworzy plik z prawami wielodostępu jaki jest zaimplementowany domyślnie w systemie. W windowsie działa to tak jakbyś otwarł/stworzył plik w trybie fmShareExclusive, a na linuxie jak fmShareDenyNone

Czyli odpowiedź na

Czy takie utworzenie strumienia blokuje możliwość odczytu danych z pliku innemu wątkowi/procesowi? Czy konieczne jest używanie flagi fmShareDenyNone (dla braku ograniczeń) lub fmShareDenyWrite (aby zablokować tylko możliwość zapisu)?

brzmi: na windowsie tak

0

Pobawiłem się dziś troszkę z moją procedurą i przedstawiam fragment procedury:

        jpg.Compress;
        ftext := ftext + 'Save,';
        jpg.SaveToFile(newFile);
        ftext := ftext + 'Save+ok,';
      Finally
        NewPicture.Free;
        ftext := ftext + 'NewPicture-free,';
      End;
    finally
      CurrentPicture.Free;
      ftext := ftext + 'CurPicture-Free,';
    end;
  finally
    jpg.Free;
    ftext := ftext+'JPG FREE,';
  end;   <--------------------
  ftext := ftext+'End,';
end;

Sposób może prostacki ale błąd o nazwie Nieprawidłowe dojście pojawia się tam gdzie przed ostatni end; a wiem to dlatego że gdy wystąpi wyjątek wyświetla mi się zawartość stringa ftext i ostatnie co jest w stringu to '....JPG FREE,'

Do czego dokładnie służy CoInitialize?

0

daj CAŁY kod wątku bo tak to sobie możemy pogdybać

1

Wypieprz cały blok try except(ten z raise), cały kod tej procedury weź w blok try except z tym że coś na wzór:

  try
    //KOD
  except
    on E: Exception do //tu postaw breakpointa
    begin
      Caption:= Format('Exception: %0:s Class: %1:s At Address: 0x%2:.8x', [E.Message, E.ClassName, Integer(ExceptAddr)]);
    end;
  end;

Od brakpointa debuguj F8 z włączonym widokiem CPU aż zobaczysz adres wyjątku (po call ExceptAddr w EAX będzie) wtedy przewiń pod ten adres i zobaczysz co jest pod tym adresem (czyli na czym się wywala) w 2 minuty a nie w 2 dni.

0

@kAzek zaraz to spróbuję, poniżej wstawiłem cały kod.

 
unit uTest;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Internet,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, sLabel, sGauge, Vcl.Graphics,
  MyAccess, rDefineMySQL, uConst, Vcl.Buttons, sSpeedButton, PrestaShopConst, Vcl.ExtCtrls, Jpeg;

type
  TImageType = packed record
    Name: String;
    Width: Integer;
    Height: Integer;
  end;

  TArrayImageType = array of TImageType;

type
  TImageTypePresta = class
    fArrayImageType: TArrayImageType;
    fTypeCount: Integer;
    fConnection: TMyConnection;
  private
  public
    constructor Create(MyConnection: TMyConnection);
    Procedure GetImageType;
    Property ArrayType: TArrayImageType read fArrayImageType write fArrayImageType;
    Property TypeCount: Integer read fTypeCount;
  published
  end;

type
  TReferenceToIdProduct = packed record
    Reference: string;
    IdProduct: Integer;
  end;

  TLinkReferenceToIdProduct = Array of TReferenceToIdProduct;

type
  TFileImage = packed record
    Name: String;
    Size: Integer;
    Raflo_ImageId: Integer;
  end;

  TArrayFileImage = Array of TFileImage;

type
  TProduct = packed record
    Coded: String;
    Name: String;
    Raflo_DetailsId: Integer;
    Raflo_IdCategory: Integer;
    QtyInWarehause: Integer;
    Price: Double;
    DescProduct: String;
    DescTechnical: String;
    Width: Double;
    Height: Double;
    Depth: Double;
    Weight: Double;
    State: String;
    FileImage: TArrayFileImage;
    IdStatusDecription: Integer;
  end;

  TArrayProduct = Array of TProduct;

type
  TPrestaProductPictureAdd = class(TThread)
    fException: Exception;
    fPrestaModule: TForm;
    fFTP: TFTP;
    fIT: TImageTypePresta;
    fProgress: Integer;
    fProgressMax: Integer;
    fProgressTitle: String;
    fProgressMore: Integer;
    fProgressMoreMax: Integer;
    fProgressMoreTitle: String;
    fLinkReferenceToIdProduct: TLinkReferenceToIdProduct;
    fsup: Integer;
  public
    constructor Create(fPM: TForm);  //(fPM: TfPrestashopModule);
    destructor Destroy; override;
  private
    procedure DoHandleException;
    procedure sUp;
    procedure ShowError;

    function CreateDirList(ID: Integer): String;
    procedure SendOrUpdateFile(ID: Integer);
    procedure DrawTransparency(Canvas: TCanvas; X, Y: Integer; aBitmap: TBitmap; Transparency: Byte);
    procedure ChangeResizeJpg(AOldFilename, ANewFilename: string; AWatermark: TPicture; Height, Width: Integer; ATransparency: Byte = 70;
      background: TColor = clWhite);
    procedure AddWatermarkJpg(AOldFilename, ANewFilename: string; AWatermark: TPicture; ATransparency: Byte = 70);
    procedure PrepareImage(ID: Integer; fFile: string);
    Procedure AddImage(Product: TProduct);
    procedure GetAllReferenceFromPresta;
    procedure UpdateProgress;
    procedure SetProgress;
    procedure UpdateProgressMore;
    procedure SetProgressMore;
  protected
    procedure Execute; override;
    procedure HandleException; virtual;
  end;



implementation

// -----------------------------------------------------------------------------------------------------------
// TImageTypePresta
// -----------------------------------------------------------------------------------------------------------

Constructor TImageTypePresta.Create(MyConnection: TMyConnection);
begin
  fConnection := MyConnection;
  fTypeCount := 0;
  setlength(fArrayImageType, 0);
end;

Procedure TImageTypePresta.GetImageType;
{ Pobiera nazwy i rozmiary w jakich muszą zostać utworzone pliki ze zdjęciami produktu }
var
  DataPresta: TMyQuery;
begin
  DataPresta := TMyQuery.Create(nil);
  Try
    DataPresta.Connection := fConnection;
    DataPresta.SQL.Text := 'SELECT * FROM ' + Tab_Ps_image_type + ' WHERE ' + psit_products + '=1';
    DataPresta.Active := True;
    fTypeCount := DataPresta.RecordCount;
    setlength(fArrayImageType, fTypeCount);
    while not DataPresta.Eof do
    begin
      fArrayImageType[DataPresta.RecNo - 1].Name := DataPresta.FieldByName(psit_name).AsString;
      fArrayImageType[DataPresta.RecNo - 1].Width := DataPresta.FieldByName(psit_width).AsInteger;
      fArrayImageType[DataPresta.RecNo - 1].Height := DataPresta.FieldByName(psit_height).AsInteger;
      DataPresta.Next;
    end;
  Finally
    DataPresta.Free;
  End;
end;

// -------------------------------------------------------------------------------------------------------------------------------
// Thread PrestaProductPictureAdd
// -------------------------------------------------------------------------------------------------------------------------------
constructor TPrestaProductPictureAdd.Create(fPM: TForm);
begin
  fPrestaModule := fPM;
  FreeOnTerminate := True;
  fIT := TImageTypePresta.Create(fPrestaModule.fConnectionShop);
  inherited Create(False);
end;

destructor TPrestaProductPictureAdd.Destroy;
begin
  fIT.Free;
  inherited Destroy;
end;

procedure TPrestaProductPictureAdd.DoHandleException;
begin
  if GetCapture <> 0 then
    SendMessage(GetCapture, WM_CANCELMODE, 0, 0);
  if fException is Exception then
    Application.ShowException(fException)
  else
    System.SysUtils.ShowException(fException, nil);
end;

procedure TPrestaProductPictureAdd.HandleException;
begin
  // This function is virtual so you can override it
  // and add your own functionality.
  fException := Exception(ExceptObject);
  try
    // Don't show EAbort messages
    if not(fException is EAbort) then
      Synchronize(DoHandleException);
  finally
    fException := nil;
  end;
end;

procedure TPrestaProductPictureAdd.UpdateProgress;
begin
  fPrestaModule.SetGauge(fProgress);
end;

procedure TPrestaProductPictureAdd.SetProgress;
begin
  fPrestaModule.InfoLabel(fProgressTitle);
  fPrestaModule.InitGauge(fProgressMax);
  fPrestaModule.SetGauge(0);
end;

procedure TPrestaProductPictureAdd.UpdateProgressMore;
begin
  fPrestaModule.SetGaugeMore(fProgressMore);
end;

procedure TPrestaProductPictureAdd.SetProgressMore;
begin
  fPrestaModule.InfoMoreLabel(fProgressMoreTitle);
  fPrestaModule.InitGaugeMore(fProgressMoreMax);
  fPrestaModule.SetGaugeMore(0);
end;

procedure TPrestaProductPictureAdd.Execute;
var
  RP: TRafloProducts;
  PNR: Integer;
begin
    fException := nil;
    sleep(200); // Czas na wykonanie ShowModal

    Try
      fProgressTitle := 'Wgrywanie nowych zdjęć do produktów';
      fProgressMax := 1;
      Synchronize(SetProgress);
      fIT.GetImageType;
      RP := TRafloProducts.Create(fPrestaModule.ConnectionRaflo);
      Try
        RP.OnlyGetCodec := True;
        RP.GetImageId := True;
        GetAllReferenceFromPresta;

        if fPrestaModule.UpdateFromArray then
        begin
          // From list
          fProgressMax := High(fPrestaModule.fArrayProductIdDetails);
          if fProgressMax < 0 then
          begin
            PostMessage(fPrestaModule.Handle, WM_EndThread, Msg_Error, 0); // Aborted
            Exit;
          end;
          Synchronize(SetProgress);
          RP.AddProduct(fPrestaModule.fArrayProductIdDetails); // Odczyt produktu
          for PNR := 0 to High(fPrestaModule.fArrayProductIdDetails) do
          begin
            AddImage(RP.Product[PNR]);
            fProgress := PNR;
            Synchronize(UpdateProgress);
            if fPrestaModule.Aborted then
            begin
              PostMessage(fPrestaModule.Handle, WM_EndThread, Msg_Aborted, 0); // Aborted
              Exit;
            end;
          end;
        end
        else
        begin
          // All
          RP.AddProduct(fPrestaModule.fArrayProductIdDetails); // Odczyt produktu
          fProgressMax := RP.ProductCount;
          Synchronize(SetProgress);
          for PNR := 0 to RP.ProductCount - 1 do
          begin
            AddImage(RP.Product[PNR]);
            fProgress := PNR;
            Synchronize(UpdateProgress);
            if fPrestaModule.Aborted then
            begin
              PostMessage(fPrestaModule.Handle, WM_EndThread, Msg_Aborted, 0); // Aborted
              Exit;
            end;
          end;
        end;
      Finally
        RP.Free;
      End;
      PostMessage(fPrestaModule.Handle, WM_EndThread, Msg_OK, 0)
    Except
      HandleException;
    End;
end;

Procedure TPrestaProductPictureAdd.ShowError;
Begin
  raise Exception.Create('Procedura przerwana');
End;

Procedure TPrestaProductPictureAdd.GetAllReferenceFromPresta;
var
  DataPresta: TMyQuery;
begin
  DataPresta := TMyQuery.Create(nil);
  Try
    DataPresta.Connection := fPrestaModule.ConnectionShop;
    DataPresta.SQL.Text := 'SELECT ' + psp_id_product + ',' + psp_reference + ' FROM ' + Tab_ps_product;
    DataPresta.Active := True;
    setlength(fLinkReferenceToIdProduct, DataPresta.RecordCount);
    While not DataPresta.Eof do
    begin
      fLinkReferenceToIdProduct[DataPresta.RecNo - 1].Reference := UpperCase(DataPresta.FieldByName(psp_reference).AsString);
      fLinkReferenceToIdProduct[DataPresta.RecNo - 1].IdProduct := DataPresta.FieldByName(psp_id_product).AsInteger;
      DataPresta.Next;
    end;
  Finally
    DataPresta.Free;
  End;
end;

Procedure TPrestaProductPictureAdd.AddImage(Product: TProduct);

type
  TExecute = (Nothing, Add, Update);

var
  DataPresta: TMyQuery;
  DataRaflo: TMyQuery;
  X, Y: Integer;
  fIdImage: Integer;
  RecImage: Integer;
  ArrayIdImage: Array of Integer;
  Execute: TExecute;
  LastImage: Integer;

  function IdImageIsInPresta(aId: Integer): Boolean;
  var
    Z: Integer;
  begin
    Result := False;
    for Z := 0 to High(ArrayIdImage) do
      if ArrayIdImage[Z] = aId then
        Exit(True);
  end;

  function BuildSetIdImage: String;
  var
    B: Integer;
  begin
    Result := '(';
    for B := 0 to High(ArrayIdImage) do
      Result := Result + IntToStr(ArrayIdImage[B]) + ',';
    Result[High(Result)] := ')';
  end;

begin
  DataPresta := TMyQuery.Create(nil);
  Try
    DataPresta.Connection := fPrestaModule.ConnectionShop;
    for X := 0 to High(fLinkReferenceToIdProduct) do
      if fLinkReferenceToIdProduct[X].Reference = Product.Coded then
        break;

    if X <= High(fLinkReferenceToIdProduct) then
    begin

      // Werfikacja zdjec juz wgranych a te które są do wgrania
      // Pobierz idImage zdjec danego produktu z PrestaShop
      DataPresta.SQL.Text := 'SELECT ' + psi_id_image + ',' + psi_position + ' FROM ' + Tab_ps_image + ' WHERE ' + psi_id_product + '=' +
        IntToStr(fLinkReferenceToIdProduct[X].IdProduct) + ' ORDER BY ' + psi_position;
      DataPresta.Active := True;
      setlength(ArrayIdImage, DataPresta.RecordCount);
      LastImage := 0;
      while not DataPresta.Eof do
      begin
        ArrayIdImage[DataPresta.RecNo - 1] := DataPresta.FieldByName(psi_id_image).AsInteger;
        LastImage := DataPresta.FieldByName(psi_position).AsInteger;
        DataPresta.Next;
      end;

      DataRaflo := TMyQuery.Create(nil);
      Try
        DataRaflo.Connection := fPrestaModule.ConnectionRaflo;
        {...}
        // Przygotuj zdjęcia
        fIdImage := 1; 
        PrepareImage(fIdImage + fLinkReferenceToIdProduct[X].IdProduct * 10, Product.FileImage[0].Name);
        {...}
      Finally
        DataRaflo.Free;
      End;
    end;
  Finally
    DataPresta.Free;
  End;
end;

function TPrestaProductPictureAdd.CreateDirList(ID: Integer): String;
var
  X: Integer;
  T: String;
begin
  Result := '';
  T := IntToStr(ID);
  for X := 1 to Length(T) do
    Result := Result + T[X] + '/';
end;

procedure TPrestaProductPictureAdd.sUp;
begin
  SendOrUpdateFile(fsup);
end;

procedure TPrestaProductPictureAdd.SendOrUpdateFile(ID: Integer);
var
  FoundFile: Integer;
  DirList: TStringList;
  RecFile: TSearchRec;
begin
  fPrestaModule.FTPShop.Login;
  fPrestaModule.FTPShop.ChangeToRootDir;
  fPrestaModule.FTPShop.ForceCreateDir(urlImgPrestashop + CreateDirList(ID));

  // Pobieranie listy plików
  DirList := TStringList.Create;
  try
    FoundFile := FindFirst(SystemRaflo.Path.AppData + PathPrestaShop + IntToStr(ID) + '\*.*', faAnyFile, RecFile);
    while FoundFile = 0 do
    begin
      if RecFile.Name[1] <> '.' then
        DirList.Add(SystemRaflo.Path.AppData + PathPrestaShop + IntToStr(ID) + '\' + RecFile.Name);
      FoundFile := FindNext(RecFile);
    end;

    // Wgrywanie plików na serwer
    for FoundFile := 0 to DirList.Count - 1 do
    begin
      fPrestaModule.FTPShop.DirectFileName := DirList[FoundFile];
      fPrestaModule.FTPShop.DirectFile := True;
      fPrestaModule.FTPShop.StoreFile(ExtractFileName(DirList[FoundFile]), not True);
    end;

  finally
    DirList.Free;
  end;
end;

procedure TPrestaProductPictureAdd.PrepareImage(ID: Integer; fFile: string);
const
  index = '<?php' + #13#10 + 'header("Expires: Mon, 26 Jul 1997 05:00:00 GMT");' + #13#10 + 'header("Last-Modified: ".gmdate("D, d M Y H:i:s")." GMT");' +
    #13#10 + 'header("Cache-Control: no-store, no-cache, must-revalidate");' + #13#10 + 'header("Cache-Control: post-check=0, pre-check=0", false);' + #13#10 +
    'header("Pragma: no-cache");' + #13#10 + 'header("Location: ../");' + #13#10 + 'exit;';
var
  TypeNr: Integer;
  Transparancy: Integer;
  Path: String;
  TF: TextFile;
begin
  Path := SystemRaflo.Path.AppData + PathPrestaShop + IntToStr(ID) + '\';
  ForceDirectories(Path);

  if fPrestaModule.Settings.Watermark_Active Then
    Transparancy := 70
  else
    Transparancy := 100;

  // AddWatermarkJpg(PWideChar(fFile), PWideChar(Path + IntToStr(ID) + '.jpg'), CompanyData.Logo, Transparancy);

  for TypeNr := 0 to fIT.TypeCount - 1 do
    ChangeResizeJpg(fFile, Path + IntToStr(ID) + '-' + fIT.ArrayType[TypeNr].Name + '.jpg', CompanyData.Logo, fIT.ArrayType[TypeNr].Height,
      fIT.ArrayType[TypeNr].Width, Transparancy);

  // Wymagany plik index.php przez prestashop
  AssignFile(TF, Path + 'index.php');
  Try
    ReWrite(TF);
    Write(TF, Index);
    Flush(TF);
  Finally
    CloseFile(TF);
  End;
end;

procedure TPrestaProductPictureAdd.AddWatermarkJpg(AOldFilename, ANewFilename: string; AWatermark: TPicture; ATransparency: Byte = 70);
var
  CurrentPicture: TBitmap;
  PictureWatermark: TBitmap;
  jpg: TJpegImage;
  NewHeight: Integer;
  NewWidth: Integer;
  pt: TPoint;
begin
  jpg := TJpegImage.Create;
  try
    try
      jpg.Loadfromfile(AOldFilename);
      CurrentPicture := TBitmap.Create;
      Try
        { Tworzy płutno z zawartością JPG }
        CurrentPicture.Width := jpg.Width;
        CurrentPicture.Height := jpg.Height;
        CurrentPicture.Canvas.Draw(0, 0, jpg);
        { Wstawianie znaku wodnego }
        If Assigned(AWatermark.Graphic) then
          If not AWatermark.Graphic.Empty then
          Begin
            NewHeight := Round(CurrentPicture.Height * 0.5);
            NewWidth := Round(CurrentPicture.Height * 0.5) * PictureWatermark.Width div PictureWatermark.Height;
            if NewWidth > CurrentPicture.Width then
            begin
              NewWidth := Round(CurrentPicture.Width * 0.5);
              NewHeight := NewWidth * PictureWatermark.Height div PictureWatermark.Width;
            end;

            PictureWatermark := TBitmap.Create;
            Try
              PictureWatermark.SetSize(NewWidth, NewHeight);
              PictureWatermark.TransparentColor := clWhite;
              PictureWatermark.Transparent := True;
              PictureWatermark.Canvas.StretchDraw(Rect(0, 0, NewWidth, NewHeight), AWatermark.Graphic);

              pt.X := (CurrentPicture.Width - PictureWatermark.Width) div 2;
              pt.Y := (CurrentPicture.Height - PictureWatermark.Height) div 2;

              DrawTransparency(CurrentPicture.Canvas, pt.X, pt.Y, PictureWatermark, ATransparency);
            Finally
              PictureWatermark.Free;
            end;
          end;
        jpg.Assign(CurrentPicture);
        jpg.SaveToFile(ANewFilename);
      finally
        CurrentPicture.Free;
      end;
    except
      raise;
    end;
  finally
    jpg.Free;
  end;
end;


procedure TPrestaProductPictureAdd.ChangeResizeJpg(AOldFilename, ANewFilename: string; AWatermark: TPicture; Height, Width: Integer;
  ATransparency: Byte = 70; background: TColor = clWhite);
{ Procedura zmienia wielkość zdjęcia i jeśli szerokość albo wysokość podana jest nieproporcjonalna co do zdjęcia to
  zostaje to uzupełnione tłem o kolorze background }
var
  CurrentPicture: TBitmap;
  NewPicture: TBitmap;
  PictureWatermark: TBitmap;
  jpg: TJpegImage;
  NewHeight: Integer;
  NewWidth: Integer;
  pt: TPoint;
begin
  jpg := TJpegImage.Create;
  try
    jpg.Loadfromfile(AOldFilename);
    // Proporcjonalne pomnijeszenie
    NewHeight := Height;
    NewWidth := Height * jpg.Width div jpg.Height;
    if NewWidth > Width then
    begin
      NewWidth := Width;
      NewHeight := NewWidth * jpg.Height div jpg.Width;
    end;
    CurrentPicture := TBitmap.Create;
    try
      NewPicture := TBitmap.Create;
      try
        { Tworzy nowy rysunek z zachowanie proporcji }
        CurrentPicture.SetSize(NewWidth, NewHeight);
        CurrentPicture.Canvas.StretchDraw(CurrentPicture.Canvas.Cliprect, jpg);

        { Tworzenie tła o podanych wymiarach i kolorze }
        NewPicture.SetSize(Height, Width);
        NewPicture.Canvas.Brush.Style := bsSolid;
        NewPicture.Canvas.Brush.Color := background;
        NewPicture.Canvas.FillRect(Rect(0, 0, Width, Height));
        { Nakładanie obrazka na tło }
        pt.X := (Width - CurrentPicture.Width) div 2;
        pt.Y := (Height - CurrentPicture.Height) div 2;
        NewPicture.Canvas.Draw(pt.X, pt.Y, CurrentPicture);

        { Wstawianie znaku wodnego }
        if Assigned(AWatermark.Graphic) then
          if not AWatermark.Graphic.Empty then
          begin
            if NewPicture.Width > 200 then
            begin
              NewHeight := Round(NewPicture.Height * 0.5);
              NewWidth := Round(NewPicture.Height * 0.5) * AWatermark.Width div AWatermark.Height;
              if NewWidth > NewPicture.Width then
              begin
                NewWidth := Round(NewPicture.Width * 0.5);
                NewHeight := NewWidth * AWatermark.Height div AWatermark.Width;
              end;
              PictureWatermark := TBitmap.Create;
              Try
                PictureWatermark.SetSize(NewWidth, NewHeight);
                PictureWatermark.TransparentColor := clWhite;
                PictureWatermark.Transparent := True;
                PictureWatermark.Canvas.StretchDraw(Rect(0, 0, NewWidth, NewHeight), AWatermark.Graphic);
                pt.X := (NewPicture.Width - PictureWatermark.Width) div 2;
                pt.Y := (NewPicture.Height - PictureWatermark.Height) div 2;
                DrawTransparency(NewPicture.Canvas, pt.X, pt.Y, PictureWatermark, ATransparency);
              Finally
                PictureWatermark.Free;
              End;
            end;
          end;

        jpg.Assign(NewPicture);
        jpg.CompressionQuality := 85;
        jpg.Compress;
        jpg.SaveToFile(ANewFilename);
      finally
        NewPicture.Free;
      end;
    finally
      CurrentPicture.Free;
    end;
  finally
    jpg.Free;
  end;
end;

procedure TPrestaProductPictureAdd.DrawTransparency(Canvas: TCanvas; X, Y: Integer; ABitmap: TBitmap; Transparency: Byte);
var
  Temp: TBitmap;
  ByteSrc, ByteDest: ^Byte;
  TripleSrc, TripleDest: ^TRGBTriple;
  TransparentColor: TRGBTriple;
  H, V: Integer;
begin
  ABitmap.PixelFormat := pf24bit;
  Temp := TBitmap.Create;
  Temp.Canvas.Brush.Color := ABitmap.TransparentColor;
  Temp.Width := ABitmap.Width;
  Temp.Height := ABitmap.Height;
  Temp.PixelFormat := pf24bit;
  Temp.Canvas.CopyRect(Rect(0, 0, ABitmap.Width, ABitmap.Height), Canvas, Rect(X, Y, ABitmap.Width + X, ABitmap.Height + Y));

  if ABitmap.Transparent then
  begin
    TransparentColor.rgbtBlue := (ABitmap.TransparentColor and $FF0000) shr 16;
    TransparentColor.rgbtGreen := (ABitmap.TransparentColor and $00FF00) shr 8;
    TransparentColor.rgbtRed := ABitmap.TransparentColor and $0000FF;

    Temp.TransparentColor := ABitmap.TransparentColor;
    Temp.Transparent := True;

    for V := 0 to ABitmap.Height - 1 do
    begin
      TripleSrc := ABitmap.Scanline[V];
      TripleDest := Temp.Scanline[V];
      for H := 0 to ABitmap.Width - 1 do
      begin
        if (TransparentColor.rgbtBlue <> TripleSrc.rgbtBlue) or (TransparentColor.rgbtGreen <> TripleSrc.rgbtGreen) or
          (TransparentColor.rgbtRed <> TripleSrc.rgbtRed) then
        begin
          TripleDest^.rgbtBlue := Trunc((TripleDest^.rgbtBlue / 100) * Transparency + (TripleSrc^.rgbtBlue / 100) * (100 - Transparency));
          TripleDest^.rgbtGreen := Trunc((TripleDest^.rgbtGreen / 100) * Transparency + (TripleSrc^.rgbtGreen / 100) * (100 - Transparency));
          TripleDest^.rgbtRed := Trunc((TripleDest^.rgbtRed / 100) * Transparency + (TripleSrc^.rgbtRed / 100) * (100 - Transparency));
        end;

        Inc(TripleSrc);
        Inc(TripleDest);
      end;
    end;
  end
  else
  begin
    for V := 0 to ABitmap.Height - 1 do
    begin
      ByteSrc := ABitmap.Scanline[V];
      ByteDest := Temp.Scanline[V];
      for H := 0 to ABitmap.Width * 3 - 1 do
      begin
        ByteDest^ := Trunc((ByteDest^ / 100) * Transparency +
          (ByteSrc^ / 100) * (100 - Transparency));
        Inc(ByteSrc);
        Inc(ByteDest);
      end;
    end;
  end;
  Canvas.Draw(X, Y, Temp);
  Temp.Free;
end;


end.
0
  1. co to jest CompanyData?
  2. jeśli ktoś przekaże AWatermark = nil to to If Assigned(AWatermark.Graphic) then się wywali
  3. tu masz błąd
jpg := TJpegImage.Create;
  try
    try
      jpg.Loadfromfile(AOldFilename);
      CurrentPicture := TBitmap.Create;
      Try
        { Tworzy płutno z zawartością JPG }
        CurrentPicture.Width := jpg.Width;
        CurrentPicture.Height := jpg.Height;
        CurrentPicture.Canvas.Draw(0, 0, jpg);
        { Wstawianie znaku wodnego }
        If Assigned(AWatermark.Graphic) then
          If not AWatermark.Graphic.Empty then
          Begin
            NewHeight := Round(CurrentPicture.Height * 0.5);
            NewWidth := Round(CurrentPicture.Height * 0.5) * PictureWatermark.Width div PictureWatermark.Height;
            if NewWidth > CurrentPicture.Width then
            begin
              NewWidth := Round(CurrentPicture.Width * 0.5);
              NewHeight := NewWidth * PictureWatermark.Height div PictureWatermark.Width;
            end;
 
            PictureWatermark := TBitmap.Create;

najpierw używasz NewWidth := Round(CurrentPicture.Height * 0.5) * PictureWatermark.Width div PictureWatermark.Height; a potem dopiero tworzysz PictureWatermark := TBitmap.Create;

  1. to mi się wykonuje i działa - wyciągnąłem samom obróbkę i zapisywanie obrazka
unit ThreadUnit;

interface

uses
  Graphics, Jpeg, Types, Dialogs, SysUtils, Classes;

type
  TRGBTriple = packed record
    rgbtBlue: Byte;
    rgbtGreen: Byte;
    rgbtRed: Byte;
  end;

  TTestThread = class(TThread)
  private
    procedure DrawTransparency(Canvas: TCanvas; X, Y: Integer; aBitmap: TBitmap; Transparency: Byte);
  protected
    procedure Execute; override;
  end;

implementation

procedure TTestThread.DrawTransparency(Canvas: TCanvas; X, Y: Integer;
  aBitmap: TBitmap; Transparency: Byte);
var
  Temp: TBitmap;
  ByteSrc, ByteDest: ^Byte;
  TripleSrc, TripleDest: ^TRGBTriple;
  TransparentColor: TRGBTriple;
  H, V: Integer;
begin
  ABitmap.PixelFormat := pf24bit;
  Temp := TBitmap.Create;
  Temp.Canvas.Brush.Color := ABitmap.TransparentColor;
  Temp.Width := ABitmap.Width;
  Temp.Height := ABitmap.Height;
  Temp.PixelFormat := pf24bit;
  Temp.Canvas.CopyRect(Rect(0, 0, ABitmap.Width, ABitmap.Height), Canvas, Rect(X, Y, ABitmap.Width + X, ABitmap.Height + Y));
 
  if ABitmap.Transparent then
  begin
    TransparentColor.rgbtBlue := (ABitmap.TransparentColor and $FF0000) shr 16;
    TransparentColor.rgbtGreen := (ABitmap.TransparentColor and $00FF00) shr 8;
    TransparentColor.rgbtRed := ABitmap.TransparentColor and $0000FF;
 
    Temp.TransparentColor := ABitmap.TransparentColor;
    Temp.Transparent := True;
 
    for V := 0 to ABitmap.Height - 1 do
    begin
      TripleSrc := ABitmap.Scanline[V];
      TripleDest := Temp.Scanline[V];
      for H := 0 to ABitmap.Width - 1 do
      begin
        if (TransparentColor.rgbtBlue <> TripleSrc.rgbtBlue) or (TransparentColor.rgbtGreen <> TripleSrc.rgbtGreen) or
          (TransparentColor.rgbtRed <> TripleSrc.rgbtRed) then
        begin
          TripleDest^.rgbtBlue := Trunc((TripleDest^.rgbtBlue / 100) * Transparency + (TripleSrc^.rgbtBlue / 100) * (100 - Transparency));
          TripleDest^.rgbtGreen := Trunc((TripleDest^.rgbtGreen / 100) * Transparency + (TripleSrc^.rgbtGreen / 100) * (100 - Transparency));
          TripleDest^.rgbtRed := Trunc((TripleDest^.rgbtRed / 100) * Transparency + (TripleSrc^.rgbtRed / 100) * (100 - Transparency));
        end;
 
        Inc(TripleSrc);
        Inc(TripleDest);
      end;
    end;
  end
  else
  begin
    for V := 0 to ABitmap.Height - 1 do
    begin
      ByteSrc := ABitmap.Scanline[V];
      ByteDest := Temp.Scanline[V];
      for H := 0 to ABitmap.Width * 3 - 1 do
      begin
        ByteDest^ := Trunc((ByteDest^ / 100) * Transparency +
          (ByteSrc^ / 100) * (100 - Transparency));
        Inc(ByteSrc);
        Inc(ByteDest);
      end;
    end;
  end;
  Canvas.Draw(X, Y, Temp);
  Temp.Free;
end;

procedure TTestThread.Execute;
const
  AOldFilename: string = 'd:\download\old.jpg';
  ANewFilename: string = 'd:\download\new.jpg';
var
  CurrentPicture: TBitmap;
  PictureWatermark: TBitmap;
  jpg: TJpegImage;
  NewHeight: Integer;
  NewWidth: Integer;
  pt: TPoint;
  AWatermark: TPicture;
begin
  AWatermark := TPicture.Create;
  AWatermark.LoadFromFile('d:\download\water.bmp');
  jpg := TJpegImage.Create;
  try
    try
      jpg.Loadfromfile(AOldFilename);
      CurrentPicture := TBitmap.Create;
      Try
        { Tworzy płutno z zawartością JPG }
        CurrentPicture.Width := jpg.Width;
        CurrentPicture.Height := jpg.Height;
        CurrentPicture.Canvas.Draw(0, 0, jpg);
        { Wstawianie znaku wodnego }
        If Assigned(AWatermark) and Assigned(AWatermark.Graphic) and not AWatermark.Graphic.Empty then
        Begin
          NewHeight := Round(CurrentPicture.Height * 0.5);
          NewWidth := Round(CurrentPicture.Height * 0.5);
          if NewWidth > CurrentPicture.Width then
          begin
            NewWidth := Round(CurrentPicture.Width * 0.5);
            NewHeight := NewWidth;
          end;

          PictureWatermark := TBitmap.Create;
          Try
            PictureWatermark.Width := NewWidth;
            PictureWatermark.Height := NewHeight;
            PictureWatermark.TransparentColor := clWhite;
            PictureWatermark.Transparent := True;
            PictureWatermark.Canvas.StretchDraw(Rect(0, 0, NewWidth, NewHeight), AWatermark.Graphic);

            pt.X := (CurrentPicture.Width - PictureWatermark.Width) div 2;
            pt.Y := (CurrentPicture.Height - PictureWatermark.Height) div 2;

            DrawTransparency(CurrentPicture.Canvas, pt.X, pt.Y, PictureWatermark, 128);
          Finally
            PictureWatermark.Free;
          end;
        end;
        jpg.Assign(CurrentPicture);
        jpg.SaveToFile(ANewFilename);
      finally
        CurrentPicture.Free;
      end;
    except
      on E: Exception do
        ShowMessage(e.Message);
    end;
  finally
    jpg.Free;
  end;
end;

end.
0

1.CompanyData to zmienna typy TCompanydata = packed record gdzie Logo: TPicture;
2.

If Assigned(AWatermark.Graphic) then
  • usunąłem przypadkowo wcześniejszy wiersz If Assigned(AWatermark) then
</ul>
3. Chciałem na szybko uprościć procedurę aby była prawidłowa zgodnie ze wskazówkami kolegi  @furious programming i z pośpiechu nie zamieniłem PictureWatermark na AWatermark.

4. Chciałem was przeprosić bo na początku źle się wyraziłem: Wątek się uruchamia i przerabia zdjęcia poprawnie+ zapis do mysql-a ale po obróbce 50-100 zdjęć dopiero pojawiają się wspomniane błędy.

5. Jeżeli całość uruchomię z okna głównego tj. z pominięciem Thread to brak jakichkolwiek błędów.
0

W załączniku napisałem program z wykorzystaniem wątku - który maksymalnie uprościłem. Załączyłem także skompilowany plik exe oraz plik.jpg który należy wrzucić luzem na dysk C. Nowe pliki będą tworzyły się w C:\Tymczasowy

0

@Rafał D - a Ty masz w ogóle na swojej maszynie prawa zapisu bezpośrednio na dysku C:\?

Jeszcze się okaże że nie masz i wszyscy będziemy się śmiać z Ciebie :]

0

@furious programming chciałbym aby to była przyczyna powstawania błędów ale niestety nie, mam pełen dostęp

0

@kAzek Oto co znajduje się pod adresem z EAX

 
Vcl.Graphics

procedure GDIError;
const
  BufSize = 256;
var
  ErrorCode: Integer;
{$IF DEFINED(CLR)}
  Buf: StringBuilder;
{$ELSE}
  Buf: array [Byte] of Char;
{$ENDIF}
begin
{$IF DEFINED(CLR)}
  Buf := StringBuilder.Create(BufSize);
{$ENDIF}
  ErrorCode := GetLastError;
  if (ErrorCode <> 0) and (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, nil,
    ErrorCode, LOCALE_USER_DEFAULT, Buf, BufSize, nil) <> 0) then
{$IF DEFINED(CLR)}
    raise EOutOfResources.Create(Buf.ToString)
{$ELSE}
    raise EOutOfResources.Create(Buf)  //<- Tutaj wskazuje adres z EAX
{$ENDIF}
  else
    OutOfResources;
end;


0

Nie mam dzisiaj za bardzo czasu ale tak przy kawie zerkam i widzę że w procedurze ChangeResizeJpg bitmapa NewPicture nie pozwala się dobierać do swojego Canvas (zwłaszcza po nim rysować) a więc tak na szybko dodałem 2 x Synchronize i wydaje mi się (jak na razie ok) to załatwia sprawę:

        Synchronize( procedure begin
          NewPicture.Canvas.FillRect(Rect(0, 0, Width, Height));
          { Nakładanie obrazka na tło }
          pt.X := (Width - CurrentPicture.Width) div 2;
          pt.Y := (Height - CurrentPicture.Height) div 2;
          NewPicture.Canvas.Draw(pt.X, pt.Y, CurrentPicture);
        end );
//....
                  Synchronize( procedure begin
                    DrawTransparency(NewPicture.Canvas, pt.X, pt.Y, PictureWatermark, ATransparency);
                  end );

ale to i tak nie jest jakimś mega rozwiązaniem, bo powoduje ze jednak spora część kodu wykonuje się poza wątkiem wiec pasowało by ten kod jakoś przepisać aby było lepiej. Chyba że we właściwej aplikacji nie używasz kilku wątków jednocześnie do tego to nawet nie ma sensu z tym kombinować. Oczywiście pomijam fakt że w ogóle ten kod chyba nie działa jak powinien (dziwnie dodaje ten watermark) a o jego wyglądzie nie wspominam ale rozumiem że to testowy. Jak pisałem nie mam czasu tym bardziej że nie mam za bardzo doświadczenia z rysowaniem zwłaszcza w wątkach i pewnie by mi też z tym trochę zeszło.

0

@kAzek Wydaje się że pomogło póki co nie otrzymuję błędów, jednak mam pytanie skąd wiesz że "w procedurze ChangeResizeJpg bitmapa NewPicture nie pozwala się dobierać do swojego Canvas (zwłaszcza po nim rysować)" ?

  1. Dziwnie dodaje bo zostawiłem minimalną ilość całego kodu aby łatwiej zlokalizować co powoduje powstawanie błędów - jakość na poziomie Minecraft

  2. Zauważyłem jeszcze jedną dziwną rzecz. Czasami nowe pliki jpg które powstają nie zawierają np: Obrazka z AWatermark, obrazka z "plik.jpg" albo są puste tzn zawierają tylko białe tło

Ten przykład znalazłem na stronie Embarcadero

{
This example uses a button on a form and creates two bitmaps
dynamically.  One bitmap is monchrome, which means all
non-white colors become black.  The bitmap file path is
relative to the Debug directory.
}
procedure TForm1.Button1Click(Sender: TObject);
var
 BitMap1,BitMap2 : TBitMap;
 MyFormat : Word;
begin
   BitMap2 := TBitMap.Create;
   BitMap1 := TBitMap.Create;
try
   BitMap1.LoadFromFile('factory.bmp');
   BitMap2.Assign(BitMap1);     // Copy BitMap1 into BitMap2
   BitMap2.Dormant;             // Free up GDI resources
   BitMap2.FreeImage;           // Free up Memory.
   Canvas.Draw(20,20,BitMap2);  // Note that previous calls don't lose the image
   BitMap2.Monochrome := true;
   Canvas.Draw(80,80,BitMap2);
   BitMap2.ReleaseHandle;       // This will actually lose the bitmap;
 finally
   BitMap1.Free;
   BitMap2.Free;
 end;
end;

Zastanawiam się czy w moich procedurach nie brakuje:

   
BitMap2.Dormant;       
BitMap2.FreeImage;
BitMap2.ReleaseHandle; 
1

Bo umiem używać debuggera ;) poza tym widzę że wszystkie Draw muszą być w Synchronize (właśnie dlatego czasem masz pusty obrazek)

         Synchronize( procedure begin
           CurrentPicture.Canvas.StretchDraw(CurrentPicture.Canvas.Cliprect, jpg);
         end );

a reszta to pewnie błędy w obliczeniach nie wiem położenia, długości lub szerokości ale jak pisałem dzisiaj jestem zbyt zajęty aby się tym zajmować.
EDIT: A co do tego co dodałeś jak pisałem wcześniej nie mam dużego doświadczenia w grafice a jestem zajęty i nie sprawdzałem czy nie ma wycieku pamięci wstaw sobie głównego pliku projektu (DPR przed Initialize) i będziesz widział czy potrzeba jak pokaże jakieś wycieki:

ReportMemoryLeaksOnShutdown:=DebugHook <> 0;

Zresztą chyba niepotrzebnie nie dali tego w przykładzie :/

1

Wszystkie klasy TBitmap zmień na odpowiednie TBitmap32 z biblioteki
graphics32 https://sourceforge.net/projects/graphics32/
ta biblioteka jest „thread-safe”

0

@kAzek Wszystkie draw dałem w synchronize i po przeróbce 20 tyś. plików zero błędów. Wiec dziękuję Tobie oraz innym za pomoc.

@satq Dzięki - sprawdzę

0

@satq - Sprawdziłem bibliotekę graphics32 i nie wystarczyła zamiana zmiennych TBitmap na TBitmap32 musiałem przerobić całą procedurę ale się opłaciło, ani razu nie użyłem synchronize i wszystko działa jak należy.

Temat uważam za zamknięty, wszystkim serdecznie dziękuję za pomoc.

1 użytkowników online, w tym zalogowanych: 0, gości: 1