Delphi 7 - PNG Image isn't showing - image

I am using Delphi 7 Pro. I have installed the PNG Component in my project, but whenever I load a PNG image into the Image1 component, the application starts but its main form is invisible. If I load a JPEG or a bitmap file, the form is shown. Here's the code I'm using in my form constructor:
procedure TFMain.FormCreate(Sender: TObject);
var
regn, tmpRegn, x, y: integer;
nullClr: TColor;
Settings: TInifile;
begin
FMain.Brush.Bitmap := Image1.Picture.Bitmap;
nullClr := Image1.Picture.Bitmap.Canvas.Pixels[0, 0];
regn := CreateRectRgn(0, 0, Image1.Picture.Graphic.Width, Image1.Picture.Graphic.Height);
for x := 1 to Image1.Picture.Graphic.Width do
for y := 1 to Image1.Picture.Graphic.Height do
if Image1.Picture.Bitmap.Canvas.Pixels[x - 1, y - 1] = nullClr then
begin
tmpRegn := CreateRectRgn(x - 1, y - 1, x, y);
CombineRgn(regn, regn, tmpRegn, RGN_DIFF);
DeleteObject(tmpRegn);
end;
SetWindowRgn(FMain.Handle, regn, True);
end;
Why is this happening ? What should I change so I can use PNG image in my Image1 ?
The whole code:
unit UnitMain;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, Gauges, Buttons, IniFiles, StdCtrls, OleCtrls, SHDocVw, ExtCtrls,
Wininet, ImgBtn, ComCtrls, ShlObj, ComObj, ActiveX, jpeg;
type
TFMain = class(TForm)
Gauge1: TGauge;
Gauge2: TGauge;
Image1: TImage;
Label1: TLabel;
Label2: TLabel;
Label3: TLabel;
ImgBtn1: TImgBtn;
ImgBtn2: TImgBtn;
ImgBtn3: TImgBtn;
ImgBtn4: TImgBtn;
Panel1: TPanel;
WebBrowser1: TWebBrowser;
Image2: TImage;
Image3: TImage;
Image4: TImage;
Label4: TLabel;
ImgBtn5: TImgBtn;
Timer1: TTimer;
procedure FormCreate(Sender: TObject);
procedure FormMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
procedure FormMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
procedure ImgBtn4Click(Sender: TObject);
procedure ImgBtn3Click(Sender: TObject);
procedure ImgBtn2Click(Sender: TObject);
procedure ImgBtn1Click(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure ImgBtn5Click(Sender: TObject);
procedure WebBrowser1NavigateComplete2(Sender: TObject; const pDisp: IDispatch; var URL: OleVariant);
procedure Timer1Timer(Sender: TObject);
procedure UpdateRevision(Rev: string);
private
{ Private declarations }
public
Draging: Boolean;
X0, Y0: integer;
end;
var
FMain: TFMain;
USettings : TStrings;
implementation
uses
Frm2, GetFilesThr, Misc;
{$R *.dfm}
procedure TFmain.UpdateRevision(Rev: string);
var
Settings: TInifile;
begin
Settings := TInifile.Create(USettings[0] + '_settings.ini');
Settings.WriteString('main', 'AtRevision', Rev);
Settings.Free;
end;
function LoadSettings(): bool;
var
Settings: TInifile;
begin
Result := False;
USettings := TStringlist.Create;
USettings.Add(GetCurrentDir + '\');
if(FileExists(USettings[0] + '_settings.ini')) then
begin
Settings := TInifile.Create(USettings[0] + '_settings.ini');
USettings.Add(Settings.ReadString('main', 'NewsUrl', ''));
USettings.Add(Settings.ReadString('main', 'UpdatesUrl', ''));
USettings.Add(Settings.ReadString('main', 'LinkName', 'Lineage II'));
USettings.Add(Settings.ReadString('main', 'Installed', '0'));
USettings.Add(Settings.ReadString('main', 'CreateBackup', '0'));
USettings.Add(Settings.ReadString('main', 'AtRevision', '0'));
USettings.Add(Settings.ReadString('main', 'RunCustom', 'system\l2.exe'));
Settings.Free;
Result := True;
end
end;
// ρξηδΰες πλϋκ νΰ ρεα νΰ πΰαξχεμ ρςξλε
procedure CreateDesktopIcon(ilname, WorkDir, desc : string);
var
IObj: IUnknown;
SLink: IShellLink;
PFile: IPersistFile;
desk: string;
lnkpath: WideString;
begin
if(ilname <> '') then
begin
SetLength(desk, MAX_PATH + 1);
SHGetSpecialFolderPath(0, PAnsiChar(desk), CSIDL_DESKTOPDIRECTORY, False);
lnkpath:= PChar(desk) + '\' + ilname + '.lnk';
IObj := CreateComObject(CLSID_ShellLink);
SLink := IObj as IShellLink;
PFile := IObj as IPersistFile;
with SLink do
begin
SetDescription(PChar(desc));
SetPath(PChar(Application.ExeName));
SetWorkingDirectory(PAnsiChar(WorkDir));
end;
PFile.Save(PWChar(WideString(lnkpath)), FALSE);
end;
end;
procedure TFMain.FormCreate(Sender: TObject);
var
regn, tmpRegn, x, y: integer;
nullClr: TColor;
s_load: bool;
Settings: TInifile;
begin
s_load := LoadSettings();
if (s_load) then
begin
if (USettings[4] = '0') then
begin
Settings := TInifile.Create(USettings[0] + '_settings.ini');
Settings.WriteString('main','Installed', '1');
Settings.Free;
CreateDesktopIcon(USettings[3], USettings[0], 'Play Lineage II');
end;
end
else
begin
FMain.Timer1.Enabled := False;
ShowMessage('ERROR: _settings.ini Not Found !');
Application.Terminate; // .close ηδερό νε οπξιδες
end;
// Νΰβξδθμ κπΰρθβξρςό νΰ τξπμσ ...
FMain.brush.bitmap := Image1.picture.bitmap;
nullClr := image1.picture.Bitmap.Canvas.Pixels[0, 0];
regn := CreateRectRgn(0, 0, image1.picture.Graphic.Width, image1.picture.Graphic.Height);
for x := 1 to image1.picture.Graphic.Width do
for y := 1 to image1.picture.Graphic.Height do
if image1.picture.Bitmap.Canvas.Pixels[x - 1, y - 1] = nullClr then
begin
tmpRegn := CreateRectRgn(x - 1, y - 1, x, y);
CombineRgn(regn, regn, tmpRegn, RGN_DIFF);
DeleteObject(tmpRegn);
end;
SetWindowRgn(FMain.handle, regn, true);
end;
procedure TFMain.FormMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
Draging := true;
x0 := x;
y0 := y;
end;
procedure TFMain.FormMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
Draging := false;
end;
procedure TFMain.FormMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
begin
if Draging then
begin
FMain.Left := FMain.Left + X - X0;
FMain.top := FMain.top + Y - Y0;
end;
end;
procedure TFMain.ImgBtn4Click(Sender: TObject);
begin
FMain.Close;
end;
procedure TFMain.ImgBtn3Click(Sender: TObject);
begin
FMain.Close;
end;
procedure TFMain.ImgBtn2Click(Sender: TObject);
var
WThread: GFilesThread;
begin
Label3.Caption := '';
WThread := GFilesThread.Create(True);
WThread.FreeOnTerminate := True;
WThread.UpdatesUrl := USettings[2];
WThread.ForceCheck := True;
WThread.CreateBackup := StrToInt(USettings[5]);
WThread.LocalRevision := StrToInt(USettings[6]);
WThread.Resume;
end;
procedure TFMain.ImgBtn1Click(Sender: TObject);
begin
RunApp(USettings[0] + Usettings[7]);
FMain.Close;
end;
procedure TFMain.FormClose(Sender: TObject; var Action: TCloseAction);
begin
USettings.Free;
end;
procedure TFMain.ImgBtn5Click(Sender: TObject);
begin
FMain.Enabled := False;
Form1.Show;
end;
procedure TFMain.WebBrowser1NavigateComplete2(Sender: TObject; const pDisp: IDispatch; var URL: OleVariant);
begin
FMain.Panel1.Visible := True;
FMain.Image2.Visible := True;
FMain.Image3.Visible := True;
FMain.Image4.Visible := True;
end;
procedure TFMain.Timer1Timer(Sender: TObject);
var
WThread: GFilesThread;
begin
FMain.Timer1.Enabled := False;
WebBrowser1.Navigate(USettings[1]);
Label3.Caption := '';
WThread := GFilesThread.Create(True);
WThread.FreeOnTerminate := True;
WThread.UpdatesUrl := USettings[2];
WThread.ForceCheck := False;
WThread.CreateBackup := StrToInt(USettings[5]);
WThread.LocalRevision := StrToInt(USettings[6]);
WThread.Resume;
end;
end.

Related

EXC_BAD_ACCESS (code=1, address=Oxf0) on Button Click

This is a Lazarus project.
It happens when I press Button4. I have a few ideas what could be the reason, but I really have no idea how to fix this.
The error is:
Projekt EnglischOlympics
»Process stopped with reason:
EXC_BAD_ACCESS (code=1, address=Oxf0)
Address 10000C61E*
Assambler:
*000000010000C5DE : 48 83 7b 08 00 cmpq $0x0, 0x8(%rbx)*
The Interface unit:
unit Oberflache;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, Forms, Controls, Graphics, Dialogs, StdCtrls,
uZaehler, uSpeicher; //Hier eigene Units eingebunden
type
{ TForm1 }
TForm1 = class(TForm)
Button1: TButton;
Button2: TButton;
Button3: TButton;
Button4: TButton;
Edit1: TEdit;
Edit2: TEdit;
Edit3: TEdit;
Label1: TLabel;
Label2: TLabel;
Label3: TLabel;
Label4: TLabel;
Label5: TLabel;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure Button3Click(Sender: TObject);
procedure Button4Click(Sender: TObject);
procedure Edit1Change(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
public
end;
var
Form1: TForm1;
Zaehler:TZaehler; //Objekte deklarieren
Speicher:TSpeicher;
implementation
{$R *.lfm}
{ TForm1 }
procedure TForm1.FormCreate(Sender: TObject);
begin
Zaehler := TZaehler.Create; // Objekte erzeugen
Speicher := TSpeicher.Create;
Zaehler.SetzeSchulNr(1);
Zaehler.SetzeSchulerNr(1);
end;
procedure TForm1.Button1Click(Sender: TObject);
var
Zahl : integer;
begin
Zahl := StrToInt(Edit1.Text);
Speicher.AnzahlSchulen(Zahl);
Zaehler.AnzahlSchulen(Zahl);
end;
procedure TForm1.Button2Click(Sender: TObject);
var
Bezeichnung : string;
begin
Bezeichnung := Edit2.Text;
Speicher.EingabeSchulen(Bezeichnung);
Zaehler.SchulNrHoch(1);
If Zaehler.GibSchulNr > Zaehler.GibAnzahlSchulen
then
begin
Zaehler.SetzeSchulNr(1);
Label1.Caption := 'Name der Schule: ' + IntToStr(Zaehler.GibSchulNr);
Edit2.Text := 'Name der Schule';
Zaehler.SetzeSchulerNr(1);
Label2.Caption := Speicher.GibSchule;
end;
Edit2.Text := 'Name der Schule';
Label1.Caption :='Name der Schule: ' + IntToStr(Zaehler.GibSchulNr);
Label4.Caption := IntToStr(Zaehler.GibAnzahlSchulen);
Label5.Caption := IntToStr(Zaehler.GibSchulNr);
end;
procedure TForm1.Button3Click(Sender: TObject);
begin
Zaehler.Free;
Speicher.Free;
Close;
end;
procedure TForm1.Button4Click(Sender: TObject);
var
Bezeichnung : string;
begin
Bezeichnung := Edit3.Text;
Speicher.EingabeSchuler(Bezeichnung);
Zaehler.SchulerNrHoch(1);
Label1.Caption := 'Name des Schülers: ' + IntToStr(Zaehler.GibSchulerNr);
Edit2.Text := 'Name des Schülers';
end;
procedure TForm1.Edit1Change(Sender: TObject);
begin
end;
end.
This unit counts what number we're on:
UNIT uZaehler;
interface
//-------------------- ggf Uses-Liste einfügen ! --------------------
//uses ....;
type
TZaehler = CLASS
// weitere Attribute
private
SchulerNr : integer;
SchulNr : integer;
AnzahlS : integer;
// weitere Methoden
public
procedure AnzahlSchulen (pAnzahlS : integer);
function GibAnzahlSchulen : integer;
procedure SetzeSchulerNr (pSchulerNr: integer); virtual;
procedure SchulerNrHoch (pUm: integer); virtual;
function GibSchulerNr : integer; virtual;
procedure SetzeSchulNr (pSchulNr: integer); virtual;
procedure SchulNrHoch (pUm: integer); virtual;
function GibSchulNr : integer; virtual;
end;
implementation
//+---------------------------------------------------------------------
//| Zaehler: Methodendefinition
//+---------------------------------------------------------------------
//-------- SetzeSchulerNr (public) -------------------------------------
procedure TZaehler.SetzeSchulerNr (pSchulerNr: integer);
begin
SchulerNr := pSchulerNr;
end;
//-------- Gib Anzahl Schulen (public) -------------------------------------
function TZaehler.GibAnzahlSchulen : integer;
begin
Result := AnzahlS;
end;
//-------- Anzahl Schulen (public) ---------------------------------------
procedure TZaehler.AnzahlSchulen (pAnzahlS: integer);
begin
AnzahlS := pAnzahlS;
end;
//-------- GibSchulerNr (public) ---------------------------------------
function TZaehler.GibSchulerNr : integer;
begin
Result := SchulerNr;
end;
//-------- SchulerNrHoch (public) -------------------------------------
procedure TZaehler.SchulerNrHoch (pUm: integer);
begin
SchulerNr := SchulerNr + pUm;
end;
//-------- SetzeSchulNr (public) -------------------------------------
procedure TZaehler.SetzeSchulNr (pSchulNr: integer);
begin
SchulNr := pSchulNr;
end;
//-------- SchulNrHoch (public) -------------------------------------
procedure TZaehler.SchulNrHoch (pUm: integer);
begin
SchulNr := SchulNr + pUm;
end;
//-------- GibSchulNr (public) ---------------------------------------
function TZaehler.GibSchulNr : integer;
begin
Result := SchulNr;
end;
end.
This unit saves the current data:
UNIT uSpeicher;
interface
//-------------------- ggf Uses-Liste einfügen ! --------------------
uses
Classes, SysUtils, Forms, Controls, Graphics, Dialogs, StdCtrls, uZaehler; //Hier eigene Units eingebunden
type
TSchuler = record // Ein Schüler mit Namen, 6 Punktzahlen können eingegebn werden,
SName: string; // daraus ergibt sich TotalScore (Gesamtpunktzahl)
Score1: real;
Score2: real;
Score3: real;
Score4: real;
Score5: real;
Score6: real;
TotalScore: real;
end;
TSchule = record // Ein Team hat einen Namen und mehrere Schüler vom Typ TSchuler
TName: string; // der TeamScore wird aus den einzelnen TotalScores berechnet
Schueler: Array[1..8] of TSchuler;
TeamScore: real; //Wird aus allen TotalScores berechnet
end;
TSpeicher = CLASS
// weitere Attribute
private
// weitere Methoden
public
Teams : Array of TSchule;
procedure AnzahlSchulen (pAnzahl: integer);
procedure EingabeSchulen (pName: string);
procedure EingabeSchuler (pName: string);
procedure ZahlenAktualisieren;
function GibSchule : string;
end;
var
SchuleZahl : integer;
SchulerZahl: integer;
implementation
//+---------------------------------------------------------------------
//| Speicher: Methodendefinition
//+---------------------------------------------------------------------
//-------- Anzahl Festlege (public) -------------------------------------
procedure TSpeicher.AnzahlSchulen (pAnzahl: integer);
begin
SetLength(Teams, pAnzahl); //Anzahl der Schulen festlegen
end;
//-------- Eingabe Schulen (public) -------------------------------------
procedure TSpeicher.EingabeSchulen (pName: string);
var
i: integer;
Zaehler: TZaehler;
begin
Zaehler := TZaehler.Create;
i := Zaehler.GibSchulNr;
Teams[i].TName := pName;
Zaehler.Free;
end;
//-------- Zahl Schule Aktualisieren (public) -------------------------------------
procedure TSpeicher.ZahlenAktualisieren;
var
i, h: integer;
Zaehler: TZaehler;
begin
Zaehler := TZaehler.Create;
i := Zaehler.GibSchulNr;
h := Zaehler.GibSchulerNr;
SchuleZahl := i;
SchulerZahl := h;
Zaehler.Free;
end;
//-------- Eingabe Schuler (public) -------------------------------------
procedure TSpeicher.EingabeSchuler (pName: string);
var
i: integer;
n: integer;
Zaehler: TZaehler;
begin
Zaehler := TZaehler.Create;
i := Zaehler.GibSchulNr;
n := Zaehler.GibSchulerNr;
Teams[i].Schueler[n].SName := pName;
Zaehler.Free;
end;
//-------- GibSchule (public) ---------------------------------------
function TSpeicher.GibSchule : string;
begin
Result := Teams[SchuleZahl].TName;
end;
end.
I played around with changing the input for Teams[i].Schueler[n].SName := pName; in procedure TSpeicher.EingabeSchuler() in Speicher, but that doesn't seem to be the problem.
Any ideas?

FMX, TGrid, OnCellClick

On my fmx-form I have TGrid with column of type TCheckColumn. To capture click events on cells of grid I connect the OnCellClick handler to it.
My Question is: how to reliably trigger the OnCellClick event when clicking the left mouse button (LMB) for an arbitrary line, if:
LMB clicks occur on the same cell in the TCheckColumn;
LMB clicks are not accompanied by mouse cursor displacement.
For a better explanation of the essence of the issue, I will give a picture (see below). LMB is pressed on it in the same cell without cursor offsets. Events arising in this situation are logged in the CodeSite window (on the right). As you can see from the picture: the cell in the TCheckColumn column changes its state (the checkmark appears or disappears), but the OnCellClick event occurs only 1 time.
The picture itself
TGrid with OnCellClick event handler:
unit uMain;
interface
uses
System.SysUtils,
System.Types,
System.UITypes,
System.Classes,
System.Variants,
System.Rtti,
//
FMX.Types,
FMX.Controls,
FMX.Forms,
FMX.Graphics,
FMX.Dialogs,
FMX.Grid.Style,
FMX.Grid,
FMX.Controls.Presentation,
FMX.ScrollBox,
FMX.StdCtrls,
FMX.ImgList;
//
type
//for grid row
TRow = record
ID:integer;
Checked:boolean;
end;
//Test form
TForm1 = class(TForm)
grd: TGrid;
CheckColumn2: TCheckColumn;
Label2: TLabel;
IntegerColumn1: TIntegerColumn;
procedure FormCreate(Sender: TObject);
procedure grdGetValue(Sender: TObject; const ACol, ARow: Integer; var Value: TValue);
procedure grdSetValue(Sender: TObject; const ACol, ARow: Integer; const Value: TValue);
procedure grdCellClick(const Column: TColumn; const Row: Integer);
private
FRowsA: array of TRow;
FSelectedRow: integer;
//
procedure PopulateGrid;
//
end;
//for cols of grid
TMyCols = (mcID, mcChecked);
var
Form1: TForm1;
implementation
{$R *.fmx}
//FormCreate
procedure TForm1.FormCreate(Sender: TObject);
begin
PopulateGrid;
end;
{$REGION 'TGrid'}
//PopulateGrid
procedure TForm1.PopulateGrid;
const
rows = 10;//rows count
begin
Grd.RowCount := rows ;
SetLength(FRowsA, rows);
for var r := 0 to rows-1 do
begin
//
FRowsA[r].ID := r; //id
FRowsA[r].Checked := false ; //check
end;
end;
//grdCellClick
procedure TForm1.grdCellClick(const Column: TColumn; const Row: Integer);
var
selRow, cnt: integer;
begin
var ci := Column.Index ;
FSelectedRow := Row;
cnt := grd.RowCount ;
//checked col
if ci = Ord(TMyCols.mcChecked) then
begin
//
grd.RowCount := 0;
grd.RowCount := cnt;
grd.SelectRow(FSelectedRow);
//
FRowsA[Row].Checked := not FRowsA[Row].Checked;
//
Log.d( Format('CellClick raised: row=%d; col=%d', [Row, ci]) );
end;
end;
//grdSetValue
procedure TForm1.grdSetValue(Sender: TObject; const ACol, ARow: Integer; const Value: TValue);
var
oldVal, newVal: boolean;
begin
var g := Sender as TGrid;
if not Assigned(g) then Exit;
if (ARow < 0) or (ARow >= g.RowCount) then Exit;
//
//col num
case ACol of
//id col
Ord(TMyCols.mcID):
begin
FRowsA[ARow].Checked := Value.AsBoolean;//id
end;
//checked col
Ord(TMyCols.mcChecked):
begin
oldVal := FRowsA[ARow].Checked;
Value.TryAsType<boolean>(newVal);
FRowsA[ARow].Checked := newVal;//checked
Log.d( Format('OnSetValue raised: row=%d; col=%d; oldValue=%s; newValue=%s', [ARow, ACol, oldVal.ToString(), newVal.ToString()]) );
end;
//
end;
//
end;
//grdGetValue
procedure TForm1.grdGetValue(Sender: TObject; const ACol, ARow: Integer; var Value: TValue);
var
val: boolean;
begin
var g := Sender as TGrid;
if not Assigned(g) then Exit;
if (ARow < 0) or (ARow >= g.RowCount) then Exit;
case ACol of
//id
Ord(TMyCols.mcID) :
begin
Value := FRowsA[ARow].ID;
end;
//checked
Ord(TMyCols.mcChecked):
begin
Value := FRowsA[ARow].Checked;
end;
end;
Log.d( Format('OnGetValue raised: row=%d; col=%d', [ARow, ACol]) );
//
end;
{$ENDREGION}
//
end.

How to display list text with other controls on same line?

As an exercise for myself, I'm trying to recreate the To-Do app from the (fascinating) todomvc.com web site. The UI looks like this:
A user writes a To-Do item in an Edit box control (above the crossed out "buy milk") and presses Enter. To-Do items appear below.
As you can see, each line includes a stylized radio control, the text, and a button with an image (red x). The button appears when a user hovers the cursor inside the line.
I don't care about the button, having an image, or appearing only upon OnEnter. I can't figure out how to make a similarly styled (ListView? ComboBox?) control with a radio control and button.
I'm using Delphi VCL, but could switch to FMX.
There really isn't any shortcut here: you simply need to write quite a lot of code. The Windows OS doesn't provide anything like this. I would implement from scratch using an empty window with custom GDI painting and mouse and keyboard input processing. It's not difficult at all, but it does require quite a lot of code.
That was a lot of words and no code.
As a remedy, here is a very quick demonstration control based on Direct2D (because I realised I really do need anti aliasing):
unit ItemListBox;
interface
uses
Windows, SysUtils, Types, UITypes, Classes, Controls, Graphics, Generics.Defaults,
Generics.Collections, Forms, Messages, Direct2D, D2D1;
type
TItem = class
strict private
FCaption: TCaption;
FChecked: Boolean;
FTag: NativeInt;
FOnChanged: TNotifyEvent;
procedure Changed;
procedure SetCaption(const Value: TCaption);
procedure SetChecked(const Value: Boolean);
public
property Caption: TCaption read FCaption write SetCaption;
property Checked: Boolean read FChecked write SetChecked;
property Tag: NativeInt read FTag write FTag;
property OnChanged: TNotifyEvent read FOnChanged write FOnChanged;
end;
TPart = (ilbpText, ilbpCheckBox, ilbpClearButton);
TItemListBox = class(TCustomControl)
strict private
FItems: TObjectList<TItem>;
FItemHeight: Integer;
FCanvas: TDirect2DCanvas;
FIndex: Integer;
FPart: TPart;
FMouseDownIndex: Integer;
FMouseDownPart: TPart;
FFocusIndex: Integer;
function GetItem(Index: Integer): TItem;
function GetItemCount: Integer;
procedure ItemChanged(Sender: TObject);
procedure DrawItem(Index: Integer; Item: TItem);
procedure DrawCheckBox(Index: Integer; Item: TItem; Hot: Boolean = False);
procedure DrawClearButton(Index: Integer; Visible: Boolean; Hot: Boolean = False);
function ItemRect(Index: Integer): TRect;
function TextRect(Index: Integer): TRect;
function CheckBoxRect(Index: Integer): TRect;
function ClearButtonRect(Index: Integer): TRect;
procedure CreateDeviceResources;
procedure HitTest(const P: TPoint; out Index: Integer; out Part: TPart);
procedure StateChange(ANewIndex: Integer; ANewPart: TPart);
function CanvasWidth: Integer;
function CanvasHeight: Integer;
protected
procedure Paint; override;
procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
procedure WMSize(var Message: TWMSize); message WM_SIZE;
procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
procedure CreateWnd; override;
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X: Integer;
Y: Integer); override;
procedure MouseMove(Shift: TShiftState; X: Integer; Y: Integer); override;
procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X: Integer;
Y: Integer); override;
procedure KeyDown(var Key: Word; Shift: TShiftState); override;
procedure WMGetDlgCode(var Message: TWMGetDlgCode); message WM_GETDLGCODE;
procedure WMSetFocus(var Message: TWMSetFocus); message WM_SETFOCUS;
procedure WMKillFocus(var Message: TWMKillFocus); message WM_KILLFOCUS;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
property Canvas: TDirect2DCanvas read FCanvas;
function AddItem(const ACaption: string; AChecked: Boolean;
ATag: NativeInt = 0): Integer;
procedure RemoveItem(AIndex: Integer);
property Items[Index: Integer]: TItem read GetItem;
property ItemCount: Integer read GetItemCount;
published
property Align;
property AlignWithMargins;
property Anchors;
property Cursor;
property Font;
property Hint;
property PopupMenu;
property TabOrder;
property TabStop default True;
end;
procedure Register;
implementation
uses
Math;
procedure Register;
begin
RegisterComponents('Rejbrand 2020', [TItemListBox]);
end;
function Scale(X: Integer): Integer;
begin
Result := MulDiv(X, Screen.PixelsPerInch, 96);
end;
{ TItem }
procedure TItem.Changed;
begin
if Assigned(FOnChanged) then
FOnChanged(Self);
end;
procedure TItem.SetCaption(const Value: TCaption);
begin
if FCaption <> Value then
begin
FCaption := Value;
Changed;
end;
end;
procedure TItem.SetChecked(const Value: Boolean);
begin
if FChecked <> Value then
begin
FChecked := Value;
Changed;
end;
end;
{ TItemListBox }
function TItemListBox.AddItem(const ACaption: string; AChecked: Boolean;
ATag: NativeInt): Integer;
var
Item: TItem;
begin
Item := TItem.Create;
Item.Caption := ACaption;
Item.Checked := AChecked;
Item.OnChanged := ItemChanged;
Result := FItems.Add(Item);
InvalidateRect(Handle, ItemRect(Result), True);
end;
function TItemListBox.ClearButtonRect(Index: Integer): TRect;
begin
Result := Rect(CanvasWidth - 32, Index * FItemHeight, CanvasWidth,
(Index + 1) * FItemHeight);
end;
procedure TItemListBox.CMMouseLeave(var Message: TMessage);
begin
inherited;
StateChange(-1, ilbpText);
end;
constructor TItemListBox.Create(AOwner: TComponent);
begin
inherited;
FItems := TObjectList<TItem>.Create;
FItemHeight := 32;
FIndex := -1;
FMouseDownIndex := -1;
FFocusIndex := -1;
Color := clWindow;
TabStop := True;
end;
procedure TItemListBox.CreateDeviceResources;
begin
FreeAndNil(FCanvas);
FCanvas := TDirect2DCanvas.Create(Handle);
end;
procedure TItemListBox.CreateWnd;
begin
inherited;
CreateDeviceResources;
end;
destructor TItemListBox.Destroy;
begin
FreeAndNil(FItems);
FreeAndNil(FCanvas);
inherited;
end;
procedure TItemListBox.DrawClearButton(Index: Integer; Visible: Boolean; Hot: Boolean);
var
R: TRect;
begin
if not Visible then
Exit;
R := ClearButtonRect(Index);
InflateRect(R, -7, -7);
Canvas.Pen.Color := IfThen(Hot, clRed, clMaroon);
Canvas.Pen.Width := 2;
Canvas.MoveTo(R.Left, R.Top);
Canvas.LineTo(R.Right, R.Bottom);
Canvas.MoveTo(R.Right, R.Top);
Canvas.LineTo(R.Left, R.Bottom);
end;
procedure TItemListBox.DrawItem(Index: Integer; Item: TItem);
var
R: TRect;
S: string;
begin
// Background
Canvas.Brush.Color := clWindow;
Canvas.Brush.Style := bsSolid;
Canvas.Pen.Color := clWindowText;
Canvas.Pen.Width := 1;
Canvas.Pen.Style := psSolid;
R := ItemRect(Index);
Canvas.FillRect(R);
// Text
R := TextRect(Index);
S := Item.Caption;
Canvas.Font.Assign(Font);
Canvas.Font.Color := IfThen(Item.Checked, clGrayText, clWindowText);
if Item.Checked then
Canvas.Font.Style := [fsStrikeOut]
else
Canvas.Font.Style := [];
Canvas.TextRect(R, S, [tfSingleLine, tfEndEllipsis, tfVerticalCenter]);
// Check box
DrawCheckBox(Index, Item, (FIndex = Index) and (FPart = ilbpCheckBox));
// Clear button
DrawClearButton(Index, FIndex = Index, (FIndex = Index) and (FPart = ilbpClearButton));
// Focus indicator
if InRange(FFocusIndex, 0, FItems.Count - 1) and Focused then
begin
Canvas.Pen.Color := clSilver;
Canvas.Pen.Width := 1;
Canvas.Pen.Style := psSolid;
Canvas.Brush.Style := bsClear;
R := TextRect(FFocusIndex);
InflateRect(R, 0, -2);
Canvas.Rectangle(R);
end;
end;
procedure TItemListBox.DrawCheckBox(Index: Integer; Item: TItem;
Hot: Boolean);
var
R: TRect;
begin
R := CheckBoxRect(Index);
InflateRect(R, -5, -5);
Canvas.Pen.Color := clSilver;
Canvas.Pen.Width := 1;
Canvas.Brush.Color := IfThen(Hot, clSilver, clWhite);
Canvas.Ellipse(R);
if Assigned(Item) and Item.Checked then
begin
Canvas.Pen.Color := clGreen;
Canvas.Pen.Width := 2;
Canvas.MoveTo(R.Left + R.Width div 5, R.Bottom - R.Height div 2);
Canvas.LineTo(R.Left + Round(R.Width / 2.5), R.Bottom - Round(R.Height / 3.8));
Canvas.LineTo(R.Right - Round(R.Width / 4.5), R.Top + R.Height div 5);
end;
end;
function TItemListBox.GetItem(Index: Integer): TItem;
begin
Result := FItems[Index];
end;
function TItemListBox.GetItemCount: Integer;
begin
Result := FItems.Count;
end;
procedure TItemListBox.HitTest(const P: TPoint; out Index: Integer;
out Part: TPart);
var
i: Integer;
Q: TPoint;
begin
Q.X := MulDiv(P.X, 96, Screen.PixelsPerInch);
Q.Y := MulDiv(P.Y, 96, Screen.PixelsPerInch);
for i := 0 to FItems.Count - 1 do
if ItemRect(i).Contains(Q) then
begin
Index := i;
if CheckBoxRect(i).Contains(Q) then
Part := ilbpCheckBox
else if ClearButtonRect(i).Contains(Q) then
Part := ilbpClearButton
else
Part := ilbpText;
Exit;
end;
Index := -1;
Part := ilbpText;
end;
procedure TItemListBox.ItemChanged(Sender: TObject);
begin
Invalidate;
end;
function TItemListBox.ItemRect(Index: Integer): TRect;
begin
Result := Rect(0, Index * FItemHeight, CanvasWidth, (Index + 1) * FItemHeight);
end;
procedure TItemListBox.KeyDown(var Key: Word; Shift: TShiftState);
begin
inherited;
case Key of
VK_DOWN:
if Succ(FFocusIndex) <= FItems.Count - 1 then
begin
Inc(FFocusIndex);
Invalidate;
end;
VK_UP:
if Pred(FFocusIndex) >= 0 then
begin
Dec(FFocusIndex);
Invalidate;
end;
VK_HOME:
if FFocusIndex <> 0 then
begin
FFocusIndex := 0;
Invalidate;
end;
VK_END:
if FFocusIndex <> FItems.Count - 1 then
begin
FFocusIndex := FItems.Count - 1;
Invalidate;
end;
VK_SPACE:
if InRange(FFocusIndex, 0, FItems.Count - 1) then
FItems[FFocusIndex].Checked := not FItems[FFocusIndex].Checked;
VK_DELETE:
if InRange(FFocusIndex, 0, FItems.Count - 1) then
RemoveItem(FFocusIndex);
end;
end;
procedure TItemListBox.MouseDown(Button: TMouseButton; Shift: TShiftState; X,
Y: Integer);
begin
inherited;
if CanFocus then
SetFocus;
HitTest(Point(X, Y), FMouseDownIndex, FMouseDownPart);
if FFocusIndex <> FMouseDownIndex then
begin
FFocusIndex := FMouseDownIndex;
Invalidate;
end;
end;
procedure TItemListBox.MouseMove(Shift: TShiftState; X, Y: Integer);
var
NewIndex: Integer;
NewPart: TPart;
begin
inherited;
HitTest(Point(X, Y), NewIndex, NewPart);
StateChange(NewIndex, NewPart);
end;
procedure TItemListBox.MouseUp(Button: TMouseButton; Shift: TShiftState; X,
Y: Integer);
var
Index: Integer;
Part: TPart;
begin
HitTest(Point(X, Y), Index, Part);
if (Index <> -1) and (Index = FMouseDownIndex) and (Button = mbLeft) then
begin
if (Part = ilbpCheckBox) and (Part = FMouseDownPart) then
FItems[Index].Checked := not FItems[Index].Checked
else if (Part = ilbpClearButton) and (Part = FMouseDownPart) then
RemoveItem(Index);
end;
end;
procedure TItemListBox.Paint;
var
i: Integer;
begin
Canvas.RenderTarget.Clear(D2D1ColorF(clWhite));
for i := 0 to FItems.Count - 1 do
DrawItem(i, FItems[i]);
end;
procedure TItemListBox.RemoveItem(AIndex: Integer);
begin
FItems.Delete(AIndex);
FFocusIndex := EnsureRange(FFocusIndex, 0, FItems.Count - 1);
Invalidate;
end;
procedure TItemListBox.StateChange(ANewIndex: Integer; ANewPart: TPart);
var
OldIndex: Integer;
OldPart: TPart;
begin
OldIndex := FIndex;
OldPart := FPart;
FIndex := ANewIndex;
FPart := ANewPart;
if FIndex = OldIndex then
begin
if FPart <> OldPart then
begin
if ilbpCheckBox in [FPart, OldPart] then
InvalidateRect(Handle, CheckBoxRect(FIndex), True);
if ilbpClearButton in [FPart, OldPart] then
InvalidateRect(Handle, ClearButtonRect(FIndex), True);
end;
end
else
begin
InvalidateRect(Handle, ItemRect(OldIndex), True);
InvalidateRect(Handle, ItemRect(FIndex), True);
end;
end;
function TItemListBox.CanvasHeight: Integer;
begin
Result := MulDiv(ClientHeight, 96, Screen.PixelsPerInch);
end;
function TItemListBox.CanvasWidth: Integer;
begin
Result := MulDiv(ClientWidth, 96, Screen.PixelsPerInch);
end;
function TItemListBox.CheckBoxRect(Index: Integer): TRect;
begin
Result := Rect(0, Index * FItemHeight, 32, (Index + 1) * FItemHeight);
end;
function TItemListBox.TextRect(Index: Integer): TRect;
begin
Result := Rect(40, Index * FItemHeight, CanvasWidth - 40,
(Index + 1) * FItemHeight);
end;
procedure TItemListBox.WMEraseBkgnd(var Message: TWMEraseBkgnd);
begin
Message.Result := 1;
end;
procedure TItemListBox.WMGetDlgCode(var Message: TWMGetDlgCode);
begin
inherited;
Message.Result := Message.Result or DLGC_WANTARROWS;
end;
procedure TItemListBox.WMKillFocus(var Message: TWMKillFocus);
begin
inherited;
Invalidate;
end;
procedure TItemListBox.WMPaint(var Message: TWMPaint);
var
PaintStruct: TPaintStruct;
res: HRESULT;
begin
BeginPaint(Handle, PaintStruct);
try
if Assigned(FCanvas) then
begin
FCanvas.BeginDraw;
try
Paint;
finally
res := FCanvas.RenderTarget.EndDraw;
if res = D2DERR_RECREATE_TARGET then
CreateDeviceResources;
end;
end;
finally
EndPaint(Handle, PaintStruct);
end;
end;
procedure TItemListBox.WMSetFocus(var Message: TWMSetFocus);
begin
inherited;
Invalidate;
end;
procedure TItemListBox.WMSize(var Message: TWMSize);
var
S: TD2DSizeU;
begin
if Assigned(FCanvas) then
begin
S := D2D1SizeU(ClientWidth, ClientHeight);
ID2D1HwndRenderTarget(FCanvas.RenderTarget).Resize(S);
end;
Invalidate;
inherited;
end;
end.
Example (with a simple TEdit at the top):
But please notice that this is not a finished control; it's merely a very primitive sketch or prototype. It is not fully tested. In addition, a real control would have scrolling support and a keyboard interface. Since it is very late in Sweden right now, I don't really have time to add that at the moment.
Update: I added high-DPI support and a keyboard interface (up, down, home, end, space, delete):

delphi: how can I put Image in DBGrid Title?

How can I put Image in TDBGrid column heading?
I tried, but the image kept showing and kept disappearing when i put the mouse over the title.
procedure TForm1.DBGrid1DrawColumnCell(Sender: TObject; const Rect: TRect;
DataCol: Integer; Column: TColumn; State: TGridDrawState);
begin
if Column.FieldName = order then
Begin
Column.Title.Font.Color := clBlue;
//if gdFixed in State then // didn't work.. I don't know why!!!
if Rect.Top < 30 then
ImageList1.Draw(DBGrid1.Canvas, Rect.Right-18, Rect.Top-18, 0);
end
else
Column.Title.Font.Color := clWindowText;
end;
You can use a interposer class for TDBGrid and override the DrawCell procedure.
type
TDBGrid = Class(DBGrids.TDBGrid)
private
FIcon:TIcon;
FImageList: TImageList;
procedure SetImageList(const Value: TImageList);
Destructor Destroy;override;
published
procedure DrawCell(ACol, ARow: Longint; ARect: TRect; AState: TGridDrawState); override;
Property Imagelist: TImageList read FImageList Write SetImageList;
End;
TForm2 = class(TForm)
.......
implementation
{$R *.dfm}
{ TDBGrid }
destructor TDBGrid.Destroy;
begin
if Assigned(FIcon) then FIcon.Free;
inherited;
end;
procedure TDBGrid.SetImageList(const Value: TImageList);
begin
FImageList := Value;
FreeAndNil(FIcon);
if Assigned(FImageList) then
begin
FIcon := TIcon.Create;
FImageList.GetIcon(0, FIcon);
end;
end;
procedure TDBGrid.DrawCell(ACol, ARow: Integer; ARect: TRect; AState: TGridDrawState);
var
L_Col: Integer;
begin
if dgIndicator in Options then
L_Col := ACol - 1
else
L_Col := ACol;
inherited;
if Assigned(FIcon) and (L_Col > -1) and (ARow = 0) and (Columns[L_Col].FieldName = 'ID') and (gdFixed in AState) then
begin
Canvas.Draw(ARect.Right - 18, ARect.Bottom - 18, FIcon);
//FImagelist.Draw(Canvas,ARect.Right - 18, ARect.Bottom - 18,0); // would cause more flickering
end;
end;
procedure TForm2.FormCreate(Sender: TObject);
begin
DBGrid1.DoubleBuffered := true;
DBGrid1.Imagelist := ImageList1;
ReportMemoryLeaksOnShutDown := true;
end;

How to create "No Activate" form in Firemonkey

In XCode by adding these methods to your NSView subclass can prevent the window from becoming active when clicking on it:
- (BOOL)shouldDelayWindowOrderingForEvent:(NSEvent )theEvent {
return YES;
}
- (BOOL)acceptsFirstMouse:(NSEvent )theEvent {
return YES;
}
- (void)mouseDown:(NSEvent )theEvent {
[[[NSApp]] preventWindowOrdering];
}
In Windows platform It is done by this simple code:
HWND hWnd = FindWindowW((String("FM") + fmxForm->ClassName()).c_str(),
fmxForm->Caption.c_str());
SetWindowLong(hWnd, GWL_EXSTYLE,
GetWindowLong(hWnd, GWL_EXSTYLE) | WS_EX_NOACTIVATE);
How can I subclass NSView to prevent my FMX TForm becoming active when clicking on it?
How can I create "No Activate" form in firemonkey?
It is possible using NSPanel with NSNonactivatingPanelMask flag. The NSView of fmx form should become child of NSPanel. I have written a helper class which works for both Windows and Mac platforms (Works on XE4):
unit NoActivateForm;
interface
uses Fmx.Forms, Fmx.Types
{$IFDEF POSIX}
, Macapi.AppKit
{$ENDIF}
;
type TNoActivateForm = class
private
form: TForm;
{$IFDEF POSIX}
panel: NSPanel;
timer: TTimer; // for simulating mouse hover event
{$ENDIF}
procedure SetPosition(const x, y: Integer);
procedure GetPosition(var x, y: Integer);
procedure SetDimensions(const width, height: Integer);
procedure SetLeft(const Value: Integer);
procedure SetTop(const Value: Integer);
procedure SetHeight(const Value: Integer);
procedure SetWidth(const Value: Integer);
procedure SetVisible(const Value: Boolean);
function GetLeft: Integer;
function GetTop: Integer;
function GetHeight: Integer;
function GetWidth: Integer;
function GetVisible: Boolean;
{$IFDEF POSIX}
procedure OnTimer(Sender: TObject);
{$ENDIF}
public
constructor Create(AForm: TForm);
destructor Destroy; override;
property Left: Integer read GetLeft write SetLeft;
property Top: Integer read GetTop write SetTop;
property Height: Integer read GetHeight write SetHeight;
property Width: Integer read GetWidth write SetWidth;
property Visible: Boolean read GetVisible write SetVisible;
end;
implementation
uses
Classes, System.Types
{$IFDEF MSWINDOWS}
, Winapi.Windows;
{$ELSE}
, Macapi.CocoaTypes, FMX.Platform.Mac, Macapi.CoreGraphics, Macapi.CoreFoundation;
{$ENDIF}
constructor TNoActivateForm.Create(AForm: TForm);
{$IFDEF POSIX}
var
rect: NSRect;
bounds: CGRect;
window: NSWindow;
style: integer;
panelCount: integer;
begin
form := AForm;
form.Visible := false;
bounds := CGDisplayBounds(CGMainDisplayID);
rect := MakeNSRect(form.Left, bounds.size.height - form.Top - form.Height,
form.ClientWidth, form.ClientHeight);
style := NSNonactivatingPanelMask;
style := style or NSHUDWindowMask;
panel := TNSPanel.Wrap(
TNSPanel.Alloc.initWithContentRect(rect, style, NSBackingStoreBuffered,
true));
panel.setFloatingPanel(true);
//panel.setHasShadow(false); optional
window := WindowHandleToPlatform(form.Handle).Wnd;
panel.setContentView(TNSView.Wrap(window.contentView));
TNSView.Wrap(window.contentView).retain;
timer := TTimer.Create(form.Owner);
timer.OnTimer := OnTimer;
timer.Interval := 50;
end;
{$ELSE}
var hWin: HWND;
begin
form := AForm;
form.TopMost := true;
hWin := FindWindow(PWideChar('FM' + form.ClassName), PWideChar(form.Caption));
if hWin <> 0 then
SetWindowLong(hWin, GWL_EXSTYLE,
GetWindowLong(hWin, GWL_EXSTYLE) or WS_EX_NOACTIVATE);
end;
{$ENDIF}
destructor TNoActivateForm.Destroy;
{$IFDEF POSIX}
begin
panel.release;
end;
{$ELSE}
begin
end;
{$ENDIF}
procedure TNoActivateForm.SetPosition(const x, y: Integer);
{$IFDEF POSIX}
var point: NSPoint;
screen: CGRect;
begin
screen := CGDisplayBounds(CGMainDisplayID);
point.x := x;
point.y := round(screen.size.height) - y - form.height;
panel.setFrameOrigin(point);
end;
{$ELSE}
begin
form.Left := x;
form.Top := y;
end;
{$ENDIF}
procedure TNoActivateForm.GetPosition(var x, y: Integer);
{$IFDEF POSIX}
var screen: CGRect;
begin
screen := CGDisplayBounds(CGMainDisplayID);
x := round(panel.frame.origin.x);
y := round(screen.size.height - panel.frame.origin.y - panel.frame.size.height);
end;
{$ELSE}
begin
x := form.Left;
y := form.Top;
end;
{$ENDIF}
procedure TNoActivateForm.SetDimensions(const width, height: Integer);
{$IFDEF POSIX}
var size: NSSize;
begin
size.width := width;
size.height := height;
panel.setContentSize(size);
end;
{$ELSE}
begin
form.width := width;
form.height := height;
end;
{$ENDIF}
procedure TNoActivateForm.SetLeft(const Value: Integer);
begin
SetPosition(Value, Top);
end;
procedure TNoActivateForm.SetTop(const Value: Integer);
begin
SetPosition(Left, Value);
end;
procedure TNoActivateForm.SetHeight(const Value: Integer);
begin
SetDimensions(Width, Value);
end;
procedure TNoActivateForm.SetWidth(const Value: Integer);
begin
SetDimensions(Value, Height);
end;
procedure TNoActivateForm.SetVisible(const Value: Boolean);
begin
{$IFDEF POSIX}
panel.setIsVisible(Value);
{$ELSE}
form.visible := Value;
{$ENDIF}
end;
function TNoActivateForm.GetLeft: Integer;
var x, y: Integer;
begin
GetPosition(x, y);
result := x;
end;
function TNoActivateForm.GetTop: Integer;
var x, y: Integer;
begin
GetPosition(x, y);
result := y;
end;
function TNoActivateForm.GetHeight: Integer;
begin
{$IFDEF POSIX}
result := round(panel.frame.size.height);
{$ELSE}
result := form.Height;
{$ENDIF}
end;
function TNoActivateForm.GetWidth: Integer;
begin
{$IFDEF POSIX}
result := round(panel.frame.size.width);
{$ELSE}
result := form.Width;
{$ENDIF}
end;
function TNoActivateForm.GetVisible: Boolean;
begin
{$IFDEF POSIX}
result := panel.isVisible();
{$ELSE}
result := form.visible;
{$ENDIF}
end;
{$IFDEF POSIX}
procedure TNoActivateForm.OnTimer(Sender: TObject);
var event: CGEventRef;
point: CGPoint;
form_rect: TRectF;
client_point, mouse_loc: TPointF;
shift: TShiftState;
begin
event := CGEventCreate(nil);
point := CGEventGetLocation(event);
CFRelease(event);
mouse_loc.SetLocation(point.x, point.y);
if Visible = true then
begin
form_rect := RectF(0, 0, form.Width, form.Height);
client_point.X := mouse_loc.X - Left;
client_point.Y := mouse_loc.y - Top;
if PtInRect(form_rect, client_point) then
form.MouseMove(shift, client_point.x, client_point.y)
else
form.MouseLeave();
end;
end;
{$ENDIF}
end.
Usage of above unit:
TNoActivateForm *naKeyboard; // global scope
void __fastcall TfrmKeyboard::TfrmKeyboard(TObject *Sender)
{
naKeyboard = new TNoActivateForm(frmKeyboard); // frmKeyboard is a normal fmx form
naKeyboard->Visible = true;
}
If frmKeyboard is your Main Form then do not put above code in form constructor, It is recommended to put it in OnShow.
Note: WindowHandleToPlatform doesn't seem to exist in XE3 so that line can be replaced with
window := NSWindow(NSWindowFromObjC(FmxHandleToObjC(Form.Handle)));
You can turn off the forms mouse handling to prevent it being focused. Assuming your form is called myform:
uses fmx.platform.mac, macapi.appkit;
.
.
Var nswin:nswindow;
.
.
NSWin:= NSWindow(NSWindowFromObjC(FmxHandleToObjC(myform.Handle))); { get the NSWindow }
NSWin.setIgnoresMouseEvents(true); { ignore mouse events }
NSWin.setAcceptsMouseMovedEvents(false);
There is a slight problem in that it doesn't stop a right mouse click. If that's a problem, you will have to respond to the mousedown event in the form and call the main forms mousedown so it doesn't lose the mouse event. Since the right mouse down will then capture the mouse events, you also then need to respond to mouse move and mouse up events too - forwarding them to your main form. Although it captures the mouse on right click, it will still not focus the form.
Dave Peters
DP Software

Resources