I have an (Delphi XE2) VCL app containing an object TDownloadUrl (VCL.ExtActns) to check several webpages, so I wonder if there is an equivalent object in FireMonkey, 'cause I wanna take advantage of rich features from this new platform.
A Firemonkey app demo using threads would appreciate. Thanks in advance.
Actions don't exist yet with FireMonkey.
BTW, you can create the same behavior with a code like this:
IdHTTP1: TIdHTTP;
...
procedure TForm2.MenuItem1Click(Sender: TObject);
const
FILENAME = 'C:\Users\Whiler\Desktop\test.htm';
URL = 'http://stackoverflow.com/questions/7491389/firemonkey-and-tdownloadurl';
var
// sSource: string;
fsSource: TFileStream;
begin
if FileExists(FILENAME) then
begin
fsSource := TFileStream.Create(FILENAME, fmOpenWrite);
end
else
begin
fsSource := TFileStream.Create(FILENAME, fmCreate);
end;
try
IdHTTP1.Get(URL, fsSource);
finally
fsSource.Free;
end;
// sSource := IdHTTP1.Get(URL);
end;
The commented lines can replace the others if you just need the source in memory...
If you want to use a thread, you can manage it like this:
unit Unit2;
interface
uses
System.SysUtils, System.Types, System.UITypes, System.Classes, System.Variants,
FMX.Types, FMX.Controls, FMX.Forms, FMX.Dialogs, IdBaseComponent, IdComponent, IdTCPConnection, IdTCPClient, IdHTTP, FMX.Menus;
type
TDownloadThread = class(TThread)
private
idDownloader: TIdHTTP;
FFileName : string;
FURL : string;
protected
procedure Execute; override;
procedure Finished;
public
constructor Create(const sURL: string; const sFileName: string);
destructor Destroy; override;
end;
type
TForm2 = class(TForm)
MenuBar1: TMenuBar;
MenuItem1: TMenuItem;
procedure MenuItem1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form2: TForm2;
implementation
{$R *.fmx}
procedure TForm2.MenuItem1Click(Sender: TObject);
const
FILENAME = 'C:\Users\Whiler\Desktop\test.htm';
URL = 'http://stackoverflow.com/questions/7491389/firemonkey-and-tdownloadurl';
var
// sSource: string;
fsSource: TFileStream;
begin
TDownloadThread.Create(URL, FILENAME).Start;
end;
{ TDownloadThread }
constructor TDownloadThread.Create(const sURL, sFileName: string);
begin
inherited Create(true);
idDownloader := TIdHTTP.Create(nil);
FFileName := sFileName;
FURL := sURL;
FreeOnTerminate := True;
end;
destructor TDownloadThread.Destroy;
begin
idDownloader.Free;
inherited;
end;
procedure TDownloadThread.Execute;
var
// sSource: string;
fsSource: TFileStream;
begin
inherited;
if FileExists(FFileName) then
begin
fsSource := TFileStream.Create(FFileName, fmOpenWrite);
end
else
begin
fsSource := TFileStream.Create(FFileName, fmCreate);
end;
try
idDownloader.Get(FURL, fsSource);
finally
fsSource.Free;
end;
Synchronize(Finished);
end;
procedure TDownloadThread.Finished;
begin
// replace by whatever you need
ShowMessage(FURL + ' has been downloaded!');
end;
end.
Regarding this:
A Firemonkey app demo using threads would appreciate.
You can find a FireMonkey demo which is using Thread here: https://radstudiodemos.svn.sourceforge.net/svnroot/radstudiodemos/branches/RadStudio_XE2/FireMonkey/FireFlow/MainForm.pas
type
TImageThread = class(TThread)
private
FImage: TImage;
FTempBitmap: TBitmap;
FFileName: string;
protected
procedure Execute; override;
procedure Finished;
public
constructor Create(const AImage: TImage; const AFileName: string);
destructor Destroy; override;
end;
...
TImageThread.Create(Image, Image.TagString).Start;
if you don't have this demo in your sample directory, you can check it out from the subversion repository used in the link above.
You can using this code.
unit BitmapHelperClass;
interface
uses
System.Classes, FMX.Graphics;
type
TBitmapHelper = class helper for TBitmap
public
procedure LoadFromUrl(AUrl: string);
procedure LoadThumbnailFromUrl(AUrl: string; const AFitWidth, AFitHeight: Integer);
end;
implementation
uses
System.SysUtils, System.Types, IdHttp, IdTCPClient, AnonThread;
procedure TBitmapHelper.LoadFromUrl(AUrl: string);
var
_Thread: TAnonymousThread<TMemoryStream>;
begin
_Thread := TAnonymousThread<TMemoryStream>.Create(
function: TMemoryStream
var
Http: TIdHttp;
begin
Result := TMemoryStream.Create;
Http := TIdHttp.Create(nil);
try
try
Http.Get(AUrl, Result);
except
Result.Free;
end;
finally
Http.Free;
end;
end,
procedure(AResult: TMemoryStream)
begin
if AResult.Size > 0 then
LoadFromStream(AResult);
AResult.Free;
end,
procedure(AException: Exception)
begin
end
);
end;
procedure TBitmapHelper.LoadThumbnailFromUrl(AUrl: string; const AFitWidth,
AFitHeight: Integer);
var
Bitmap: TBitmap;
scale: Single;
begin
LoadFromUrl(AUrl);
scale := RectF(0, 0, Width, Height).Fit(RectF(0, 0, AFitWidth, AFitHeight));
Bitmap := CreateThumbnail(Round(Width / scale), Round(Height / scale));
try
Assign(Bitmap);
finally
Bitmap.Free;
end;
end;
end.
Related
I have an application where an invisible "Host" application object creates main form and main form creates temporarily a data monitoring dialog form.
There is an asynchronous data receiver in "Host" that has a trace output event. This event should be temporarily bound with data monitoring dialog form's method when dialog form exists and unbound when it is about to be destroyed.
I made a minimal equivalent to this application below. Could you check whether it is the right way to do so? Please pay attention to "Attention" comments.
program BindToTempObject;
uses
Vcl.Forms, System.Classes, Vcl.StdCtrls, Vcl.ExtCtrls, System.SysUtils;
type
TBoolEvent = procedure(b: Boolean) of object;
TDialogForm = class(TForm)
public
constructor Create(AOwner: TComponent); override;
procedure BoolEventHandler(b: Boolean);
end;
TMainForm = class(TForm)
private
_btn: TButton;
_onBoolEventRelay: TBoolEvent; //Attention
procedure _btnClick(Sender: TObject);
public
constructor Create(AOwner: TComponent); override;
procedure BoolEventRelay(b: Boolean); //Attention
end;
TAppObject = class
private
_mainForm: TMainForm;
_eventSource: TTimer;
_boolState: Boolean;
procedure _eventSourceTick(Sender: TObject);
public
OnBoolEvent: TBoolEvent;
constructor Create();
destructor Destroy(); override;
end;
var
app: TAppObject;
{ TAppObject }
constructor TAppObject.Create();
begin
Application.CreateForm(TMainForm, _mainForm);
OnBoolEvent := _mainForm.BoolEventRelay; //Attention
_eventSource := TTimer.Create(nil);
_eventSource.OnTimer := _eventSourceTick;
_eventSource.Enabled := True;
end;
destructor TAppObject.Destroy();
begin
_eventSource.OnTimer := nil;
_eventSource.Free();
inherited;
end;
procedure TAppObject._eventSourceTick(Sender: TObject);
begin
_boolState := not _boolState;
if Assigned(OnBoolEvent) then OnBoolEvent(_boolState);
end;
{ TMainForm }
constructor TMainForm.Create(AOwner: TComponent);
begin
inherited CreateNew(AOwner);
Caption := 'Main form';
_btn := TButton.Create(Self);
_btn.Parent := Self;
_btn.Caption := 'Click me';
_btn.OnClick := _btnClick;
end;
procedure TMainForm.BoolEventRelay(b: Boolean);
begin
if Assigned(_onBoolEventRelay) then _onBoolEventRelay(b); //Attention
end;
procedure TMainForm._btnClick(Sender: TObject);
var
dlg: TDialogForm;
begin
dlg := TDialogForm.Create(Self);
try
_onBoolEventRelay := dlg.BoolEventHandler; //Attention
dlg.ShowModal();
finally
_onBoolEventRelay := nil; //Attention
dlg.Free();
end;
end;
{ TDialogForm }
procedure TDialogForm.BoolEventHandler(b: Boolean);
begin
Caption := BoolToStr(b, True);
end;
constructor TDialogForm.Create(AOwner: TComponent);
begin
inherited CreateNew(AOwner);
Caption := 'Dialog form';
end;
begin
Application.Initialize();
app := TAppObject.Create();
try
Application.Run();
finally
app.Free();
end;
end.
You could do it that way, sure. A decent separation of responsibilities between classes, so they don't have to know about each other.
However, in your particular example, since everything is in a single unit, and the app object is globally accessible, you could simplifly the code a little bit by assigning the TDialogForm.BoolEventHandler() method directly to the TAppObject.OnBoolEvent event and get rid of TMainForm as a middle man:
program BindToTempObject;
uses
Vcl.Forms, System.Classes, Vcl.StdCtrls, Vcl.ExtCtrls, System.SysUtils;
type
TBoolEvent = procedure(b: Boolean) of object;
TDialogForm = class(TForm)
public
constructor Create(AOwner: TComponent); override;
destructor Destroy(); override;
procedure BoolEventHandler(b: Boolean);
end;
TMainForm = class(TForm)
private
_btn: TButton;
procedure _btnClick(Sender: TObject);
public
constructor Create(AOwner: TComponent); override;
end;
TAppObject = class
private
_mainForm: TMainForm;
_eventSource: TTimer;
_boolState: Boolean;
procedure _eventSourceTick(Sender: TObject);
public
OnBoolEvent: TBoolEvent;
constructor Create();
destructor Destroy(); override;
end;
var
app: TAppObject;
{ TAppObject }
constructor TAppObject.Create();
begin
Application.CreateForm(TMainForm, _mainForm);
_eventSource := TTimer.Create(nil);
_eventSource.OnTimer := _eventSourceTick;
_eventSource.Enabled := True;
end;
destructor TAppObject.Destroy();
begin
_eventSource.OnTimer := nil;
_eventSource.Free();
inherited;
end;
procedure TAppObject._eventSourceTick(Sender: TObject);
begin
_boolState := not _boolState;
if Assigned(OnBoolEvent) then OnBoolEvent(_boolState);
end;
{ TMainForm }
constructor TMainForm.Create(AOwner: TComponent);
begin
inherited CreateNew(AOwner);
Caption := 'Main form';
_btn := TButton.Create(Self);
_btn.Parent := Self;
_btn.Caption := 'Click me';
_btn.OnClick := _btnClick;
end;
procedure TMainForm._btnClick(Sender: TObject);
var
dlg: TDialogForm;
begin
dlg := TDialogForm.Create(Self);
try
dlg.ShowModal();
finally
dlg.Free();
end;
end;
{ TDialogForm }
procedure TDialogForm.BoolEventHandler(b: Boolean);
begin
Caption := BoolToStr(b, True);
end;
constructor TDialogForm.Create(AOwner: TComponent);
begin
inherited CreateNew(AOwner);
Caption := 'Dialog form';
app.OnBoolEvent := BoolEventHandler;
end;
destructor TDialogForm.Destroy();
begin
app.OnBoolEvent := nil;
inherited;
end;
begin
Application.Initialize();
app := TAppObject.Create();
try
Application.Run();
finally
app.Free();
end;
end.
Hy! I want to add IXMLNodes to an XML document. My main procedure is btnXmlSaveToFileClick which Saves XML structure to a file. My problem is I cannot add IXMLNode as a child. Sorry for my English.
Any help or advice would be greatly appreciated.
Here is my example:
*
unit Unit3;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs,
XMLDoc, XMLIntf, Vcl.StdCtrls;
type
IXMLDataSample1 = interface(IXMLNode)
['{D7B7E084-1BF8-4185-85D1-1C83B74EA651}']
function GetXmlDAtaSample1: WideString;
procedure SetXmlDAtaSample1(const Value: WideString);
property XmlDataSample1: WideString read GetXmlDataSample1 write SetXmlDataSample1;
end;
IXMLDataSample2 = interface(IXMLNode)
['{6D7CE38B-3F57-4F18-A337-8405E72637E6}']
function GetXmlDataSample2: WideString;
procedure SetXmlDataSample2(const Value: WideString);
property XmlDataSample2: WideString read GetXmlDataSample2 write SetXmlDataSample2;
end;
TXMLHandler<IXMLType: IXMLNode> = class
private
class function ConvertXMLNodeToXMLType(aNode: IXMLNode): IXMLType;
protected
class function GetXMLClass: TClass; virtual; abstract;
class function GetXMLRootElementName: WideString; virtual; abstract;
class function GetXMLIfType: TGUID; virtual; abstract;
class procedure SaveXMLToFile(aXML: IXMLType; const aFileName: string);
class function NewXML: IXMLType; virtual;
end;
TDataSampleXMLHandler1 = class(TXMLHandler<IXMLDataSample1>)
public
class function GetXMLClass: TClass; override;
class function GetXMLRootElementName: WideString; override;
class function GetXMLIfType: TGUID; override;
end;
TDataSampleXMLHandler12 = class(TXMLHandler<IXMLDataSample2>)
protected
class function GetXMLClass: TClass; override;
class function GetXMLRootElementName: WideString; override;
class function GetXMLIfType: TGUID; override;
end;
TForm3 = class(TForm)
btnXmlSaveToFile: TButton;
procedure btnXmlSaveToFileClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form3: TForm3;
implementation
{$R *.dfm}
type
TXMLSampleDataObj1 = class(TXMLNode, IXMLDataSample1)
private
function GetXmlDataSample1: WideString;
procedure SetXmlDataSample1(const Value: WideString);
end;
TXMLSampleDataObj2 = class(TXMLNode, IXMLDataSample2)
private
function GetXMlDataSample2: WideString;
procedure SetXmlDAtaSample2(const Value: WideString);
end;
procedure TForm3.btnXmlSaveToFileClick(Sender: TObject);
//Works well
vXML1 := TDataSampleXMLHandler1.NewXML;
vXML1.XmlDataSample1 := 'test data';
TDataSampleXMLHandler1.SaveXMLToFile(vXml1, 'C:\Teszt\XmlSample.XML');
//My problem here, cannot add IXMLNode to XMLDocument
vXMLDoc := NewXMLDocument;
vXMLDoc.ChildNodes.Add(vXML1);
//And add vXML2 and more...
vXMLDoc.SaveToFile('C:\Teszt\XmlDocSaveSAmple.XML');
end;
{ TXMLHandler<IXMLType> }
class function TXMLHandler<IXMLType>.ConvertXMLNodeToXMLType(
aNode: IXMLNode): IXMLType;
begin
Result := default(IXMLType);
try
Supports(aNode, GetXMLIfType, result);
finally
aNode := nil;
end;
end;
class function TXMLHandler<IXMLType>.NewXML: IXMLType;
begin
Result :=
ConvertXMLNodeToXMLType(NewXMLDocument.GetDocBinding(GetXMLRootElementName, GetXMLClass, ''));
end;
class procedure TXMLHandler<IXMLType>.SaveXMLToFile(aXML: IXMLType;
const aFileName: string);
begin
aXML.OwnerDocument.SaveToFile(aFileName);
end;
{ TDataSampleXMLHandler12 }
class function TDataSampleXMLHandler12.GetXMLClass: TClass;
begin
Result := TXMLSampleDataObj2;
end;
class function TDataSampleXMLHandler12.GetXMLIfType: TGUID;
begin
Result := IXMLDataSample2;
end;
class function TDataSampleXMLHandler12.GetXMLRootElementName: WideString;
begin
Result := 'Sample2'
end;
{ TDataSampleXMLHandler1 }
class function TDataSampleXMLHandler1.GetXMLClass: TClass;
begin
Result := TXMLSampleDataObj1;
end;
class function TDataSampleXMLHandler1.GetXMLIfType: TGUID;
begin
Result := IXMLDataSample1;
end;
class function TDataSampleXMLHandler1.GetXMLRootElementName: WideString;
begin
Result := 'Sample2';
end;
{ TXMLSampleDataObj1 }
function TXMLSampleDataObj1.GetXmlDataSample1: WideString;
begin
Result := ChildNodes['XmlDataSample1'].Text;
end;
procedure TXMLSampleDataObj1.SetXmlDataSample1(const Value: WideString);
begin
ChildNodes['XmlDataSample1'].NodeValue := Value;
end;
{ TXMLSampleDataObj2 }
function TXMLSampleDataObj2.GetXMLDataSample2: WideString;
begin
Result := ChildNodes['XmlDataSample2'].Text;
end;
procedure TXMLSampleDataObj2.SetXmlDataSample2(const Value: WideString);
begin
ChildNodes['XmlDataSample2'].NodeValue := Value;
end;
end.*
Saving a single XML node to a document is working well. But I want to add these nodes to an XML document the application stoppes, got no error.
My problem here is:
procedure TForm3.btnXmlSaveToFileClick(Sender: TObject);
//Works well
vXML1 := TDataSampleXMLHandler1.NewXML;
vXML1.XmlDataSample1 := 'test data';
TDataSampleXMLHandler1.SaveXMLToFile(vXml1, 'C:\Teszt\XmlSample.XML');
//My problem here, cannot add IXMLNode to XMLDocument
vXMLDoc := NewXMLDocument;
vXMLDoc.ChildNodes.Add(vXML1);
//And add vXML2 and more...
vXMLDoc.SaveToFile('C:\Teszt\XmlDocSaveSAmple.XML');
end;
My finally XML what I want to looks like:
<?xml version="1.0"?>
<Sample2>
<XmlDataSample2>test data</XmlDataSample2>
</Sample2>
<Sample1>
<XmlDataSample1>test data</XmlDataSample1>
</Sample1>
The XML standard allows only 1 top-level element in a document. You are going to have to make your <Sample... > elements be children of another top-level element, eg:
<?xml version="1.0"?>
<Samples>
<Sample2>
<XmlDataSample2>test data</XmlDataSample2>
</Sample2>
<Sample1>
<XmlDataSample1>test data</XmlDataSample1>
</Sample1>
</Samples>
procedure TForm3.btnXmlSaveToFileClick(Sender: TObject);
var
vXMLDoc: IXMLDocument;
vXML1: IXMLDataSample1;
vXMLSamples: IXMLNode;
begin
vXML1 := TDataSampleXMLHandler1.NewXML;
vXML1.XmlDataSample1 := 'test data';
vXMLDoc := NewXMLDocument;
vXMLSamples := vXMLDoc.AddChild('Samples');
vXMLSamples.ChildNodes.Add(vXML1);
//And add vXML2 and more...
vXMLDoc.SaveToFile('C:\Teszt\XmlDocSaveSample.XML');
end;
I have written a simple loader to install my program and its help file.
unit PSInstaller;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Registry, Vcl.StdCtrls, HTMListB,
HTMLabel, System.Zip;
type
TfmPDSInstaller = class(TForm)
HTMLabel1: THTMLabel;
HTMListBox1: THTMListBox;
btnNext: TButton;
Button1: TButton;
procedure FormCreate(Sender: TObject);
procedure FormShow(Sender: TObject);
procedure btnNextClick(Sender: TObject);
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
function InstallFile(ResID: integer; pName: String): Boolean;
public
{ Public declarations }
end;
var
fmPDSInstaller: TfmPDSInstaller;
implementation
{$R 'ProtonStudio32.res' 'ProtonStudio32.rc'}
{$R *.dfm}
Var IDEDirectory: String;
Const APP = 100;
HELP = 200;
procedure TfmPDSInstaller.btnNextClick(Sender: TObject);
begin
HTMListBox1.AddItem('Copying Proton Studio to Proton IDE directory',nil);
if InstallFile(APP, 'Studio Application') then begin
HTMListBox1.AddItem('Copying Proton Studio Help to Proton IDE directory',nil);
If InstallFile(HELP, 'Studio Help') then
HTMListBox1.AddItem('Proton Studio Installed', nil);
end;
end;
function TfmPDSInstaller.InstallFile(ResID: integer; pName: String): Boolean;
Var rs: TResourceStream;
Zip: TZipFile;
s: String;
begin
Result := false;
try
Rs := TResourceStream.CreateFromID(HInstance, ResID, RT_RCDATA);
Zip := TZipFile.Create;
try
Zip.Open(Rs,zmRead);
Zip.ExtractAll(IDEDirectory);
finally
Rs.Free;
Zip.Free;
Result := true;
end;
except
on EFOpenError do
s := 'Unable to Open resource ' + pName;
else
s := 'Unable to Copy file from resource ' + pName;
end;
HTMListBox1.AddItem(s, nil);
end;
procedure TfmPDSInstaller.Button1Click(Sender: TObject);
begin
Close;
end;
procedure TfmPDSInstaller.FormCreate(Sender: TObject);
Var Reg: TRegistry;
begin
btnNext.Enabled := false;
Reg := TRegistry.Create;
HTMListBox1.AddItem('Checking for ProtonIDE',nil);
if Reg.OpenKey('Software\MecaniqueUK\ProtonIDE\Install', false) then begin
IDEDirectory := Reg.ReadString('IDE');
Reg.CloseKey;
end;
Reg.Free;
end;
procedure TfmPDSInstaller.FormShow(Sender: TObject);
begin
btnNext.Enabled := false;
if DirectoryExists(IDEDirectory) then begin
HTMListbox1.AddItem('Click Next to install Proton Studio in ' + IDEDirectory, nil);
btnNext.Enabled := true;
end
else
HTMListBox1.AddItem('Proton IDE must be installed first', nil);
end;
end.
I have created a .rc script to load my program and help
#100 RT_RCDATA "D:\Data\Documents\RAD Studio\Projects\ProtonNewIDE\Win32\Debug\ProtonNewIDE.zip"
#200 RT_RCDATA "D:\Data\Documents\RAD Studio\Projects\ProtonNewIDE\Win32\Debug\Proton Studio.zip"
I'm working in Delphi Berlin 10.1, Build resulted in my resource file being generated and I can open it in my Resource Editor but when I try and open the resource:
Rs := TResourceStream.CreateFromID(Application.Handle, ResID, RT_RCDATA);
I get an Address violation. It breaks in System.Classes at this point:
HResInfo := FindResource(Instance, Name, ResType);
and both the Name and ResType are empty.
I would appreciate a pointer to what am I doing wrong?
You are passing a window handle instead of a module handle. Pass HInstance instead, the handle to the module containing this code.
I would like to create a Windows Service (with Delphi) that will attempt, every hour, to retrieve a specific file from a specific Amazon S3 Bucket.
I have no problem accessing the Amazon S3 Bucket with my VCL application. However, if I try to run the same function through my Windows Service, it returns absolutely nothing. I believe that it is a permission issue: my Service does not permission to access the outside world.
What should I do to remedy my problem?
I am using Delphi Tokyo Update 3, my Service is built upon a DataSnap Server.
Here is the code for my 'server container' unit:
unit UnitOurDataSnapServerContainer;
interface
uses
System.SysUtils, System.Classes, System.Win.Registry, Vcl.SvcMgr,
Datasnap.DSTCPServerTransport,
Datasnap.DSServer, Datasnap.DSCommonServer,
IPPeerServer, IPPeerAPI, Datasnap.DSAuth;
type
TServerContainer_OurCompany = class(TService)
DSServer_OurCompany: TDSServer;
DSServerClass_OurCompany: TDSServerClass;
DSTCPServerTransport_OurCompany: TDSTCPServerTransport;
procedure DSServerClass_OurCompanyGetClass(DSServerClass: TDSServerClass; var PersistentClass: TPersistentClass);
procedure ServiceStart(Sender: TService; var Started: Boolean);
private
{ Private declarations }
protected
function DoStop: Boolean; override;
function DoPause: Boolean; override;
function DoContinue: Boolean; override;
procedure DoInterrogate; override;
public
function GetServiceController: TServiceController; override;
end;
var
ServerContainer_OurCompany: TServerContainer_OurCompany;
implementation
{$R *.dfm}
uses
Winapi.Windows,
UnitOurDataSnapServerMethods;
procedure TServerContainer_OurCompany.DSServerClass_OurCompanyGetClass(DSServerClass: TDSServerClass; var PersistentClass: TPersistentClass);
begin
PersistentClass := UnitOurDataSnapServerMethods.TOurDataSnapServerMethods;
end;
procedure ServiceController(CtrlCode: DWord); stdcall;
begin
ServerContainer_OurCompany.Controller(CtrlCode);
end;
function TServerContainer_OurCompany.GetServiceController: TServiceController;
begin
Result := ServiceController;
end;
function TServerContainer_OurCompany.DoContinue: Boolean;
begin
Result := inherited;
DSServer_OurCompany.Start;
end;
procedure TServerContainer_OurCompany.DoInterrogate;
begin
inherited;
end;
function TServerContainer_OurCompany.DoPause: Boolean;
begin
DSServer_OurCompany.Stop;
Result := inherited;
end;
function TServerContainer_OurCompany.DoStop: Boolean;
begin
DSServer_OurCompany.Stop;
Result := inherited;
end;
procedure TServerContainer_OurCompany.ServiceStart(Sender: TService; var Started: Boolean);
begin
{$IFDEF RELEASE}
DSServer_OurCompany.HideDSAdmin := True;
{$ENDIF}
DSServer_OurCompany.Start;
end;
end.
Here is the code for my 'servermethods' unit:
unit UnitOurDataSnapServerMethods;
interface
uses
System.SysUtils, System.Classes, Datasnap.DSServer, Datasnap.DSAuth;
type
{$METHODINFO ON}
TOurDataSnapServerMethods = class(TComponent)
private
{ Private declarations }
public
{ Public declarations }
function Get_ListOfFilesInS3Bucket(aS3Path: String; aFileExtension: String) : Integer;
end;
{$METHODINFO OFF}
implementation
uses
Data.Cloud.CloudAPI, Data.Cloud.AmazonAPI;
function TOurDataSnapServerMethods.Get_ListOfFilesInS3Bucket(aS3Path: String; aFileExtension: String) : Integer;
var
iFileList: TStrings;
iFileExtension: String;
iOptionalParams: TStrings;
iResponseInfo: TCloudResponseInfo;
iStorageService: TAmazonStorageService;
iAmazonBucketResult: TAmazonBucketResult;
iAmazonObjectResult: TAmazonObjectResult;
iAmazonConnectionInfo: TAmazonConnectionInfo;
begin
Result := 0;
iFileExtension := aFileExtension;
if Pos('.', iFileExtension) = 0 then
iFileExtension := '.' + iFileExtension;
try
iAmazonConnectionInfo := TAmazonConnectionInfo.Create(nil);
iAmazonConnectionInfo.AccountName := 'AKIA****************';
iAmazonConnectionInfo.AccountKey := 'BzNn************************************';
iOptionalParams := TStringList.Create;
iOptionalParams.Values['prefix'] := aS3Path;
iStorageService := TAmazonStorageService.Create(iAmazonConnectionInfo);
iResponseInfo := TCloudResponseInfo.Create;
iAmazonBucketResult := nil;
iFileList := TStringList.Create;
try
iAmazonBucketResult := iStorageService.GetBucket('our-s3-bucket', iOptionalParams, iResponseInfo);
for iAmazonObjectResult in iAmazonBucketResult.Objects do
begin
if Pos(iFileExtension, iAmazonObjectResult.Name) <> 0 then
iFileList.Add(iAmazonObjectResult.Name);
end;
Result := iFileList.Count;
except
on e: Exception do
;
end;
FreeAndNil(iAmazonBucketResult);
finally
iFileList.Free;
iResponseInfo.Free;
iStorageService.Free;
iOptionalParams.Free;
iAmazonConnectionInfo.Free;
end;
end;
end.
It is the call to 'iStorageService.GetBucket' that returns nothing.
I am trying to write class that inherits from FMX TStyledControl. When style is updated it loads style resource objects to cache.
I created project group for package with custom controls and test FMX HD project as it describes in Delphi help. After installing package and placing TsgSlideHost on the test form I run test app. It works well, but when I close it and try to rebuild package RAD Studio says “Error in rtl160.bpl” or “invalid pointer operation”.
It seems what problem in LoadToCacheIfNeeded procedure from TsgStyledControl, but I’m not understand why. Is there any restriction on using RTTI with FMX styles or anything?
TsgStyledControl sources:
unit SlideGUI.TsgStyledControl;
interface
uses
System.SysUtils, System.Classes, System.Types, FMX.Types, FMX.Layouts, FMX.Objects,
FMX.Effects, System.UITypes, FMX.Ani, System.Rtti, System.TypInfo;
type
TCachedAttribute = class(TCustomAttribute)
private
fStyleName: string;
public
constructor Create(const aStyleName: string);
property StyleName: string read fStyleName;
end;
TsgStyledControl = class(TStyledControl)
private
procedure CacheStyleObjects;
procedure LoadToCacheIfNeeded(aField: TRttiField);
protected
function FindStyleResourceAs<T: class>(const AStyleLookup: string): T;
function GetStyleName: string; virtual; abstract;
function GetStyleObject: TControl; override;
public
procedure ApplyStyle; override;
published
{ Published declarations }
end;
implementation
{ TsgStyledControl }
procedure TsgStyledControl.ApplyStyle;
begin
inherited;
CacheStyleObjects;
end;
procedure TsgStyledControl.CacheStyleObjects;
var
ctx: TRttiContext;
typ: TRttiType;
fld: TRttiField;
begin
ctx := TRttiContext.Create;
try
typ := ctx.GetType(Self.ClassType);
for fld in typ.GetFields do
LoadFromCacheIfNeeded(fld);
finally
ctx.Free
end;
end;
function TsgStyledControl.FindStyleResourceAs<T>(const AStyleLookup: string): T;
var
fmxObj: TFmxObject;
begin
fmxObj := FindStyleResource(AStyleLookup);
if Assigned(fmxObj) and (fmxObj is T) then
Result := fmxObj as T
else
Result := nil;
end;
function TsgStyledControl.GetStyleObject: TControl;
var
S: TResourceStream;
begin
if (FStyleLookup = '') then
begin
if FindRCData(HInstance, GetStyleName) then
begin
S := TResourceStream.Create(HInstance, GetStyleName, RT_RCDATA);
try
Result := TControl(CreateObjectFromStream(nil, S));
Exit;
finally
S.Free;
end;
end;
end;
Result := inherited GetStyleObject;
end;
procedure TsgStyledControl.LoadToCacheIfNeeded(aField: TRttiField);
var
attr: TCustomAttribute;
styleName: string;
styleObj: TFmxObject;
val: TValue;
begin
for attr in aField.GetAttributes do
begin
if attr is TCachedAttribute then
begin
styleName := TCachedAttribute(attr).StyleName;
if styleName <> '' then
begin
styleObj := FindStyleResource(styleName);
val := TValue.From<TFmxObject>(styleObj);
aField.SetValue(Self, val);
end;
end;
end;
end;
{ TCachedAttribute }
constructor TCachedAttribute.Create(const aStyleName: string);
begin
fStyleName := aStyleName;
end;
end.
Using of TsgStyledControl:
type
TsgSlideHost = class(TsgStyledControl)
private
[TCached('SlideHost')]
fSlideHost: TLayout;
[TCached('SideMenu')]
fSideMenuLyt: TLayout;
[TCached('SlideContainer')]
fSlideContainer: TLayout;
fSideMenu: IsgSideMenu;
procedure ReapplyProps;
procedure SetSideMenu(const Value: IsgSideMenu);
protected
function GetStyleName: string; override;
function GetStyleObject: TControl; override;
procedure UpdateSideMenuLyt;
public
constructor Create(AOwner: TComponent); override;
procedure ApplyStyle; override;
published
property SideMenu: IsgSideMenu read fSideMenu write SetSideMenu;
end;
Using TRttiField.GetAttributes leads to errors in design-time. It's a bug in Delphi XE2. See QC Report.