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

DirtyBorov

Пользователи
  • Постов

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

  • Посещение

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

    6

Активность репутации

  1. Like
    DirtyBorov получил реакцию от Rusland в Альтернатива для TTask   
    Хочу поделится своим модулем, некой альтернативой TTask, которой я пользуюсь уже довольно продолжительное время.  Возможно кому то будет полезно. 
    AsyncTask это глобальная функция в модуле, которая возвращает интерфейс IAsyncTask. По этой причине нет нужды специально создавать объект и заботится о его удалении.
    Пример использования:
    procedure GetAsyncRequest(const aUrl: string); var LResult: string; begin AsyncTask.Run( procedure begin // это основной метод потока, он не синхронизирован. От сюда нельзя обращатся к визуальным компонентам // или переменным вне функции без синхронизации (если необходимо) LResult := HttpRequest.Get(aUrl); end, procedure begin // Эта процедура выполнится при успешном завершении потока (без exception). // Процедура синхронизированна, по этому тут можно обращатся к любым визуальным компонентам ShowMessage(LResult); end, procedure(E: Exception) begin // Эта процедура выполнится только если во время работы потока произошла ошибка ShowException(E); end, procedure begin // Эта процедура выполнится в любом случае (после завершения потока), в не зависимости была ошибка или нет ShowMessage(LResult); end ); // обратите внимание, что обязательно задать только первую процедуру, остальные можно не указывать или передать вместо них nil. Например так: AsyncTask.Run( procedure begin ... end, nil, procedure(E: Exception) begin ShowException(E); end);  
    Async.Task.pas.zip
  2. Like
    DirtyBorov получил реакцию от rareMax в Альтернатива для TTask   
    Хочу поделится своим модулем, некой альтернативой TTask, которой я пользуюсь уже довольно продолжительное время.  Возможно кому то будет полезно. 
    AsyncTask это глобальная функция в модуле, которая возвращает интерфейс IAsyncTask. По этой причине нет нужды специально создавать объект и заботится о его удалении.
    Пример использования:
    procedure GetAsyncRequest(const aUrl: string); var LResult: string; begin AsyncTask.Run( procedure begin // это основной метод потока, он не синхронизирован. От сюда нельзя обращатся к визуальным компонентам // или переменным вне функции без синхронизации (если необходимо) LResult := HttpRequest.Get(aUrl); end, procedure begin // Эта процедура выполнится при успешном завершении потока (без exception). // Процедура синхронизированна, по этому тут можно обращатся к любым визуальным компонентам ShowMessage(LResult); end, procedure(E: Exception) begin // Эта процедура выполнится только если во время работы потока произошла ошибка ShowException(E); end, procedure begin // Эта процедура выполнится в любом случае (после завершения потока), в не зависимости была ошибка или нет ShowMessage(LResult); end ); // обратите внимание, что обязательно задать только первую процедуру, остальные можно не указывать или передать вместо них nil. Например так: AsyncTask.Run( procedure begin ... end, nil, procedure(E: Exception) begin ShowException(E); end);  
    Async.Task.pas.zip
  3. Like
    DirtyBorov получил реакцию от rareMax в Альтернатива для TTask   
    Да, я в курсе - это всего лишь уточнение. Тут тоже можно использовать например так:
    var LTask: IAsyncTask;
    LTask :=  AsyncTask;
    LTask.Run (...);
    ...
    LTask.Terminate; // досрочно завершаем поток
    В ITask exception глушится, что не всегда хорошо. Тут его можно обработать очень просто, если есть нужда. Процедуры тут изначально синхронизированны и в подавляющем большинстве это как раз то что нужно - не нужно постоянно писать код синхронизации (хотя он и тривиален).
    Сам же модуль был написан еще до появления ITask, так что я как то исторически привык использовать именно его. Однако у ITask есть свои преимущества и они неоспоримы. Это всего лишь альтернатива для некоторых случаев.
  4. Like
    DirtyBorov отреагировална Axbor в MaskEdit   
    // --------------------------------------------------------------------------- #include <fmx.h> #pragma hdrstop #include "Unit1.h" // --------------------------------------------------------------------------- #pragma package(smart_init) #pragma resource "*.fmx" TForm1 *Form1; // --------------------------------------------------------------------------- __fastcall TForm1::TForm1(TComponent* Owner) : TForm(Owner) { Mask = "+7(00)000-00-00;0;*"; PhoneNumber = ""; } // --------------------------------------------------------------------------- void __fastcall TForm1::edtPhoneTyping(TObject *Sender) { edtPhone->CaretPosition = GetCaretPos(); } // --------------------------------------------------------------------------- int __fastcall TForm1::GetCaretPos() { int i; int Result = 0; for (i = 0; i < Mask.Length(); i++) { if (!(MaskGetCharType(Mask, i) == mcDirective || MaskGetCharType(Mask, i) == mcMask)) Result += 1; if ((Result + PhoneNumber.Length()) == i) break; } Result = Result + PhoneNumber.Length() - 1; return Result; } int __fastcall TForm1::GetMaxLength() { int Result = 0; for (int i = 0; i < Mask.Length(); i++) if (MaskGetCharType(Mask, i) == mcMask) Result = Result + 1; return Result; } void __fastcall TForm1::edtPhoneKeyDown(TObject *Sender, WORD &Key, System::WideChar &KeyChar, TShiftState Shift) { if ((Key == 8) && (PhoneNumber.Length() > 0)) PhoneNumber = PhoneNumber.SubString(1, PhoneNumber.Length() - 1); else if ((PhoneNumber.Length() < GetMaxLength()) && (Key == 0) && IsDigit(KeyChar)) PhoneNumber = PhoneNumber + KeyChar; else KeyChar = 0; } // --------------------------------------------------------------------------- void __fastcall TForm1::edtPhoneKeyUp(TObject *Sender, WORD &Key, System::WideChar &KeyChar, TShiftState Shift) { edtPhone->CaretPosition = GetCaretPos(); } //--------------------------------------------------------------------------- void __fastcall TForm1::edtPhoneValidating(TObject *Sender, UnicodeString &Text) { Text = FormatMaskText(Mask, PhoneNumber); } //--------------------------------------------------------------------------- void __fastcall TForm1::FormCreate(TObject *Sender) { edtPhone->Text = FormatMaskText(Mask, PhoneNumber); } //--------------------------------------------------------------------------- //--------------------------------------------------------------------------- #ifndef Unit1H #define Unit1H //--------------------------------------------------------------------------- #include <System.Classes.hpp> #include <FMX.Controls.hpp> #include <FMX.Forms.hpp> #include <System.MaskUtils.hpp> #include <FMX.Controls.Presentation.hpp> #include <FMX.Edit.hpp> #include <FMX.StdCtrls.hpp> #include <FMX.Types.hpp> #include <System.Character.hpp> #include <string.h> //--------------------------------------------------------------------------- class TForm1 : public TForm { __published: // IDE-managed Components TEdit *edtPhone; TButton *Button1; void __fastcall edtPhoneTyping(TObject *Sender); void __fastcall edtPhoneKeyDown(TObject *Sender, WORD &Key, System::WideChar &KeyChar, TShiftState Shift); void __fastcall edtPhoneKeyUp(TObject *Sender, WORD &Key, System::WideChar &KeyChar, TShiftState Shift); void __fastcall edtPhoneValidating(TObject *Sender, UnicodeString &Text); void __fastcall FormCreate(TObject *Sender); private: // User declarations public: String PhoneNumber; String Mask; int __fastcall GetCaretPos(); int __fastcall GetMaxLength(); // User declarations __fastcall TForm1(TComponent* Owner); }; //--------------------------------------------------------------------------- extern PACKAGE TForm1 *Form1; //--------------------------------------------------------------------------- #endif Для тех кому нужен на C++
  5. Like
    DirtyBorov получил реакцию от Ingalime в MaskEdit   
    Случилось так, что потребовался мне ввод номера телефона. Компонента, аналога TMaskEdit в FMX нет, так что пришлось "изобретать на коленке". Компонент писать было лень, потому просто покажу как я решил это в конкретном диалоге с использованием TEdit. Может кому то пригодится. Из кода я убрал все лишнее, оставил только то что относится к делу.
    uses .... System.MaskUtils, System.Character; type TFormRegistry = class(TForm) edtPhone: TEdit; procedure edtPhoneValidating(Sender: TObject; var Text: string); procedure edtPhoneKeyDown(Sender: TObject; var Key: Word; var KeyChar: Char; Shift: TShiftState); procedure FormCreate(Sender: TObject); procedure edtPhoneEnter(Sender: TObject); procedure edtPhoneTyping(Sender: TObject); private const Mask = '+7(000)000-00-00;0;*'; /// '+0(000)000-00-00;0;*' - для других стран, например для Украины +3(999).... private PhoneNumber: string; function GetCaretPos: Integer; function GetMaxLength: integer; public end; procedure TFormRegistry.FormCreate(Sender: TObject); begin edtPhone.Text := FormatMaskText(Mask, PhoneNumber); end; function TFormRegistry.GetCaretPos: Integer; var i: integer; begin Result := 0; for i := 0 to Mask.Length-1 do begin if not (MaskGetCharType(Mask, i) in [mcDirective, mcMask]) then Result := Result + 1; if (Result + PhoneNumber.Length) = i then Break; end; Result := Result + PhoneNumber.Length - 1; end; function TFormRegistry.GetMaxLength: integer; var i: integer; begin Result := 0; for i := 0 to Mask.Length-1 do if (MaskGetCharType(Mask, i) in [mcMask]) then Result := Result + 1; end; procedure TFormRegistry.edtPhoneKeyDown(Sender: TObject; var Key: Word; var KeyChar: Char; Shift: TShiftState); begin if (Key = 8) and (PhoneNumber.Length > 0) then PhoneNumber := Copy(PhoneNumber, 1, PhoneNumber.Length-1) else if (PhoneNumber.Length < GetMaxLength) and (Key = 0) and IsDigit(KeyChar) then PhoneNumber := PhoneNumber + KeyChar else KeyChar := #0; end; procedure TFormRegistry.edtPhoneEnter(Sender: TObject); begin edtPhone.CaretPosition := GetCaretPos; end; procedure TFormRegistry.edtPhoneTyping(Sender: TObject); begin edtPhone.CaretPosition := GetCaretPos; end; procedure TFormRegistry.edtPhoneValidating(Sender: TObject; var Text: string); begin Text := FormatMaskText(Mask, PhoneNumber); end; end.
  6. Like
    DirtyBorov получил реакцию от kami в TMS Pack for FireMonkey   
    Дался вам этот акутест. Лучше посоветуйте на счет TreeView
  7. Like
    DirtyBorov отреагировална Roma77751 в TMS Pack for FireMonkey   
    вопрос снимаю,нашел и поставил tmsfmxwebbrowser,пока все работает. Кстати TMS Pack for FireMonkey есть на codmasters.ru, если кто не найдет пишите ссылку кину.
  8. Like
    DirtyBorov получил реакцию от Alisson R Oliveira в MaskEdit   
    Случилось так, что потребовался мне ввод номера телефона. Компонента, аналога TMaskEdit в FMX нет, так что пришлось "изобретать на коленке". Компонент писать было лень, потому просто покажу как я решил это в конкретном диалоге с использованием TEdit. Может кому то пригодится. Из кода я убрал все лишнее, оставил только то что относится к делу.
    uses .... System.MaskUtils, System.Character; type TFormRegistry = class(TForm) edtPhone: TEdit; procedure edtPhoneValidating(Sender: TObject; var Text: string); procedure edtPhoneKeyDown(Sender: TObject; var Key: Word; var KeyChar: Char; Shift: TShiftState); procedure FormCreate(Sender: TObject); procedure edtPhoneEnter(Sender: TObject); procedure edtPhoneTyping(Sender: TObject); private const Mask = '+7(000)000-00-00;0;*'; /// '+0(000)000-00-00;0;*' - для других стран, например для Украины +3(999).... private PhoneNumber: string; function GetCaretPos: Integer; function GetMaxLength: integer; public end; procedure TFormRegistry.FormCreate(Sender: TObject); begin edtPhone.Text := FormatMaskText(Mask, PhoneNumber); end; function TFormRegistry.GetCaretPos: Integer; var i: integer; begin Result := 0; for i := 0 to Mask.Length-1 do begin if not (MaskGetCharType(Mask, i) in [mcDirective, mcMask]) then Result := Result + 1; if (Result + PhoneNumber.Length) = i then Break; end; Result := Result + PhoneNumber.Length - 1; end; function TFormRegistry.GetMaxLength: integer; var i: integer; begin Result := 0; for i := 0 to Mask.Length-1 do if (MaskGetCharType(Mask, i) in [mcMask]) then Result := Result + 1; end; procedure TFormRegistry.edtPhoneKeyDown(Sender: TObject; var Key: Word; var KeyChar: Char; Shift: TShiftState); begin if (Key = 8) and (PhoneNumber.Length > 0) then PhoneNumber := Copy(PhoneNumber, 1, PhoneNumber.Length-1) else if (PhoneNumber.Length < GetMaxLength) and (Key = 0) and IsDigit(KeyChar) then PhoneNumber := PhoneNumber + KeyChar else KeyChar := #0; end; procedure TFormRegistry.edtPhoneEnter(Sender: TObject); begin edtPhone.CaretPosition := GetCaretPos; end; procedure TFormRegistry.edtPhoneTyping(Sender: TObject); begin edtPhone.CaretPosition := GetCaretPos; end; procedure TFormRegistry.edtPhoneValidating(Sender: TObject; var Text: string); begin Text := FormatMaskText(Mask, PhoneNumber); end; end.
  9. Like
    DirtyBorov получил реакцию от enatechno в Как найти реальный индекс узла TTreeViewItem дерева?   
    Коллега, вы совершенно не верно подходите к решению задачи. TreeView - это представление, а база данных - это модель. Потому построение дерева должно опираться на данных в БД, а не наоборот. 
    Дерево в базе хранят обычно в одной таблице такой структуры:
    id - id объекта
    parent - id родителя
    text - наименование
     
    например ваша структура в БД будет примерно так выглядеть:
    1, null, Родитель 1
       2, 1, Потомок 1-1
       3, 1, Потомок 1-1
    4, null, Родитель 2
       5, 4, Потомок 2-1
       6, 4, Потомок 2-2
          7, 6, Потомок 2-3  - обратите внимание - потомок потомка
    и т.д.
     
    Для того что бы связать запись БД и Item в дереве используйте свойство Tag. Это просто и удобно. 
    Как строить дерево:
    1. Самый плохой способ  - при запуске программы, из БД считывается все данные и по ним строится полное дерево. При добавлении/удалении записи все повторяем - перечитываем полное дерево. Таким способом лучше не делать. За такой метод бьют ногами не похвалят. Причем и пользователи (за тормоза программы) и админ сервера БД (за нагрузку на сервер).
     
    2. Этот способ немного лучше -  при запуске мы точно также считываем полное дерево из БД. Но при добавлении записей, мы добавляем только конкретный Item в дерево и его Tag присваиваем ID который назначил сервер при создании записи в БД. Но тут все еще есть недостаток - полное построение дерева - если записей много, то может занимать много времени.
     
    3. Самый лучший способ - при запуске считываются только корневые записи (parent = null). А остальные подгружаются по мере необходимости. Когда пользователь разворачивает ветку, то из БД получаем все записи parent = Selected.Tag и добавляем детей к этой ветке.  Добавление новых записей так же как в способе 2.
     
    Рекомендую вам использовать именно способ 3. Во первых он самый быстрый, во вторых считывание из БД наиболее простое. Иначе вам без рекурсивных хранимых процедур будет сделать полное чтение дерево очень сложно.  Здесь же можно все выбирать простыми запросами. 
    Еще пара советов:
    если данных много и по дереву ходят много - то постепенно программа подгрузит много веток и это может занимать много памяти, что может привести к тормозам. Потому при сворачивании ветки, лучше всех детей удалять. 
    Когда ветка не имеет детей, то у нее нет слева стрелочки для разворачивания. Потому возникает вопрос - как же тогда развернуть ветку, чтобы подгрузить детей? Все просто. Надо создать одного фейкового ребенка. Т.е. просто Item-пустышку не связанную с БД. А когда ветку разворачивают, то первым делом надо пустышку удалить. Потом считать БД. Естественно при сворачивании делаем наоборот - сначала удаляем все реальные Item-ы, а потом вновь добавляем пустышку.
    Вот как то так.
  10. Like
    DirtyBorov отреагировална Brovin Yaroslav в [Windows] Как поменять иконку формы без стилизованной рамки?   
    Добрый день,
     
    У вас все правильно написано. В вашем коде вы меняете иконку самого приложения в трее. А вот чтобы поменять иконку у формы, нужно отправлять сообщение WM_SETICON окну а не приложению:
    uses VCL.Graphics, Winapi.Windows, Winapi.Messages, FMX.Platform.Win; procedure TForm3.Button1Click(Sender: TObject); var NewAppIcon: TIcon; begin NewAppIcon := TIcon.Create; NewAppIcon.LoadFromFile('c:\icon.ico'); SendMessage(ApplicationHWND, WM_SETICON, 1, NewAppIcon.Handle); SendMessage(WindowHandleToPlatform(Handle).Wnd, WM_SETICON, 1, NewAppIcon.Handle); end;
  11. Like
    DirtyBorov получил реакцию от Belov.V. в [TRESTRequest] Лучшая практика, когда нужно отправить несколько запросов через RESTRequest   
    По каким то причинам мне не удается прикрепить файл содержащий TWaitControl. Потому просто выложу его код полностью. Благо он совсем короткий. 
    Модуль универсальный. Его можно использовать не только для REST но и вообще для любых длительных операций которые нужно выполнять в потоках.
     
    Обратите внимание, что в конструктор передается TForm. Это экземпляр ГЛАВНОЙ формы приложения.  Это нужно потому что TWaitControl , будет перекрывать главную форму полупрозрачным квадратом, создавая эффект затемнения и заодно делая недоступным разные кнопки на форме.  Рекомендую создавать TWaitControl в событии OnCreate главной формы:
    TMainForm = class(TForm) private Wait: TWaitControl; end; procedure TMainForm.FormCreate(Sender: TObject); begin Application.OnException := OnException; Wait := TWaitControl.Create(Self); Wait.Title.Text := 'Ждите пожалуйста...'; end; unit Wait.Control; interface uses FMX.Forms, FMX.Objects, FMX.Types, FMX.Effects, FMX.StdCtrls, System.SysUtils, System.Classes, System.UITypes; type TWaitControl = class(TRectangle) private FWindow: TRectangle; FTitle: TLabel; FHadErrors: Boolean; FWaiting: Boolean; procedure DoErrorHandling(E: Exception; AOnError: TProc<TWaitControl, Exception>); procedure DoOnCompleted(AOnComplete: TProc<TWaitControl>); public constructor Create(MainForm: TForm); reintroduce; procedure Run(ATask: TProc<TWaitControl>; AOnComplete: TProc<TWaitControl> = nil; AOnError: TProc<TWaitControl, Exception> = nil); virtual; property Waiting: Boolean read FWaiting; property HadErrors: Boolean read FHadErrors; property Window: TRectangle read FWindow; property Title: TLabel read FTitle; end; implementation { TWaitControl } constructor TWaitControl.Create(MainForm: TForm); begin inherited Create(MainForm); Parent := MainForm; Align := TAlignLayout.Contents; Visible := False; Fill.Color := $4B000000; FWindow := TRectangle.Create(Self); FWindow.Parent := Self; FWindow.Fill.Color := $96000000; FWindow.Align := TAlignLayout.Center; FWindow.Width := 250; FWindow.Height := 65; FTitle := TLabel.Create(FWindow); FTitle.Parent := FWindow; FTitle.Align := TAlignLayout.Client; FTitle.StyledSettings := FTitle.StyledSettings - [TStyledSetting.Size, TStyledSetting.Style]; FTitle.TextSettings.Font.Size := 16; // FTitle.TextSettings.Font.Style := [TFontStyle.fsBold]; with TAniIndicator.Create(FWindow) do begin Parent := FWindow; Style := TAniIndicatorStyle.Circular; Align := TAlignLayout.Left; Margins.Left := 15; Margins.Top := 15; Margins.Right := 15; Margins.Bottom := 15; Width := Height; Enabled := True; end; with TShadowEffect.Create(FWindow) do Parent := FWindow; end; procedure TWaitControl.DoErrorHandling(E: Exception; AOnError: TProc<TWaitControl, Exception>); begin TThread.Synchronize(TThread.CurrentThread, procedure begin FWaiting := False; FHadErrors := True; Visible := False; if Assigned(AOnError) then AOnError(Self, E); end); end; procedure TWaitControl.DoOnCompleted(AOnComplete: TProc<TWaitControl>); begin TThread.Synchronize(nil, procedure begin FWaiting := False; Visible := False; if Assigned(AOnComplete) then AOnComplete(Self); end); end; procedure TWaitControl.Run; begin Visible := True; FWaiting := True; TThread.CreateAnonymousThread( procedure begin try FHadErrors := False; ATask(Self); DoOnCompleted(AOnComplete); except on E:Exception do DoErrorHandling(E, AOnError); end; // DoOnCompleted(AOnComplete); end).Start; end; end.
  12. Like
    DirtyBorov получил реакцию от willi в MaskEdit   
    Случилось так, что потребовался мне ввод номера телефона. Компонента, аналога TMaskEdit в FMX нет, так что пришлось "изобретать на коленке". Компонент писать было лень, потому просто покажу как я решил это в конкретном диалоге с использованием TEdit. Может кому то пригодится. Из кода я убрал все лишнее, оставил только то что относится к делу.
    uses .... System.MaskUtils, System.Character; type TFormRegistry = class(TForm) edtPhone: TEdit; procedure edtPhoneValidating(Sender: TObject; var Text: string); procedure edtPhoneKeyDown(Sender: TObject; var Key: Word; var KeyChar: Char; Shift: TShiftState); procedure FormCreate(Sender: TObject); procedure edtPhoneEnter(Sender: TObject); procedure edtPhoneTyping(Sender: TObject); private const Mask = '+7(000)000-00-00;0;*'; /// '+0(000)000-00-00;0;*' - для других стран, например для Украины +3(999).... private PhoneNumber: string; function GetCaretPos: Integer; function GetMaxLength: integer; public end; procedure TFormRegistry.FormCreate(Sender: TObject); begin edtPhone.Text := FormatMaskText(Mask, PhoneNumber); end; function TFormRegistry.GetCaretPos: Integer; var i: integer; begin Result := 0; for i := 0 to Mask.Length-1 do begin if not (MaskGetCharType(Mask, i) in [mcDirective, mcMask]) then Result := Result + 1; if (Result + PhoneNumber.Length) = i then Break; end; Result := Result + PhoneNumber.Length - 1; end; function TFormRegistry.GetMaxLength: integer; var i: integer; begin Result := 0; for i := 0 to Mask.Length-1 do if (MaskGetCharType(Mask, i) in [mcMask]) then Result := Result + 1; end; procedure TFormRegistry.edtPhoneKeyDown(Sender: TObject; var Key: Word; var KeyChar: Char; Shift: TShiftState); begin if (Key = 8) and (PhoneNumber.Length > 0) then PhoneNumber := Copy(PhoneNumber, 1, PhoneNumber.Length-1) else if (PhoneNumber.Length < GetMaxLength) and (Key = 0) and IsDigit(KeyChar) then PhoneNumber := PhoneNumber + KeyChar else KeyChar := #0; end; procedure TFormRegistry.edtPhoneEnter(Sender: TObject); begin edtPhone.CaretPosition := GetCaretPos; end; procedure TFormRegistry.edtPhoneTyping(Sender: TObject); begin edtPhone.CaretPosition := GetCaretPos; end; procedure TFormRegistry.edtPhoneValidating(Sender: TObject; var Text: string); begin Text := FormatMaskText(Mask, PhoneNumber); end; end.
  13. Like
    DirtyBorov получил реакцию от rareMax в MaskEdit   
    Случилось так, что потребовался мне ввод номера телефона. Компонента, аналога TMaskEdit в FMX нет, так что пришлось "изобретать на коленке". Компонент писать было лень, потому просто покажу как я решил это в конкретном диалоге с использованием TEdit. Может кому то пригодится. Из кода я убрал все лишнее, оставил только то что относится к делу.
    uses .... System.MaskUtils, System.Character; type TFormRegistry = class(TForm) edtPhone: TEdit; procedure edtPhoneValidating(Sender: TObject; var Text: string); procedure edtPhoneKeyDown(Sender: TObject; var Key: Word; var KeyChar: Char; Shift: TShiftState); procedure FormCreate(Sender: TObject); procedure edtPhoneEnter(Sender: TObject); procedure edtPhoneTyping(Sender: TObject); private const Mask = '+7(000)000-00-00;0;*'; /// '+0(000)000-00-00;0;*' - для других стран, например для Украины +3(999).... private PhoneNumber: string; function GetCaretPos: Integer; function GetMaxLength: integer; public end; procedure TFormRegistry.FormCreate(Sender: TObject); begin edtPhone.Text := FormatMaskText(Mask, PhoneNumber); end; function TFormRegistry.GetCaretPos: Integer; var i: integer; begin Result := 0; for i := 0 to Mask.Length-1 do begin if not (MaskGetCharType(Mask, i) in [mcDirective, mcMask]) then Result := Result + 1; if (Result + PhoneNumber.Length) = i then Break; end; Result := Result + PhoneNumber.Length - 1; end; function TFormRegistry.GetMaxLength: integer; var i: integer; begin Result := 0; for i := 0 to Mask.Length-1 do if (MaskGetCharType(Mask, i) in [mcMask]) then Result := Result + 1; end; procedure TFormRegistry.edtPhoneKeyDown(Sender: TObject; var Key: Word; var KeyChar: Char; Shift: TShiftState); begin if (Key = 8) and (PhoneNumber.Length > 0) then PhoneNumber := Copy(PhoneNumber, 1, PhoneNumber.Length-1) else if (PhoneNumber.Length < GetMaxLength) and (Key = 0) and IsDigit(KeyChar) then PhoneNumber := PhoneNumber + KeyChar else KeyChar := #0; end; procedure TFormRegistry.edtPhoneEnter(Sender: TObject); begin edtPhone.CaretPosition := GetCaretPos; end; procedure TFormRegistry.edtPhoneTyping(Sender: TObject); begin edtPhone.CaretPosition := GetCaretPos; end; procedure TFormRegistry.edtPhoneValidating(Sender: TObject; var Text: string); begin Text := FormatMaskText(Mask, PhoneNumber); end; end.
  14. Like
    DirtyBorov получил реакцию от XoviX в [TRESTRequest] Лучшая практика, когда нужно отправить несколько запросов через RESTRequest   
    По каким то причинам мне не удается прикрепить файл содержащий TWaitControl. Потому просто выложу его код полностью. Благо он совсем короткий. 
    Модуль универсальный. Его можно использовать не только для REST но и вообще для любых длительных операций которые нужно выполнять в потоках.
     
    Обратите внимание, что в конструктор передается TForm. Это экземпляр ГЛАВНОЙ формы приложения.  Это нужно потому что TWaitControl , будет перекрывать главную форму полупрозрачным квадратом, создавая эффект затемнения и заодно делая недоступным разные кнопки на форме.  Рекомендую создавать TWaitControl в событии OnCreate главной формы:
    TMainForm = class(TForm) private Wait: TWaitControl; end; procedure TMainForm.FormCreate(Sender: TObject); begin Application.OnException := OnException; Wait := TWaitControl.Create(Self); Wait.Title.Text := 'Ждите пожалуйста...'; end; unit Wait.Control; interface uses FMX.Forms, FMX.Objects, FMX.Types, FMX.Effects, FMX.StdCtrls, System.SysUtils, System.Classes, System.UITypes; type TWaitControl = class(TRectangle) private FWindow: TRectangle; FTitle: TLabel; FHadErrors: Boolean; FWaiting: Boolean; procedure DoErrorHandling(E: Exception; AOnError: TProc<TWaitControl, Exception>); procedure DoOnCompleted(AOnComplete: TProc<TWaitControl>); public constructor Create(MainForm: TForm); reintroduce; procedure Run(ATask: TProc<TWaitControl>; AOnComplete: TProc<TWaitControl> = nil; AOnError: TProc<TWaitControl, Exception> = nil); virtual; property Waiting: Boolean read FWaiting; property HadErrors: Boolean read FHadErrors; property Window: TRectangle read FWindow; property Title: TLabel read FTitle; end; implementation { TWaitControl } constructor TWaitControl.Create(MainForm: TForm); begin inherited Create(MainForm); Parent := MainForm; Align := TAlignLayout.Contents; Visible := False; Fill.Color := $4B000000; FWindow := TRectangle.Create(Self); FWindow.Parent := Self; FWindow.Fill.Color := $96000000; FWindow.Align := TAlignLayout.Center; FWindow.Width := 250; FWindow.Height := 65; FTitle := TLabel.Create(FWindow); FTitle.Parent := FWindow; FTitle.Align := TAlignLayout.Client; FTitle.StyledSettings := FTitle.StyledSettings - [TStyledSetting.Size, TStyledSetting.Style]; FTitle.TextSettings.Font.Size := 16; // FTitle.TextSettings.Font.Style := [TFontStyle.fsBold]; with TAniIndicator.Create(FWindow) do begin Parent := FWindow; Style := TAniIndicatorStyle.Circular; Align := TAlignLayout.Left; Margins.Left := 15; Margins.Top := 15; Margins.Right := 15; Margins.Bottom := 15; Width := Height; Enabled := True; end; with TShadowEffect.Create(FWindow) do Parent := FWindow; end; procedure TWaitControl.DoErrorHandling(E: Exception; AOnError: TProc<TWaitControl, Exception>); begin TThread.Synchronize(TThread.CurrentThread, procedure begin FWaiting := False; FHadErrors := True; Visible := False; if Assigned(AOnError) then AOnError(Self, E); end); end; procedure TWaitControl.DoOnCompleted(AOnComplete: TProc<TWaitControl>); begin TThread.Synchronize(nil, procedure begin FWaiting := False; Visible := False; if Assigned(AOnComplete) then AOnComplete(Self); end); end; procedure TWaitControl.Run; begin Visible := True; FWaiting := True; TThread.CreateAnonymousThread( procedure begin try FHadErrors := False; ATask(Self); DoOnCompleted(AOnComplete); except on E:Exception do DoErrorHandling(E, AOnError); end; // DoOnCompleted(AOnComplete); end).Start; end; end.
  15. Like
    DirtyBorov получил реакцию от XoviX в [TRESTRequest] Лучшая практика, когда нужно отправить несколько запросов через RESTRequest   
    Логично. Но тема не раскрыта.
    Во первых, я написал, о том что мне было НУЖЕН json, потому ответы не десереализуются в объекты. Во вторых нет необходимости использовать TJson.JsonToObject. Все гораздо проще. Как я уже писал, нужно изменить функцию Request. Например так:
    function Request<T: class>(ABody: TApiObject): T; ... function TRestAPI.Request<T>(ABody: TApiObject): T; var i: integer; begin RESTRequest.ClearBody; RESTRequest.AddBody(ABody); RESTRequest.Execute; if (RESTResponse.StatusCode <> 200) then raise Exception.CreateFmt('Оштбка сервера %d "%s"',[RESTResponse.StatusCode, RESTResponse.StatusText]); if not Assigned(RESTResponse.JSONValue) then raise Exception.Create('Ответ сервера не содержит подходящих данных'); Result := RESTResponse.JSONValue.GetValue<T>('content'); end; Теперь по поводу потоков. Все верно, но не совсем.  Поскольку TRestAPI это наследник TDataModule, то я подразумевал использование в программе единственного его экземпляра. А значит код на подобии такого - полный отстой:
    function TRestAPI.GetUserInfo(ABody: TApiInfo): TJSONValue; begin TThread.CreateAnonymousThread(procedure begin RESTClient.BaseURL := BaseURL + '?act=terminal&area=info&infoType=2&response=js'; Result := Request(ABody); end).Start; end; Почему? Потому что если из главного модуля выполнить подряд сразу два запроса - то мы получим exception. Так как потоки раздерутся из-за единственных экземпляров:
    RESTClient: TRESTClient; RESTRequest: TRESTRequest; RESTResponse: TRESTResponse;   Первое что приходит на ум: 1. Создавать динамически TRestAPI для каждого запроса 2. Создавать TRESTClient, TRESTRequest, TRESTResponse для каждого запроса.   Логично? Нет. Это вообще полное гамно плохая идея. Потому что будет много лишнего кода, а мы стремимся все сделать красиво.    Что же, мы к этому подошли, покажу как же я использовал данный код. А использовал я его конечно же в потоках. Идея очень простая и весьма удобная. Взял я ее с сайта fmxexpress.com (к сожалению не помню автора, но вы можете найти). Мне она настолько понравилась, что я теперь использую ее повсеместно. Конечно код я модернизировал под себя и адаптировал для использования на desktop. Код позволяет отправить в поток любую функцию. При этом при завершении или ошибке будет вызваны соответсвующие функции. Но весь код будет находится в одном месте (используются анонимные методы). При выполнении запроса будет выведено окно с анимацией и надписью "Ждите..." Вот пример вызова запроса: procedure TFormCashbox.RequestCardInfo(const ACardNum: string); var Json: TJSONValue; Body: TApiInfo; begin lblStatus.Text := 'Запрос информации...'; Wait.Run( procedure(AWait: TWaitControl) begin Body := TApiInfo.Create; Body.Card_num := ACardNum; Body.Hall_id := '1600'; Json := RestAPI.SendRequest(Body); end, procedure(AWait: TWaitControl) begin CurrentCard.SetState(TCardState.Used, ACardNum, Json); lblStatus.Text := 'Готов'; end, procedure (AWait: TWaitControl; AException: Exception) begin OnException(Self, AException); end ); end; Весь секрет кроется в Wait. Метод Run принимает три метода: 
    1.основной код
    2.код завершения потока
    3.код при возникновении ошибки в потоке.
     
    Сам же Wait: TWaitControl - это наследник от TRectangle. Когда выполняется метод Run, он появляется на экране и показывает надпись. Дополнительно он поверх всей формы выводит полупрозрачный фон, что создает эффект как на многих сайтах.
    Я не буду объяснять как работает TWaitControl, там все тривиально. Просто приложу готовый модуль - пользуйтесь. С помощью него вы можете сильно упростить жизнь при работе с потоками. 
  16. Like
    DirtyBorov получил реакцию от xenon54 в Наследник от TListItemSimpleControl   
    Пробовал кто то наследоваться от TListItemSimpleControl? Печаль-беда
    Меня собственно не устроил TListItemTextButton. Захотел я сделать свою кнопочку. Для этого создал свой unit и наследовался от TListItemSimpleControl. Но тут меня ждал большой сюрприз. Дело в том что многие поля и даже методы оказались не доступны! Беглое изучение кода в файле FMX.ListView.Types показали что "не боги горшки обжигают". Досадных ошибок в нем хватает. Когда разработчики писали этот модуль, у них все было хорошо, потому что как известно в пределах видимости unit можно в одном классе иметь доступ к полям private другого класса. Это известная "болезнь".
     
    В чем собственно проблемы?  Сначала не нашлось некоторые константы и поля классов. Эти поля активно используются в наследниках, хотя объявлены они так:
      TListItemSimpleControl = class(TListItemObject)   private const     DisabledOpacity = 0.6;   private     FEnabled: Boolean;     FPressed: Boolean;     FMouseOver: Boolean;     FOnClick: TNotifyEvent;     FTouchExpand: Single;    ... Дальше оказалось еще интересней.  Есть такой метод:
    procedure SetData(const AValue: TValue); override; Как видим, метод перекрытый. Это значит что он где то в родительском классе объявлен как virtual, однако компилятор бодро сообщил что такой метод не найден в базовом классе. Внезапно! Смотрим базовые классы и что же мы видим:
     TListItemObject = class(TInterfacedPersistent)   private     .....     procedure SetData(const Value: TValue); virtual; Браво! Аплодирую стоя! 
    Дальше копать я не стал. Уже и так стало ясно что затея с наследованием обречена на провал. Единственное пожалуй решение из данной ситуации это скопировать модуль FMX.ListView.Types  в папку с проектом, добавить его в проект и внести нужные изменения. Ну или дописать в этом модуле свои классы.   Написал я это с горяча. Достали нелепые ошибки. Может кому то пригодится мои исследования и сэкономят немного времени.
  17. Like
    DirtyBorov получил реакцию от aleksandrguru в [TRESTRequest] Лучшая практика, когда нужно отправить несколько запросов через RESTRequest   
    По каким то причинам мне не удается прикрепить файл содержащий TWaitControl. Потому просто выложу его код полностью. Благо он совсем короткий. 
    Модуль универсальный. Его можно использовать не только для REST но и вообще для любых длительных операций которые нужно выполнять в потоках.
     
    Обратите внимание, что в конструктор передается TForm. Это экземпляр ГЛАВНОЙ формы приложения.  Это нужно потому что TWaitControl , будет перекрывать главную форму полупрозрачным квадратом, создавая эффект затемнения и заодно делая недоступным разные кнопки на форме.  Рекомендую создавать TWaitControl в событии OnCreate главной формы:
    TMainForm = class(TForm) private Wait: TWaitControl; end; procedure TMainForm.FormCreate(Sender: TObject); begin Application.OnException := OnException; Wait := TWaitControl.Create(Self); Wait.Title.Text := 'Ждите пожалуйста...'; end; unit Wait.Control; interface uses FMX.Forms, FMX.Objects, FMX.Types, FMX.Effects, FMX.StdCtrls, System.SysUtils, System.Classes, System.UITypes; type TWaitControl = class(TRectangle) private FWindow: TRectangle; FTitle: TLabel; FHadErrors: Boolean; FWaiting: Boolean; procedure DoErrorHandling(E: Exception; AOnError: TProc<TWaitControl, Exception>); procedure DoOnCompleted(AOnComplete: TProc<TWaitControl>); public constructor Create(MainForm: TForm); reintroduce; procedure Run(ATask: TProc<TWaitControl>; AOnComplete: TProc<TWaitControl> = nil; AOnError: TProc<TWaitControl, Exception> = nil); virtual; property Waiting: Boolean read FWaiting; property HadErrors: Boolean read FHadErrors; property Window: TRectangle read FWindow; property Title: TLabel read FTitle; end; implementation { TWaitControl } constructor TWaitControl.Create(MainForm: TForm); begin inherited Create(MainForm); Parent := MainForm; Align := TAlignLayout.Contents; Visible := False; Fill.Color := $4B000000; FWindow := TRectangle.Create(Self); FWindow.Parent := Self; FWindow.Fill.Color := $96000000; FWindow.Align := TAlignLayout.Center; FWindow.Width := 250; FWindow.Height := 65; FTitle := TLabel.Create(FWindow); FTitle.Parent := FWindow; FTitle.Align := TAlignLayout.Client; FTitle.StyledSettings := FTitle.StyledSettings - [TStyledSetting.Size, TStyledSetting.Style]; FTitle.TextSettings.Font.Size := 16; // FTitle.TextSettings.Font.Style := [TFontStyle.fsBold]; with TAniIndicator.Create(FWindow) do begin Parent := FWindow; Style := TAniIndicatorStyle.Circular; Align := TAlignLayout.Left; Margins.Left := 15; Margins.Top := 15; Margins.Right := 15; Margins.Bottom := 15; Width := Height; Enabled := True; end; with TShadowEffect.Create(FWindow) do Parent := FWindow; end; procedure TWaitControl.DoErrorHandling(E: Exception; AOnError: TProc<TWaitControl, Exception>); begin TThread.Synchronize(TThread.CurrentThread, procedure begin FWaiting := False; FHadErrors := True; Visible := False; if Assigned(AOnError) then AOnError(Self, E); end); end; procedure TWaitControl.DoOnCompleted(AOnComplete: TProc<TWaitControl>); begin TThread.Synchronize(nil, procedure begin FWaiting := False; Visible := False; if Assigned(AOnComplete) then AOnComplete(Self); end); end; procedure TWaitControl.Run; begin Visible := True; FWaiting := True; TThread.CreateAnonymousThread( procedure begin try FHadErrors := False; ATask(Self); DoOnCompleted(AOnComplete); except on E:Exception do DoErrorHandling(E, AOnError); end; // DoOnCompleted(AOnComplete); end).Start; end; end.
  18. Like
    DirtyBorov получил реакцию от aleksandrguru в [TRESTRequest] Лучшая практика, когда нужно отправить несколько запросов через RESTRequest   
    У вас какая то надуманная проблема. На самом деле "руками" все делается намного проще чем кажется. При этом код будет минимизировать ошибки, потому что он будет типовой, шаблонный. Вот я приведу кусочек код из одной моей программы:
    unit Rest.API; interface uses   CodeSiteLogging,   System.JSON, REST.JsonReflect, Rest.Classes,   System.SysUtils, System.Classes, IPPeerClient, REST.Client, REST.Types, Data.Bind.Components, Data.Bind.ObjectScope; type   TApiObject = class abstract   end;   TApiLogin = class(TApiObject)   public     Login: string;     Password: string;   end;   TRestAPI = class(TDataModule)     RESTClient: TRESTClient;     RESTRequest: TRESTRequest;     RESTResponse: TRESTResponse;   private      const BaseURL = 'http://bla-bla.com/index.php';   private     // Выполняет запрос     function Request(ABody: TApiObject): TJSONValue;     function SendLogin(ABody: TApiLogin): TJSONValue;     function SendRegistry(ABody: TApiUser): TJSONValue;     function GetUserInfo(ABody: TApiInfo): TJSONValue;     function SetBalance(ABody: TApiBalance): TJSONValue;   public     function SendRequest(AObject: TApiObject; AOwn: Boolean = true): TJSONValue;   end; var   RestAPI: TRestAPI; implementation {%CLASSGROUP 'FMX.Controls.TControl'} {$R *.dfm} { TDataHTTP } /// Основная функция отправки json-объекта. она принимает обычный объект и сериализует его в json function TRestAPI.Request(ABody: TApiObject): TJSONValue; var   i: integer; begin   RESTRequest.ClearBody;   RESTRequest.AddBody(ABody);   RESTRequest.Execute; /// проверяем ответ сервера   if (RESTResponse.StatusCode <> 200) then     raise Exception.CreateFmt('Оштбка сервера %d "%s"',[RESTResponse.StatusCode, RESTResponse.StatusText]); /// проверяем, содержит ли ответ json   if not Assigned(RESTResponse.JSONValue) then      raise Exception.Create('Ответ сервера не содержит подходящих данных'); /// Проверяем, не содержится ли в ответе ошибок   Result := RESTResponse.JSONValue.GetValue<TJSONValue>('content');   if not RESTResponse.JSONValue.GetValue<string>('status').Equals('success') then      raise Exception.Create(RESTResponse.JSONValue.GetValue<string>('error')); end; /// Так делаем отправку на конкретный URL /// Запрос логина (проверка существования пользователя) function TRestAPI.SendLogin(ABody: TApiLogin): TJSONValue; begin   RESTClient.BaseURL := BaseURL + '?act=users&area=login&response=js';   Result := Request(ABody); end; /// регистрация нового пользователя function TRestAPI.SendRegistry(ABody: TApiUser): TJSONValue; begin   RESTClient.BaseURL := BaseURL + '?act=terminal&area=create&registerType=2&response=js';   Result := Request(ABody); end; /// Информация о пользователе function TRestAPI.GetUserInfo(ABody: TApiInfo): TJSONValue; begin   RESTClient.BaseURL := BaseURL + '?act=terminal&area=info&infoType=2&response=js';   Result := Request(ABody); end; /// Изменить баланс пользователя function TRestAPI.SetBalance(ABody: TApiBalance): TJSONValue; begin   RESTClient.BaseURL := BaseURL + '?act=terminal&area=cash&response=js';   Result := Request(ABody); end; /// Это не обязательная функция, она просто упрощает работу. По сути просто вызывает нужную функцию, /// в зависимости от переданного объекта. после отправки запроса, удаляет объект из памяти. function TRestAPI.SendRequest(AObject: TApiObject; AOwn: Boolean): TJSONValue; begin   try     if (AObject is TApiLogin) then        Result := SendLogin(AObject as TApiLogin)     else     if (AObject is TApiUser) then        Result := SendRegistry(AObject as TApiUser)     else     if (AObject is TApiInfo) then        Result := GetUserInfo(AObject as TApiInfo)     else     if (AObject is TApiBalance) then        Result := SetBalance(AObject as TApiBalance)   finally     if AOwn and Assigned(AObject) then        FreeAndNil(AObject);   end; end; end. А работать с этим так:
    procedure DoLogin(const AUser, APassw: string); var Usr: TApiLogin; Jsn: TJsonObject; begin Usr := TApiLogin.Create; Usr.Login := AUser; Usr.Password := APassw; Jsn := RestAPI.SendRequest(Usr, True); end; Следует заметить, что все запросы возвращают json. Просто потому что мне так было нужно. Однако можно немного изменить функцию Request, что бы возвращался объект конкретного типа. 
×
×
  • Создать...