I am using Delphi Rio to develop a service to make an update program.
I have created a TComponent to encapsulated all the work.
The component work as expected used in a normal VCL project, but is not working as expected when used in a service project.
here is the code:
function TTaurineUpgrade.DownloadFile(serverURL, localFile: String): Boolean;
var workConnection : TclDownLoader;
strError : String;
timeOut : Integer;
tmpInteger : Int64;
begin
Result := False;
strError := '';
if not IsURLExist(serverURL, tmpInteger) then begin
raise Exception.Create(Format('Fisierul %S nu exista pe server!', [serverURL]));
end;
try
try
WriteFeedback(EVENTLOG_INFORMATION_TYPE, eInformation, 'Conectare server Elite Soft Media pentru download file...', '', True);
WriteNotifyEventFeedback(_InfoVisibleDownloadInfo);
workConnection := TclDownLoader.Create(Application);
if Assigned(fProgressBar) then begin
fProgressBar.InternetControl := workConnection;
end;
workConnection.OnStatusChanged := DownLoaderMainStatusChanged;
workConnection.OnError := DownLoaderMainError;
workConnection.URL := serverURL;
workConnection.LocalFolder := writingPathFiles;
workConnection.LocalFile := localFile;
workConnection.Start(True);
fStatusTransfer := psUnknown;
IsAbortDownload := False;
while (fStatusTransfer <> psSuccess) do begin
WriteFeedback(EVENTLOG_INFORMATION_TYPE, eInformation, Format('fStatusTransfer = %S', [GetProcessStatusAsString(fStatusTransfer)]), '', False);
if IsAbortDownload then begin
WriteFeedback(EVENTLOG_WARNING_TYPE, eWarning, 'IsAbortDownload=True, Break', '', True);
Break;
end;
Sleep(1000);
ApplicationProcessMessages;
end;
workConnection.CloseConnection;
WriteFeedback(EVENTLOG_INFORMATION_TYPE, eInformation, 'Inchidere conexiune server Elite Soft Media...', '', True);
if IsAbortDownload then begin
WriteFeedback(EVENTLOG_WARNING_TYPE, eWarning, 'IsAbortDownload=True, Abort', '', True);
Abort;
end;
Result := True;
except
on e : Exception do begin
strError := e.Message;
end;
end;
finally
if Assigned(workConnection) then begin
FreeAndNil(workConnection);
end;
WriteNotifyEventFeedback(_InfoNotVisibleDownloadInfo);
end;
Sleep(500);
ApplicationProcessMessages;
if strError <> '' then begin
raise Exception.Create(strError);
end;
end;
procedure TTaurineUpgrade.DownLoaderMainStatusChanged(Sender: TObject; Status: TclProcessStatus);
begin
case Status of
psErrors : WriteFeedback(EVENTLOG_ERROR_TYPE, eError, 'Eroare in functia DownLoaderMainStatusChanged', '', True);
end;
fStatusTransfer := Status;
end;
procedure TTaurineUpgrade.DownLoaderMainError(Sender: TObject; const Error: String; ErrorCode: Integer);
begin
raise Exception.Create((Sender as TclDownLoader).Errors.Text);
end;
when using the component in service it stay forever in the while loop. (in the most of the cases) sometime is working (rarely)
anyone have a hint?
You should not be using ApplicationProcessMessages but instead ServiceThread.ProcessRequests when dealing with Service Applications
I want to get and show the name and extension of selected file in explorer by delphi7.
I use below code for show caption of active window but i need selected file name in active window.
function ActiveCaption: string;
var
Handle: THandle;
Len: LongInt;
Title: string;
begin
Result := '';
Handle := GetForegroundWindow;
if Handle <> 0 then
begin
Len := GetWindowTextLength(Handle) + 1;
SetLength(Title, Len);
GetWindowText(Handle, PChar(Title), Len);
ActiveCaption := TrimRight(Title);
end;
end;
procedure TForm1.Timer1Timer(Sender: TObject);
begin
Label1.Caption := ActiveCaption;
end;
The only way I know of is to use the Active-X IShellWindows and IWebBrowser Interfaces to to that.
First, you have to import the "Microsoft Internet Controls" Active-X (via the Component Menu). By that you will get a unit called "SHDocVW_TLB". Put this unit and the ActiveX unit in your uses clause.
Than you can use the following two functions to retrieve the selected file from the window handle provided:
The first function does a rough test if the given handle belongs to an explorer window
function isexplorerwindow(exwnd: hwnd): boolean;
var
p: array[0..max_path] of Char;
begin
GetClassName(exwnd, p, SizeOf(p));
result := ((strcomp(p, 'CabinetWClass') = 0) or (strcomp(p, 'ExploreWClass') = 0));
end;
And the second function retrieves the name of the nth selected file:
function getexplorerselectedfile(exwnd: hwnd; nr: integer): string;
var
pvShell: IShellWindows;
pvWeb2: IWebBrowser2;
ovIE: OleVariant;
psp: IServiceProvider;
psb: IShellBrowser;
isw: IShellView;
ido: IDataObject;
FmtEtc: TFormatEtc;
Medium: TStgMedium;
dwcount: integer;
n: integer;
p: array[0..max_path] of Char;
s: string;
found: boolean;
begin
found := false;
result := '';
s :='';
try
pvShell := CoShellWindows.Create;
for dwcount := 0 to Pred(pvShell.count) do
begin
ovIE := pvShell.Item(dwcount);
if (ovIE.hwnd = exwnd) or ((exwnd = 0) and isexplorerwindow(ovIE.hwnd)) then
begin
found := true;
if (IDispatch(ovIE).QueryInterface(IWebBrowser2, pvWeb2) = S_OK) then
begin
psp := (pvWeb2 as IServiceProvider);
psp.QueryService(IID_IShellBrowser, IID_IShellBrowser, psb);
psb.QueryActiveShellView(isw);
if isw.GetItemObject(SVGIO_SELECTION, IDataObject, pointer(ido)) = S_OK then
begin
try
FmtEtc.cfFormat := CF_HDROP;
FmtEtc.ptd := nil;
FmtEtc.dwAspect := DVASPECT_CONTENT;
FmtEtc.lindex := -1;
FmtEtc.tymed := TYMED_HGLOBAL;
ido.GetData(FmtEtc, Medium);
GlobalLock(Medium.hGlobal);
try
n := DragQueryFile(Medium.hGlobal, $FFFFFFFF, nil, 0);
if nr < n then
begin
DragQueryFile(Medium.hGlobal, nr, p, max_path);
s := strpas(p);
end;
finally
DragFinish(Medium.hGlobal);
GlobalUnLock(Medium.hGlobal);
end;
finally
ReleaseStgMedium(Medium);
end;
end;
pvWeb2 := nil;
end;
end;
ovIE := Unassigned;
if found then
break;
end;
pvShell := nil;
finally
result := s;
end;
end;
To test this code create a new project and place a button and a memo on the form.
Add the following units to the uses clause:
USES SHDocVW_TLB, ShlObj, activex, shellapi;
And add this code to the button event handler:
PROCEDURE TForm2.Button1Click(Sender: TObject);
VAR
wnd, exwnd: hwnd;
n: integer;
s: STRING;
BEGIN
exwnd := 0;
wnd := getwindow(getdesktopwindow, gw_child);
REPEAT
IF isexplorerwindow(wnd) THEN
BEGIN
exwnd := wnd;
break;
END;
wnd := getwindow(wnd, gw_hwndnext);
UNTIL (wnd = 0) OR (exwnd <> 0);
IF exwnd <> 0 THEN
BEGIN
n := 0;
REPEAT
s := getexplorerselectedfile(exwnd, n);
memo1.Lines.Add(s);
inc(n);
UNTIL s = '';
END;
END;
If you press the button, the memo will contain the selected files of the first open explorer window it finds. Of course you should have an explorer window open with at least one file selected.
I am working on datasnap client server software. When executed, server reads data from my database and keeps it in memory. Every client when connecting to the server, requests the data calling a procedure on the server. But I am having problems with huge memory consumption on server side.
Server lifeCycle set to invocation or session does not affect the huge memory used by server.
In this test, when launching server, it uses about 5MB. Connection a client and getting data from the server, makes the server use another 58MB. For every next client! And this is just with 6 objects. In my real software server gets over 200MB for a client. My old version of the software has 50+ clients running.
I tested this with Delphi XE6, XE7, XE8, 10, 10 with Update 1.
ReportmemoryLeakAtShutdown reports nothing at client, and a very small amount at server, but it is reported as a known bug.
Am I doing something very wrong, or it is a Delphi problem?
Here is my test source:
common unit for server and client:
TOwnedFlag = (ofOwned);
TOwnedFlags = set of TOwnedFlag;
TMarshalList<T: class> = class
private
FList: TArray<T>;
FFlags: TOwnedFlags; // use set for internal flags because sets are not marshalled
public
constructor Create(AList: TArray<T>; AOwnsItems: Boolean = True); overload;
constructor Create; overload;
destructor Destroy; override;
property List: TArray<T> read FList;
end;
TMyClass = class
ID: integer;,
Name: String;
Desc: String;
Desc1: String;
Desc2: String;
Desc3: String;
....
constructor Create;
end;
implementation
constructor TMarshalList<T>.Create(AList: TArray<T>; AOwnsItems: Boolean);
begin
FList := AList;
if AOwnsItems then FFlags := [ofOwned];
end;
constructor TMarshalList<T>.Create;
begin
FFlags := [ofOwned];
end;
destructor TMarshalList<T>.Destroy;
var
LItem: T;
begin
if ofOwned in FFlags then
for LItem in FList do
LItem.Free;
inherited;
end;
constructor TMyClass.create;
var
i: integer;
begin
//this I made just to have objects with noticeable size...
desc := '01101011010110101010101010101010110101010100110100101010010101010101001010101010101010010100100010001111011010010101010110101101'+
'01101011010110101010101010101010110101010100110100101010010101010101001010101010101010010100100010001111011010010101010110101101'+
'01101011010110101010101010101010110101010100110100101010010101010101001010101010101010010100100010001111011010010101010110101101'+
'01101011010110101010101010101010110101010100110100101010010101010101001010101010101010010100100010001111011010010101010110101101';
for I := 1 to 8 do
desc := desc + desc;
desc1 := desc;
desc2 := desc;
....
end;
ServerContainer
MyList: TList<TMyClass>;
procedure TServerContainer.DataModuleCreate(Sender: TObject);
var
c: TMyClass;
I: Integer;
begin
MyList := TList<TMyClass>.create;
for I := 0 to 5 do begin
c := TMyClass.create;
c.ID := i;
c.Name := inttostr(i);
MyList.Add(c);
end;
end;
procedure TServerContainer.DataModuleDestroy(Sender: TObject);
var
I: Integer;
begin
for I := 0 to myList.Count-1 do
myList[i].Free;
myList.Free;
end;
ServerMethods
function TServerMethods.getMarshalList: TMarshalList<TMyClass>;
var
c: TMyClass;
I: Integer;
l: TList<TMyClass>;
begin
l := TList<TMyClass>.create;
for I := 0 to servercontainer.MyList.Count-1 do begin
c := TMyClass.create;
c.ID := servercontainer.MyList[i].ID;
c.Name := servercontainer.MyList[i].Name;
l.Add(c);
end;
Result := TMarshalList<TMyClass>.Create(l.ToArray, True);
l.free;
GetInvocationMetaData.CloseSession := True;
end;
Client
procedure TForm1.Button1Click(Sender: TObject);
var
server: TServerMethodsClient;
c: TMyClass;
I: Integer;
list: TMarshalList<TMyClass>;
begin
ticks := GetTickCount;
memo1.Lines.clear;
server := TServerMethodsClient.Create(SQLConnection1.DBXConnection);
list := server.getMarshalList;
for i := 0 to high(list.List)-1 do begin
c := list.List[i];
end;
server.Free;
end;
you can download the sources here: https://kikimor.com/owncloud/index.php/s/Aw55lBzvFX9Q6tl
Want to obtain Delphi Application build number and post into title bar
Here is how I do it. I put this in almost all of my small utilities:
procedure GetBuildInfo(var V1, V2, V3, V4: word);
var
VerInfoSize, VerValueSize, Dummy: DWORD;
VerInfo: Pointer;
VerValue: PVSFixedFileInfo;
begin
VerInfoSize := GetFileVersionInfoSize(PChar(ParamStr(0)), Dummy);
if VerInfoSize > 0 then
begin
GetMem(VerInfo, VerInfoSize);
try
if GetFileVersionInfo(PChar(ParamStr(0)), 0, VerInfoSize, VerInfo) then
begin
VerQueryValue(VerInfo, '\', Pointer(VerValue), VerValueSize);
with VerValue^ do
begin
V1 := dwFileVersionMS shr 16;
V2 := dwFileVersionMS and $FFFF;
V3 := dwFileVersionLS shr 16;
V4 := dwFileVersionLS and $FFFF;
end;
end;
finally
FreeMem(VerInfo, VerInfoSize);
end;
end;
end;
function GetBuildInfoAsString: string;
var
V1, V2, V3, V4: word;
begin
GetBuildInfo(V1, V2, V3, V4);
Result := IntToStr(V1) + '.' + IntToStr(V2) + '.' +
IntToStr(V3) + '.' + IntToStr(V4);
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
Form1.Caption := Form1.Caption + ' - v' + GetBuildInfoAsString;
end;
I most strongly recommend not to use GetFileVersion when you want to know the version of the executable that is currently running! I have two pretty good reasons to do this:
The executable may be unaccessible (disconnected drive/share), or changed (.exe renamed to .bak and replaced by a new .exe without the running process being stopped).
The version data you're trying to read has actually already been loaded into memory, and is available to you by loading this resource, which is always better than to perform extra (relatively slow) disk operations.
To load the version resource in Delphi I use code like this:
uses Windows,Classes,SysUtils;
var
verblock:PVSFIXEDFILEINFO;
versionMS,versionLS:cardinal;
verlen:cardinal;
rs:TResourceStream;
m:TMemoryStream;
p:pointer;
s:cardinal;
begin
m:=TMemoryStream.Create;
try
rs:=TResourceStream.CreateFromID(HInstance,1,RT_VERSION);
try
m.CopyFrom(rs,rs.Size);
finally
rs.Free;
end;
m.Position:=0;
if VerQueryValue(m.Memory,'\',pointer(verblock),verlen) then
begin
VersionMS:=verblock.dwFileVersionMS;
VersionLS:=verblock.dwFileVersionLS;
AppVersionString:=Application.Title+' '+
IntToStr(versionMS shr 16)+'.'+
IntToStr(versionMS and $FFFF)+'.'+
IntToStr(VersionLS shr 16)+'.'+
IntToStr(VersionLS and $FFFF);
end;
if VerQueryValue(m.Memory,PChar('\\StringFileInfo\\'+
IntToHex(GetThreadLocale,4)+IntToHex(GetACP,4)+'\\FileDescription'),p,s) or
VerQueryValue(m.Memory,'\\StringFileInfo\\040904E4\\FileDescription',p,s) then //en-us
AppVersionString:=PChar(p)+' '+AppVersionString;
finally
m.Free;
end;
end;
Thanks to the posts above, I made my own library for this purpose.
I believe that it is a little bit more correct than all other solutions here, so I share it - feel free to reuse it...
unit KkVersion;
interface
function FileDescription: String;
function LegalCopyright: String;
function DateOfRelease: String; // Proprietary
function ProductVersion: String;
function FileVersion: String;
implementation
uses
Winapi.Windows, System.SysUtils, System.Classes, Math;
(*
function GetHeader(out AHdr: TVSFixedFileInfo): Boolean;
var
BFixedFileInfo: PVSFixedFileInfo;
RM: TMemoryStream;
RS: TResourceStream;
BL: Cardinal;
begin
Result := False;
RM := TMemoryStream.Create;
try
RS := TResourceStream.CreateFromID(HInstance, 1, RT_VERSION);
try
RM.CopyFrom(RS, RS.Size);
finally
FreeAndNil(RS);
end;
// Extract header
if not VerQueryValue(RM.Memory, '\\', Pointer(BFixedFileInfo), BL) then
Exit;
// Prepare result
CopyMemory(#AHdr, BFixedFileInfo, Math.Min(sizeof(AHdr), BL));
Result := True;
finally
FreeAndNil(RM);
end;
end;
*)
function GetVersionInfo(AIdent: String): String;
type
TLang = packed record
Lng, Page: WORD;
end;
TLangs = array [0 .. 10000] of TLang;
PLangs = ^TLangs;
var
BLngs: PLangs;
BLngsCnt: Cardinal;
BLangId: String;
RM: TMemoryStream;
RS: TResourceStream;
BP: PChar;
BL: Cardinal;
BId: String;
begin
// Assume error
Result := '';
RM := TMemoryStream.Create;
try
// Load the version resource into memory
RS := TResourceStream.CreateFromID(HInstance, 1, RT_VERSION);
try
RM.CopyFrom(RS, RS.Size);
finally
FreeAndNil(RS);
end;
// Extract the translations list
if not VerQueryValue(RM.Memory, '\\VarFileInfo\\Translation', Pointer(BLngs), BL) then
Exit; // Failed to parse the translations table
BLngsCnt := BL div sizeof(TLang);
if BLngsCnt <= 0 then
Exit; // No translations available
// Use the first translation from the table (in most cases will be OK)
with BLngs[0] do
BLangId := IntToHex(Lng, 4) + IntToHex(Page, 4);
// Extract field by parameter
BId := '\\StringFileInfo\\' + BLangId + '\\' + AIdent;
if not VerQueryValue(RM.Memory, PChar(BId), Pointer(BP), BL) then
Exit; // No such field
// Prepare result
Result := BP;
finally
FreeAndNil(RM);
end;
end;
function FileDescription: String;
begin
Result := GetVersionInfo('FileDescription');
end;
function LegalCopyright: String;
begin
Result := GetVersionInfo('LegalCopyright');
end;
function DateOfRelease: String;
begin
Result := GetVersionInfo('DateOfRelease');
end;
function ProductVersion: String;
begin
Result := GetVersionInfo('ProductVersion');
end;
function FileVersion: String;
begin
Result := GetVersionInfo('FileVersion');
end;
end.
Pass the full file name of your EXE to this function, and it will return a string like:
2.1.5.9, or whatever your version # is.
function GetFileVersion(exeName : string): string;
const
c_StringInfo = 'StringFileInfo\040904E4\FileVersion';
var
n, Len : cardinal;
Buf, Value : PChar;
begin
Result := '';
n := GetFileVersionInfoSize(PChar(exeName),n);
if n > 0 then begin
Buf := AllocMem(n);
try
GetFileVersionInfo(PChar(exeName),0,n,Buf);
if VerQueryValue(Buf,PChar(c_StringInfo),Pointer(Value),Len) then begin
Result := Trim(Value);
end;
finally
FreeMem(Buf,n);
end;
end;
end;
After defining that, you can use it to set your form's caption like so:
procedure TForm1.FormShow(Sender: TObject);
begin
//ParamStr(0) is the full path and file name of the current application
Form1.Caption := Form1.Caption + ' version ' + GetFileVersion(ParamStr(0));
end;
We do this for all our apps but we use a Raize component RzVersioninfo.
works quite well just need to use the following code
on form create
Caption := RzVersioninfo1.filedescripion + ': ' + RzVersionInfo1.FileVersion;
obviously if you don't want any of the other components from raize use one of the options above as there is a cost to the raize components.
From http://www.martinstoeckli.ch/delphi/delphi.html#AppVersion
With this function you can get the version of a file, which contains a
version resource. This way you can display the version number of your
application in an information dialog. To include a version resource to
your Delphi application, set the "Versioninfo" in the project options.
My code:
uses unit Winapi.Windows;
function GetModuleVersion(Instance: THandle; out iMajor, iMinor, iRelease, iBuild: Integer): Boolean;
var
fileInformation: PVSFIXEDFILEINFO;
verlen: Cardinal;
rs: TResourceStream;
m: TMemoryStream;
begin
result := false;
m := TMemoryStream.Create;
try
try
rs := TResourceStream.CreateFromID(Instance, 1, RT_VERSION);
try
m.CopyFrom(rs, rs.Size);
finally
rs.Free;
end;
except
exit;
end;
m.Position:=0;
if not VerQueryValue(m.Memory, '\', Pointer(fileInformation), verlen) then
begin
iMajor := 0;
iMinor := 0;
iRelease := 0;
iBuild := 0;
Exit;
end;
iMajor := fileInformation.dwFileVersionMS shr 16;
iMinor := fileInformation.dwFileVersionMS and $FFFF;
iRelease := fileInformation.dwFileVersionLS shr 16;
iBuild := fileInformation.dwFileVersionLS and $FFFF;
finally
m.Free;
end;
Result := True;
end;
Usage:
if GetModuleVersion(HInstance, iMajor, iMinor, iRelease, iBuild) then
ProgramVersion := inttostr(iMajor)+'.'+inttostr(iMinor)+'.'+inttostr(iRelease)+'.'+inttostr(iBuild);
How can I get all installed components in TStrings?
I think this code work only within packages:
uses TypInfo, ToolIntf, Exptintf;
procedure GetComponentNames(lst: TStrings);
var
i, k: Integer;
CRef: TClass;
strName: ShortString;
begin
lst.Clear;
for i := 0 to ToolServices.GetModuleCount-1 do
begin
for k := 0 to ToolServices.GetComponentCount(i)-1 do
begin
CRef := TClass(GetClass(ToolServices.GetComponentName(i, k)));
while CRef <> nil do
begin
strName := CRef.ClassName;
if lst.IndexOf(strName) = -1 then
lst.Add(strName);
if str <> 'TComponent' then
CRef := CRef.ClassParent
else
CRef := nil;
end;
end;
end;
end;
Or:
uses ToolsApi;
{....}
var
a, i: Integer;
begin
with (BorlandIDEServices as IOTAPackageServices) do
begin
for a := 0 to GetPackageCount - 1 do
begin
for i := 0 to GetComponentCount(a) - 1 do
begin
{get each component name with GetComponentName(a, i);}
// DoSomething
end;
end;
end;
end;
Thanks for help.
This example doesn't use the OpenAPI, it uses the Registry. It works but it also lists non-visual components amongst other hidden items.
procedure GetComponentNames(lst: TStrings);
var
i, j, iPos: Integer;
Reg: TRegistry;
sComponent: String;
slValues, slData: TStrings;
begin
Reg := TRegistry.Create;
slValues := TStringList.Create;
slData := TStringList.Create;
try
Reg.RootKey := HKEY_CURRENT_USER;
Reg.OpenKey('Software\Borland\Delphi\6.0\Palette', False); // Change reg key where appropriate
Reg.GetValueNames(slValues);
for i := 0 to Pred(slValues.Count) do
begin
lst.Append(slValues[i]);
lst.Append('----------');
slData.Delimiter := ';';
slData.DelimitedText := Reg.ReadString(slValues[i]);
for j := 0 to Pred(slData.Count) do
begin
sComponent := slData[j];
iPos := Pos('.', sComponent);
if (iPos > 0) then
Delete(sComponent, 1, iPos);
lst.Append(sComponent);
end;
end;
finally
slData.Free;
slValues.Free;
Reg.Free;
end; {try..finally}
end;
I'm not saying this is ideal but it does give you a list and a headstart.