Delphi XE5 string size exchange limitation between DLL and EXE - delphi

I have a Delphi 7 DLL function that returns large string and it works fine but in Delphi XE5 I get an access violation after a specific size.
I have written a sample demo, that reflects my actual code, that generates also a AV in Delphi XE5 that returns also a large string but again after a specific size, I get an Access Violation ?
13000 lines of 20 chars, it works fine but with 14000 lines it crashes.
I did some tests with Delphi 7 and it works fine also.
What am I doing wrong ? Can anyone help me out ?
Thanks.
Here is the code of my DLL :
function RetLargeStr(Buffer : pAnsiChar; var BufferSize: Integer) : boolean ; stdcall;
var l_ansiStr : string;
loop : integer;
begin
Result := False;
//13000 ok 14000+ fail ???
for loop := 1 to 15000 do
begin
l_AnsiStr := l_AnsiStr + 'String of 20 chars' + Char($0D) + Char($0A) ;
end;
if Assigned(Buffer) and (BufferSize >= Length(l_ansiStr) + 1) then
begin
//Buffer := pAnsiChar(AnsiString(l_AnsiStr));
move(l_AnsiStr, Buffer^, length(l_AnsiStr) + 1);
Result := True;
end;
//Return actual size of output string.
BufferSize := Length(l_AnsiStr) + 1;
end ;
Here’s the call from my EXE :
procedure TForm1.Button7Click(Sender: TObject);
var l_StrOut : pAnsiChar;
l_Str : ansistring;
p_Size : integer;
begin
p_Size := 600000;
SetLength(l_Str, p_Size);
l_strout := pAnsiChar(l_str);
Memo2.Lines.Clear;
if RetLargeStr(l_StrOut, p_Size)
then Memo2.Lines.Add( l_StrOut );
end;

The way you have it here it's probably just luck that it works at all.
In the DLL, when you do this:
Buffer := pAnsiChar(AnsiString(l_AnsiStr));
you are actually returning the string buffer allocated in the DLL to the calling EXE, even though you've explicitly allocated a receive buffer before the call. That receive buffer pointer gets overwritten.
The crash most likely occurs because the heap manager in the EXE is unprepared for freeing a memory block, which was allocated somewhere else (in the DLL).
Instead of assigning to buffer, you might try copying the content of the string to it, like this:
if Assigned(Buffer) and (BufferSize >= Length(l_ansiStr) + 1) then
begin
move(AnsiStr[1], Buffer^, length(AnsiStr) + 1));
Result := True;
end;
Test code (DLL):
library Project2;
uses
SysUtils,
Classes;
function RetLargeStr(Buffer : pAnsiChar; var BufferSize: Integer) : boolean ; stdcall;
var l_ansiStr : string;
loop : integer;
begin
Result := False;
//13000 ok 14000+ fail ???
for loop := 1 to 15000 do
begin
l_AnsiStr := l_AnsiStr + 'String of 20 chars' + Char($0D) + Char($0A) ;
end;
if Assigned(Buffer) and (BufferSize >= Length(l_ansiStr) + 1) then
begin
//Buffer := pAnsiChar(AnsiString(l_AnsiStr));
move(l_AnsiStr[1], Buffer^, length(l_AnsiStr) + 1);
Result := True;
end;
//Return actual size of output string.
BufferSize := Length(l_AnsiStr) + 1;
end ;
exports
RetLargeStr;
begin
end.
Test code (EXE):
unit Unit3;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls;
type
TForm3 = class(TForm)
Button1: TButton;
Memo1: TMemo;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form3: TForm3;
implementation
{$R *.dfm}
function RetLargeStr(Buffer : pAnsiChar; var BufferSize: Integer) : boolean ; stdcall; external 'project2.dll';
procedure TForm3.Button1Click(Sender: TObject);
var l_StrOut : pAnsiChar;
l_Str : ansistring;
p_Size : integer;
begin
p_Size := 600000;
SetLength(l_Str, p_Size);
l_strout := pAnsiChar(l_str);
Memo1.Lines.Clear;
if RetLargeStr(l_StrOut, p_Size)
then Memo1.Lines.Add( l_StrOut );
end;
end.

Related

DataSnap ServerMethod functions returned as ftStream parameters being wrongly truncated

As DataSnap users will know, its ServerMethods return values to their callers
as DataSnap parameters.
There have been a number of reports on SO and elsewhere relating to a problem with
DataSnap servers returning ServerMethod results as ftStream parameters, that the stream is truncated
prematurely or returned empty. An example is here:
Can't retrieve TStreams bigger than around 260.000 bytes from a Datasnap Server
I have put together a reproducible test case of this that I intend submitting to
Emba's Quality Portal as an MCVE, but before I do I'd like some help pinning down
where the problem occurs. I'm using Delphi Seattle on Win64, compiling to 32-bits, btw.
My MCVE is completely self-contained (i.e. includes both server and client) and does
not depend on any database data. Its ServerMethods module contains a function
(BuildString in the code below) which returns a string of a caller-specified length
and two ServerMethods GetAsString and GetAsStream which return the result
as parameters of types ftString and ftStream, respectively.
Its GetString method successfully returns a string of any requested length up to
the maximum I've tested, which is 32000000 (32 million) bytes.
Otoh, the GetStream method works up to a requested size of 30716; above that,
the returned stream has a size of -1 and is empty. The expected behaviour of course
that it should be capable of working with much larger sizes, just as GetString does.
On the outbound (server) side, at some point the returned stream is passed into
DataSnap's JSon layer en route to the tcp/ip transport layer and on the inbound side, similarly, the stream is retrieved
from the JSon layer. What I'd like to be able to do, and what this q is about,
is to capture the outbound and inbound JSon representations of the AsStream
parameter value in human-legible form so that I identify whether the unwanted
truncation of its data occurs on the server or client side. How do I do that?
the reason I'm asking this is that despite hours of looking I've been unable to identify exactly
where the JSon conversions occur. It's like looking for a needle in a haystack.
If you take a look at the method TDBXJSonStreamWriter.WriteParameter in Data.DBXStream,
the one thing it doesn't write is the stream's contents!
One thing I have been able to establish is regarding line 4809 in Data.DBXStream
Size := ((FBuf[IncrAfter(FOff)] and 255) shl 8) or (FBuf[IncrAfter(FOff)] and 255)
in the function TDBXRowBuffer.ReadReaderBlobSize. On entry to
this method, Size is initialised to zero, and it is this line which sets Size to 30716
for all requested stream sizes >= that value. But I don't know whether this is cause or effect,
i.e. whether the stream trucation has already taken place or whether it's this line
which causes it.
My code is below; apologies for the length of it, but DataSnap projects require
quite a lot of baggage at the best of times and I've included some code which
initialises some of the components to avoid having to post .DFMs too.
ServerMethods code:
unit ServerMethods2u;
interface
uses System.SysUtils, System.Classes, System.Json, variants, Windows,
Datasnap.DSServer, Datasnap.DSAuth, DataSnap.DSProviderDataModuleAdapter;
{$MethodInfo on}
type
TServerMethods1 = class(TDSServerModule)
public
function GetStream(Len: Integer): TStream;
function GetString(Len: Integer): String;
end;
{$MethodInfo off}
implementation
{$R *.dfm}
uses System.StrUtils;
function BuildString(Len : Integer) : String;
var
S : String;
Count,
LeftToWrite : Integer;
const
scBlock = '%8d bytes'#13#10;
begin
LeftToWrite := Len;
Count := 1;
while Count <= Len do begin
S := Format(scBlock, [Count]);
if LeftToWrite >= Length(S) then
else
S := Copy(S, 1, LeftToWrite);
Result := Result + S;
Inc(Count, Length(S));
Dec(LeftToWrite, Length(S));
end;
if Length(Result) > 0 then
Result[Length(Result)] := '.'
end;
function TServerMethods1.GetStream(Len : Integer): TStream;
var
SS : TStringStream;
begin
SS := TStringStream.Create;
SS.WriteString(BuildString(Len));
SS.Position := 0;
Result := SS;
end;
function TServerMethods1.GetString(Len : Integer): String;
begin
Result := BuildString(Len);
end;
ServerContainer code:
unit ServerContainer2u;
interface
uses System.SysUtils, System.Classes, Datasnap.DSTCPServerTransport,
Datasnap.DSServer, Datasnap.DSCommonServer, Datasnap.DSAuth, IPPeerServer,
DataSnap.DSProviderDataModuleAdapter;
type
TServerContainer1 = class(TDataModule)
DSServer1: TDSServer;
DSTCPServerTransport1: TDSTCPServerTransport;
DSServerClass1: TDSServerClass;
procedure DataModuleCreate(Sender: TObject);
procedure DSServerClass1GetClass(DSServerClass: TDSServerClass;
var PersistentClass: TPersistentClass);
end;
var
ServerContainer1: TServerContainer1;
implementation
{$R *.dfm}
uses ServerMethods2u;
procedure TServerContainer1.DataModuleCreate(Sender: TObject);
begin
DSServerClass1.Server := DSServer1;
DSTCPServerTransport1.Server := DSServer1;
end;
procedure TServerContainer1.DSServerClass1GetClass(
DSServerClass: TDSServerClass; var PersistentClass: TPersistentClass);
begin
PersistentClass := TServerMethods1;
end;
end.
ServerForm code:
unit ServerForm2u;
interface
uses Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants,
System.Classes, Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs,
Vcl.StdCtrls, DBXJSON, Data.DBXDataSnap, IPPeerClient,
Data.DBXCommon, Data.FMTBcd, Data.DB, Data.SqlExpr, Data.DbxHTTPLayer,
DataSnap.DSServer;
type
TForm1 = class(TForm)
btnGetStream: TButton;
edStreamSize: TEdit;
SQLConnection1: TSQLConnection;
SMGetStream: TSqlServerMethod;
Memo1: TMemo;
Label1: TLabel;
btnGetString: TButton;
Label2: TLabel;
edStringSize: TEdit;
SMGetString: TSqlServerMethod;
procedure FormCreate(Sender: TObject);
procedure btnGetStreamClick(Sender: TObject);
procedure btnGetStringClick(Sender: TObject);
private
public
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.FormCreate(Sender: TObject);
begin
SqlConnection1.ConnectionData.Properties.Values['CommunicationProtocol'] := 'tcp/ip';
SqlConnection1.ConnectionData.Properties.Values['BufferKBSize'] := '64';
SMGetStream.Params.Clear;
SMGetStream.Params.CreateParam(ftInteger, 'Len', ptInput);
SMGetStream.Params.CreateParam(ftStream, 'Result', ptOutput);
SMGetString.Params.Clear;
SMGetString.Params.CreateParam(ftInteger, 'Len', ptInput);
SMGetString.Params.CreateParam(ftString, 'Result', ptOutput);
end;
procedure TForm1.btnGetStreamClick(Sender: TObject);
var
SS : TStringStream;
S : TStream;
begin
Memo1.Lines.Clear;
SS := TStringStream.Create;
try
SMGetStream.Params[0].AsInteger := StrtoInt(edStreamSize.Text);
SMGetStream.ExecuteMethod;
S := SMGetStream.Params[1].AsStream;
S.Position := 0;
if S.Size > 0 then begin
try
SS.CopyFrom(S, S.Size);
Memo1.Lines.BeginUpdate;
Memo1.Lines.Text := SS.DataString;
Memo1.Lines.Insert(0, IntToStr(S.Size));
finally
Memo1.Lines.EndUpdate;
end;
end
else
ShowMessage(IntToStr(S.Size));
finally
SS.Free;
end;
end;
procedure TForm1.btnGetStringClick(Sender: TObject);
var
S : String;
Size : Integer;
begin
Memo1.Lines.Clear;
Size := StrtoInt(edStringSize.Text);
SMGetString.Params[0].AsInteger := Size;
SMGetString.ExecuteMethod;
S := SMGetString.Params[1].AsString;
if Length(S) > 0 then begin
try
Memo1.Lines.BeginUpdate;
Memo1.Lines.Text := S;
Memo1.Lines.Insert(0, IntToStr(Length(S)));
finally
Memo1.Lines.EndUpdate;
end;
end;
end;
end.

issuing Netsh command from Delphi program

I am trying to capture the Device ID of an AirCard. I am using the following code with the intentions of storing the results in a text file (imei.txt) that I store in the Temp folder and loop through the contents, looking for DEVICE ID.
The problems is that it only writes "The following command was not found: mbn show interface." to the file.
I have tested the Netsh command from the command line and it returns what I would expect.
xs1 := CreateOleObject('WSCript.Shell');
xs1.run('%comspec% /c netsh mbn show interface > "' + IMEIFileName +
'"', 0, true);
It is failing to process the NetSh command properly. Am I passing it through the Comspec correctly? It seems to not run the "NetSh" command and acts as if I am running "mbn" from the command prompt.
Thanks
unit uMain;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants,
System.Classes, Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs, System.Win.ComObj, ShlObj, Vcl.StdCtrls;
type
TfrmMain = class(TForm)
Button1: TButton;
Memo1: TMemo;
procedure Button1Click(Sender: TObject);
private
procedure GetAirCardInformation;
{ Private declarations }
public
{ Public declarations }
IMEI: string;
PhoneNumber: string;
end;
var
frmMain: TfrmMain;
implementation
{$R *.dfm}
procedure TfrmMain.Button1Click(Sender: TObject);
begin
GetAirCardInformation;
end;
procedure TfrmMain.GetAirCardInformation;
var
xs1 : OleVariant;
IMEIFileName: String;
IMEIStrings: TStringList;
I: Integer;
function GetSpecialFolder(const CSIDL: Integer): string;
var
RecPath: PWideChar;
begin
RecPath := StrAlloc(MAX_PATH);
try
FillChar(RecPath^, MAX_PATH, 0);
if SHGetSpecialFolderPath(0, RecPath, CSIDL, false) then
result := RecPath
else
result := '';
finally
StrDispose(RecPath);
end;
end;
begin
IMEI := '';
IMEIFileName := GetSpecialFolder(CSIDL_LOCAL_APPDATA) + '\Temp\imei.txt';
Memo1.Lines.Add('IMEIFileName: ' + IMEIFileName);
try
if FileExists(IMEIFileName) then
DeleteFile(IMEIFileName);
xs1 := CreateOleObject('WSCript.Shell');
xs1.run('%comspec% /c netsh mbn show interface > "' + IMEIFileName +
'"', 0, true);
if FileExists(IMEIFileName) then
begin
IMEIStrings := TStringList.Create;
IMEIStrings.LoadFromFile(IMEIFileName);
IMEIStrings.NameValueSeparator := ':';
Memo1.Lines.Add('IMEIStrings Count: ' + intToStr(IMEIStrings.Count));
for I := 0 to IMEIStrings.Count - 1 do
begin
Memo1.Lines.Add(IMEIStrings.text);
if (Uppercase(Trim(IMEIStrings.Names[I])) = 'DEVICE ID') then
begin
IMEI := Trim(IMEIStrings.Values[IMEIStrings.Names[I]]);
Memo1.Lines.Add('IMEI:' + IMEI);
break;
end;
end;
end;
except
IMEI := '';
end;
Memo1.Lines.Add('process complete');
end;
end.
You should not be using the WShell COM object to run cmd.exe. That is overkill. You can use CreateProcess() instead. However, when running cmd.exe programmably, you cannot redirect its output using the > operator, that only works in an actual command window. You can instead use the STARTUPINFO structure to redirect the output to an anonymous pipe created with CreatePipe(), and then you can read from that pipe using ReadFile(). No need to use a temp file at all. MSDN has an article on this topic:
Creating a Child Process with Redirected Input and Output
There are plenty of examples floating around that demonstrate this technique in Delphi.
That being said, a better option is to not use netsh at all. Windows 7 and later have a Mobile Broadband API. You can enumerate the MBN interfaces directly in your code.
For example, using the WwanEnumerateInterfaces() function:
unit WwApi;
{$MINENUMSIZE 4}
interface
uses
Windows;
const
WWAN_STR_DESC_LENGTH = 256;
type
WWAN_INTERFACE_STATE = (
WwanInterfaceStateNotReady,
WwanInterfaceStateDeviceLocked,
WwanInterfaceStateUserAccountNotActivated,
WwanInterfaceStateRegistered,
WwanInterfaceStateRegistering,
WwanInterfaceStateDeregistered,
WwanInterfaceStateAttached,
WwanInterfaceStateAttaching,
WwanInterfaceStateDetaching,
WwanInterfaceStateActivated,
WwanInterfaceStateActivating,
WwanInterfaceStateDeactivating
);
WWAN_INTF_OPCODE = (
WwanIntfOpcodePin,
WwanIntfOpcodeRadioState,
WwanIntfOpcodePreferredProviders,
WwanIntfOpcodeCurrentConnection,
WwanIntfOpcodeProvisionedContexts,
WwanIntfOpcodeActivateUserAccount,
WwanIntfOpcodeVendorSpecific,
WwanIntfOpcodeInterfaceObject,
WwanIntfOpcodeConnectionObject,
WwanIntfOpcodeAcState,
WwanIntfOpcodeClearManualConnectState,
WwanIntfOpcodeGetStoredRadioState,
WwanIntfOpcodeGetRadioInfo,
WwanIntfOpcodeHomeProvider
);
// I don't know the definition of this type!
WWAN_STATUS = DWORD; //?
WWAN_INTERFACE_STATUS = record
fInitialized: BOOL;
InterfaceState: WWAN_INTERFACE_STATE;
end;
PWWAN_INTERFACE_INFO = ^WWAN_INTERFACE_INFO;
WWAN_INTERFACE_INFO = record
InterfaceGuid: TGuid;
strInterfaceDescription: array[0..WWAN_STR_DESC_LENGTH-1] of WCHAR;
InterfaceStatus: WWAN_INTERFACE_STATUS;
ParentInterfaceGuid: TGuid;
fIsAdditionalPdpContextInterface: BOOL;
end;
PWWAN_INTERFACE_INFO_LIST = ^WWAN_INTERFACE_INFO_LIST;
WWAN_INTERFACE_INFO_LIST = record
dwNumberOfItems: DWORD;
pInterfaceInfo: array[0..0] of WWAN_INTERFACE_INFO;
end;
function WwanOpenHandle(dwClientVersion: DWORD; pReserved: Pointer; var pdwNegotiatedVersion: DWORD; var phClientHandle: THandle): DWORD; stdcall;
function WwanCloseHandle(hClientHandle: THandle; pReserved: Pointer): DWORD; stdcall;
function WwanEnumerateInterfaces(hClientHandle: THandle; pdwReserved: PDWORD; var ppInterfaceList: PWWAN_INTERFACE_INFO_LIST): DWORD; stdcall;
procedure WwanFreeMemory(pMem: Pointer); stdcall;
function WwanQueryInterface(hClientHandle: THandle; const pInterfaceGuid: TGuid; opCode: WWAN_INTF_OPCODE; pReserved: Pointer; var pdwDataSize: DWORD; var ppData: PByte; var pRequestId: ULONG; var pStatus: WWAN_STATUS): DWORD; stdcall;
implementation
const
WwApiLib = 'WwApi.dll';
function WwanOpenHandle; external WwApiLib delayed;
function WwanCloseHandle; external WwApiLib delayed;
function WwanEnumerateInterfaces; external WwApiLib delayed;
procedure WwanFreeMemory; external WwApiLib delayed;
function WwanQueryInterface; external WwApiLib delayed;
end.
unit uMain;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants,
System.Classes, Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs,
Vcl.StdCtrls;
type
TfrmMain = class(TForm)
Button1: TButton;
Memo1: TMemo;
procedure Button1Click(Sender: TObject);
private
procedure GetAirCardInformation;
{ Private declarations }
public
{ Public declarations }
IMEI: string;
PhoneNumber: string;
end;
var
frmMain: TfrmMain;
implementation
{$R *.dfm}
uses
WwApi;
procedure TfrmMain.Button1Click(Sender: TObject);
begin
GetAirCardInformation;
end;
procedure TfrmMain.GetAirCardInformation;
var
dwNegotiatedVersion: DWORD;
hClientHandle: THandle;
pInterfaceList: PWWAN_INTERFACE_INFO_LIST;
pInterface: PWWAN_INTERFACE_INFO;
I: DWORD;
begin
IMEI := '';
Memo1.Clear;
try
// The value of the first parameter is undocumented!
// WlanOpenHandle() has a similar parameter, where 1
// is for XP and 2 is for Vista+. Maybe it is the same
// for WwanOpenHandle()?...
//
if WwanOpenHandle(2, nil, dwNegotiatedVersion, hClientHandle) = 0 then
try
if WwanEnumerateInterfaces(hClientHandle, nil, pInterfaceList) = 0 then
try
Memo1.Lines.Add('IMEIStrings Count: ' + IntToStr(pInterfaceList.dwNumberOfItems));
if pInterfaceList.dwNumberOfItems > 0 then
begin
pInterface := #pInterfaceList.pInterfaceInfo[0];
for I := 0 to pInterfaceList.dwNumberOfItems-1 do
begin
// use pInterface as needed...
Memo1.Lines.Add('Desc:' + StrPas(pInterface.strInterfaceDescription));
Memo1.Lines.Add('Intf:' + GUIDToString(pInterface.InterfaceGuid));
// and so on ...
Memo1.Lines.Add('');
Inc(pInterface);
end;
end;
finally
WwanFreeMemory(pInterfaceList);
end;
finally
WwanCloseHandle(hClientHandle, nil);
end;
except
end;
Memo1.Lines.Add('process complete');
end;
end.
Alternatively, using the IMbnInterfaceManager and IMbnInterface COM interfaces, which give you more detailed information:
unit uMain;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants,
System.Classes, Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs,
Vcl.StdCtrls;
type
TfrmMain = class(TForm)
Button1: TButton;
Memo1: TMemo;
procedure Button1Click(Sender: TObject);
private
procedure GetAirCardInformation;
{ Private declarations }
public
{ Public declarations }
IMEI: string;
PhoneNumber: string;
end;
var
frmMain: TfrmMain;
implementation
{$R *.dfm}
uses
// I found the MbnApi.pas unit on the DelphiPraxis forum:
//
// http://www.delphipraxis.net/1342330-post2.html
//
// It is too large to post here on StackOverflow!
// Otherwise, you can import the mbnapi.tlb TypeLibrary yourself...
//
MbnApi, ActiveX, ComObj;
procedure TfrmMain.Button1Click(Sender: TObject);
begin
GetAirCardInformation;
end;
procedure TfrmMain.GetAirCardInformation;
var
Mgr: IMbnInterfaceManager;
pInterfaceArray, pPhoneNumberArray: PSafeArray;
pInterface: IMbnInterface;
subscriber: IMbnSubscriberInformation;
ReadyState: MBN_READY_STATE;
lIntfLower, lIntfUpper: LONG;
lPhoneNumLower, lPhoneNumUpper: LONG;
I, J: LONG;
wStr: WideString;
begin
Memo1.Clear;
try
OleCheck(CoCreateInstance(CLASS_MbnInterfaceManager, nil, CLSCTX_ALL, IMbnInterfaceManager, Mgr));
OleCheck(Mgr.GetInterfaces(pInterfaceArray));
try
OleCheck(SafeArrayGetLBound(pInterfaceArray, 1, lIntfLower));
OleCheck(SafeArrayGetUBound(pInterfaceArray, 1, lIntfUpper));
for I = lIntfLower to lIntfUpper do
begin
OleCheck(SafeArrayGetElement(pInterfaceArray, I, pInterface));
try
// use pInterface as needed...
OleCheck(pInterface.get_InterfaceID(wStr));
try
Memo1.Lines.Add('Interface ID:' + wStr);
finally
wStr := '';
end;
OleCheck(pInterface.GetReadyState(ReadyState));
Memo1.Lines.Add('Ready State:' + IntToStr(Ord(ReadyState)));
OleCheck(pInterface.GetSubscriberInformation(subscriber));
try
OleCheck(subscriber.Get_SubscriberID(wStr));
try
Memo1.Lines.Add('Subscriber ID: ' + wStr);
finally
wStr := '';
end;
OleCheck(subscriber.Get_SimIccID(wStr));
try
Memo1.Lines.Add('Sim ICC ID: ' + wStr);
finally
wStr := '';
end;
OleCheck(subscriber.Get_TelephoneNumbers(pPhoneNumberArray));
try
OleCheck(SafeArrayGetLBound(pPhoneNumberArray, 1, lPhoneNumLower));
OleCheck(SafeArrayGetUBound(pPhoneNumberArray, 1, lPhoneNumUpper));
for J = lPhoneNumLower to lPhoneNumUpper do
begin
OleCheck(SafeArrayGetElement(pPhoneNumberArray, J, wStr));
try
Memo1.Lines.Add('Phone #:' + wStr);
finally
wStr := '';
end;
end;
finally
SafeArrayDestroy(pPhoneNumberArray);
end;
finally
subscriber := nil;
end;
// and so on...
Memo1.Lines.Add('');
finally
pInterface := nil;
end;
end;
finally
SafeArrayDestroy(pInterfaceArray);
end;
except
end;
Memo1.Lines.Add('process complete');
end;
end.

NetShareEnum not displaying shares correctly

I'm developing a project to help me managing my remote network, as I need some very specific features I decided to code it.
I connect to the remote computers using WNetAddConnection2 and this part is working. But now I try to list all the shares (ADMIN$, C$, IPC$, and any shared folders) using the NetShareEnum function. I relied on this function and not on WNetEnumResource because I found more examples working with NetShareEnum, and it's working better for me. The problem is that my implementation of NetShareEnum is listing only some type of folders (looks like only folders that are shared but I have no access). It doesn't list normal folders (where I have access), ADMIN$, C$, IPC$, or anything else. Only shared folders that I'm without rights to access.
I still not sure if the behavior is the same on all servers, but the ones I tested it was. So far what I have is:
unit Unit1;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls;
type
TForm1 = class(TForm)
Memo1: TMemo;
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
HostFile: TStringList;
iHost: integer;
type
SharesThread = class(TThread)
strict private
IPAddress: String;
function Authenticate: bool;
procedure EnumShares(RemoteName: PWChar);
protected
constructor Create(const IPv4: string);
procedure Execute; override;
end;
type
_SHARE_INFO_502 = packed record
shi502_netname: PWideChar;
shi502_type: DWORD;
shi502_remark: PWideChar;
shi502_permissions: DWORD;
shi502_max_uses: DWORD;
shi502_current_uses: DWORD;
shi502_path: LPWSTR;
shi502_passwd: LPWSTR;
shi502_reserved: DWORD;
shi502_security_dsc: PSECURITY_DESCRIPTOR;
end;
SHARE_INFO_502 = _SHARE_INFO_502;
PSHARE_INFO_502 = ^SHARE_INFO_502;
LPSHARE_INFO_502 = PSHARE_INFO_502;
TShareInfo502 = SHARE_INFO_502;
PShareInfo502 = PSHARE_INFO_502;
type
TShareInfo502Array = Array [0..MaxWord] of TShareInfo502;
PShareInfo502Array = ^TShareInfo502Array;
function NetApiBufferFree(buffer: Pointer): DWORD; stdcall; external 'netapi32.dll';
function NetShareEnum(servername: PWideChar;
level: DWORD;
bufptr: PByteArray;
prefmaxlen: DWORD;
entriesread: PDWORD;
totalentries: PDWORD;
resume_handle: PDWORD): DWORD; stdcall; external 'netapi32.dll';
implementation
const
NERR_Success = 0;
MAX_PREFERRED_LENGTH = DWORD( -1 );
procedure StartThreads;
var
CurrentIP: string;
begin
if (iHost < HostFile.Count) then
begin
CurrentIP:= HostFile.Strings[iHost];
inc(iHost);
SharesThread.Create(CurrentIP);
end
else
Form1.Memo1.Lines.Add('finished');
end;
constructor SharesThread.Create(const IPv4: string);
begin
inherited Create(false);
FreeOnTerminate:= true;
IPAddress:= IPv4;
end;
function SharesThread.Authenticate;
var
lpNetResource: TNetResource;
myres: cardinal;
begin
with lpNetResource do
begin
dwType := RESOURCETYPE_ANY;
lpLocalName := nil;
lpProvider := nil;
lpRemoteName:= PChar('\\'+IPAddress);
end;
myres := WNetAddConnection2(lpNetResource, PChar('123456'), PChar('BlackNote'), 0);
if ( myres = NO_ERROR ) then
begin
Result:= true;
EnumShares(lpNetResource.lpRemoteName);
end
else
begin
Result:= false;
end;
end;
procedure SharesThread.EnumShares(RemoteName: PWChar);
var
p: PShareInfo502Array;
res, er, tr, resume, i: DWORD;
begin
repeat
res:=NetShareEnum(RemoteName, 502, #p, MAX_PREFERRED_LENGTH, #er, #tr, #resume);
if (res = ERROR_SUCCESS) or (res = ERROR_MORE_DATA) then
begin
for i:=1 to Pred(er) do
begin
Form1.Memo1.Lines.Add(String(p^[i].shi502_netname));
end;
NetApiBufferFree(p);
end;
until (res <> ERROR_MORE_DATA);
end;
procedure SharesThread.Execute;
begin
if Authenticate then
Form1.Memo1.Lines.Add(IPAddress + '=' + 'Listed shares above')
end;
{$R *.dfm}
procedure TForm1.FormCreate(Sender: TObject);
begin
HostFile:= TStringList.Create;
HostFile.LoadFromFile('Hosts.txt');
iHost:= 0;
StartThreads;
end;
end.
I can post my IP address here to you try this project, but not sure if this is under the rules. Anyway, is something wrong with this code?
I think you have BAD multithreading issues.
First of all, check if the very API you use is thread-safe.
I did not found this particular information, but http://computer-programming-forum.com/82-mfc/8e7756aee43ed65a.htm
Maybe you just can not call that function from different threads at the same time.
Second: all hundreds of your threads do Form1.Memo1.Lines.Add(String(p^[i].shi502_netname)) - that is VERY wrong.
You CAN NOT access GUI objects from threads. CAN NOT. Period.
See Delphi 7 Occasional deadlock changing TLabel.Font.Style from IdHTTPListener event for example.
The very process of loading form from DFM-resource, initializing it, creating Windows and Delphi objects and binding them, together is complex.
When at the same time hundreds of threads are crashing into half-created from and updating half-created MEMO they literally do destroy actions of one another.
Basically you told us that Windows did not returned you all the shares - but what you mean is that half-created TMemo abused by hundreds of threads does not show you all the shares. That is not the same, that might mean Windows work badly, but it also might mean Windows works ok, but you fail to put all the results into VCL GUI. You have to ensure what exactly happened.
Try getting shares
1.1 only in one single thread!
1.2 and that should be MAIN thread, not extra ones.
1.3 and you only should start it after the form is created - for example from some button click event.
And check if there is the difference.
You should not add data by one line to the memo - it is VERY slow.
Make a simple test.
uses Hourglass; // http://www.deltics.co.nz/blog/posts/tag/delticshourglass
const cMax = 10000;
procedure TForm1.Button1Click( Sender: TObject );
var sl: TStrings; i: integer; t: cardinal;
begin
HourglassOn();
t := GetTickCount();
sl := TStringList.Create;
try
for i := 1 to cMax do
sl.Add(IntToStr(i));
Memo1.Lines.Clear;
Memo1.Lines.AddStrings(sl);
finally
sl.Destroy;
end;
t := GetTickCount - t;
ShowMessage('It took ' + IntoToStr(t) + '/1000 seconds');
end;
procedure TForm2.Button1Click( Sender: TObject );
var i: integer; t: cardinal;
begin
HourglassOn();
t := GetTickCount();
Memo1.Lines.Clear;
for i := 1 to cMax do begin
Memo1.Lines.Add(IntToStr(i));
// giving Windows chance to repaint the memo
// simulating access from extra threads
// when main thread is free to repaint forms time and again
Application.ProcessMessages;
end;
t := GetTickCount - t;
ShowMessage('It took ' + IntoToStr(t) + '/1000 seconds');
end;
So a little draft to test your issues might be like this
http://docwiki.embarcadero.com/Libraries/XE2/en/System.IOUtils.TFile.ReadAllLines
http://www.thedelphigeek.com/2010/06/omnithreadlibrary-20-sneak-preview-1.html
http://www.thedelphigeek.com/2010/11/multistage-processes-with.html
http://otl.17slon.com/book/chap04.html#highlevel-pipeline
Just a draft for you to look into generic approach
const WM_EnumEnded = WM_USER + 1;
type TFrom1 = class(TForm)
Memo1: TMemo;
Button1: TButton;
Button2: TButton;
....
public
var Enums: iOmniBlockingCollection;
procedure StartEnum( const SingleThread: boolean );
procedure ShowResults( var m: TMessage); message WM_EnumEnded;
.....
procedure TFrom1.StartEnum( const SingleThread: boolean );
var hosts: TStringDynArray; // TArray<string>, array of string....
Source: IOmniBlockingCollection;
iWorker: IOmniParallelLoop<T>; // variable only needed for if-then-else
begin
hosts := TFile.ReadAllLines('hosts.txt');
Self.Enums := TOmniBlockingCollection.Create; // Results accumulator
Source := TOmniBlockingCollection.Create;
Source.Add( TOmniValue.FromArray<string>(hosts) );
iWorker := Parallel.ForEach<string>( Source ).NoWait().OnStop(
procedure begin PostMessage( Self.Handle, WM_EnumEnded, 0, 0) end
);
if SingleThread then iWorker := iWorker.NumTasks(1);
iWorker.Execute(
procedure(const value: String)
var i: integer;
begin
....
res:=NetShareEnum(RemoteName, 502 { 503 better ?? } ... );
....
Self.Enums.Add( TOmniValue(String(p^[i].shi502_netname)) );
...
end;
);
end;
procedure TFrom1.ShowResults( var m: TMessage );
var sa: TArray<String>;
begin
Self.Enums.CompleteAdding;
sa := TOmniblockingCollection.ToArray<string>( Self.Enums );
Memo1.Clear;
Memo1.Lines.AddStrings( sa );
end;
procedure TFrom1.Button1Click(sender: Tobject);
begin
StartEnum( True );
end;
procedure TFrom1.Button2Click(sender: Tobject);
begin
StartEnum( False );
end;

Encrypt and decrypt a Unicode string

Can someone give me the code to encrypt and decrypt a Unicode strings in delphi firemonkey Mobile?
I've tried everything with xor with other libraries , and nothing.
There are always characters that are not recognized as the euro symbol € .
If someone could help me , would be appreciated.
Edit:
Thank you Hans, but always I have the same problem with stringstream . This code works perfectly in windows , but ios gives me this error : "No mapping for the Unicode character exists in the target multibyte code page"
unit UMain;
interface
uses
System.SysUtils, System.Types, System.UITypes, System.Classes, System.Variants,
FMX.Types, FMX.Controls, FMX.Forms, FMX.Graphics, FMX.Dialogs, ElAES,
FMX.StdCtrls, FMX.Layouts, FMX.Memo, Math;
type
TForm2 = class(TForm)
ToolBar1: TToolBar;
Label1: TLabel;
Label2: TLabel;
Memo1: TMemo;
Layout1: TLayout;
Button1: TButton;
Button3: TButton;
procedure Button1Click(Sender: TObject);
procedure Button3Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
const
PASSWORD = '1234';
var
Form2: TForm2;
implementation
{$R *.fmx}
{$R *.iPhone.fmx IOS}
function StringToHex(S: string): string;
var
i: integer;
begin
Result := '';
// Go throught every single characters, and convert them
// to hexadecimal...
for i := 1 to Length( S ) do
Result := Result + IntToHex( Ord( S[i] ), 2 );
end;
function HexToString(S: string): string;
var
i: integer;
begin
Result := '';
// Go throught every single hexadecimal characters, and convert
// them to ASCII characters...
for i := 1 to Length( S ) do
begin
// Only process chunk of 2 digit Hexadecimal...
if ((i mod 2) = 1) then
Result := Result + Chr( StrToInt( '0x' + Copy( S, i, 2 )));
end;
end;
procedure TForm2.Button1Click(Sender: TObject);
var
Source: TStringStream;
Dest: TStringStream;
Key: TAESKey128;
begin
try
Source := TStringStream.Create( Memo1.Text );
Dest := TStringStream.Create('');
FillChar( Key, SizeOf(Key), 0 );
Move( PChar(PASSWORD)^, Key, Min( SizeOf( Key ), Length( PASSWORD )));
EncryptAESStreamECB( Source, 0, Key, Dest );
//Memo1.Lines.BeginUpdate;
Memo1.Text := Dest.DataString;
//Memo1.Lines.EndUpdate;
Label2.Text := 'Texto Encriptado';
Source.Free;
Dest.Free;
except on E: Exception do
begin
ShowMessage(e.ToString);
Source.Free;
Dest.Free;
Memo1.Text :='';
end;
end;
end;
procedure TForm2.Button3Click(Sender: TObject);
var
Source: TStringStream;
Dest: TStringStream;
Key: TAESKey128;
Size: integer;
begin
try
Source := TStringStream.Create(Trim(Memo1.Text) );
Dest := TStringStream.Create('');
Size := Source.Size;
Source.ReadBuffer(Size, SizeOf(Size));
FillChar(Key, SizeOf(Key), 0);
Move(PChar(PASSWORD)^, Key, Min(SizeOf(Key), Length(PASSWORD)));
Source.Position := 0;
DecryptAESStreamECB(Source, Source.Size - Source.Position, Key, Dest);
Memo1.Text := Trim(Dest.DataString);
Label2.Text := 'Texto Original';
Source.Free;
Dest.Free;
except on E: Exception do
begin
ShowMessage(e.ToString);
Source.Free;
Dest.Free;
Memo1.Text :='';
end;
end;
end;
end.
I've also tried to create stringstream with this:
Source := TStringStream.Create(Trim(Memo1.Text) , TEncoding.Unicode) ;
and sometimes works well and sometimes gives me the following error:"Los surrogate char without a preceding high surrogate char at index: 8. chaeck that the string is encoded properly.
Any ideas?
Use standardized libraries instead of trying to make your own encryption solution. There are for example several implementation of AES encryption available for Delphi (e.g. Eldos which is included in the NativeXML library).
Write your string (MyString) to a stream and encrypt it:
var
lSourceStream: TStringStream;
lDestinationStream: TMemoryStream;
begin
lSourceStream := TStringStream.Create(MyString);
lDestinationStream := TMemoryStream.Create;
AESencrypt(lSourceStream,lDestinationStream);
lDestinationStream.SaveToFile(<filename>);
end;

Issues passing data from DLL to Application

I'm a bit puzzled as to how Pointers should be properly used in my scenario. I have a DLL with some embedded resources in it. I expose a function in this DLL which passes binary data of one of those resources back to its calling app. In this case, I've embedded a JPG image file. My DLL does properly load the file into a resource stream. However from there, the passing it back to the app gets messy.
Here's my DLL's code (with a JPG loaded and named SOMERESOURCE):
library ResDLL;
{$R *.dres}
uses
System.SysUtils,
System.Classes,
Winapi.Windows;
{$R *.res}
function GetResource(const ResName: PChar; Buffer: Pointer;
var Length: Integer): Bool; stdcall;
var
S: TResourceStream;
L: Integer;
Data: array of Byte;
begin
Result:= False;
try
S:= TResourceStream.Create(HInstance, UpperCase(ResName), RT_RCDATA);
try
S.Position:= 0;
L:= S.Size;
Length:= L;
SetLength(Data, L);
S.Read(Data[0], L);
Buffer:= #Data[0];
Result:= True;
finally
S.Free;
end;
except
Result:= False;
end;
end;
exports
GetResource;
begin
end.
And here's my app's code (with just a TBitBtn and TImage):
function GetResource(const ResName: PChar; Buffer: Pointer;
var Length: Integer): Bool; stdcall; external 'ResDLL.dll';
procedure TForm1.BitBtn1Click(Sender: TObject);
var
Buffer: array of Byte;
Size: Integer;
S: TMemoryStream;
P: TPicture;
begin
if GetResource('SOMERESOURCE', #Buffer[0], Size) then begin
S:= TMemoryStream.Create;
try
SetLength(Buffer, Size);
S.Write(Buffer, Size);
S.Position:= 0;
P:= TPicture.Create;
try
P.Graphic.LoadFromStream(S);
Image1.Picture.Assign(P);
finally
P.Free;
end;
finally
S.Free;
end;
end else begin
raise Exception.Create('Problem calling DLL');
end;
end;
It appears as if the whole DLL call is successful, however the data which was received is empty (full of 0's). I am full of curiosity as to how something like Data would need to be called as Data[0], and in what scenarios I should, and also in what scenarios I need to use #Data. I wrote that code in the DLL entirely, and I'm not familiar with such work, so I'm sure I botched it up somewhere. Where am I going wrong?
On the DLL side, GetResource() is reading the resource data into a local array and not copying it into the buffer that is passed to the function. Assigning the local array to the Buffer pointer does not copy the data being pointed at.
On the app side, BitBtn1Click() is not allocating any memory for GetResource() to write the resource data into. Even if it were, you are not writing the buffer into the TMemoryStream correctly. Even if you were, you are not loading the TMemoryStream into the TPicture correctly.
You have a couple of approaches you can take to fix the Buffer issue:
1) have GetResource() allocate a buffer and return it to the app, then have the app pass the buffer back to the DLL when finished to free it:
library ResDLL;
{$R *.dres}
uses
System.SysUtils,
System.Classes,
Winapi.Windows;
{$R *.res}
function GetResourceData(const ResName: PChar; var Buffer: Pointer;
var Length: Integer): Bool; stdcall;
var
S: TResourceStream;
L: Integer;
Data: Pointer;
begin
Result := False;
try
S := TResourceStream.Create(HInstance, UpperCase(ResName), RT_RCDATA);
try
L := S.Size;
GetMem(Data, L);
try
S.ReadBuffer(Data^, L);
Buffer := Data;
Length := L;
except
FreeMem(Data);
raise;
end;
Result := True;
finally
S.Free;
end;
except
end;
end;
procedure FreeResourceData(Buffer: Pointer); stdcall;
begin
try
FreeMem(Buffer);
except
end;
end;
exports
GetResourceData,
FreeBufferData;
begin
end.
.
unit uMain;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Vcl.Buttons, Vcl.ExtCtrls;
type
TForm1 = class(TForm)
BitBtn1: TBitBtn;
Image1: TImage;
procedure BitBtn1Click(Sender: TObject);
private
public
end;
var
Form1: TForm1;
implementation
uses
Vcl.Imaging.jpeg;
{$R *.dfm}
function GetResourceData(const ResName: PChar; var Buffer: Pointer;
var Length: Integer): Bool; stdcall; external 'ResDLL.dll';
procedure FreeResourceData(Buffer: Pointer); stdcall; external 'ResDLL.dll';
procedure TForm1.BitBtn1Click(Sender: TObject);
var
Buffer: Pointer;
Size: Integer;
S: TMemoryStream;
JPG: TJPEGImage;
begin
if GetResourceData('SOMERESOURCE', Buffer, Size) then
begin
try
S := TMemoryStream.Create;
try
S.WriteBuffer(Buffer^, Size);
S.Position := 0;
JPG := TJPEGImage.Create;
try
JPG.LoadFromStream(S);
Image1.Picture.Assign(JPG);
finally
JPG.Free;
end;
finally
S.Free;
end;
finally
FreeResourceData(Buffer);
end;
end else begin
raise Exception.Create('Problem calling DLL');
end;
end;
end.
2) have the app query the DLL for the size of the resource, then allocate a buffer and pass it to the DLL to fill in:
library ResDLL;
{$R *.dres}
uses
System.SysUtils,
System.Classes,
Winapi.Windows;
{$R *.res}
function GetResourceData(const ResName: PChar; Buffer: Pointer;
var Length: Integer): Bool; stdcall;
var
S: TResourceStream;
L: Integer;
Data: Pointer;
begin
Result := False;
try
S := TResourceStream.Create(HInstance, UpperCase(ResName), RT_RCDATA);
try
L := S.Size;
if Buffer <> nil then
begin
if Length < L then Exit;
S.ReadBuffer(Buffer^, L);
end;
Length := L;
Result := True;
finally
S.Free;
end;
except
end;
end;
exports
GetResourceData;
begin
end.
.
unit uMain;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Vcl.Buttons, Vcl.ExtCtrls;
type
TForm1 = class(TForm)
BitBtn1: TBitBtn;
Image1: TImage;
procedure BitBtn1Click(Sender: TObject);
private
public
end;
var
Form1: TForm1;
implementation
uses
Vcl.Imaging.jpeg;
{$R *.dfm}
function GetResourceData(const ResName: PChar; Buffer: Pointer;
var Length: Integer): Bool; stdcall; external 'ResDLL.dll';
procedure TForm1.BitBtn1Click(Sender: TObject);
var
Buffer: array of Byte;
Size: Integer;
S: TMemoryStream;
JPG: TJPEGImage;
begin
if GetResourceData('SOMERESOURCE', nil, Size) then
begin
SetLength(Buffer, Size);
if GetResourceData('SOMERESOURCE', #Buffer[0], Size) then
begin
S := TMemoryStream.Create;
try
S.WriteBuffer(Buffer[0], Size);
S.Position := 0;
// alternatively, use TBytesStream, or a custom
// TCustomMemoryStream derived class, to read
// from the original Buffer directly so it does
// not have to be copied in memory...
JPG := TJPEGImage.Create;
try
JPG.LoadFromStream(S);
Image1.Picture.Assign(JPG);
finally
JPG.Free;
end;
finally
S.Free;
end;
Exit;
end;
end;
raise Exception.Create('Problem calling DLL');
end;
end.
Or:
library ResDLL;
{$R *.dres}
uses
System.SysUtils,
System.Classes,
Winapi.Windows;
{$R *.res}
function GetResourceData(const ResName: PChar; Buffer: Pointer;
var Length: Integer): Bool; stdcall;
var
S: TResourceStream;
L: Integer;
Data: Pointer;
begin
Result := False;
if (Buffer = nil) or (Length <= 0) then Exit;
try
S := TResourceStream.Create(HInstance, UpperCase(ResName), RT_RCDATA);
try
L := S.Size;
if Length < L then Exit;
S.ReadBuffer(Buffer^, L);
Length := L;
Result := True;
finally
S.Free;
end;
except
end;
end;
function GetResourceSize(const ResName: PChar): Integer; stdcall;
var
S: TResourceStream;
begin
Result := 0;
try
S := TResourceStream.Create(HInstance, UpperCase(ResName), RT_RCDATA);
try
Result := S.Size;
finally
S.Free;
end;
except
end;
end;
exports
GetResourceData,
GetResourceSize;
begin
end.
.
unit uMain;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Vcl.Buttons, Vcl.ExtCtrls;
type
TForm1 = class(TForm)
BitBtn1: TBitBtn;
Image1: TImage;
procedure BitBtn1Click(Sender: TObject);
private
public
end;
var
Form1: TForm1;
implementation
uses
Vcl.Imaging.jpeg;
{$R *.dfm}
function GetResourceData(const ResName: PChar; Buffer: Pointer;
var Length: Integer): Bool; stdcall; external 'ResDLL.dll';
function GetResourceSize(const ResName: PChar): Integer; stdcall; external 'ResDLL.dll';
procedure TForm1.BitBtn1Click(Sender: TObject);
var
Buffer: array of Byte;
Size: Integer;
S: TMemoryStream;
JPG: TJPEGImage;
begin
Size := GetResourceSize('SOMERESOURCE');
id Size > 0 then
begin
SetLength(Buffer, Size);
if GetResourceData('SOMERESOURCE', #Buffer[0], Size) then
begin
S := TMemoryStream.Create;
try
S.WriteBuffer(Buffer[0], Size);
S.Position := 0;
JPG := TJPEGImage.Create;
try
JPG.LoadFromStream(S);
Image1.Picture.Assign(JPG);
finally
JPG.Free;
end;
finally
S.Free;
end;
Exit;
end;
end;
raise Exception.Create('Problem calling DLL');
end;
end.
You don't need to export any functions at all from your DLL. You can just use the DLL's module handle directly from your host executable.
You are already passing a module handle to the resource stream constructor. You are passing the module handle of the executable. Instead, pass the module handle of the library.
var
hMod: HMODULE;
....
hMod := LoadLibrary('ResDLL');
try
S:= TResourceStream.Create(hMod, ...);
....
finally
FreeLibrary(hMod);
end;
If you don't want to call any functions in the DLL, if it is a resource only DLL, then use LoadLibraryEx and LOAD_LIBRARY_AS_IMAGE_RESOURCE instead:
hMod := LoadLibraryEx('ResDLL', 0, LOAD_LIBRARY_AS_IMAGE_RESOURCE);
Perhaps you know that the the DLL is already loaded. For example, it is linked to your executable implicitly. In that case you can more simply use GetModuleHandle rather than LoadLibrary or LoadLibraryEx.
hMod := GetModuleHandle('ResDLL');
S:= TResourceStream.Create(hMod, ...);
Note that I omitted all error checking for the sake of a simple exposition.
Another way passing the stream from a DLL to the application could be using interfaced streams.
implementation
uses MemoryStream_Interface;
{$R *.dfm}
Type
TGetStream = Procedure(var iStream:IDelphiStream);stdcall;
procedure TForm1.Button1Click(Sender: TObject);
var
h:THandle;
p:TGetStream;
ms :IDelphiStream;
j:TJpegImage;
begin
ms := TInterfacedMemoryStream.Create;
h := LoadLibrary('ShowStream.dll');
if h <> 0 then
try
#p := GetProcAddress(h,'GetJpegStream');
p(ms);
ms.Position := 0;
j := TJpegImage.create;
Image1.Picture.Assign(j);
j.Free;
Image1.Picture.Graphic.LoadFromStream(TInterfacedMemoryStream(ms));
finally
FreeLibrary(h);
end;
end;
The code for IDelphiStream can be found on http://www.delphipraxis.net.
I won't copy the content of MemoryStream_Interface to this post, because there are no copyright informations on the code from the mentioned page.

Resources