Перейти к содержанию
Fire Monkey от А до Я

IVGSoft

Пользователи
 Профиль  Обзор контента

  • Постов

    61

  • Зарегистрирован

  • Посещение

  • Победитель дней

    6

 Тип контента 

Сообщения, опубликованные IVGSoft

    Скроллинг на канве

    в Анимация

    Опубликовано

    5 часов назад, Barbanel сказал:

    Может использоваться GDI (это из другой области) либо ЦПУ.

    Первым делом FMX пытается использовать аппаратное ускорение (DirectX на Windows), при невозможности - GDI+.

    Посмотрите исходники и увидите на каком канвасе все рисуется.

    обновление визуальных компонентов

    в Прочие вопросы

    Опубликовано

    Я же писал - заведите флажок у слушающего потока. И его дергайте в Екзекьют. А в основном цикле проверяйте состояние его.

    И тогда уберите  вот єти строки : 

          Client1.Socket.CheckForDataOnSource(100);
      while Client1.Socket.InputBufferIsEmpty = true do
        Client1.Socket.CheckForDataOnSource(100);

    И вообще меняйте архитектуру :)

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

    обновление визуальных компонентов

    в Прочие вопросы

    Опубликовано

    Вот пример (обрезанный) из другого проекта : 

    TJobCompleteEvent = procedure(Sender: TObject; Success: boolean) of object;
  TivgImageProcessor = class(TThread)
  private
	...

    fOnGrayScaleReady: TImageProcessedEvent;
    fOnEdgeMapReady: TImageProcessedEvent;
    fOnUnfilteredLinesReady: TImageProcessedEvent;
    fOnFilteredLinesReady: TImageProcessedEvent;
    fOnHaughSpaceImageReady: TImageProcessedEvent;
    fOnScreenImageReady: TImageProcessedEvent;
    fOnFullSizeReady: TImageProcessedEvent;
    fOnPreviewReady: TImageProcessedEvent;
    fOnResultReady: TResultReadyEvent;
    fOnCurveReady: TResultReadyEvent;
    fOnError: TProcessingErrorEvent;
    fOnNotify: TProcessingNotifyEvent;
    fOnJobComplete: TJobCompleteEvent;

    procedure DoULinesReady;
    procedure DoFLinesReady;
    procedure DoHaughSpaceReady;
    procedure DoGrayImgReady;
    procedure DoEdgeMapReady;
    procedure DoResultReady;
    procedure DoScreenReady;
    procedure DoFullSizeImgReady;
    procedure DoPreviewReady;
    procedure DoCurveReady;
    procedure DoError;
    procedure DoNotify;
    procedure DoJobComplete;

    procedure DoLoad(var aTask: TProcessingTask);
    procedure DoSave(aTask: TProcessingTask);
    procedure DoCropCalculate(aSrc: TBitmapSurface; out res: TProcessingResult);
    procedure DoCrop;
    procedure DoRotate;
    procedure DoAdjust;
    procedure DoPreview;
    procedure DoCannyTrace(bm_in, bm_out: TBitmapSurface; lowerThreshold, upperThreshold: integer);
    procedure Convolve(ABitmap: TBitmapSurface; AMask: T3x3FloatArray; ABias: integer);

  protected
    procedure Execute; override;
    function ExecuteTask(aTask: TProcessingTask): boolean; virtual;

  public
    constructor Create(aVer : string);
    destructor Destroy; override;

    procedure AbortBatch;

    procedure RunBatch(Jobs: TProcessingJobs; inputImages: TStringDynArray;
      CanOverwrite: boolean; outPath, outExt: string;
      multPage: boolean; mirroring : integer = 0); overload;
    procedure RunBatch(Jobs: TProcessingJobs; FromPath, ToPath: string;
      outExt: string; CanOverwrite: boolean; multPage: boolean; mirroring : integer = 0); overload;
    procedure RunSingleTask(aTask: TProcessingTask);
    procedure SharpenImg(aBmp: TBitmapSurface; aVal: single);
    procedure CalcImgCropRect(SourceImg: TBitmapSurface);
    procedure MakePreview(aMirror : integer);

    // color correction
    procedure DoColorCorrection(aSrc: TBitmapSurface); overload;
    procedure DoColorCorrection(aSrc: TBitmapSurface; fCrv : TCorrectionCurve); overload;

    function PavlidisContourTrace(aBmp: TBitmapSurface; sx, sy: integer;
      coords: PCoordinates; const aWorkArea: TRect): TPavResult;

    // events
    property OnGrayImageReady: TImageProcessedEvent read fOnGrayScaleReady write fOnGrayScaleReady;
    property OnEdgeMapReady: TImageProcessedEvent read fOnEdgeMapReady write fOnEdgeMapReady;
    property OnUnfilteredLinesReady: TImageProcessedEvent read fOnUnfilteredLinesReady write fOnUnfilteredLinesReady;
    property OnFilteredLinesReady: TImageProcessedEvent read fOnFilteredLinesReady write fOnFilteredLinesReady;
    property OnHaughSpaceReady : TImageProcessedEvent read fOnHaughSpaceImageReady write fOnHaughSpaceImageReady;
    property OnScreenImageReady: TImageProcessedEvent read fOnScreenImageReady write fOnScreenImageReady;
    property OnFullSizeReady: TImageProcessedEvent read fOnFullSizeReady write fOnFullSizeReady;
    property OnPreviewReady: TImageProcessedEvent read fOnPreviewReady write fOnPreviewReady;
    property OnResultReady: TResultReadyEvent read fOnResultReady write fOnResultReady;
    property OnCurveReady: TResultReadyEvent read fOnCurveReady write fOnCurveReady;
    property OnError: TProcessingErrorEvent read fOnError write fOnError;
    property OnNotify: TProcessingNotifyEvent read fOnNotify write fOnNotify;
    property OnJobComplete: TJobCompleteEvent read fOnJobComplete write fOnJobComplete;
  end;

procedure TivgImageProcessor.DoJobComplete;
begin
  if Assigned(fOnJobComplete) then
    fOnJobComplete(Self, fSuccess);
end;

...

procedure TivgImageProcessor.DoHaughSpaceReady;
begin
  if Assigned(fOnHaughSpaceImageReady) then
    fOnHaughSpaceImageReady(Self, fImgToShow);
end;

...

procedure TivgImageProcessor.Execute;

begin
  while not Self.Terminated do
  begin
    if not fTaskComplete then
      try
        while (fProcTasks.Count <> 0) and not fStoped do
        begin
          fSuccess := true;
          fTaskActive := true;
          try
            try
              fCurrentTask := fProcTasks[0];
              ExecuteTask(fProcTasks[0]);
              Inc(fSuccessCounter);
            except
              on E: Exception do
              begin
                Inc(fErrorsCounter);
                fErrorMsg := E.Message;
                Synchronize(DoError);
              end;
            end;
          finally
            fProcTasks.Delete(0);
            Inc(fJobsFinished);
            fTaskActive := false;
          end;
        end;
        if fCurrentTask.MultiPaged and not fStoped then
        begin
          if fUseCompression then
            fNotification := 'Saving multipage PDF document. Estimated time - '
              + FormatDateTime('hh:nn:ss',
              SecondsToDateTime(cPDFPAGESAVINGTIME * fJobsTotal))
          else
            fNotification := 'Saving multipage PDF document. Estimated time - '
              + FormatDateTime('hh:nn:ss',
              SecondsToDateTime(uPDFPAGESAVINGTIME * fJobsTotal));
          Synchronize(DoNotify);
          MultiPagePDF.SaveToFile(fCurrentTask.ToPath);

        end;
        fTaskComplete := true;
        fSuccess := true;
        if fStoped then
        begin
          fNotification := 'Batch processing aborted!';
          fSuccess := false;
          fProcTasks.Clear;
        end
        else
          fNotification := 'Job complete';
        fStoped := false;
        Synchronize(DoNotify);
        Synchronize(DoJobComplete);
      except
        on E: Exception do
        begin
          Inc(fErrorsCounter);
          fTaskActive := false;
          fTaskComplete := true;
          fSuccess := false;
          fErrorMsg := 'Task processing failed! Err :: ' + E.Message;
          DoError;
          Synchronize(DoJobComplete);
        end;
      end;

    Self.Sleep(1);
  end;
end;

     

    обновление визуальных компонентов

    в Прочие вопросы

    Опубликовано

    3 минуты назад, gonzales сказал:

    Так вот в этом как раз и вопрос, как мне заставить главный поток ждать ответа от сервера, если ответ приходит не в главном потоке?

    А хоспади! :) Заведите свойство у потока скажем property IsAnswerReceived : boolean read fIsAnswerReceived;

    В начале цикла в методе Execute сбрасывайте его на false, а по приходу ответа выставляйте в  true.

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

    Это один из вариантов. Второй вариант это создать свойство обработчик события у слушающего потока. По приходу ответа - "выстреливать" им.

    Сам обработчик пишете в главном потоке и присваиваете его слушающему потоку при (после) создании.

    обновление визуальных компонентов

    в Прочие вопросы

    Опубликовано

    2 минуты назад, gonzales сказал:

    метод Execute

    Вы не можете его вызывать. Да и не надо.

    Передавайте потоку сигналы для управления. И отслеживайте их в методе Execute. И наоборот - пришел ответ от сервера в потоке - сигнализируйте главному потоку о получении.

    обновление визуальных компонентов

    в Прочие вопросы

    Опубликовано

    18 минут назад, Евгений Корепов сказал:

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

    В общем, согласен. На практике же пока не стыкался с такими проблемами. Такое может случиться в каком-то интенсивном приложении, согласен.

    Потокобезопасность превыше всего. :) Но зачастую это выглядит как в анекдоте про монашку, свечу и презерватив.

    обновление визуальных компонентов

    в Прочие вопросы

    Опубликовано

    19 минут назад, gonzales сказал:

    А можно еще вопрос, у idTCPClient есть свойство Socket и IOHandler, у которых все свойства и методы идентичны. В чем разница между ними? Работает и так и так.

    Ну, IOHandler можно менять. Например на свой с шифрованием. Рекомендуется использовать его.

    обновление визуальных компонентов

    в Прочие вопросы

    Опубликовано

    2 минуты назад, gonzales сказал:

    Спасибо большое!!!

    Пошел делать!!!

    Удачи! :)

    На самом деле мой пример не очень удачный, ибо в нем напрямую дергаются компоненты главной формы. Лучше каким-то образом слать на главную форму сообщения об изменении. Либо создать какие-то события. Собственно в другом проекте я пошел по пути создания событий. А вот в обработчике события уже смотрим нужна ли синхронизация или нет.

    обновление визуальных компонентов

    в Прочие вопросы

    Опубликовано

    1 минуту назад, gonzales сказал:

    1. Метод Execute вызывается после создания экземпляра класса и живет, пока экземпляр не будет уничтожен, верно?

    По умолчанию - да. Но можно указать флаг Suspended при создании. Тогда метод Execute будет запущен после снятия єтого флага.

    2 минуты назад, gonzales сказал:

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

    Синхронизация нужна при обращении к визуальным компонентам. И то только при обновлении (перерисовке) их свойств. Для чтения не надо.

    4 минуты назад, gonzales сказал:

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

    Да, именно так. Если есть изменения визуальных компонентов - надо использовать синхронизацию.

    Can not save record(data) into database mySQL Using Delphi 10.3 Rio in Release Mode

    в Вопросы / Questions

    Опубликовано · Изменено пользователем IVGSoft 

    procedure TLocationForm.btnSendClick(Sender: TObject);
begin
    with dmMyLocation do
    begin
      if not fgActivityDialog.IsShown then
      begin
        fgActivityDialog.Message := 'Please, Wait';
        fgActivityDialog.Show;
        FActivityDialogThread := TThread.CreateAnonymousThread(procedure
        begin
          Sleep(1000);
          if TThread.CheckTerminated then
            Exit;
          TThread.Synchronize(nil, procedure
          begin
            fgActivityDialog.Message := 'Sending data...';
          end);
          try
              qInsert.SQL.Clear;
              qInsert.SQL.Add('INSERT INTO mabsensilokasi(');
              qInsert.SQL.Add('idlokasi,');
              qInsert.SQL.Add('tgllokasi,');
              qInsert.SQL.Add('latx,');
              qInsert.SQL.Add('longx,');
              qInsert.SQL.Add('latlongx,');
              qInsert.SQL.Add('namalokasi) ');
              qInsert.SQL.Add('VALUES(');
              qInsert.SQL.Add(':idlokasi,');
              qInsert.SQL.Add(':tgllokasi,');
              qInsert.SQL.Add(':latx,');
              qInsert.SQL.Add(':longx,');
              qInsert.SQL.Add(':latlongx,');
              qInsert.SQL.Add(':namalokasi)');

              qInsert.Prepare;
              qInsert.Params[0].AsInteger := 0;
              qInsert.Params[1].AsDateTime := Now;
              qInsert.Params[2].AsFloat := strToFloat(ENUSLat);
              qInsert.Params[3].AsFloat := strToFloat(ENUSLong);
              qInsert.Params[4].AsString := ENUSLat+':'+ENUSLong;
              qInsert.Params[5].AsString := edtNamaLokasi.Text;

              try
                UniConnection1.Connect;
                qInsert.ExecSQL;
                TThread.Synchronize(nil, procedure
                begin
                  ShowMessage('Record was saved into MySQL Server DB...'); //showup windows of dialog when data was save succesfully into db mysql server
                end);
              except
                on e:exception do
                begin
                  TThread.Synchronize(nil, procedure
                  begin
                    ShowMessage(e.Message);
                    UniConnection1.Disconnect;
                  end);
                end;//exception
              end;//try

              //fgActivityDialog.ExecuteAction(btnSend);
            Sleep(1000);
            if TThread.CheckTerminated then
              Exit;


            TThread.Synchronize(nil, procedure
            begin
              fgActivityDialog.Message := 'Finish';
            end);
            Sleep(500);

            if TThread.CheckTerminated then
              Exit;

          finally
            if not TThread.CheckTerminated then
              TThread.Synchronize(nil, procedure
              begin
                fgActivityDialog.Hide;
              end);
          end;//try
        end);//FActivityDialogThread

        FActivityDialogThread.FreeOnTerminate := False;
        FActivityDialogThread.Start;
      end;//if


    end;//endDM

end;//endProc

    I have changed your code a little bit. To make some kind of separation.

    обновление визуальных компонентов

    в Прочие вопросы

    Опубликовано

    19 часов назад, gonzales сказал:

    Как мне это все добро запихнуть в поток?

    Создайте свой класс потока. Я так поступаю для полного контроля над потоком.

    Например как-то так : 

      TBeePosMessageThread = class(TThread)
  private
    function ExtractData(aPacket : PBeePosDataPacket): string;
    procedure ProcessPacket(aPacket : pointer);
    procedure DoProcess(aPacket : PBeePosDataPacket);
  protected
    procedure Execute; override;
  end;

implementation

{ TBeePosMessageThread }

procedure TBeePosMessageThread.DoProcess(aPacket: PBeePosDataPacket);
var
  jObj : TJSONObject;
  sObj : string;
  cmd : string;
  typ : string;
  oObj : string;
  lock : boolean;
  id, uid : TBeePosID;
  price : Currency;
  qty : double;
  table : integer;
begin
  sObj := ExtractData(aPacket);
  jObj := nil;
  try
    jObj := TJSONObject.ParseJSONValue(sObj) as TJSONObject;
    cmd := jObj.Values['command'].Value;
    typ := jObj.Values['type'].Value;
    if cmd = 'update' then
      begin
        //New order received
        if typ = 'order' then
          begin
            oObj := (jObj.Values['object'] as TJSONObject).ToJSON;
            Synchronize(procedure
                          begin
                            MainFrm.OrderReceived(oObj);
                          end);
          end;
        //order lock changed
        if typ = 'orderlock' then
          begin
            try
              lock := jObj.Values['value'].Value.ToBoolean;
            except
            end;
            try
              id := jObj.Values['object'].Value.ToInt64;
            except
            end;
            try
              uid := jObj.Values['user'].Value.ToInt64;
            except
            end;
            try
              table := jObj.Values['table'].Value.ToInteger;
            except
            end;
            Synchronize(procedure
                          begin
                            MainFrm.SetOrderLocked(id, uid, lock, table);
                          end);
          end;
        //menu item stock changed
        if typ = 'menuitem' then
          begin
            id := 0;
            try
              id := jObj.Values['object'].Value.ToInt64;
            except
            end;
            try
              price := jObj.Values['price'].Value.ToDouble;
            except
            end;
            try
              qty := jObj.Values['qty'].Value.ToDouble;
            except
            end;
            Synchronize(procedure
                          begin
                            MainFrm.MenuStockChanged(id, qty, price);
                          end);
          end;
        //ingredient stock changed
        if typ = 'ingredient' then
          begin
            id := 0;
            try
              id := jObj.Values['object'].Value.ToInt64;
            except
            end;
            try
              price := jObj.Values['price'].Value.ToDouble;
            except
            end;
            try
              qty := jObj.Values['qty'].Value.ToDouble;
            except
            end;
            Synchronize(procedure
                          begin
                            MainFrm.IngredientStockChanged(id, qty, price);
                          end);
          end;
        //Customer received
        if typ = 'customer' then
          begin
            oObj := (jObj.Values['object'] as TJSONObject).ToJSON;
            Synchronize(procedure
                          begin
                            MainFrm.CustomerAdded(oObj);
                          end);
          end;
      end;
    if cmd = 'delete' then
      begin
        if typ = 'order' then
          begin
            try
              id := jObj.Values['object'].Value.ToInt64;
            except
            end;
            Synchronize(procedure
                          begin
                            MainFrm.RemoveOrder(id);
                          end);
          end;
      end;
  finally
    if Assigned(jObj) then
      FreeAndNil(jObj);
  end;
end;

procedure TBeePosMessageThread.Execute;
var
  Len : integer;
  Buf : TIdBytes;
  pBuf : pointer;
begin
  while not Terminated do
    begin
      sleep(10);
      if MainFrm.MessagingClient.Connected then
        begin
          len := 0;
          try
            if MainFrm.MessagingClient.IOHandler.CheckForDataOnSource(100) then
              begin
                len := MainFrm.MessagingClient.IOHandler.InputBuffer.Size;
                try
                  MainFrm.MessagingClient.IOHandler.ReadBytes(Buf, len, false);
                  GetMem(pBuf, len);
                  Move(Buf[0], pBuf^, len);
                  ProcessPacket(pBuf);
                finally
                  SetLength(Buf, 0);
                end;
              end;
          except
            on E:EIdException do
              Synchronize(procedure
                begin
                  MainFrm.MessagingClientDisconnected(nil);
                end);
          end;
        end
      else
        begin
          TTask.Run(procedure
            begin
              Synchronize(procedure
                      begin
                        MainFrm.MessagingClientDisconnected(nil);
                      end)
            end);
          Exit;
        end;
    end;
end;

function TBeePosMessageThread.ExtractData(aPacket: PBeePosDataPacket): string;
var
  str : string;
begin
  DecryptPacket(aPacket.Data, aPacket.BufferSize);
  SetLength(str, (aPacket.BufferSize div SizeOf(Char)) - 1);
  Move(aPacket.Data^, str[1], aPacket.BufferSize);
  Result := TIdDecoderMIME.DecodeString(str);
end;

procedure TBeePosMessageThread.ProcessPacket(aPacket: pointer);
var
  aDataPacket : PBeePosDataPacket;
begin
  try
    if TBeePosContext.CheckPacket(aPacket) then
      begin
        GetMem(aDataPacket, SizeOf(TBeePosDataPacket));
        aDataPacket.Header := PBeePosDataPacket(aPacket).Header;
        aDataPacket.BufferSize := PBeePosDataPacket(aPacket).BufferSize;
        aDataPacket.Data := nil;
        GetMem(aDataPacket.Data, aDataPacket.BufferSize);
        Move(pointer(NativeUInt(aPacket) + SizeOf(TBeePosMessagePacket))^,
             aDataPacket.Data^, aDataPacket.BufferSize);
        try
          DoProcess(aDataPacket);
        finally
          FreeMem(aDataPacket.Data);
        end;
      end
  finally
    FreeMem(aDataPacket);
    FreeMem(aPacket);
  end;
end;

     

    Зависимость от регистра русских символов при использовании LIKE

    в SQLite

    Опубликовано

    В 23.02.2019 в 13:01, Dstaryh сказал:

    Предлагаю простой вариант перевода edit1.text в верхний регистр для последующего поиска по СУБД из введенных данных в edit1, работает хоть с кириллицей, хоть с латиницей! правда через дополнительный memo, свойства которого в инспекторе ставим CharCase = ecUpperCase, Visible = false, и в обработчиках событий  OnChangeTracking обоих компонентов пишем процедуры: 

    procedure TForm1.Edit1ChangeTracking(Sender: TObject);
    begin
    Memo1.Text:= AnsiUpperCase(edit1.Text);

    end;

    procedure TForm1.Memo1ChangeTracking(Sender: TObject);
    begin
         edit1.Text:=memo1.Text;

              FDQuery1.Close;
              FDQuery1.SQL.Text:='SELECT * FROM <имя таблицы> WHERE <имя поля> like '+QuotedStr('%'+Edit1.Text+'%');
              FDQuery1.Open;
    end;

     

    Вы, наверное, не правильно поняли проблему. :) Перевести строку в аппер для подсовывания в запрос не проблема. Проблема в том, что SQLite не умеет преобразовывать кирилицу в аппер (или лоуер)!

    обновление визуальных компонентов

    в Прочие вопросы

    Опубликовано · Изменено пользователем IVGSoft

    10 часов назад, gonzales сказал:

    В смысле в бесконечном цикле?

    Почему бесконечном? :) Тут как захотите. Обычно делают как-то так :

    While not (Terminated or fStopped) do

    begin

      DoSomeActions;

    end;

    обновление визуальных компонентов

    в Прочие вопросы

    Опубликовано

    3 часа назад, gonzales сказал:

    А как поток поможет?

    Очень просто - в потоке проверяйте наличие данных. Появился ответ - меняйте состояние контролов. Он будет работать в фоновом режиме. Можно даже снизить ему приоритет.

    обновление визуальных компонентов

    в Прочие вопросы

    Опубликовано

    Ну, во-первых Вы не указали что за сервер используется - HTTP или какой-то иной. Если сервер самописный ТСР, то можно на клиентской стороне открыть сокет на прослушку для сообщений от сервера и по приходу пакета от сервера менять отображение визуальных компонентов.

    Всплывающее сообщение при его закрытии разворачивает приложение

    в Сворачивание, разворачивание и FullScreen

    Опубликовано

    2 часа назад, #WAMACO сказал:

    Используйте механизм уведомлений, которые всплывают внизу, в трее.

    Да, очень удобно. Но есть ограничения :( Не все платформы поддерживаются.

    Audio Streaming

    в iOS

    Опубликовано · Изменено пользователем IVGSoft

    В 08.06.2018 в 14:44, Martifan сказал:

    сам у Bass есть этот модуль разберусь и результат вылажу

    Вечер добрый! И как успехи с прикручиванием кодека?

×
×
  • Создать...