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;
Related
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 reading Hodges book "More Coding in Delphi", section on Factory Pattern. I come up with a problem. I need to implement Init procedures for each descendant of TBaseGateway class. The problem is I do not know how to pass correct record type. Is there any nice solution?
unit Unit2;
interface
uses
Generics.Collections, System.SysUtils, System.Classes, Dialogs;
type
TGatewayTpe = (gtSwedbank, gtDNB);
type
IGateway = interface
['{07472665-54F5-4868-B4A7-D68134B9770B}']
procedure Send(const AFilesToSend: TStringList);
end;
type
TBaseGateway = class(TAggregatedObject, IGateway)
public
procedure Send(const AFilesToSend: TStringList); virtual; abstract;
end;
type
TSwedbankGateway = class(TBaseGateway)
public
// procedure Init(const ASwedbanRecord: TSwedBankRecord);
procedure Send(const AFilesToSend: TStringList); override;
end;
type
TDNBGateway = class(TBaseGateway)
public
// procedure Init(const ADNBRecord: TDNBRecord);
procedure Send(const AFilesToSend: TStringList); override;
end;
type
TGatewayFunction = reference to function: TBaseGateway;
type
TGatewayTypeAndFunction = record
GatewayType: TGatewayTpe;
GatewayFunction: TGatewayFunction;
end;
type
TGatewayFactory = class
strict private
class var FGatewayTypeAndFunctionList: TList<TGatewayTypeAndFunction>;
public
class constructor Create;
class destructor Destroy;
class procedure AddGateway(const AGatewayType: TGatewayTpe;
const AGatewayFunction: TGatewayFunction);
end;
implementation
class procedure TGatewayFactory.AddGateway(const AGatewayType: TGatewayTpe;
const AGatewayFunction: TGatewayFunction);
var
_GatewayTypeAndFunction: TGatewayTypeAndFunction;
begin
_GatewayTypeAndFunction.GatewayType := AGatewayType;
_GatewayTypeAndFunction.GatewayFunction := AGatewayFunction;
FGatewayTypeAndFunctionList.Add(_GatewayTypeAndFunction);
end;
class constructor TGatewayFactory.Create;
begin
FGatewayTypeAndFunctionList := TList<TGatewayTypeAndFunction>.Create;
end;
class destructor TGatewayFactory.Destroy;
begin
FreeAndNil(FGatewayTypeAndFunctionList);
end;
procedure TSwedbankGateway.Send(const AFilesToSend: TStringList);
begin
ShowMessage(Self.ClassName);
end;
procedure TDNBGateway.Send(const AFilesToSend: TStringList);
begin
ShowMessage(Self.ClassName);
end;
initialization
TGatewayFactory.AddGateway(gtDNB,
function: TBaseGateway
begin
Result := TDNBGateway.Create(nil);
end);
TGatewayFactory.AddGateway(gtSwedbank,
function: TBaseGateway
begin
Result := TSwedbankGateway.Create(nil);
end);
end.
If we look into the online help of XE2 or XE3 for TObjectList methods
, we see that the binarysearch function is accessible for the TObjectList. But if we try into XE3 it doesn't even compile.
For the example, the sort function is available also, but this one compile.
Any idea is welcome.
Sample code :
unit FM_Main;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, System.Contnrs, Vcl.CheckLst, System.Generics.Collections;
type
TTPRODData = class
private
FData1 : String;
FData2 : String;
FCount : Integer;
public
constructor Create; overload;
destructor Destroy; override;
end;
TTPRODDataList = class(TObjectList)
function GetItem(Index: Integer): TTPRODData;
procedure SetItem(Index: Integer; const Value: TTPRODData);
public
constructor Create; overload;
destructor Destroy; override;
property Items[Index: Integer]: TTPRODData read GetItem write SetItem; default;
procedure SortOnProductCode;
end;
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
//
// Sort function.
//
function CompareProductCode(Item1, Item2: Pointer): Integer;
begin
Result := CompareStr(TTPRODData(Item1).FData1, TTPRODData(Item2).FData1);
end;
//
//
//
procedure TForm1.Button1Click(Sender: TObject);
var
aProdList : TTPRODDataList;
aDummy : TTPRODData;
aNdx : Integer;
begin
aProdList := TTPRODDataList.Create;
// This call works.
aProdList.Sort(CompareProductCode);
// This call doesn't even compile !
aProdList.BinarySearch(aDummy, aNdx);
end;
{ TTPRODData }
constructor TTPRODData.Create;
begin
inherited Create;
FData1 := '';
FData2 := '';
FCount := 0;
end;
destructor TTPRODData.Destroy;
begin
inherited;
end;
{ TTPRODDataList }
constructor TTPRODDataList.Create;
begin
inherited Create;
end;
destructor TTPRODDataList.Destroy;
begin
Clear;
inherited;
end;
function TTPRODDataList.GetItem(Index: Integer): TTPRODData;
begin
result := TTPRODData(inherited GetItem(index));
end;
procedure TTPRODDataList.SetItem(Index: Integer; const Value: TTPRODData);
begin
inherited setItem(index, value);
end;
procedure TTPRODDataList.SortOnProductCode;
begin
Sort(CompareProductCode);
end;
end.
As suggested by David Heffernan, here follow the code for the comparer for the sort function.
For those who are interested, here follow the code for the comparer method:
TTProdComparer = class(TComparer<TTPRODData>)
public
function Compare(const Item1, Item2: TTPRODData): Integer; override;
end;
And the code :
{ TTProdComparer }
function TTProdComparer.Compare(const Item1, Item2: TTPRODData): Integer;
begin
Result := CompareStr(Item1.FData1 , Item2.FData1 );
end;
The documentation that you have linked to is for the generic container TObjectList<T> from the Generics.Collections unit.
But the class that you have used in your code is the legacy non-generic container TObjectList from the Contnrs unit.
The BinarySearch method that you are trying to use only exists on the generic class.
If you switch to the generic container then you'll find that you can remove most of the boiler-plate code from your class. It becomes:
TTPRODDataList = class(TObjectList<TTPRODData>)
public
procedure SortOnProductCode;
end;
You don't need GetItem, SetItem and Items because the type-safe generic class already has that functionality sorted.
The only work you have to do is to adapt your sorting code to fit with the somewhat different interface used by the Delphi generic containers.
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.
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.