mmover

Пользователи
  • Публикаций

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

  • Посещение

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

    4

Весь контент mmover

  1. Я в свое время тоже над этим бился... Вот такая конструкция получилась (Delphi 10.2.3): unit Unit1; interface uses System.SysUtils, System.Types, System.UITypes, System.Classes, System.Variants, FMX.Types, FMX.Controls, FMX.Forms, FMX.Graphics, FMX.Dialogs, FMX.Objects, FMX.Platform.Win, FMX.Platform, Winapi.Windows, Winapi.Messages, FMX.Memo; type TForm1 = class(TForm) private type TShowAction = (saNone, saNormal, saMinimize, saMaximize); protected procedure CreateHandle; override; private AppIsActive : Boolean; FOldFMXWndProc : TFNWndProc; FNewFMXWndProc : Pointer; FShowAction: TShowAction; procedure FMXFormWndProc(var Msg: Winapi.Messages.TMessage); public { Public declarations } end; var Form1: TForm1; implementation {$R *.fmx} procedure TForm1.CreateHandle; var H : HWND; begin inherited CreateHandle; H := FormToHWND(Self); FOldFMXWndProc := TFNWndProc(GetWindowLong(H, GWL_WNDPROC)); FNewFMXWndProc := MakeObjectInstance(FMXFormWndProc); SetWindowLong(H, GWL_WNDPROC, NativeInt(FNewFMXWndProc)); end ; procedure TForm1.FMXFormWndProc(var Msg: Winapi.Messages.TMessage); begin case Msg.Msg of WM_SHOWWINDOW : begin case TWMShowWindow(Msg).Status of SW_PARENTCLOSING: if FShowAction = saNone then begin if IsIconic(FormToHWND(Self)) then FShowAction := saMinimize else if IsZoomed(FormToHWND(Self)) then FShowAction := saMaximize else FShowAction := saNormal; TThread.CurrentThread.ForceQueue(nil, procedure begin SendMessage(FormToHWND(Self),WM_SYSCOMMAND, SC_MINIMIZE,0); WindowState := TWindowState.wsMinimized; end); end; SW_PARENTOPENING: if FShowAction <> saNone then begin if FShowAction = saMaximize then WindowState := TWindowState.wsMaximized else if FShowAction = saNormal then WindowState := TWindowState.wsNormal; FShowAction := saNone; exit; end; end; end; WM_NCACTIVATE : begin if (Msg.WParam = 0) then Msg.WParam := Byte(AppIsActive); end; end; Msg.Result := CallWindowProc(FOldFMXWndProc, FormToHWND(Self), Msg.Msg, Msg.WParam, Msg.LParam); case Msg.Msg of WM_ACTIVATEAPP : begin AppIsActive := Msg.WParam = 1 ; end ; end; end; end.
  2. Можно перехватить событие изменения позиции. Только обязательно нужно сохранить предыдущий обработчик для его принудительного вызова. Вот грубый пример : var SavePositionOnChange : TNotifyEvent; procedure TForm2.FormShow(Sender: TObject); begin SavePositionOnChange := Button4.Position.OnChange ; Button4.Position.OnChange := ButtonPositionChange; end; procedure TForm2.ButtonPositionChange(Sender: TObject); begin { делаем что нужно .... } if Assigned(SavePositionOnChange) then SavePositionOnChange(Sender) end;
  3. Пришел на ум такой вариант : procedure TForm2.FormShow(Sender: TObject); var i : Integer; B : TButton ; begin ScrollBox1.BeginUpdate; for i := 1 to 10 do begin B := TButton.Create(Self) ; B.Parent := ScrollBox1; B.Height := 50; B.Align := TAlignLayout.Top ; B.Tag := Random(50); B.Text := 'Button '+IntToStr(B.Tag); end; ScrollBox1.EndUpdate; end; procedure TForm2.ButtonSortClick(Sender: TObject); var L : TList<Tcontrol>; i : Integer; begin L := TList<Tcontrol>.Create; for i := 0 to ScrollBox1.Content.ControlsCount-1 do L.Add(ScrollBox1.Content.Controls[i]); L.Sort(TComparer<TControl>.Construct( function(const Left, Right: TControl) : Integer begin Result := CompareValue(Left.Tag,Right.Tag); end)); for i := 0 to L.Count-1 do begin L[i].Align := TAlignLayout.None; L[i].Position.Y := i* L[i].Height; L[i].Align := TAlignLayout.Top; end; ScrollBox1.RealignContent; L.Free; end;
  4. Судя по картинкам, вот эта библиотека умеет : https://github.com/Zeus64/alcinoe
  5. mmover

    HueTrackBar

    procedure TForm2.HueTrackBar1Change(Sender: TObject); begin Rectangle1.Fill.Color := HSLtoRGB(HueTrackBar1.Value,1,0.5); end;
  6. В стиле подправить координаты для SourceLink (уменьшить прямоугольник, что бы в него не попадала рамка)
  7. mmover

    Свои кнопки в заголовке окна

    Примерно так : MyCaptionButton.StylesData['ButtonStyle.OnClick'] := TValue.From<TNotifyEvent>(ButtonClick);
  8. mmover

    ListBox1.ScrollToItem(Item);

    Попробуйте так : procedure TForm1.Process; Const N=100; var I,Index:Integer; Item:TListBoxItem; begin for I := 1 to N do begin Item:=TListBoxItem.Create(ListBox1); Item.Text:=IntToStr(I); ListBox1.AddObject(Item); end; ListBox1.ApplyStyleLookup; // (создаст ContentLayout) ListBox1.ScrollToItem(Item); end;
  9. Меняется с помощью стиля. Например: procedure TForm2.Button1Click(Sender: TObject); begin ComboBox1.ListBox.DefaultItemStyles.ItemStyle := 'ListBoxItemMyStyle' ; ComboBox1.NeedStyleLookup; end;
  10. У TMS есть компонент с похожим функционалом - TTMSFMXHotSpotImage. На картинку накладываются произвольные регионы с возможностью обработки событий.
  11. type THackCustomComboBox = class(TCustomComboBox) public property Popup; end; ...... begin THackCustomComboBox(ComboBox1).Popup.IsOpen := False; end;
  12. Может быть эта информация поможет : http://riversoftavg.com/blogs/index.php/2016/01/17/colorful-text-with-fmx/
  13. mmover

    Ручная анимация прокрутки списка

    Вот, накидал класс который может помочь. unit UAnimHelper; interface uses System.Classes, System.SysUtils, FMX.Types; type TAnimateStep = reference to procedure(Value : Single); TAnimateHelper = class private type TAniInst = class(TFmxObject) private FValue : Single; FStepProc : TAnimateStep; FStopProc : TProc; procedure SetValue(Value : Single); procedure DoAniFinished(Sender: TObject); public constructor Create(AStepProc : TAnimateStep; AStopProc : TProc); published property Value : Single read FValue write SetValue; end; public class procedure DoAnimate(Root : IRoot; // без указания формы анимация работать не будет Duration, FromValue, ToValue : Single; AType: TAnimationType; AInterpolation: TInterpolationType; StepProc : TAnimateStep; StopProc : TProc = nil); end; implementation uses FMX.Ani; constructor TAnimateHelper.TAniInst.Create(AStepProc : TAnimateStep; AStopProc : TProc); begin inherited Create(nil); FStepProc := AStepProc; FStopProc := AStopProc; end; procedure TAnimateHelper.TAniInst.SetValue(Value : Single); begin if Assigned(FStepProc) then FStepProc(Value); end; procedure TAnimateHelper.TAniInst.DoAniFinished(Sender: TObject); begin if Assigned(FStopProc) then FStopProc(); TThread.ForceQueue(nil, procedure begin TAnimation(Sender).TagObject.DisposeOf; end); end; class procedure TAnimateHelper.DoAnimate(Root : IRoot; Duration, FromValue, ToValue : Single; AType: TAnimationType; AInterpolation: TInterpolationType; StepProc : TAnimateStep; StopProc : TProc = nil); var AniInst : TAniInst; Animation: TFloatAnimation; begin AniInst := TAniInst.Create(StepProc,StopProc); AniInst.FValue := FromValue; Animation := TFloatAnimation.Create(nil); Animation.TagObject := AniInst; Animation.Parent := AniInst; Animation.SetRoot(Root); Animation.AnimationType := AType; Animation.Interpolation := AInterpolation; Animation.OnFinish := AniInst.DoAniFinished; Animation.Duration := Duration; Animation.PropertyName := 'Value'; Animation.StartFromCurrent := True; Animation.StopValue := ToValue; Animation.Start; end; end. Пример использования : procedure TForm1.Button3Click(Sender: TObject); begin TAnimateHelper.DoAnimate(Self, 1.2, ListBox1.ViewportPosition.Y , 400, TAnimationType.&In, TInterpolationType.Circular, procedure(Value : Single) begin ListBox1.ViewportPosition := PointF(0,Value); end); end;
  14. mmover

    Окончание скроллинга в ListBox

    Стандартным способом никак (или я плохо искал) Получилось не очень, но работает. (на форме только два ListBox-а) ......... type THackListBox = class(TListBox) public property VScrollBar; end; THackScrollBar = class(TScrollBar) public property Track; end; procedure TForm1.FormShow(Sender: TObject); var i : Integer ; begin for i := 0 to 50 do ListBox1.Items.Add('Item '+ IntToStr(i)); for i := 0 to 50 do ListBox2.Items.Add('Item '+ IntToStr(i)); ListBox1.OnVScrollChange := ListBoxVScrollChange; ListBox2.OnVScrollChange := ListBoxVScrollChange; end; procedure TForm1.EndScrollListBox(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Single); var ListB : TCustomListBox; C : TFmxObject; begin if Sender is TThumb then if TThumb(Sender).IsPressed then begin ListB := nil; C := TFmxObject(Sender); while C <> nil do begin C := C.Parent; if (C <> nil) and (C is TCustomListBox) then begin ListB := C as TCustomListBox; break; end; end; if ListB <> nil then ShowMessage('End tracking scroll Listbox. Name : '+ ListB.Name); end; end; procedure TForm1.ListBoxVScrollChange(Sender: TObject); begin if Sender is TListBox then if not Assigned(THackScrollBar(THackListBox(Sender).VScrollBar).Track.Thumb.OnMouseUp) then THackScrollBar(THackListBox(Sender).VScrollBar).Track.Thumb.OnMouseUp := EndScrollListBox; end;
  15. mmover

    Узнать дату Android приложения

    Как то так : .... var PackageInfo: JPackageInfo; PackageManager: JPackageManager; Activity: JActivity; begin Activity := TJNativeActivity.Wrap(PANativeActivity(System.DelphiActivity)^.clazz); PackageManager := Activity.getPackageManager; PackageInfo := PackageManager.getPackageInfo(Activity.getPackageName, TJPackageManager.JavaClass.GET_CONFIGURATIONS); Result := PackageInfo.lastUpdateTime; end;
  16. mmover

    Memory TreeView

    Самое простое : https://github.com/davidberneda/GenericTree Сам не пробовал, но давно использую похожую конструкцию.
  17. Примерно так: interface uses System.SysUtils, System.Types, System.UITypes, System.Classes, System.Variants, FMX.Types, FMX.Controls, FMX.Forms, FMX.Graphics; type TMyLabel = class(TControl) private FFontTextSettingInfo: TTextSettingsInfo; function GetTextSettings: TTextSettings; procedure SetTextSettings(const Value: TTextSettings); public constructor Create(AOwner: TComponent); override; destructor Destroy; override; published property LabelFont: TTextSettings read GetTextSettings write SetTextSettings; end; implementation type TMyTextSettings = class (TTextSettingsInfo.TCustomTextSettings) public constructor Create(const AOwner: TPersistent); override; published property Font; property FontColor; property HorzAlign; property VertAlign; // можно убрать ненужные свойства // property WordWrap default True; // property Trimming default TTextTrimming.Character; end; constructor TMyTextSettings.Create(const AOwner: TPersistent); begin inherited; WordWrap := False; Trimming := TTextTrimming.Character; end; constructor TMyLabel.Create(AOwner: TComponent); begin inherited Create(AOwner); FFontTextSettingInfo := TTextSettingsInfo.Create(Self,TMyTextSettings); // FFontTextSettingInfo.TextSettings.FontColor := TAlphaColors.Black; // FFontTextSettingInfo.TextSettings.OnChanged := FontChanged; end; destructor TMyLabel.Destroy; begin FFontTextSettingInfo.Free; inherited Destroy; end; function TMyLabel.GetTextSettings: TTextSettings; begin Result := FFontTextSettingInfo.TextSettings; end; procedure TMyLabel.SetTextSettings(const Value: TTextSettings); begin FFontTextSettingInfo.TextSettings.Assign(Value); end; end.
  18. Я делал так : ... Filt := TBitmapCodecManager.GetFileTypes; FiltExt := TDictionary<string,boolean>.Create; A := Filt.Split([';']); for i := 0 to High(A) do FiltExt.AddOrSetValue(String.LowerCase(A[i].Remove(0,1)),False); ... Files := TDirectory.GetFiles(IncludeTrailingPathDelimiter(DirName),'*.*', function(const Path: string; const SearchRec: TSearchRec): Boolean var SR: TSearchRec; S : String; begin S := String.LowerCase(TPath.GetExtension(SearchRec.Name)); Result := FiltExt.ContainsKey(S); if Result then begin SR := SearchRec; SR.Name := Path + SR.Name; FCurrentDirectoryFiles.Add(SR); end; end); ...