Wednesday, May 19, 2021

Firemonkey 3D Globe Example.

Delphi 10.4.2
Compiles for Windows, OSX, Android, IOS, FMXLinux


Here is an example of a Firemonkey 3D app. It shows the earth lit by sunlight at current time.
On the dark side it shows the city lights.
Earth can be rotated and zoomed.

It uses two spheres with bitmap textures, one for the lighted globe and one for the city lights. The bitmap for city lights is masked off for only the lights on the dark side.

Download the source code here:
https://i-logic.com/ftp/GlobalView.zip

Friday, May 8, 2020

More Accurate Sleep Function on Windows

Delphi 10.3.3


You may want to use the sleep function for slowing or pacing a repeating action. But you are going to have problems if you need sleeps less than 20 milliseconds.

The normal minimum time period for the sleep function is 20 milliseconds. That means if you use Sleep(1) trying to set it for 1 millisecond it will actually sleep for 20 milliseconds.

But there is a Windows function that increases the resolution of timers.
 
You have to turn it on with
timeBeginPeriod(minimum millisecond resolution);

timeBeginPeriod(1)
will set the minimum timer resolution to 1 millisecond
 
And turn it off (go back to default) with
timeEndPeriod(minimum millisecond resolution);
Call it with the same value you called begin with.

Contained in Unit  Winapi.MmSystem.

For Windows XP and newer.
This is a global Windows OS function. It will give the higher resolution timing to all running Windows processes. That’s why you would want to turn it off after you don’t need it anymore.

Microsoft says setting a higher resolution can improve the accuracy of time-out intervals in wait functions. However, it can also reduce overall system performance, because the thread scheduler switches tasks more often. High resolutions can also prevent the CPU power management system from entering power-saving modes.


Example Delphi app:

 
unit MainUnit;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls;

type
  TMainForm = class(TForm)
    Memo1: TMemo;
    Memo2: TMemo;
    Button1: TButton;
    Button2: TButton;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  MainForm: TMainForm;

implementation

{$R *.dfm}
uses
  math,Winapi.MmSystem;

procedure TMainForm.Button1Click(Sender: TObject);
var
  I, x: Integer;
  s: string;
  K: Integer;
begin
  memo1.Clear;
  Application.ProcessMessages; // to clear the memo
  for K := 1 to 25 do
  begin
    s := '';
    for I := 1 to 25 do
    begin
      x := randomrange(33, 57);
      s := s + char(x);
      sleep(1);
    end;
    memo1.Lines.Add(s);
  end;
end;

procedure TMainForm.Button2Click(Sender: TObject);
var
  I, x: Integer;
  s: string;
  K: Integer;
begin
  memo2.Clear;
  Application.ProcessMessages; // to clear the memo
  TimeBeginPeriod(1);
  for K := 1 to 25 do
  begin
    s := '';
    for I := 1 to 25 do
    begin
      x := randomrange(33, 57);
      s := s + char(x);
      sleep(1);
    end;
    memo2.Lines.Add(s);
  end;
  TimeEndPeriod(1);
end;

end.
 
*****************************************
DFM file:

object MainForm: TMainForm
  Left = 0
  Top = 0
  BorderStyle = bsSingle
  Caption = 'Fast Sleep'
  ClientHeight = 309
  ClientWidth = 532
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'Tahoma'
  Font.Style = []
  OldCreateOrder = False
  PixelsPerInch = 96
  TextHeight = 13
  object Memo1: TMemo
    Left = 8
    Top = 55
    Width = 249
    Height = 242
    Font.Charset = DEFAULT_CHARSET
    Font.Color = clWindowText
    Font.Height = -11
    Font.Name = 'Courier New'
    Font.Style = []
    ParentFont = False
    TabOrder = 0
  end
  object Memo2: TMemo
    Left = 276
    Top = 55
    Width = 245
    Height = 242
    Font.Charset = DEFAULT_CHARSET
    Font.Color = clWindowText
    Font.Height = -11
    Font.Name = 'Courier New'
    Font.Style = []
    ParentFont = False
    TabOrder = 1
  end
  object Button1: TButton
    Left = 92
    Top = 16
    Width = 75
    Height = 25
    Caption = 'Normal'
    TabOrder = 2
    OnClick = Button1Click
  end
  object Button2: TButton
    Left = 372
    Top = 16
    Width = 75
    Height = 25
    Caption = 'Fast'
    TabOrder = 3
    OnClick = Button2Click
  end
end

Download Source files:

Thursday, April 30, 2020

TAniIndicator - How to make it work

Delphi 10.3.3

Many want to use a busy indicator to show the user there is a non visible process in operation. Usually when Delphi programmers try this the first time they notice the TAniIndicator doesn't rotate when they want it to. The problem is that the background process is in the same main form thread as the AniIndicator, which stops the AniIndicator from visibly moving.

In this example we download a file from the internet in the background while the Delphi TAniIndicator component is busy rotating.

The main issue is that the AniIndicator needs to be running in the main form thread and whatever long process you are doing in the background has to be running in another created thread. It wont work the other way around.

You can download the example code below. This example works the same on Windows, Android, IOS and MacOS.







unit MainUnit;

interface

uses
  System.Types, System.Classes, FMX.Types, FMX.Controls, FMX.Forms, FMX.Graphics, FMX.Dialogs, FMX.StdCtrls,
  FMX.Layouts, System.Net.HttpClient, System.Net.HttpClientComponent, System.Net.URLClient,
  FMX.Controls.Presentation, FMX.Objects;

type
  TMainform = class(TForm)
    LoadButton: TButton;
    AniIndicator1: TAniIndicator;
    Layout1: TLayout;
    Layout2: TLayout;
    Layout3: TLayout;
    Image1: TImage;
    NetHTTPClient1: TNetHTTPClient;
    Layout4: TLayout;
    ClearImageButton: TButton;
    procedure LoadButtonClick(Sender: TObject);
    procedure ClearImageButtonClick(Sender: TObject);
  private
    { Private declarations }
    procedure load_from_internet;
  public
    { Public declarations }
  end;

var
  Mainform: TMainform;

implementation

{$R *.fmx}
uses
  System.threading, system.uitypes;

procedure TMainform.ClearImageButtonClick(Sender: TObject);
begin
  Image1.Bitmap.Clear(TAlphaColorRec.White);
end;

procedure TMainform.load_from_internet;
var
  Task: ITask;
  url: string;
begin

// turn on ani indicator
  mainform.AniIndicator1.Enabled := True;
  mainform.AniIndicator1.Visible := True;

  Task := TTask.Create(
    procedure
    var
      ms: tmemorystream;
      resp: IHTTPResponse;
    begin
      // ***** do what you need to do in the thread 

      // while the aniindicator is running **********
      NetHTTPClient1.UserAgent := 'Mozilla/5.0+(Windows+NT+10.0;+Win64;+x64;+rv:75.0)+Gecko/20100101+Firefox/75.0';
      ms := tmemorystream.Create;
     // some image file on internet
      url := 'https://www.i-logic.com/kitten.jpg';
      try
        resp := NetHTTPClient1.Get(url, ms);

        if TTask.CurrentTask.Status <> TTaskStatus.Canceled then
        begin
          TThread.Queue(TThread.CurrentThread,
            procedure
            begin
              // ****** this is where it comes when the

              // thread is finished *************
              // we can work with the visual form components
              ms.Position := 0;
              // put the data into image1
              try
               if resp.StatusCode = 200 then  // file was found
                  image1.Bitmap.LoadFromStream(ms);
              finally
                ms.Free;
               // turn off aniindicator
                mainform.AniIndicator1.Enabled := False;
                mainform.AniIndicator1.Visible := False;
              end;
            end);
        end;
      except
       // ****** error in get url *************
        TThread.Queue(TThread.CurrentThread,
          procedure
          begin
            ms.Free;
            // turn off aniindicator
            mainform.AniIndicator1.Enabled := False;
            mainform.AniIndicator1.Visible := False;
          end);
      end;
    end);

  Task.Start;
end;

procedure TMainform.LoadButtonClick(Sender: TObject);
begin
  load_from_internet;
end;

end.



**********************************************


The mainunit FMX file:


object Mainform: TMainform
  Left = 0
  Top = 0
  Caption = 'AniIndicator'
  ClientHeight = 480
  ClientWidth = 258
  FormFactor.Width = 320
  FormFactor.Height = 480
  FormFactor.Devices = [Desktop]
  DesignerMasterStyle = 0
  object Layout1: TLayout
    Align = Top
    Size.Width = 258.000000000000000000
    Size.Height = 73.000000000000000000
    Size.PlatformDefault = False
    TabOrder = 1
    object LoadButton: TButton
      Align = Center
      Size.Width = 195.000000000000000000
      Size.Height = 35.000000000000000000
      Size.PlatformDefault = False
      TabOrder = 0
      Text = 'Load From Internet'
      OnClick = LoadButtonClick
    end
  end
  object Layout2: TLayout
    Align = Top
    Position.Y = 73.000000000000000000
    Size.Width = 258.000000000000000000
    Size.Height = 76.000000000000000000
    Size.PlatformDefault = False
    TabOrder = 2
    object AniIndicator1: TAniIndicator
      Align = Center
      Size.Width = 81.000000000000000000
      Size.Height = 68.000000000000000000
      Size.PlatformDefault = False
    end
  end
  object Layout3: TLayout
    Align = Top
    Position.Y = 149.000000000000000000
    Size.Width = 258.000000000000000000
    Size.Height = 156.000000000000000000
    Size.PlatformDefault = False
    TabOrder = 3
    object Image1: TImage
      MultiResBitmap = <
        item
        end>
      Align = Center
      Size.Width = 185.000000000000000000
      Size.Height = 117.000000000000000000
      Size.PlatformDefault = False
    end
  end
  object Layout4: TLayout
    Align = Top
    Position.Y = 305.000000000000000000
    Size.Width = 258.000000000000000000
    Size.Height = 80.000000000000000000
    Size.PlatformDefault = False
    TabOrder = 5
    object ClearImageButton: TButton
      Align = Center
      Size.Width = 124.000000000000000000
      Size.Height = 32.000000000000000000
      Size.PlatformDefault = False
      TabOrder = 0
      Text = 'Clear Image'
      OnClick = ClearImageButtonClick
    end
  end
  object NetHTTPClient1: TNetHTTPClient
    Asynchronous = False
    ConnectionTimeout = 60000
    ResponseTimeout = 60000
    HandleRedirects = True
    AllowCookies = True
    UserAgent = 'Embarcadero URI Client/1.0'
    Left = 92
    Top = 200
  end
end


**************************************
Source Code:
https://i-logic.com/ftp/AniInicatorCode.zip

Thursday, September 17, 2015

Dragging Rectangles on Firemonkey Form

Delphi DX10 

For the perennial question of how to move objects around the form at run time, here is a method for dragging Rectangles (or any shapes) around on the form with the mouse or touch.

Considerations:

We need a Layout in the background to use as a coordinate system that can be turned on and off. 

We need to set Rectangle.Hittest:= true so we can pick it.

We need to set Layout.Hittest := false to start with or it will interfere with picking the rectangles.

When we pick a rectangle, we need to capture the mouse events of the Layout so we can use the coordinates MouseMove and MouseUp to stop. We will do this with Layout1.Root.Captured := Layout1;

Use the Layout X,Y MouseMove coordinates to move rectangle.

Use Layout MouseUp event to end dragging. Layout mouse capture is turned off and we can pick the next rectangle.


unit File: Mainunit.pas

unit Mainunit;

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.Layouts, FMX.Controls.Presentation, FMX.StdCtrls;

type
  TMainForm = class(TForm)
    Layout1: TLayout;
    Rectangle1: TRectangle;
    procedure Rectangle1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Single);
    procedure Layout1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Single);
    procedure Layout1MouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Single);
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  MainForm: TMainForm;

implementation


{$R *.fmx}

const
  MAX_RECTANGLES = 10;
  RECT_WIDTH = 80;
  RECT_HEIGHT = 80;

var
  Grab: boolean = false;
  Offset: tpointf;
  MovingRectangle: TRectangle;
  RectArray: array [0 .. MAX_RECTANGLES] of TRectangle;

procedure TMainForm.FormCreate(Sender: TObject);
var
  I: integer;
  TitleRect: TRectangle;
  TitleLabel: TLabel;
begin
  Layout1.HitTest := false; // want to pick rectangles
  for I := Low(RectArray) to high(RectArray) do
  begin
    RectArray[I] := TRectangle.Create(self);
    RectArray[I].Parent := Layout1;
    RectArray[I].OnMouseDown := Rectangle1MouseDown;
    RectArray[I].OnMouseUp := Layout1MouseUp;
    RectArray[I].Width := RECT_WIDTH;
    RectArray[I].Height := RECT_HEIGHT;
    RectArray[I].fill.Color := random($FFFFFF) or $FF000000;
    RectArray[I].Position.X := random(trunc(Layout1.Width - RECT_WIDTH));
    RectArray[I].Position.Y := random(trunc(Layout1.Height - RECT_HEIGHT));

    TitleRect := TRectangle.Create(self);
    TitleRect.fill.Color := Talphacolorrec.White;
    TitleRect.Position.X := 0;
    TitleRect.Position.Y := 0;
    TitleRect.Width := RECT_WIDTH;
    TitleRect.Height := 16;
    TitleRect.HitTest := false;

    TitleLabel := TLabel.Create(self);
    TitleLabel.StyledSettings:=[];
    TitleLabel.Font.Size:=12;
    TitleLabel.Text := 'Caption ' + I.ToString;
    TitleRect.AddObject(TitleLabel);

    RectArray[I].AddObject(TitleRect);
  end;
end;

procedure TMainForm.Layout1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Single);
begin
  if Grab and (ssleft in Shift) then
  begin
    // keep from dragging off Layout
    if X > (Layout1.Width + Offset.X - RECT_WIDTH) then
      X := Layout1.Width + Offset.X - RECT_WIDTH;
    if Y > (Layout1.Height + Offset.Y - RECT_HEIGHT) then
      Y := Layout1.Height + Offset.Y - RECT_HEIGHT;
    if X < Offset.X then
      X := Offset.X;
    if Y < Offset.Y then
      Y := Offset.Y;

    MovingRectangle.Position.X := X - Offset.X;
    MovingRectangle.Position.Y := Y - Offset.Y;
  end;
end;

procedure TMainForm.Layout1MouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Single);
begin
  Grab := false;
  // MouseUp automatically turns off mouse capture of Layout1
end;

procedure TMainForm.Rectangle1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState;
  X, Y: Single);
begin
  MovingRectangle := Sender as TRectangle;
  Offset.X := X;
  Offset.Y := Y;
  // sets mouse capture to Layout1
  Layout1.Root.Captured := Layout1;
  MovingRectangle.BringToFront; // optional
  MovingRectangle.Repaint;
  Grab := true;
end;

end.



FMX File: Mainunit.FMX

object MainForm: TMainForm
  Left = 0
  Top = 0
  BorderIcons = [biSystemMenu, biMinimize]
  BorderStyle = Single
  Caption = 'Form33'
  ClientHeight = 480
  ClientWidth = 640
  FormFactor.Width = 320
  FormFactor.Height = 480
  FormFactor.Devices = [Desktop]
  OnCreate = FormCreate
  OnDestroy = FormDestroy
  DesignerMasterStyle = 0
  object Layout1: TLayout
    Anchors = [akLeft, akTop, akRight, akBottom]
    HitTest =
False    
    Position.X = 30.000000000000000000
    Position.Y = 30.000000000000000000
    Size.Width = 579.000000000000000000
    Size.Height = 421.000000000000000000
    Size.PlatformDefault = False
    TabOrder = 0
    OnMouseMove = Layout1MouseMove
    OnMouseUp = Layout1MouseUp
    object Rectangle1: TRectangle
      Align = Client
      Fill.Color = claAntiquewhite
      HitTest = False
      Size.Width = 579.000000000000000000
      Size.Height = 421.000000000000000000
      Size.PlatformDefault = False
    end
  end
end



DPR File:
program DragRectangles;

uses
  System.StartUpCopy,
  FMX.Forms,
  Mainunit in 'Mainunit.pas' {MainForm};

{$R *.res}

begin
  ReportMemoryLeaksOnShutdown := DebugHook <> 0;
  Application.Initialize;
  Application.CreateForm(TMainForm, MainForm);
  Application.Run;
end.


Works in Windows, OSX, IOS, Android

Download DX10 Source code: DragRectangles.zip

Form Shown on Screens:



You can test when the rectangle you are moving lands on top of another one.
Just replace the TMainForm.Layout1MouseUp procedure with this one:

procedure TMainForm.Layout1MouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Single);
var
  I: integer;
  BottomRectangle: TRectangle;

  function PointInRect(X, Y { top rect corner coords in layout1 } : Single; BotRect: TRectangle): boolean;
  begin
    if (X >= BotRect.Position.X) and (X <= (BotRect.Position.X + BotRect.Width)) and (Y >= BotRect.Position.Y)
      and (Y <= BotRect.Position.Y + BotRect.Height) then
      result := true
    else
      result := false;
  end;

  function RectangleOnTop(TopRect, BotRect: TRectangle): boolean;
  var
    X1, Y1, X2, Y2, X3, Y3, X4, Y4: Single;
  begin
    // 4 corners
    // 1-------2
    // 3-------4
    result := false;
    X1 := TopRect.Position.X; // these are the four corners according in layout1 coords
    Y1 := TopRect.Position.Y; // of the top moving rect
    X2 := X1 + TopRect.Width;
    Y2 := Y1;
    X3 := X1;
    Y3 := Y1 + TopRect.Height;
    X4 := X2;
    Y4 := Y3;

    // check 4 corners of top rect
    if PointInRect(X1, Y1, BotRect) or PointInRect(X2, Y2, BotRect) or PointInRect(X3, Y3, BotRect) or
      PointInRect(X4, Y4, BotRect) then
      result := true;
  end;

begin
  Grab := false;
  // MouseUp automatically turns off mouse capture of Layout1

  // check to see if over another rectangle
  for I := Low(RectArray) to high(RectArray) do
  begin
    if MovingRectangle <> RectArray[I] then
    begin
      if RectangleOnTop(MovingRectangle, RectArray[I]) then
      begin
        BottomRectangle := RectArray[I];
        beep;
        showmessage('Over Rect ' + TLabel(BottomRectangle.Children.Items[0].Children.Items[0]).Text);
        break;
      end;
    end;
  end;
end;

 

Wednesday, December 17, 2014

Using Custom Fonts in Android - Delphi

Android

For XE7  to 10.2.1 Tokyo

 You should be able to use any True Type Font in an android app.

Example using the font Script MT Bold. This font is in the Windows Font Folder. The font file name is SCRIPTBL.TTF.

1. copy SCRIPTBL.TTF to the project folder.
2. In Deployment window, add SCRIPTBL.TTF file. Set Remote Path to .\assets\internal\
Set Remote Name to .SCRIPTBL.ttf (make the ttf extension lower case so we can hard code it into the program)



3. Load FMX.FontGlyphs.Android.pas into the editor. ( the file is in C:\Program Files (x86)\Embarcadero\Studio\15.0\source\fmx)
If it is read only, right click in editor and turn off Read-Only.
Save the file to the project folder. Don't change the file name. Then you can edit it in the Delphi editor.
  A. Add System.IOUtils to the uses clause.
  B. Go to procedure TAndroidFontGlyphManager.LoadResource;
  • Add a var FontFile: string;
  • There is a line in the procedure that says:Typeface := TJTypeface.JavaClass.create(FamilyName, TypefaceFlag);
  • Replace that line with:
 FontFile := TPath.GetDocumentsPath + PathDelim + CurrentSettings.Family + '.ttf';
 if FileExists(FontFile) then
   Typeface := TJTypeface.JavaClass.createFromFile(StringToJString(FontFile))
   else
     Typeface := TJTypeface.JavaClass.Create(FamilyName, TypefaceFlag); 
This will make it look for a font file by that name first.

4. For each component you want to use this font on, set the TextSettings Font Family property to SCRIPTBL
This is the name of the font file without the file extension. Don't put "SCRIPTBL.ttf" and don't put "Script MT Bold".
You will have to type or paste it in to the property box.

Note: filenames in Android are case sensitive, so you have to get them all the same.

This is a form with label, textbox, memo, checkbox, radio button:
Note: an easier idea for the filename is:
If the font family name is not the same as the file name of the font, you can just make a copy of the font file and rename it to the Font FamilyName and use that. Then the font will show up at both design time and runtime.
 

How to Use Custom Fonts in IOS - Delphi


IOS

XE7

You should be able to use any True Type Font in your IOS app.

Example using the font Script MT Bold. This font is in the Windows Font Folder. The font file name is SCRIPTBL.TTF.

1. Copy SCRIPTBL.TTF to the project folder.
2. Compile the app for IOS so that it makes an info.plist file in the debug folder.
3. Open the info.plist file in the Delphi editor. Save it as custom.info.plist in the project folder.
Add another key in it:
 <key>UIAppFonts</key>
 <array>
 <string>SCRIPTBL.TTF</string>
 </array>

This tells IOS to be able to use the additional font file. IOS will automatically look for it in the bundle.

4. In the Deployment page, add SCRIPTBL.TTF with Remote Path of .\



5. Add your custom plist file with Remote Name of info.plist



6. Uncheck the deployment of the old info.plist



This will substitute the info plist with your font info in it.

For each component, set the TextSettins Font Family property to Script MT Bold. Since this font is already installed in Windows, you can choose it off the dropdown list.

This is a form with label, textbox, memo, checkbox, radio button.