How to consume in process server method with DataSnap 2010 - delphi

I define a server method:
TServerMethod = class(TPersistent)
public
function EchoString(Value: string): string;
end;
The method EchoString return an equivalent Value string.
I then use TDSTCPServerTransport with TDSServer and TDSServerClass to wrap the server methods.
In client side, I create a DataSnap TSQLConnection and generate a TServerMethodProxy client class:
function TServerMethodClient.EchoString(Value: string): string;
begin
if FEchoStringCommand = nil then
begin
FEchoStringCommand := FDBXConnection.CreateCommand;
FEchoStringCommand.CommandType := TDBXCommandTypes.DSServerMethod;
FEchoStringCommand.Text := 'TServerMethod.EchoString';
FEchoStringCommand.Prepare;
end;
FEchoStringCommand.Parameters[0].Value.SetWideString(Value);
FEchoStringCommand.ExecuteUpdate;
Result := FEchoStringCommand.Parameters[1].Value.GetWideString;
end;
I able to consume the EchoString method via TCP connection in client application:
var o: TServerMethodClient;
begin
o := TSeverMethodClient.Create(SQLConnection1.DBXConnection);
try
ShowMessage(o.EchoString('Hello'));
finally
o.Free;
end;
end;
The above scenarios is using TCP/IP as communication protocol.
However, I wish to deploy my ServerMethod together with my client as "In Process" model. How can I achieve that without changing my client and server method code?
What parameter should I pass to TServerMethodClient.Create constructor in order to establish a in process connection?
o := TSeverMethodClient.Create(SQLConnection1.DBXConnection);
In old DataSnap day, we can use TLocalConnection to enjoy In Process access without changing both client and server codes.

DataSnap Server Method was introduced in Delphi 2009. Most video or demo about DataSnap server method available only introduce socket based client server access communication. e.g.: TCP or HTTP protocol.
However, DataSnap was designed as a scalable data access solution that able to work with one, two, three or more tiers model. All examples we see so far are suitable for 2 or 3 tiers design. I can’t find any example talking about 1 tier or in-process design.
Indeed, it is very simple to work with in-process server method. Most steps are similar to out-of-process server methods.
Define a Server Method
Define a well known EchoString() and a Sum() server method:
unit MyServerMethod;
interface
uses Classes, DBXCommon;
type
{$MethodInfo On}
TMyServerMethod = class(TPersistent)
public
function EchoString(Value: string): string;
function Sum(const a, b: integer): integer;
end;
{$MethodInfo Off}
implementation
function TMyServerMethod.EchoString(Value: string): string;
begin
Result := Value;
end;
function TMyServerMethod.Sum(const a, b: integer): integer;
begin
Result := a + b;
end;
end.
Define a DataModule to access the server method
Drop a TDSServer and TDSServerClass as usual to the data module. Define a OnGetClass event to TDSServerClass instance. Please note that you don’t need to drop any transport components like TDSTCPServerTransport or TDSHTTPServer as we only want to consume the server method for in-process only.
object MyServerMethodDataModule1: TMyServerMethodDataModule
OldCreateOrder = False
Height = 293
Width = 419
object DSServer1: TDSServer
AutoStart = True
HideDSAdmin = False
Left = 64
Top = 40
end
object DSServerClass1: TDSServerClass
OnGetClass = DSServerClass1GetClass
Server = DSServer1
LifeCycle = 'Server'
Left = 64
Top = 112
end
end
unit MyServerMethodDataModule;
uses MyServerMethod;
procedure TMyServerMethodDataModule.DSServerClass1GetClass(
DSServerClass: TDSServerClass; var PersistentClass: TPersistentClass);
begin
PersistentClass := TMyServerMethod;
end;
Generate Server Method Client Classes
It is not easy to generate the server method client classes design for in-process server. You may try any methods you are familiar with to hook up your server method to TCP or HTTP transport service, start the service and attempt to generate the client class by any means.
//
// Created by the DataSnap proxy generator.
//
unit DataSnapProxyClient;
interface
uses DBXCommon, DBXJSON, Classes, SysUtils, DB, SqlExpr, DBXDBReaders;
type
TMyServerMethodClient = class
private
FDBXConnection: TDBXConnection;
FInstanceOwner: Boolean;
FEchoStringCommand: TDBXCommand;
public
constructor Create(ADBXConnection: TDBXConnection); overload;
constructor Create(ADBXConnection: TDBXConnection; AInstanceOwner: Boolean); overload;
destructor Destroy; override;
function EchoString(Value: string): string;
function Sum(const a, b: integer): integer;
end;
implementation
function TMyServerMethodClient.EchoString(Value: string): string;
begin
if FEchoStringCommand = nil then
begin
FEchoStringCommand := FDBXConnection.CreateCommand;
FEchoStringCommand.CommandType := TDBXCommandTypes.DSServerMethod;
FEchoStringCommand.Text := 'TMyServerMethod.EchoString';
FEchoStringCommand.Prepare;
end;
FEchoStringCommand.Parameters[0].Value.SetWideString(Value);
FEchoStringCommand.ExecuteUpdate;
Result := FEchoStringCommand.Parameters[1].Value.GetWideString;
end;
function TMyServerMethodClient.Sum(a: Integer; b: Integer): Integer;
begin
if FSumCommand = nil then
begin
FSumCommand := FDBXConnection.CreateCommand;
FSumCommand.CommandType := TDBXCommandTypes.DSServerMethod;
FSumCommand.Text := 'TMyServerMethod.Sum';
FSumCommand.Prepare;
end;
FSumCommand.Parameters[0].Value.SetInt32(a);
FSumCommand.Parameters[1].Value.SetInt32(b);
FSumCommand.ExecuteUpdate;
Result := FSumCommand.Parameters[2].Value.GetInt32;
end;
constructor TMyServerMethodClient.Create(ADBXConnection: TDBXConnection);
begin
inherited Create;
if ADBXConnection = nil then
raise EInvalidOperation.Create('Connection cannot be nil. Make sure the connection has been opened.');
FDBXConnection := ADBXConnection;
FInstanceOwner := True;
end;
constructor TMyServerMethodClient.Create(ADBXConnection: TDBXConnection; AInstanceOwner: Boolean);
begin
inherited Create;
if ADBXConnection = nil then
raise EInvalidOperation.Create('Connection cannot be nil. Make sure the connection has been opened.');
FDBXConnection := ADBXConnection;
FInstanceOwner := AInstanceOwner;
end;
destructor TMyServerMethodClient.Destroy;
begin
FreeAndNil(FEchoStringCommand);
inherited;
end;
end.
Invoke the server method via in-process
You may see from the following code that there is no different to access the server method for in-process and out-of-process design.
First, you create an instant of datasnap server. This will register the DSServer to the TDBXDriverRegistry. e.g. DSServer1 in this case.
You may then use TSQLConnection with DSServer1 as driver name instead of “DataSnap” that require socket connection to initiate in-process communication invoking the server method.
var o: TMyServerMethodDataModule;
Q: TSQLConnection;
c: TMyServerMethodClient;
begin
o := TMyServerMethodDataModule.Create(Self);
Q := TSQLConnection.Create(Self);
try
Q.DriverName := 'DSServer1';
Q.LoginPrompt := False;
Q.Open;
c := TMyServerMethodClient.Create(Q.DBXConnection);
try
ShowMessage(c.EchoString('Hello'));
finally
c.Free;
end;
finally
o.Free;
Q.Free;
end;
end;
Troubleshoot: Encounter Memory Leak after consume the in-process server methods
This happens in Delphi 2010 build 14.0.3513.24210. It may have fixed in future release. You may check QC#78696 for latest status. Please note that you need to add “ReportMemoryLeaksOnShutdown := True;” in the code to show the leak report.
The memory leaks has no relation with in-process server methods. It should be a problem in class TDSServerConnection where a property ServerConnectionHandler doesn’t free after consume.
Here is a fix for the problem:
unit DSServer.QC78696;
interface
implementation
uses SysUtils,
DBXCommon, DSServer, DSCommonServer, DBXMessageHandlerCommon, DBXSqlScanner,
DBXTransport,
CodeRedirect;
type
TDSServerConnectionHandlerAccess = class(TDBXConnectionHandler)
FConProperties: TDBXProperties;
FConHandle: Integer;
FServer: TDSCustomServer;
FDatabaseConnectionHandler: TObject;
FHasServerConnection: Boolean;
FInstanceProvider: TDSHashtableInstanceProvider;
FCommandHandlers: TDBXCommandHandlerArray;
FLastCommandHandler: Integer;
FNextHandler: TDBXConnectionHandler;
FErrorMessage: TDBXErrorMessage;
FScanner: TDBXSqlScanner;
FDbxConnection: TDBXConnection;
FTransport: TDSServerTransport;
FChannel: TDbxChannel;
FCreateInstanceEventObject: TDSCreateInstanceEventObject;
FDestroyInstanceEventObject: TDSDestroyInstanceEventObject;
FPrepareEventObject: TDSPrepareEventObject;
FConnectEventObject: TDSConnectEventObject;
FErrorEventObject: TDSErrorEventObject;
FServerCon: TDSServerConnection;
end;
TDSServerConnectionPatch = class(TDSServerConnection)
public
destructor Destroy; override;
end;
TDSServerDriverPatch = class(TDSServerDriver)
protected
function CreateConnectionPatch(ConnectionBuilder: TDBXConnectionBuilder): TDBXConnection;
end;
destructor TDSServerConnectionPatch.Destroy;
begin
inherited Destroy;
TDSServerConnectionHandlerAccess(ServerConnectionHandler).FServerCon := nil;
ServerConnectionHandler.Free;
end;
function TDSServerDriverPatch.CreateConnectionPatch(
ConnectionBuilder: TDBXConnectionBuilder): TDBXConnection;
begin
Result := TDSServerConnectionPatch.Create(ConnectionBuilder);
end;
var QC78696: TCodeRedirect;
initialization
QC78696 := TCodeRedirect.Create(#TDSServerDriverPatch.CreateConnection, #TDSServerDriverPatch.CreateConnectionPatch);
finalization
QC78696.Free;
end.
Troubleshoot: Encounter "Invalid command handle" when consume more than one server method at runtime for in-process application
This happens in Delphi 2010 build 14.0.3513.24210. It may have fixed in future release. You may check QC#78698 for latest status.
To replay this problem, you may consume the server method as:
c := TMyServerMethodClient.Create(Q.DBXConnection);
try
ShowMessage(c.EchoString('Hello'));
ShowMessage(IntToStr(c.Sum(100, 200)));
finally
c.Free;
end;
or this:
c := TMyServerMethodClient.Create(Q.DBXConnection);
try
ShowMessage(c.EchoString('Hello'));
ShowMessage(IntToStr(c.Sum(100, 200)));
ShowMessage(c.EchoString('Hello'));
finally
c.Free;
end;
Here is a fix for the problem
unit DSServer.QC78698;
interface
implementation
uses SysUtils, Classes,
DBXCommon, DBXMessageHandlerCommon, DSCommonServer, DSServer,
CodeRedirect;
type
TDSServerCommandAccess = class(TDBXCommand)
private
FConHandler: TDSServerConnectionHandler;
FServerCon: TDSServerConnection;
FRowsAffected: Int64;
FServerParameterList: TDBXParameterList;
end;
TDSServerCommandPatch = class(TDSServerCommand)
private
FCommandHandle: integer;
function Accessor: TDSServerCommandAccess;
private
procedure ExecutePatch;
protected
procedure DerivedClose; override;
function DerivedExecuteQuery: TDBXReader; override;
procedure DerivedExecuteUpdate; override;
function DerivedGetNextReader: TDBXReader; override;
procedure DerivedPrepare; override;
end;
TDSServerConnectionPatch = class(TDSServerConnection)
public
function CreateCommand: TDBXCommand; override;
end;
TDSServerDriverPatch = class(TDSServerDriver)
private
function CreateServerCommandPatch(DbxContext: TDBXContext; Connection:
TDBXConnection; MorphicCommand: TDBXCommand): TDBXCommand;
public
constructor Create(DBXDriverDef: TDBXDriverDef); override;
end;
constructor TDSServerDriverPatch.Create(DBXDriverDef: TDBXDriverDef);
begin
FCommandFactories := TStringList.Create;
rpr;
InitDriverProperties(TDBXProperties.Create);
// '' makes this the default command factory.
//
AddCommandFactory('', CreateServerCommandPatch);
end;
function TDSServerDriverPatch.CreateServerCommandPatch(DbxContext: TDBXContext;
Connection: TDBXConnection; MorphicCommand: TDBXCommand): TDBXCommand;
var
ServerConnection: TDSServerConnection;
begin
ServerConnection := Connection as TDSServerConnection;
Result := TDSServerCommandPatch.Create(DbxContext, ServerConnection, TDSServerHelp.GetServerConnectionHandler(ServerConnection));
end;
function TDSServerCommandPatch.Accessor: TDSServerCommandAccess;
begin
Result := TDSServerCommandAccess(Self);
end;
procedure TDSServerCommandPatch.DerivedClose;
var
Message: TDBXCommandCloseMessage;
begin
Message := Accessor.FServerCon.CommandCloseMessage;
Message.CommandHandle := FCommandHandle;
Message.HandleMessage(Accessor.FConHandler);
end;
function TDSServerCommandPatch.DerivedExecuteQuery: TDBXReader;
var
List: TDBXParameterList;
Parameter: TDBXParameter;
Reader: TDBXReader;
begin
ExecutePatch;
List := Parameters;
if (List <> nil) and (List.Count > 0) then
begin
Parameter := List.Parameter[List.Count - 1];
if Parameter.DataType = TDBXDataTypes.TableType then
begin
Reader := Parameter.Value.GetDBXReader;
Parameter.Value.SetNull;
Exit(Reader);
end;
end;
Result := nil;
end;
procedure TDSServerCommandPatch.DerivedExecuteUpdate;
begin
ExecutePatch;
end;
function TDSServerCommandPatch.DerivedGetNextReader: TDBXReader;
var
Message: TDBXNextResultMessage;
begin
Message := Accessor.FServerCon.NextResultMessage;
Message.CommandHandle := FCommandHandle;
Message.HandleMessage(Accessor.FConHandler);
Result := Message.NextResult;
end;
procedure TDSServerCommandPatch.DerivedPrepare;
begin
inherited;
FCommandHandle := Accessor.FServerCon.PrepareMessage.CommandHandle;
end;
procedure TDSServerCommandPatch.ExecutePatch;
var
Count: Integer;
Ordinal: Integer;
Params: TDBXParameterList;
CommandParams: TDBXParameterList;
Message: TDBXExecuteMessage;
begin
Message := Accessor.FServerCon.ExecuteMessage;
if not IsPrepared then
Prepare;
for ordinal := 0 to Parameters.Count - 1 do
Accessor.FServerParameterList.Parameter[Ordinal].Value.SetValue(Parameters.Parameter[Ordinal].Value);
Message.Command := Text;
Message.CommandType := CommandType;
Message.CommandHandle := FCommandHandle;
Message.Parameters := Parameters;
Message.HandleMessage(Accessor.FConHandler);
Params := Message.Parameters;
CommandParams := Parameters;
if Params <> nil then
begin
Count := Params.Count;
if Count > 0 then
for ordinal := 0 to Count - 1 do
begin
CommandParams.Parameter[Ordinal].Value.SetValue(Params.Parameter[Ordinal].Value);
Params.Parameter[Ordinal].Value.SetNull;
end;
end;
Accessor.FRowsAffected := Message.RowsAffected;
end;
function TDSServerConnectionPatch.CreateCommand: TDBXCommand;
var
Command: TDSServerCommand;
begin
Command := TDSServerCommandPatch.Create(FDbxContext, self, ServerConnectionHandler);
Result := Command;
end;
var QC78698: TCodeRedirect;
initialization
QC78698 := TCodeRedirect.Create(#TDSServerConnection.CreateCommand, #TDSServerConnectionPatch.CreateCommand);
finalization
QC78698.Free;
end.
Reference:
QC#78696: Memory Leak in
TDSServerConnection for in-process
connection
QC#78698: Encounter "Invalid command
handle" when consume more than one
server method at runtime for
in-process application

See DataSnap: In-Process Server Method.

Related

Unexpected failure of custom registered Reverter using TJSONUnMarshal

The code below is from the JSonMarshall project in chapter 7 of Marco Cantu's Delphi 2010 Handbook. The source code is available from here http://cc.embarcadero.com/item/27600. I have made two changes to it:
Add JSon to the implementation Uses clause to get it to compile.
Added the line
theName := 'XXX'; // added by me
to the TDataWithList.Create constructor to assist debugging
I am running the code in Delphi Seattle (without update 1)
The purpose of the project is to demo a custom converter and reverter for the TDataWithList declared type. The custom converter seems to work fine, judging by the result output to Memo1.
However, attempting to run the reverter results in a "Read of address 00000000" AV on the line
sList.Add (Args[I]);
in btnUnmarshalReverterClick. The immediate cause of this is that contrary to what
the author evidently intended, when the above line executes, sList is Nil.
My question is simply why is sList Nil and how to fix this problem?
I have tried, not entirely successfully, to trace through the DBXJSONReflect source
to find out why.
After
Obj := ObjectInstance(FRTTICtx, objType);
in function TJSONUnMarshal.CreateObject, TDataWithList(obj).theName is 'XXX'
as I'd expect and TDataWithList(obj).theLList is an initialized, but empty,
TStringList.
However, by the time the anonymous method in btnUnmarshalReverterClick is called, TDataWithList(Data).theList is Nil.
Update: The reason that TDataWithList(Data).theList (incorrectly, imo) becomes Nil is that it is set to Nil in TJSONPopulationCustomizer.PrePopulate by a call to PrePopulateObjField. So I suppose the question is, why does PrePopulate allow an object's field which has been initialized in its constructor to be overwritten as if it knows better that the object's constructor.
Update2:
There may be an additional problem, in that as far as I can tell, in
TInternalJSONPopulationCustomizer.PrePopulateObjField, the assignment which overwrites TListWithData.theList with Nil, namely
rttiField.SetValue(Data, TValue.Empty);
does not seem to result in the TStringlist destructor being called.
Btw, I get the same error running the project in XE4, which is the earliest version I have which includes JSonUnMarshal.
Code:
type
[...]
TDataWithList = class
private
theName: String;
theList: TStringList;
public
constructor Create (const aName: string); overload;
constructor Create; overload;
function ToString: string; override;
destructor Destroy; override;
end;
[...]
procedure TFormJson.btnMarshalConverterClick(Sender: TObject);
var
theData: TDataWithList;
jMarshal: TJSONMarshal;
jValue: TJSONValue;
begin
theData := TDataWithList.Create('john');
try
jMarshal := TJSONMarshal.Create(
TJSONConverter.Create); // converter is owned
try
jMarshal.RegisterConverter(TDataWithList, 'theList',
function (Data: TObject; Field: string): TListOfStrings
var
I: Integer;
sList: TStringList;
begin
sList := TDataWithList(Data).theList;
SetLength(Result, sList.Count);
for I := 0 to sList.Count - 1 do
Result[I] := sList[I];
end);
jValue := jMarshal.Marshal(theData);
try
Memo1.Lines.Text := jValue.ToString;
finally
jValue.Free;
end;
finally
jMarshal.Free;
end;
finally
theData.Free;
end;
end;
procedure TFormJson.btnUnmarshalReverterClick(Sender: TObject);
var
jUnmarshal: TJSONUnMarshal;
jValue: TJSONValue;
anObject: TObject;
begin
jValue := TJSONObject.ParseJSONValue(
TEncoding.ASCII.GetBytes (Memo1.Lines.Text), 0);
try
jUnmarshal := TJSONUnMarshal.Create;
try
jUnmarshal.RegisterReverter(TDataWithList, 'theList',
procedure (Data: TObject; Field: string; Args: TListOfStrings)
var
I: Integer;
sList: TStringList;
begin
sList := TDataWithList(Data).theList;
for I := 0 to Length(Args) - 1 do
sList.Add (Args[I]);
end);
anObject := jUnmarshal.Unmarshal(jValue);
try
ShowMessage ('Class: ' + anObject.ClassName +
sLineBreak + anObject.ToString);
finally
anObject.Free;
end;
finally
jUnmarshal.Free;
end;
finally
jValue.Free;
end;
end;
function TMyData.ToString: string;
begin
Result := theName + ':' + IntToStr (theValue);
end;
{ TDataWithList }
constructor TDataWithList.Create(const aName: string);
var
I: Integer;
begin
theName := aName;
theList := TStringList.Create;
for I := 0 to 9 do
theList.Add(IntToStr (Random (1000)));
end;
constructor TDataWithList.Create;
begin
// core initialization, used for default construction
theName := 'XXX'; // added by me
theList := TStringList.Create;
end;
destructor TDataWithList.Destroy;
begin
theList.Free;
inherited;
end;
function TDataWithList.ToString: string;
begin
Result := theName + sLineBreak + theList.Text;
end;
rttiField.SetValue(Data, TValue.Empty); simply overrides the field value because as the name implies it's a field, not a property with get / set methods. The destructor of TStringList is not called due to simple pointer assignment.
The solution here is to declare a property:
TDataWithList = class
...
strict private
theList: TStringList;
...
public
property Data: TStringList read ... write SetData
...
end;
TDataWithList.SetData(TStringList aValue);
begin
theList.Assign(aValue);
end;

TJClipboardManager in Delphi

I'm trying to copy selected text, using this:
uses
Androidapi.Helpers, Androidapi.jni , AndroidAPI.JNIBridge,
Androidapi.JNI.JavaTypes, FMX.Helpers.Android,
Androidapi.JNI.GraphicsContentViewText;
procedure TForm2.Button5Click(Sender: TObject);
var
myclipboard : JClipboardManager;
s: string;
begin
myclipboard := TJClipboardManager.create;
myclipboard.getText;
showmessage(BoolToStr(myclipboard.hasText));
end;`
There are a lot of samples in Java, but i'm not enough strong yet to understand it
You are not supposed to instantiate the ClipboardManager class directly, but instead use the Content.getSystemService() method to obtain the correct manager object. The Android documentation even says so:
You do not instantiate this class directly; instead, retrieve it through getSystemService(Class).
So, you have to do this instead:
function GetClipboardManager: JClipboardManager;
var
obj: JObject;
begin
obj := SharedActivityContext.getSystemService(TJContext.JavaClass.CLIPBOARD_SERVICE);
if Assigned(obj) then
Result := TJClipboardManager.Wrap((obj as ILocalObject).GetObjectID)
else
Result := nil;
end;
procedure TForm2.Button5Click(Sender: TObject);
var
myclipboard : JClipboardManager;
begin
myclipboard := GetClipboardManager;
if Assigned(myclipboard) then
begin
//...
end;
end;
Do note that depending on which version of Android you are running on, Context.getSystemService(CLIPBOARD_SERVICE) will return either a android.content.ClipboardManager (HoneyComb+) or android.text.ClipboardManager object. Not sure how well Delphi handles that, if at all. You will have to look at the declaration of JClipboardManager to see which one it is accessing. The latter one was deprecated in Android API level 11.
Embarcadero wants you to use FMX's cross-platform IFMXClipboardService interface instead:
uses
FMX.Platform, System.Rtti;
procedure TForm2.Button5Click(Sender: TObject);
var
Clipboard: IFMXClipboardService;
value: TValue;
hasText: boolean;
s: string;
begin
hasText := False;
if PlatformServices.Current.SupportsPlatformService(IFMXClipboardService, IInterface(Clipboard)) then
begin
value := Clipboard.GetClipboard;
hasText := value.TryAsType<String>(s);
end;
ShowMessage(BoolToStr(hasText));
if hasText then ShowMessage(s);
end;

How to track number of clients with Indy TIdTCPServer

I want to know the number of current client connections to an Indy 9 TIdTCPServer (on Delphi 2007)
I can't seem to find a property that gives this.
I've tried incrementing/decrementing a counter on the server OnConnect/OnDisconnect events, but the number never seems to decrement when a client disconnects.
Any suggestions?
The currently active clients are stored in the server's Threads property, which is a TThreadList. Simply lock the list, read its Count property, and then unlock the list:
procedure TForm1.Button1Click(Sender: TObject);
var
NumClients: Integer;
begin
with IdTCPServer1.Threads.LockList do try
NumClients := Count;
finally
IdTCPServer1.Threads.UnlockList;
end;
ShowMessage('There are currently ' + IntToStr(NumClients) + ' client(s) connected');
end;
In Indy 10, the Threads property was replaced with the Contexts property:
procedure TForm1.Button1Click(Sender: TObject);
var
NumClients: Integer;
begin
with IdTCPServer1.Contexts.LockList do try
NumClients := Count;
finally
IdTCPServer1.Contexts.UnlockList;
end;
ShowMessage('There are currently ' + IntToStr(NumClients) + ' client(s) connected');
end;
Not sure why using OnConnect and OnDisconnect wouldn't work for you, but what we have done is to create a descendant of TIdCustomTCPServer; to override its DoConnect and DoDisconnect methods and create and use our own descendant of TIdServerContext (a thread descendant that will "serve" a connection).
You make the TIdCustomTCPServer aware of your own TIdServerContext class by:
(Edit Added conditional defines to show how to make it work for Indy9)
type
// Conditional defines so that we can use the same ancestors as in Indy10 and we
// can use the same method signatures for DoConnect and DoDisconnect regardless
// of the Indy version. Add other conditional defines as needed.
// Note: for INDY9 to be defined, you need to include the appropriate includes
// from Indy, or define it in your own include file.
{$IFDEF INDY9}
TIdContext = TIdPeerThread;
TIdServerContext = TIdContext;
TIdCustomTCPServer = TIdTCPServer;
{$ENDIF}
TOurContext = class(TIdServerContext)
private
FConnectionId: cardinal;
public
property ConnectionId: cardinal ...;
end;
...
constructor TOurServer.Create(aOwner: TComponent);
begin
inherited Create(aOwner);
...
{$IFDEF INDY10_UP}
ContextClass := TOurContext;
{$ELSE}
ThreadClass := TOurContext;
{$ENDIF}
...
end;
In the DoConnect override of our TIdCustomTCPServer descendant we set the ConnectionID of our context class to a unique value:
procedure TOurServer.DoConnect(AContext: TIdContext);
var
OurContext: TOurContextabsolute AContext;
begin
Assert(AContext is TOurContext);
HandleGetNewConnectionID(OurContext, OurContext.FConnectionID);
inherited DoConnect(AContext);
...
end;
Our DoDisconnect override clears the ConnectionID:
procedure TOurServer.DoDisconnect(AContext: TIdContext);
var
OurContext: TOurContextabsolute AContext;
begin
Assert(AContext is TOurContext);
OurContext.FConnectionID := 0;
...
inherited DoDisconnect(AContext);
end;
Now it is possible to get a count of the current connections at any time:
function TOurServer.GetConnectionCount: Integer;
var
i: Integer;
CurrentContext: TOurContext;
ContextsList: TList;
begin
MyLock.BeginRead;
try
Result := 0;
if not Assigned(Contexts) then
Exit;
ContextsList := Contexts.LockList;
try
for i := 0 to ContextsList.Count - 1 do
begin
CurrentContext := ContextsList[i] as TOurContext;
if CurrentContext.ConnectionID > 0 then
Inc(Result);
end;
finally
Contexts.UnLockList;
end;
finally
MyLock.EndRead;
end;
end;
How about incrementing / decrementing a counter from OnExecute (or DoExecute if you override that)? That can't go wrong!
If you use InterlockedIncrement and InterlockedDecrement you don't even need a critical section to protect the counter.
This should work on Indy 9, but it is pretty outdated nowadays, and maybe something is broken in your version, try to update to the latest Indy 9 available.
I made a simple test using Indy 10, which works very well with a simple interlocked Increment/Decrement in the OnConnect/OnDisconnect event handlers. This is my code:
//closes and opens the server, which listens at port 1025, default values for all properties
procedure TForm2.Button1Click(Sender: TObject);
begin
IdTCPServer1.Active := not IdTCPServer1.Active;
UpdateUI;
end;
procedure TForm2.FormCreate(Sender: TObject);
begin
UpdateUI;
end;
//Just increment the count and update the UI
procedure TForm2.IdTCPServer1Connect(AContext: TIdContext);
begin
InterlockedIncrement(FClientCount);
TThread.Synchronize(nil, UpdateUI);
end;
//Just decrement the count and update the UI
procedure TForm2.IdTCPServer1Disconnect(AContext: TIdContext);
begin
InterlockedDecrement(FClientCount);
TThread.Synchronize(nil, UpdateUI);
end;
//Simple 'X' reply to any character, A is the "command" to exit
procedure TForm2.IdTCPServer1Execute(AContext: TIdContext);
begin
AContext.Connection.IOHandler.Writeln('Write anything, but A to exit');
while AContext.Connection.IOHandler.ReadByte <> 65 do
AContext.Connection.IOHandler.Write('X');
AContext.Connection.IOHandler.Writeln('');
AContext.Connection.IOHandler.Writeln('Good Bye');
AContext.Connection.Disconnect;
end;
//Label update with server status and count of connected clients
procedure TForm2.UpdateUI;
begin
Label1.Caption := Format('Server is %s, %d clients connected', [
IfThen(IdTCPServer1.Active, 'Open', 'Closed'), FClientCount]);
end;
then, opening a couple of clients with telnet:
then, closing one client
That's it.
INDY 10 is available for Delphi 2007, my main advise is to upgrade anyway.

Delphi - Proxy Design Pattern - interface problem

Hi
I am trying to do design patterns in Delphi and, since I couldn't find a reference material that I like in Delphi, I am converting the patterns I have in the O’Reilly C# 3.0 Design Patterns book. But this is not the problem. I have created the Proxy pattern from this book but there are some concepts of Delphi interfaces, constructors and destructor and general object lifetime and behavior that I apparently don't understand.
First I will post my code:
unit Unit2;
interface
uses
SysUtils;
type
ISubject = interface
['{78E26A3C-A657-4327-93CB-F3EB175AF85A}']
function Request(): string;
end;
TSubject = class
public
function Request(): string;
constructor Create();
end;
TProxy = class (TInterfacedObject, ISubject)
private
FSubject: TSubject;
public
function Request(): String;
destructor Destroy(); override;
end;
TProtectionProxy = class (TInterfacedObject, ISubject)
private
FSubject: TSubject;
FPassword: String;
public
constructor Create();
destructor Destroy(); override;
function Authenticate(supplied: String): String;
function Request(): String;
end;
implementation
{ TSubjectAccessor.TProxy }
destructor TProxy.Destroy;
begin
if Assigned(Self.FSubject) then
FreeAndNil(Self.FSubject);
inherited;
end;
function TProxy.Request: String;
begin
if not Assigned(Self.FSubject) then begin
WriteLn('Subject Inactive');
Self.FSubject := TSubject.Create();
end;
WriteLn('Subject active');
Result := 'Proxy: Call to ' + Self.FSubject.Request();
end;
{ TSubject }
constructor TSubject.Create;
begin
inherited;
end;
function TSubject.Request: string;
begin
Result := 'Subject Request Choose left door' + #10;
end;
{ TProtectionProxy }
function TProtectionProxy.Authenticate(supplied: String): String;
begin
if (supplied <> Self.FPassword) then begin
Result := 'Protection proxy: No Access!';
end else begin
Self.FSubject := TSubject.Create();
Result := 'Protection Proxy: Authenticated';
end;
end;
constructor TProtectionProxy.Create;
begin
Self.FPassword := 'Abracadabra';
end;
destructor TProtectionProxy.Destroy;
begin
if Assigned(Self.FSubject) then
FreeAndNil(Self.FSubject);
inherited;
end;
function TProtectionProxy.Request: String;
begin
if not Assigned(Self.FSubject) then begin
Result := 'Protection Proxy: Authenticate first!';
end else begin
Result := 'Protection Proxy: Call to ' + Self.FSubject.Request();
end;
end;
end.
These are the interfaces and classes used in the pattern. Next, is the code that uses these types:
program Structural.Proxy.Pattern;
{$APPTYPE CONSOLE}
uses
SysUtils,
Unit2 in 'Unit2.pas';
var
subject: ISubject;
begin
ReportMemoryLeaksOnShutdown := DebugHook <> 0;
try
WriteLn('Proxy Pattern' + #10);
try
subject := TProxy.Create();
WriteLn(subject.Request());
WriteLn(subject.Request());
subject := TProtectionProxy.Create();
WriteLn(subject.Request());
WriteLn(TProtectionProxy(subject).Authenticate('Secret'));
WriteLn(TProtectionProxy(subject).Authenticate('Abracadabra'));
WriteLn(subject.Request());
ReadLn;
finally
end;
except
on E:Exception do
Writeln(E.Classname, ': ', E.Message);
end;
end.
Is it legal to just assign a new object instance against an interface variable? I see in debugging that the constructor for TProtectionProxy is executed first and then a destructor for TProxy.
After the TProtectionProxy is created, Authenticate('Abracadabra') should be validated in logic but in debugger the FPassword is empty while it was assigned in the constructor? This one is very puzzling. But when I close the application, in the destructor, the password is present?
TProtectionProxy(subject) is ok but I read that is not recommended but (subject as TProtectionProxy) was not compiling for some reason (Operator not applicable...)?
I have added destructors because of the FSubject field. Is that ok?
Can a field variable be initiated on the same line where it is declared or I need to initiate in the constructor like in TProtectionProxy?
I know it is a lot I am asking here but I don't know anyone personally who knows Delphi OOP so well that I can ask.
Thank you.
This is the new version that works well for me. Thank you for all your help.
unit Unit2;
interface
uses
SysUtils;
type
ISubject = interface
['{78E26A3C-A657-4327-93CB-F3EB175AF85A}']
function Request(): string;
end;
IProtected = interface
['{928BA576-0D8D-47FE-9301-DA3D8F9639AF}']
function Authenticate(supplied: string): String;
end;
TSubject = class
public
function Request(): string;
end;
TProxy = class (TInterfacedObject, ISubject)
private
FSubject: TSubject;
public
function Request(): String;
destructor Destroy(); override;
end;
TProtectionProxy = class (TInterfacedObject, ISubject, IProtected)
private
FSubject: TSubject;
const FPassword: String = 'Abracadabra';
public
destructor Destroy(); override;
function Authenticate(supplied: String): String;
function Request(): String;
end;
implementation
{ TSubjectAccessor.TProxy }
destructor TProxy.Destroy;
begin
if Assigned(FSubject) then
FreeAndNil(FSubject);
inherited;
end;
function TProxy.Request: String;
begin
if not Assigned(FSubject) then begin
WriteLn('Subject Inactive');
FSubject := TSubject.Create();
end;
WriteLn('Subject active');
Result := 'Proxy: Call to ' + FSubject.Request();
end;
{ TSubject }
function TSubject.Request: string;
begin
Result := 'Subject Request Choose left door' + #10;
end;
{ TProtectionProxy }
function TProtectionProxy.Authenticate(supplied: String): String;
begin
if (supplied <> FPassword) then begin
Result := 'Protection proxy: No Access!';
end else begin
FSubject := TSubject.Create();
Result := 'Protection Proxy: Authenticated';
end;
end;
destructor TProtectionProxy.Destroy;
begin
if Assigned(FSubject) then
FreeAndNil(FSubject);
inherited;
end;
function TProtectionProxy.Request: String;
begin
if not Assigned(FSubject) then begin
Result := 'Protection Proxy: Authenticate first!';
end else begin
Result := 'Protection Proxy: Call to ' + FSubject.Request();
end;
end;
end.
and the program code:
program Structural.Proxy.Pattern;
{$APPTYPE CONSOLE}
uses
SysUtils,
Unit2 in 'Unit2.pas';
var
subject: ISubject;
protect: IProtected;
begin
ReportMemoryLeaksOnShutdown := DebugHook <> 0;
try
WriteLn('Proxy Pattern' + #10);
try
subject := TProxy.Create();
WriteLn(subject.Request());
WriteLn(subject.Request());
subject := nil;
subject := TProtectionProxy.Create();
WriteLn(subject.Request());
if Supports(subject, IProtected, protect) then begin
WriteLn(protect.Authenticate('Secret'));
WriteLn(protect.Authenticate('Abracadabra'));
end;
WriteLn(subject.Request());
ReadLn;
finally
end;
except
on E:Exception do
Writeln(E.Classname, ': ', E.Message);
end;
end.
I have removed all the constructors cause now they really don't do anything. And the default parametherless constructors are inherited from TInrefacedObject, correct?
I have left Self, I would like to hear why this shouldn't be used?
thank you
I have the full pattern implementation on http://delphipatterns.blog.com/2011/02/22/proxy-2/
You are not saying what version of Delphi you are using. The code you have given is only valid in Delphi XE and produces the following (correct) output there:
Proxy Pattern
Subject Inactive
Subject active
Proxy: Call to Subject Request Choose left door
Subject active
Proxy: Call to Subject Request Choose left door
Protection Proxy: Authenticate first!
Protection proxy: No Access!
Protection Proxy: Authenticated
Protection Proxy: Call to Subject Request Choose left door
If you look at the generated machine code:
Project2.dpr.25: WriteLn(TProtectionProxy(subject).Authenticate('Secret'));
004122C2 A1788E4100 mov eax,[$00418e78]
004122C7 8B154CF84000 mov edx,[$0040f84c]
004122CD E8E22BFFFF call #SafeIntfAsClass
004122D2 8D4DE0 lea ecx,[ebp-$20]
004122D5 BA38244100 mov edx,$00412438
004122DA E875D9FFFF call TProtectionProxy.Authenticate
004122DF 8B55E0 mov edx,[ebp-$20]
004122E2 A1EC3C4100 mov eax,[$00413cec]
004122E7 E8BC24FFFF call #Write0UString
004122EC E82F25FFFF call #WriteLn
004122F1 E82A1CFFFF call #_IOTest
You can see how the compiler first generates a call to SafeIntfAsClass which is used to get from an ISubject pointer to a pointer for the object that is implementing ISubject. Then TProtectionProxy.Authenticate is being called with this (correct) Self pointer.
If you try to run the same code with older versions of Delphi, this will fail:
var
subject: ISubject;
begin
...
subject := TProtectionProxy.Create();
WriteLn(subject.Request());
WriteLn(TProtectionProxy(subject).Authenticate('Secret'));
Older versions of Delphi did not support safely casting from an interface back to an object. What happens then is that the compiler simply takes the value of the subject variable, and calls TProtectionProxy.Authenticate with it.
The call itself succeeds because TProtectionProxy.Authenticate is a simple static method, not a virtual method, so the compiler just generates a call to an absolute address for it. But inside TProtectionProxy.Authenticate, Self is then wrong. Because the subject pointer is different from the object pointer for the TProtectionProxy that's implementing ISubject.
The correct solution for older delphi versions is to introduce an additional interface:
type
IProtection = interface
['{ACA182BF-7675-4346-BDE4-9D47CA4ADBCA}']
function Authenticate(supplied: String): String;
end;
...
TProtectionProxy = class (TInterfacedObject, ISubject, IProtection)
...
var
subject: ISubject;
protection: IProtection;
...
subject := TProtectionProxy.Create();
WriteLn(subject.Request());
if Supports(subject, IProtection, protection) then begin
WriteLn(protection.Authenticate('Secret'));
WriteLn(protection.Authenticate('Abracadabra'));
end else
WriteLn('IProtection not supported!');
WriteLn(subject.Request());
Generally speaking, you should never mix object and interface based access. Once you got an interface reference to an object, you shouldn't keep any object references to it (because the object will get automatically freed whenever the last interface reference goes out of scope somewhere). And even though Delphi XE allows you to correctly cast back from an interface to an object, that is something you should use very very carefully.
Is it legal to just assign a new object instance against an interface variable?
Yes. More than that, it is the right way to use interfaces in Delphi.
I see in debugging that the constructor for TProtectionProxy is executed first and then a destructor for TProxy.
Does it make any change for you? That is implementation details.
If you want to destroy TProxy object first assign subject to nil:
subject := TProxy.Create();
WriteLn(subject.Request());
WriteLn(subject.Request());
subject := nil;
subject := TProtectionProxy.Create();
..
After the TProtectionProxy is created, Authenticate('Abracadabra') should be validated in logic but in debugger the FPassword is empty while it was assigned in the constructor? This one is very puzzling.
I don't see it. FPassword is assigned as it should be.
But when I close the application, in the destructor, the password is present?
that is because subject is global variable. You can assign it to nil to force the object destruction manually before calling readln:
Subject:= nil;
Readln;
TProtectionProxy(subject) is ok but I read that is not recommended but (subject as TProtectionProxy) was not compiling for some reason (Operator not applicable...)?
I don't understand what are you trying to do. Both TProtectionProxy(subject) and (subject as TProtectionProxy) code does not seem sound.
I have added destructors because of the FSubject field. Is that ok?
Yes, you should destroy FSubject object instance in the destructors.
Can a field variable be initiated on the same line where it is declared or I need to initiate in the constructor like in TProtectionProxy?
No, you should initiate FPassword in the constructor as you did.
If you are not going to change FPassword you can declare it as constant:
TProtectionProxy = class (TInterfacedObject, ISubject)
private
FSubject: TSubject;
const FPassword: String = 'Abracadabra';
public
constructor Create();
destructor Destroy(); override;
function Authenticate(supplied: String): String;
function Request(): String;
end;
And don't use Self - there is no need for it in your code.

How can I display Crystal XI reports inside a Delphi 2007 application?

The most recent Crystal XI component for Delphi was released for Delphi 7. That VCL component compiles in D2007, but gives me errors at runtime. What is the best way to display a database-connected Crystal Report in a Delphi 2007 application?
This is the solution I've found, using ActiveX:
First, register the Active X control like this:
In Delphi, choose Component -> Import Component
Click on "Type Library", click Next
Choose "Crystal ActiveX Report Viewer Library 11.5"
Pick whatever Palette Page you want (I went with "Data Access")
Choose an import location
Exit out of the wizard
Add the location you chose to your project Search Path
Now this code should work:
...
uses
CrystalActiveXReportViewerLib11_5_TLB, OleAuto;
...
procedure TForm1.Button1Click(Sender: TObject);
var
cry : TCrystalActiveXReportViewer;
oRpt, oApp : variant;
i : integer;
frm : TForm;
begin
cry := TCrystalActiveXReportViewer.Create(Self);
oApp := CreateOleObject('CrystalRuntime.Application');
oRpt := oApp.OpenReport('c:\my_report.rpt',1);
for i := 1 to oRpt.Database.Tables.Count do begin
oRpt.Database.Tables[i].ConnectionProperties.Item['User ID'] := 'username';
oRpt.Database.Tables[i].ConnectionProperties.Item['Password'] := 'password';
end;
frm := TForm.Create(Self);
try
cry.Parent := frm;
cry.Align := alClient;
cry.ReportSource := oRpt;
cry.ViewReport;
frm.Position := poOwnerFormCenter;
frm.ShowModal;
finally
FreeAndNil(frm);
end; //try-finally
end;
procedure TForm1.btnExportClick(Sender: TObject);
var
cry : TCrystalActiveXReportViewer;
oRpt, oApp : variant;
i : integer;
begin
//Export the report to a file
cry := TCrystalActiveXReportViewer.Create(Self);
oApp := CreateOleObject('CrystalRuntime.Application');
oRpt := oApp.OpenReport(c_DBRpt,1);
for i := 1 to oRpt.Database.Tables.Count do begin
oRpt.Database.Tables[i].ConnectionProperties.Item['User ID'] := 'username';
oRpt.Database.Tables[i].ConnectionProperties.Item['Password'] := 'password';
end;
oRpt.ExportOptions.FormatType := 29; //excel 8
oRpt.ExportOptions.DiskFileName := 'c:\output.xls';
oRpt.ExportOptions.DestinationType := 1; //file destination
//Export(False) => do NOT prompt.
//Export(True) will give runtime prompts for export options.
oRpt.Export(False);
end;
If you use this method, then this (rather dense) reference will be helpful, especially since Intellisense doesn't work on Ole objects like these.
Edit: The original link to the reference broke, so I changed it to point to a new one (valid as of Dec 15 2009). If that new one breaks, then Google should be able to find it.
I know it's not your question and it might not be an acceptable answer at all in your situation, but I have found FastReports to be clearly superior to Crystal for my purposes. It's lighter weight, includes a real scripting language, incorporates event handling, can make calls into your native code for information and updates and does not require an ActiveX connection. I can export my reports into sharp looking PDF files or Excel spreadsheets and several other formats. The quality of the output adds to the overall experience users get from my application. I could go on, but if it's off topic for you, it won't be helpful.
For the sake of anyone else who can use it, here is a complete class that gives a pleasant wrapper around these vile Crystal interactions. It works for me about 80% of the time, but I suspect a lot of this stuff is very dependent on the specific platform on which it runs. I'll post improvements as I make them.
Somebody at Business Objects should really take a hard look at this API. It sucks pretty badly.
{
Class to facilitate the display of Crystal 11 Reports.
The Crystal 11 VCL component does not seem to work with Delphi 2007.
As a result, we have to use ActiveX objects, which make deployment messy.
This class is similar to CrystalReporter, but it works for Crystal 11.
However, it lacks some of the features of the old CrystalReporter.
Refer to the crystal reports activex technical reference to duplicate the
missing functionality.
Example usage is at the bottom of this unit.
//}
unit CrystalReporter11;
interface
uses
CrystalActiveXReportViewerLib11_5_TLB, OleAuto, Classes, Controls;
type
TCryExportFormat = (
XLS
,PDF
);
type
TCrystalReporter11 = class
private
FCryRpt : TCrystalActiveXReportViewer;
FRpt, FApp : variant;
FReportFile, FUsername, FPassword, FServer, FFilters : string;
FOwner : TComponent;
procedure SetLoginInfo(const username, password, server : string);
function GetFilterConds: string;
procedure SetFilterConds(const Value: string);
public
property FilterConditions : string read GetFilterConds write SetFilterConds;
procedure ExportToFile(ExportFileName : string;
FileExportFmt : TCryExportFormat; PromptForOptions : boolean);
procedure Display;
constructor Create(AOwner : TComponent; ReportFile : string); overload;
constructor Create(AOwner : TComponent; ReportFile,
Username, Password, Server : string); overload;
end;
implementation
uses
SysUtils, Forms;
const
//these are taken from pgs 246 and 247 of the technical reference
c_FmtCode_Excel = 29;
c_FmtCode_PDF = 31;
constructor TCrystalReporter11.Create(AOwner: TComponent; ReportFile: string);
begin
inherited Create;
try
FReportFile := ReportFile;
if FileExists(FReportFile) then begin
FOwner := AOwner;
FCryRpt := TCrystalActiveXReportViewer.Create(AOwner);
FApp := CreateOleObject('CrystalRuntime.Application');
FRpt := FApp.OpenReport(FReportFile,1);
FFilters := FRpt.RecordSelectionFormula;
end
else begin
raise Exception.Create('Report file ' + ReportFile + ' not found!');
end;
except on e : exception do
raise;
end; //try-except
end;
constructor TCrystalReporter11.Create(AOwner: TComponent; ReportFile, Username,
Password, Server: string);
begin
Create(AOwner,ReportFile);
FUsername := Username;
FPassword := Password;
FServer := Server;
SetLoginInfo(FUsername,FPassword,FServer);
end;
procedure TCrystalReporter11.Display;
var
rptForm : TForm;
begin
SetLoginInfo(FUsername,FPassword,FServer);
FCryRpt.ReportSource := FRpt;
rptForm := TForm.Create(FOwner);
try
FCryRpt.Parent := rptForm;
FCryRpt.Align := alClient;
FCryRpt.ViewReport;
rptForm.Position := poOwnerFormCenter;
rptForm.WindowState := wsMaximized;
rptForm.Caption := ExtractFileName(FReportFile);
rptForm.ShowModal;
finally
FreeAndNil(rptForm);
end; //try-finally
end;
procedure TCrystalReporter11.ExportToFile(ExportFileName : string;
FileExportFmt : TCryExportFormat; PromptForOptions : boolean);
begin
case FileExportFmt of
XLS : FRpt.ExportOptions.FormatType := c_FmtCode_Excel;
PDF : FRpt.ExportOptions.FormatType := c_FmtCode_PDF;
end; //case
FRpt.ExportOptions.DiskFileName := ExportFileName;
FRpt.ExportOptions.DestinationType := 1; //file destination
FCryRpt.ReportSource := FRpt;
FRpt.Export(PromptForOptions);
end;
function TCrystalReporter11.GetFilterConds: string;
begin
Result := FFilters;
end;
procedure TCrystalReporter11.SetFilterConds(const Value: string);
begin
FFilters := Value;
if 0 < Length(Trim(FFilters)) then begin
FRpt.RecordSelectionFormula := Value;
end;
end;
procedure TCrystalReporter11.SetLoginInfo(const username, password,
server : string);
var
i : integer;
begin
//set user name and password
//crystal only accepts these values if they are CONST params
for i := 1 to FRpt.Database.Tables.Count do begin
FRpt.Database.Tables[i].ConnectionProperties.Item['User ID'] := username;
FRpt.Database.Tables[i].ConnectionProperties.Item['Password'] := password;
try
{
Some reports use direct connections, and others use an ODBC Data Source.
Crystal XI uses a different label to refer to the database name in each
method.
I don't know how to determine in advance which method is being used, so:
First, we try the direct connection.
If that fails, we try the "data source" method.
Reference: "Crystal Reports XI Technical Reference", pages 41 thru 46;
"Common ConnectionProperties"
}
FRpt.Database.Tables[i].ConnectionProperties.Item['Server'] := server;
except on E: Exception do
FRpt.Database.Tables[i].ConnectionProperties.Item['Data Source'] := server;
end;
end;
end;
{
Example usage:
procedure TForm1.btnShowRptDBClick(Sender: TObject);
var
cry : TCrystalReporter11;
begin
cry := TCrystalReporter11.Create(Self,'c:\my_report.rpt','username',
'password','server.domain.com');
try
cry.Display;
finally
FreeAndNil(cry);
end;
end;
}
end.
I too have been disappointed with the lack of effort by Crystal Reports with respect to application integration. I use the RDC, and from what I understand this is being deprecated and emphasis is being placed on .Net.
My application has these files in the uses clause:
CRRDC, CRAXDRT_TLB,
It works ok. The because drawback is parameter passing. In my option the parameter dialog boxes which come with the viewer are terrible. So I use my own Delphi application to prompt for parameters and pass them to the report.
Here is a bit simpler and clean class which solves the problem very nicely:
Unit CrystalReports;
uses Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Vcl.OleCtrls, ActiveX, ComObj, Data.DB, Data.Win.ADODB,
CrystalActiveXReportViewerLib11_TLB, Vcl.OleServer, CrystalReportsControllersLib_TLB;
type
TCrystalReportForm = class(TForm)
CRV: TCrystalActiveXReportViewer;
procedure DisplayReport;
private
{ Private declarations }
public
{Public declarations }
ReportName : WideString;
ReportCaption : String;
ReportSelectionFormula : WideString;
end;
var
CRXIRuntime : Variant;
implementation
{$R *.dfm}
procedure TCrystalReportForm.DisplayReport;
var
CrystalReport : variant;
i : integer;
begin
CrystalReport := CRXIRuntime.OpenReport(ReportName);
for i := 1 to CrystalReport.Database.Tables.Count do begin
CrystalReport.Database.Tables[1].ConnectionProperties.Item['User ID'] := 'user';
CrystalReport.Database.Tables[1].ConnectionProperties.Item['Password'] := 'password';
end;
CrystalReport.FormulaSyntax := 0;
Caption := ReportCaption;
CrystalReport.RecordSelectionFormula := ReportSelectionFormula;
CRV.Align := alClient;
CRV.ReportSource := CrystalReport;
WindowState := wsMaximized;
CRV.ViewReport;
ShowModal;
end;
begin
CRXIRuntime := CreateOleObject('CrystalRuntime.Application');
end.

Resources