Related
Using both Delphi 10.2 Tokyo and Delphi XE2.
I have a DLL that posts XML data to a site. The DLL is built with Delphi 10 in order to use TLS 1.2, which is not available with Delphi XE2.
The call to the DLL comes from a Delphi XE2 EXE, but I don't believe that is relevant, but I am noting it nonetheless.
The call to post data to a site will often return text data. Sometimes very large amounts of text data. Greater than 150K characters.
My original DLL convention was basically not correct, as I returned the contents of the returned text data as a PChar. In my readings here and elsewhere, that's a big no-no.
That "bad" methodology worked well until I started to get very large amounts of data returned. I tested it, and it failed on anything greater than 132,365 characters.
I restructured my DLL and calling code to pass in a buffer as a PChar to fill in, but I get an error trying to fill the output value!
Secondly, since I never know how big the returned data will be, how to I specify how big a buffer to fill from my calling method?
My DLL code where I get the error:
library TestDLL;
uses
SysUtils,
Classes,
Windows,
Messages,
vcl.Dialogs,
IdSSLOpenSSL, IdHTTP, IdIOHandlerStack, IdURI,
IdCompressorZLib;
{$R *.res}
function PostAdminDataViaDll(body, method, url: PChar; OutData : PChar; OutLen : integer): integer; stdcall
var HTTPReq : TIdHTTP;
var Response: TStringStream;
var SendStream : TStringStream;
var IdSSLIOHandler : TIdSSLIOHandlerSocketOpenSSL;
var Uri : TIdURI;
var s : string;
begin
Result := -1;
try
HTTPReq := TIdHTTP.Create(nil);
IdSSLIOHandler := TIdSSLIOHandlerSocketOpenSSL.Create(nil);
IdSSLIOHandler.SSLOptions.Mode := sslmClient;
IdSSLIOHandler.SSLOptions.SSLVersions := [sslvTLSv1_2, sslvTLSv1_1];
if Assigned(HTTPReq) then begin
HTTPReq.Compressor := TIdCompressorZLib.Create(HTTPReq);
HTTPReq.IOHandler := IdSSLIOHandler;
HTTPReq.ReadTimeout := 180000;//set read timeout to 3 minutes
HTTPReq.Request.ContentType := 'text/xml;charset=UTF-8';
HTTPReq.Request.Accept := 'text/xml';
HTTPReq.Request.CustomHeaders.AddValue('SOAPAction', 'http://tempuri.org/Administration/' + method);
HTTPReq.HTTPOptions := [];
end;
SendStream := TStringStream.Create(Body);
Response := TStringStream.Create(EmptyStr);
try
HTTPReq.Request.ContentLength := Length(Body);
Uri := TiDUri.Create(url);
try
HTTPReq.Request.Host := Uri.Host;
finally
Uri.Free;
end;
HTTPReq.Post(url + 'admin.asmx', SendStream,Response);
if Response.Size > 0 then begin
if assigned(OutData) then begin
s := Response.DataString;// Redundant? Probably can just use Response.DataString?
StrPLCopy(OutData, s, OutLen);// <- ACCESS VIOLATION HERE
//StrPLCopy(OutData, s, Response.Size);// <- ACCESS VIOLATION HERE
Result := 0;
end;
end
else begin
Result := -2;
end;
finally
Response.Free;
SendStream.Free;
IdSSLIOHandler.Free;
HTTPReq.Free;
end;
except
on E:Exception do begin
ShowMessage(E.Message);
Result := 1;
end;
end;
end;
exports
PostAdminDataViaDll;
begin
end.
My Calling method code:
function PostAdminData(body, method, url : string): IXMLDOMDocument;
type
TMyPost = function (body, method, url: PChar; OutData : PChar; OutLen : integer): integer; stdcall;
var Handle : THandle;
var MyPost : TMyPost;
var dataString : string;
var returnData : string;
begin
if not (FileExists(ExtractFilePath(Application.ExeName) + 'TestDLL.DLL')) then begin
Application.MessageBox(pchar('Unable to find TestDLL.DLL.'), pchar('Error posting'),MB_ICONERROR + MB_OK);
Exit;
end;
dataString := EmptyStr;
returnData := '';
Handle := LoadLibrary(PChar(ExtractFilePath(Application.ExeName) + 'TestDLL.DLL'));
if Handle <> 0 then begin
try
try
MyPost := GetProcAddress(Handle, 'PostAdminDataViaDll');
if #MyPost <> nil then begin
// NOTE 32767 is not big enough for the returned data! Help!
if MyPost(PChar(body), PChar(method), PChar(url), PChar(returnData), 32767) = 0 then begin
dataString := returnData;
end;
end;
except
end;
finally
FreeLibrary(Handle);
end;
end
else begin
Application.MessageBox(pchar('Unable to find TestDLL.DLL.'), pchar('Error posting'),MB_ICONERROR + MB_OK);
end;
if not sametext(dataString, EmptyStr) then begin
try
Result := CreateOleObject('Microsoft.XMLDOM') as IXMLDOMDocument;
Result.async := False;
Result.loadXML(dataString);
except
end;
end;
end;
I have a DLL that posts XML data to a site. The DLL is built with Delphi 10 in order to use TLS 1.2, which is not available with Delphi XE2.
Why not simply update Indy in XE2 to a newer version that supports TLS 1.2? Then you don't need the DLL at all.
My original DLL convention was basically not correct, as I returned the contents of the returned text data as a PChar. In my readings here and elsewhere, that's a big no-no.
It is not a "big no-no", especially if the response data is dynamic in nature. Returning a pointer to dynamically allocated data is perfectly fine. You would simply have to export an extra function to free the data when the caller is done using it, that's all. The "big no-no" is that this does introduce a potential memory leak, if the caller forgets to call the 2nd function. But that is what try..finally is good for.
That "bad" methodology worked well until I started to get very large amounts of data returned. I tested it, and it failed on anything greater than 132,365 characters.
That is not a lot of memory. Any failure you were getting with it was likely due to you simply misusing the memory.
I restructured my DLL and calling code to pass in a buffer as a PChar to fill in, but I get an error trying to fill the output value!
That is because you are not filling in the memory correctly.
Secondly, since I never know how big the returned data will be, how to I specify how big a buffer to fill from my calling method?
You can't, when using POST. You would have to cache the response data somewhere off to the side, and then expose ways to let the caller query that cache for its size and data afterwards.
My DLL code where I get the error:
My Calling method code:
I see a number of logic mistakes in that code.
But, the most important reason for the Access Violation error is that your EXE is simply not allocating any memory for its returnData variable.
Casting a string to a PChar never produces a nil pointer. If the input string is not empty, a pointer to the string's first Char is returned. Otherwise, a pointer to a static #0 Char is returned instead. This ensures that a string casted to PChar always results in a non-nil, null-terminated, C style character string.
Your EXE is telling the DLL that returnData can hold up to 32767 chars, but in reality it can't hold any chars at all! In the DLL, OutData is not nil, and OutLen is wrong.
Also, StrPLCopy() always null-terminates the output, but the MaxLen parameter does not include the null-terminator, so the caller must allocate room for MaxLen+1 characters. This is stated in the StrPLCopy() documentation.
With all of this said, try something more like this:
library TestDLL;
uses
SysUtils,
Classes,
Windows,
Messages,
Vcl.Dialogs,
IdIOHandlerStack, IdSSLOpenSSL, IdHTTP, IdCompressorZLib;
{$R *.res}
function PostAdminDataViaDll(body, method, url: PChar;
var OutData : PChar): integer; stdcall;
var
HTTPReq : TIdHTTP;
SendStream : TStringStream;
IdSSLIOHandler : TIdSSLIOHandlerSocketOpenSSL;
s : string;
begin
OutData := nil;
try
HTTPReq := TIdHTTP.Create(nil);
try
IdSSLIOHandler := TIdSSLIOHandlerSocketOpenSSL.Create(HTTPReq);
IdSSLIOHandler.SSLOptions.Mode := sslmClient;
IdSSLIOHandler.SSLOptions.SSLVersions := [sslvTLSv1, sslvTLSv1_1, sslvTLSv1_2];
HTTPReq.IOHandler := IdSSLIOHandler;
HTTPReq.Compressor := TIdCompressorZLib.Create(HTTPReq);
HTTPReq.ReadTimeout := 180000;//set read timeout to 3 minutes
HTTPReq.HTTPOptions := [];
HTTPReq.Request.ContentType := 'text/xml';
HTTPReq.Request.Charset := 'UTF-8';
HTTPReq.Request.Accept := 'text/xml';
HTTPReq.Request.CustomHeaders.AddValue('SOAPAction', 'http://tempuri.org/Administration/' + method);
SendStream := TStringStream.Create(Body, TEncoding.UTF8);
try
s := HTTPReq.Post(string(url) + 'admin.asmx', SendStream);
finally
SendStream.Free;
end;
Result := Length(s);
if Result > 0 then begin
GetMem(OutData, (Result + 1) * Sizeof(Char));
Move(PChar(s)^, OutData^, (Result + 1) * Sizeof(Char));
end;
finally
HTTPReq.Free;
end;
except
on E: Exception do begin
ShowMessage(E.Message);
Result := -1;
end;
end;
end;
function FreeDataViaDll(Data : Pointer): integer; stdcall;
begin
try
FreeMem(Data);
Result := 0;
except
on E: Exception do begin
ShowMessage(E.Message);
Result := -1;
end;
end;
end;
exports
PostAdminDataToCenPosViaDll,
FreeDataViaDll;
begin
end.
function PostAdminData(body, method, url : string): IXMLDOMDocument;
type
TMyPost = function (body, method, url: PChar; var OutData : PChar): integer; stdcall;
TMyFree = function (Data Pointer): integer; stdcall;
var
hDll : THandle;
MyPost : TMyPost;
MyFree : TMyFree;
dataString : string;
returnData : PChar;
returnLen : Integer;
begin
hDll := LoadLibrary(PChar(ExtractFilePath(Application.ExeName) + 'TestDLL.DLL'));
if hDll = 0 then begin
Application.MessageBox('Unable to load TestDLL.DLL.', 'Error posting', MB_ICONERROR or MB_OK);
Exit;
end;
try
try
MyPost := GetProcAddress(hDll, 'PostAdminDataViaDll');
MyFree := GetProcAddress(hDll, 'FreeDataViaDll');
if Assigned(MyPost) and Assigned(MyFree) then begin
returnLen := MyPost(PChar(body), PChar(method), PChar(url), returnData);
if returnLen > 0 then begin
try
SetString(dataString, returnData, returnLen);
finally
MyFree(returnData);
end;
end;
end;
finally
FreeLibrary(hDll);
end;
except
end;
if dataString <> '' then begin
try
Result := CreateOleObject('Microsoft.XMLDOM') as IXMLDOMDocument;
Result.async := False;
Result.loadXML(dataString);
except
end;
end;
end;
I have a txt file that contains a large quantity of emails and they are delimited with no space. And I want organize these emails line by line.
So, my question is: how get only the part that separates these emails?
Ex: (foo.txt)
brarabelalima#hotmail.comaracaesporteclube#terra.com.br
And I want like this: (new.txt)
brarabelalima#hotmail.com
aracaesporteclube#terra.com.br
This was my last attempt:
{$APPTYPE CONSOLE}
{$R *.res}
uses
SysUtils,
Windows,
Classes;
procedure arrumarEmailsTXT;
var
Linhas, Colunas:TStringList;
i,j:integer;
arq: TextFile;
begin
Linhas := TStringList.Create;
Colunas := TStringList.Create;
AssignFile(arq, 'new.txt');
Rewrite(arq);
try
Linhas.LoadFromFile('foo.txt');
for i := 0 to Pred(Linhas.Count) do
begin
Colunas.text := StringReplace(Linhas.Strings[i],'',#13,[rfReplaceAll]);
for j := 0 to Pred(Colunas.Count) do
begin
Writeln(arq, Colunas.Strings[j]);
end;
end;
finally
CloseFile(arq);
Linhas.Free;
Colunas.Free;
end;
end;
begin
arrumarEmailsTXT;
end.
First run through the text and create a list with the parts between the #-#
Then, take each entry of the new list and cut the text up from the beginning up to the first period. This will give you a list of the domains those emails have.
Then, you need to fill in the last part of the domains and create a new list base don your experience.
For example, for every 'hotmail' you will have 'hotmail.com' and 'hotmail.co.uk', etc.
After that, you can extract the correct position for each line based on the full domain names.
This however can become very heavy job and take much time and resources. Is your file big? You may need threads to run the job effectively.
Also, knowledge of where the emails come may help you cut down the domains.
SOLUTION:
{$APPTYPE CONSOLE}
{$R *.res}
uses
Winapi.Windows,
Classes,
System.SysUtils;
function ExtractEmails(const Input: String; out Emails: TStringList): Boolean;
var
I : Integer;
Buffer : String;
Tokens : TStringList;
begin
Result := False;
Tokens := TStringList.Create;
Emails := TStringList.Create;
Try
Tokens.Delimiter := #32;
Tokens.DelimitedText := Input;
For I := 0 To Tokens.Count - 1 Do
begin
Buffer := Tokens.Strings[I];
If Length(Buffer) < 5 Then Continue;
If (Pos('#',Buffer) > 1) And
(Pos('.',Buffer) > 3) And
(Pos('.',Buffer) < Length(Buffer)) Then
begin
Emails.Add(Buffer);
end;
end;
Result := True;
Finally
Tokens.Free;
end;
end;
procedure Extrai;
var
Linhas,Emails:TStringList;
arq: TextFile;
begin
Linhas := TStringList.Create;
Emails := TStringList.Create;
try
Linhas.LoadFromFile('foo.txt');
AssignFile(arq, 'emails.txt');
Rewrite(arq);
If ExtractEmails(Linhas.Text,Emails) Then
begin
Writeln(arq,Emails.Text);
end;
finally
CloseFile(arq);
Linhas.Free;
Emails.Free;
end;
end;
begin
Extrai;
end.
I've got a puzzling situation. I am using the following code in Delphi to copy a list of files to the clipboard;
procedure TfMain.CopyFilesToClipboard(FileList: string);
const
C_UNABLE_TO_ALLOCATE_MEMORY = 'Unable to allocate memory.';
C_UNABLE_TO_ACCESS_MEMORY = 'Unable to access allocated memory.';
var
DropFiles: PDropFiles;
hGlobal: THandle;
iLen: Integer;
begin
iLen := Length(FileList);
hGlobal := GlobalAlloc(GMEM_SHARE or GMEM_MOVEABLE or
GMEM_ZEROINIT, SizeOf(TDropFiles) + ((iLen + 2) * SizeOf(Char)));
if (hGlobal = 0) then
raise Exception.Create(C_UNABLE_TO_ALLOCATE_MEMORY);
try DropFiles := GlobalLock(hGlobal);
if (DropFiles = nil) then raise Exception.Create(C_UNABLE_TO_ACCESS_MEMORY);
try
DropFiles^.pFiles := SizeOf(TDropFiles);
DropFiles^.fWide := True;
if FileList <> '' then
Move(FileList[1], (PByte(DropFiles) + SizeOf(TDropFiles))^,
iLen * SizeOf(Char));
finally
GlobalUnlock(hGlobal);
end;
Clipboard.SetAsHandle(CF_HDROP, hGlobal);
except
GlobalFree(hGlobal);
end;
end;
(This seems to be a popular piece of code on the internet)
Using my application, once the files are copied to the clipboard, I can use Windows Explorer to paste them into every other folder, EXCEPT the folder where the file originally came from! I was expecting it to behave just like a normal Windows copy (i.e. on paste it should create a file with postfix of '-Copy') but this doesn't seem to work. Any clues?
I am not able to get Windows Explorer to paste into the source folder when the only clipboard format available is CF_HDROP. However, if the filenames are provided in an IDataObject instead, it works fine.
If all of the files are from the same source folder, you can retrieve the IShellFolder of the source folder and query it for child PIDLs for the individual files, then use IShellFolder.GetUIObjectOf() to get an IDataObject that represents the files. Then use OleSetClipboard() to put that object on the clipboard. For example:
uses
System.Classes, Winapi.Windows, Winapi.ActiveX, Winapi.Shlobj, Winapi.ShellAPI, System.Win.ComObj;
procedure CopyFilesToClipboard(const Folder: string; FileNames: TStrings);
var
SF: IShellFolder;
PidlFolder: PItemIDList;
PidlChildren: array of PItemIDList;
Eaten: UINT;
Attrs: DWORD;
Obj: IDataObject;
I: Integer;
begin
if (Folder = '') or (FileNames = nil) or (FileNames.Count = 0) then Exit;
OleCheck(SHParseDisplayName(PChar(Folder), nil, PidlFolder, 0, Attrs));
try
OleCheck(SHBindToObject(nil, PidlFolder, nil, IShellFolder, Pointer(SF)));
finally
CoTaskMemFree(PidlFolder);
end;
SetLength(PidlChildren, FileNames.Count);
for I := Low(PidlChildren) to High(PidlChildren) do
PidlChildren[i] := nil;
try
for I := 0 to FileNames.Count-1 do
OleCheck(SF.ParseDisplayName(0, nil, PChar(FileNames[i]), Eaten, PidlChildren[i], Attrs));
OleCheck(SF.GetUIObjectOf(0, FileNames.Count, PIdlChildren[0], IDataObject, nil, obj));
finally
for I := Low(PidlChildren) to High(PidlChildren) do
begin
if PidlChildren[i] <> nil then
CoTaskMemFree(PidlChildren[i]);
end;
end;
OleCheck(OleSetClipboard(obj));
OleCheck(OleFlushClipboard);
end;
Update: If the files are in different source folders, you can use the CFSTR_SHELLIDLIST format:
uses
System.Classes, System.SysUtils, Winapi.Windows, Winapi.ActiveX, Winapi.Shlobj, Winapi.ShellAPI, System.Win.ComObj, Vcl.Clipbrd;
{$POINTERMATH ON}
function HIDA_GetPIDLFolder(pida: PIDA): LPITEMIDLIST;
begin
Result := LPITEMIDLIST(LPBYTE(pida) + pida.aoffset[0]);
end;
function HIDA_GetPIDLItem(pida: PIDA; idx: Integer): LPITEMIDLIST;
begin
Result := LPITEMIDLIST(LPBYTE(pida) + (PUINT(#pida.aoffset[0])+(1+idx))^);
end;
var
CF_SHELLIDLIST: UINT = 0;
type
CidaPidlInfo = record
Pidl: PItemIDList;
PidlOffset: UINT;
PidlSize: UINT;
end;
procedure CopyFilesToClipboard(FileNames: TStrings);
var
PidlInfo: array of CidaPidlInfo;
Attrs, AllocSize: DWORD;
gmem: THandle;
ida: PIDA;
I: Integer;
begin
if (FileNames = nil) or (FileNames.Count = 0) or (CF_SHELLIDLIST = 0) then Exit;
SetLength(PidlInfo, FileNames.Count);
for I := Low(PidlInfo) to High(PidlInfo) do
PidlInfo[I].Pidl := nil;
try
AllocSize := SizeOf(CIDA)+(SizeOf(UINT)*FileNames.Count)+SizeOf(Word);
for I := 0 to FileNames.Count-1 do
begin
OleCheck(SHParseDisplayName(PChar(FileNames[I]), nil, PidlInfo[I].Pidl, 0, Attrs));
PidlInfo[I].PidlOffset := AllocSize;
PidlInfo[I].PidlSize := ILGetSize(PidlInfo[I].Pidl);
Inc(AllocSize, PidlInfo[I].PidlSize);
end;
gmem := GlobalAlloc(GMEM_MOVEABLE, AllocSize);
if gmem = 0 then RaiseLastOSError;
try
ida := PIDA(GlobalLock(gmem));
if ida = nil then RaiseLastOSError;
try
ida.cidl := FileNames.Count;
ida.aoffset[0] := SizeOf(CIDA)+(SizeOf(UINT)*FileNames.Count);
HIDA_GetPIDLFolder(ida).mkid.cb := 0;
for I := 0 to FileNames.Count-1 do
begin
ida.aoffset[1+I] := PidlInfo[I].PidlOffset;
Move(PidlInfo[I].Pidl^, HIDA_GetPIDLItem(ida, I)^, PidlInfo[I].PidlSize);
end;
finally
GlobalUnlock(gmem);
end;
Clipboard.SetAsHandle(CF_SHELLIDLIST, gmem);
except
GlobalFree(gmem);
raise;
end;
finally
for I := Low(PidlInfo) to High(PidlInfo) do
CoTaskMemFree(PidlInfo[I].Pidl);
end;
end;
initialization
CF_SHELLIDLIST := RegisterClipboardFormat(CFSTR_SHELLIDLIST);
Alternatively:
procedure CopyFilesToClipboard(FileNames: TStrings);
var
Pidls: array of PItemIdList;
Attrs: DWORD;
I: Integer;
obj: IDataObject;
begin
if (FileNames = nil) or (FileNames.Count = 0) then Exit;
SetLength(Pidls, FileNames.Count);
for I := Low(Pidls) to High(Pidls) do
Pidls[I] := nil;
try
for I := 0 to FileNames.Count-1 do
OleCheck(SHParseDisplayName(PChar(FileNames[I]), nil, Pidls[I], 0, Attrs));
OleCheck(CIDLData_CreateFromIDArray(nil, FileNames.Count, PItemIDList(Pidls), obj));
finally
for I := Low(Pidls) to High(Pidls) do
CoTaskMemFree(Pidls[I]);
end;
OleCheck(OleSetClipboard(obj));
OleCheck(OleFlushClipboard);
end;
However, I found that Windows Explorer will sometimes but not always allow CFSTR_SHELLIDLIST to be pasted into the source folder of a referenced file. I don't know what criteria is preventing Windows Explorer from pasting. Maybe some kind of permissions issue?
You should take Microsoft's advice:
Handling Shell Data Transfer Scenarios
Include as many formats as you can support. You generally do not know where the data object will be dropped. This practice improves the odds that the data object will contain a format that the drop target can accept.
Is there support in the Delphi XE VCL for ensuring only a single instance of an application is running?
In the past, I've used library code to control a Mutex which has always seemed complicated. As I'm starting a new project in Delphi XE, I wonder if I need to dig up that old code, or if there is support built into XE already? Or is there another easy to apply code that is nice and modern?
You create a named Mutex when you start the application. Check GetLastError to see if an other instance is already running.
Put this code right after "begin" in your DPR file. Replace the GUID with one of your own. When I need a text constant that's unlikely to be used for anything else, I usually just hit Ctrl+G to get a GUID!
if CreateMutex(nil, True, '6EACD0BF-F3E0-44D9-91E7-47467B5A2B6A') = 0 then
RaiseLastOSError;
if GetLastError = ERROR_ALREADY_EXISTS then
Exit;
It might look like the code is leaking an handle because it's not saving the return of CreateMutex. It's not. Windows will automatically release the handle when our application is terminated, and that's absolutely fine with us.
I use JCL to do this:
program MyProgram;
uses
JclAppInst;
begin
JclAppInstances.CheckSingleInstance; // Added instance checking
Application.Initialize;
Application.CreateForm(TMainForm, MainForm);
Application.Run;
end.
Documentation for this, and the notification scheme, is at the JCL Wiki.
I use this, works in XE2 through to Alexandria, has the benefit of being able to bring the currently running instance to the front.
Those that say it shouldn't do that, well, given the last thing the user did was to try launch the app, bringing a currently running instance to the front makes sense
unit CheckPrevious;
interface
uses
Windows, SysUtils, WinSock;
function RestoreIfRunning(const AppHandle : THandle; MaxInstances : integer = 1) : boolean;
implementation
type
PInstanceInfo = ^TInstanceInfo;
TInstanceInfo = packed record
PreviousHandle : THandle;
RunCounter : integer;
end;
var
MappingHandle: THandle;
InstanceInfo: PInstanceInfo;
MappingName : string;
RemoveMe : boolean = True;
function RestoreIfRunning(const AppHandle : THandle; MaxInstances : integer = 1) : boolean;
begin
Result := True;
MappingName := StringReplace(ParamStr(0),'\','',[rfReplaceAll, rfIgnoreCase]);
MappingHandle := CreateFileMapping($FFFFFFFF,nil,PAGE_READWRITE,0,SizeOf(TInstanceInfo),PChar(MappingName));
if MappingHandle = 0 then
RaiseLastOSError
else
begin
if GetLastError <> ERROR_ALREADY_EXISTS then
begin
InstanceInfo := MapViewOfFile(MappingHandle,FILE_MAP_ALL_ACCESS,0,0,SizeOf(TInstanceInfo));
InstanceInfo^.PreviousHandle := AppHandle;
InstanceInfo^.RunCounter := 1;
Result := False;
end
else //already runing
begin
MappingHandle := OpenFileMapping(FILE_MAP_ALL_ACCESS, False, PChar(MappingName));
if MappingHandle <> 0 then
begin
InstanceInfo := MapViewOfFile(MappingHandle,FILE_MAP_ALL_ACCESS,0,0,SizeOf(TInstanceInfo));
if InstanceInfo^.RunCounter >= MaxInstances then
begin
RemoveMe := False;
if IsIconic(InstanceInfo^.PreviousHandle) then
ShowWindow(InstanceInfo^.PreviousHandle, SW_RESTORE);
SetForegroundWindow(InstanceInfo^.PreviousHandle);
end
else
begin
InstanceInfo^.PreviousHandle := AppHandle;
InstanceInfo^.RunCounter := 1 + InstanceInfo^.RunCounter;
Result := False;
end
end;
end;
end;
end;
initialization
finalization
//remove one instance
if RemoveMe then
begin
MappingHandle := OpenFileMapping(FILE_MAP_ALL_ACCESS, False, PChar(MappingName));
if MappingHandle <> 0 then
begin
InstanceInfo := MapViewOfFile(MappingHandle, FILE_MAP_ALL_ACCESS, 0, 0, SizeOf(TInstanceInfo));
InstanceInfo^.RunCounter := -1 + InstanceInfo^.RunCounter;
end
else
RaiseLastOSError;
end;
if Assigned(InstanceInfo) then
UnmapViewOfFile(InstanceInfo);
if MappingHandle <> 0 then
CloseHandle(MappingHandle);
end.
In your project DPR, add the CheckPrevious unit to the uses, then just after begin put the following
if RestoreIfRunning(Application.Handle, 1) then
Exit;
I have no idea of where this code originated, otherwise I would gladly credit the author. (A search of RestoreIfRunning may suggest it was from Zarko Gajic)
This is how i do it.
closeProc(extractfilename(paramstr(0)));
function TForm1.closeProc(pname : string): integer;
const
PROCESS_TERMINATE = $0001;
var
ContinueLoop: BOOL;
FSnapshotHandle: THandle;
FProcessEntry32: TProcessEntry32;
i : integer;
pname2 : string;
begin
try
Result := 0;
i := 0;
FSnapshotHandle := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
FProcessEntry32.dwSize := SizeOf(FProcessEntry32);
ContinueLoop := Process32First(FSnapshotHandle, FProcessEntry32);
while Integer(ContinueLoop) <> 0 do
begin
pname2 := trim(UpperCase(ExtractFileName(FProcessEntry32.szExeFile)));
if ( pname2 = uppercase(pname)) then
if FProcessEntry32.th32ProcessID <> GetCurrentProcessId then
begin
Result := Integer(TerminateProcess(OpenProcess(PROCESS_TERMINATE, BOOL(0), FProcessEntry32.th32ProcessID), 0));
inc(i);
end;
ContinueLoop := Process32Next(FSnapshotHandle, FProcessEntry32);
if i > 50 then
break;
end;
CloseHandle(FSnapshotHandle);
except
end;
end;
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.