How do I detect if the specific Delphi IDE is running? - delphi

I'm working on a component installer (only for Delphi XE2) and I would like to detect if the Delphi XE2 IDE is running. How would you detect it?
P.S. I know about the TAppBuilder window class name, but I need to detect also the IDE version.

These are the steps to determine if the Delphi XE2 is running
1) First Read the location of the the bds.exe file from the App entry in the \Software\Embarcadero\BDS\9.0 registry key which can be located in the HKEY_CURRENT_USER or HKEY_LOCAL_MACHINE Root key.
2) Then using the CreateToolhelp32Snapshot function you can check if exist a exe with the same name running.
3) Finally using the PID of the last processed entry you can resolve the full file path of the Exe (using the GetModuleFileNameEx function) and then compare the names again.
Check this sample code
{$APPTYPE CONSOLE}
{$R *.res}
uses
Registry,
PsAPI,
TlHelp32,
Windows,
SysUtils;
function ProcessFileName(dwProcessId: DWORD): string;
var
hModule: Cardinal;
begin
Result := '';
hModule := OpenProcess(PROCESS_QUERY_INFORMATION or PROCESS_VM_READ, False, dwProcessId);
if hModule <> 0 then
try
SetLength(Result, MAX_PATH);
if GetModuleFileNameEx(hModule, 0, PChar(Result), MAX_PATH) > 0 then
SetLength(Result, StrLen(PChar(Result)))
else
Result := '';
finally
CloseHandle(hModule);
end;
end;
function IsAppRunning(const FileName: string): boolean;
var
hSnapshot : Cardinal;
EntryParentProc: TProcessEntry32;
begin
Result := False;
hSnapshot := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
if hSnapshot = INVALID_HANDLE_VALUE then
exit;
try
EntryParentProc.dwSize := SizeOf(EntryParentProc);
if Process32First(hSnapshot, EntryParentProc) then
repeat
if CompareText(ExtractFileName(FileName), EntryParentProc.szExeFile) = 0 then
if CompareText(ProcessFileName(EntryParentProc.th32ProcessID), FileName) = 0 then
begin
Result := True;
break;
end;
until not Process32Next(hSnapshot, EntryParentProc);
finally
CloseHandle(hSnapshot);
end;
end;
function RegReadStr(const RegPath, RegValue: string; var Str: string;
const RootKey: HKEY): boolean;
var
Reg: TRegistry;
begin
try
Reg := TRegistry.Create;
try
Reg.RootKey := RootKey;
Result := Reg.OpenKey(RegPath, True);
if Result then
Str := Reg.ReadString(RegValue);
finally
Reg.Free;
end;
except
Result := False;
end;
end;
function RegKeyExists(const RegPath: string; const RootKey: HKEY): boolean;
var
Reg: TRegistry;
begin
try
Reg := TRegistry.Create;
try
Reg.RootKey := RootKey;
Result := Reg.KeyExists(RegPath);
finally
Reg.Free;
end;
except
Result := False;
end;
end;
function GetDelphiXE2LocationExeName: string;
Const
Key = '\Software\Embarcadero\BDS\9.0';
begin
Result:='';
if RegKeyExists(Key, HKEY_CURRENT_USER) then
begin
RegReadStr(Key, 'App', Result, HKEY_CURRENT_USER);
exit;
end;
if RegKeyExists(Key, HKEY_LOCAL_MACHINE) then
RegReadStr(Key, 'App', Result, HKEY_LOCAL_MACHINE);
end;
Var
Bds : String;
begin
try
Bds:=GetDelphiXE2LocationExeName;
if Bds<>'' then
begin
if IsAppRunning(Bds) then
Writeln('The Delphi XE2 IDE Is running')
else
Writeln('The Delphi XE2 IDE Is not running')
end
else
Writeln('The Delphi XE2 IDE Is was not found');
except
on E: Exception do
Writeln(E.ClassName, ': ', E.Message);
end;
Readln;
end.
Addtional resources.
Detecting installed delphi versions

Check DebugHook <> 0.
The down side is that currently if your app is built with packages, DebugHook will return 0.
But normally this is would be a very elegant and simple test. Works great in D2009, I just noticed that it has the package dependency bug in XE2 (http://qc.embarcadero.com/wc/qcmain.aspx?d=105365).

Related

Delphi TclDownLoader problems on a service project

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

How to register an Active X .ocx library in Delphi XE4

I am trying to register an Active X .ocx Library in a Delphi program i have tried the following code with out success no errors and the program runs through all of the code but when it has finished the Active X Library hasn't been registered. What am i doing wrong ?
procedure RegisterOCX;
type
TRegFunc = function : HResult; stdcall;
var
ARegFunc : TRegFunc;
aHandle : THandle;
ocxPath,AppPath : string;
begin
GetDir(0, AppPath);
try
ocxPath := AppPath + '\VOIP.ocx';
aHandle := LoadLibrary(PChar(ocxPath));
if aHandle <> 0 then
begin
ARegFunc := GetProcAddress(aHandle,'DllRegisterServer');
if Assigned(ARegFunc) then
begin
ExecAndWait('regsvr32','/s ' + ocxPath);
end;
FreeLibrary(aHandle);
end;
except
ShowMessage('Unable to register ');
end;
end;
function ExecAndWait(const ExecuteFile, ParamString : string): boolean;
var
SEInfo: TShellExecuteInfo;
ExitCode: DWORD;
begin
FillChar(SEInfo, SizeOf(SEInfo), 0);
SEInfo.cbSize := SizeOf(TShellExecuteInfo);
with SEInfo do begin
fMask := SEE_MASK_NOCLOSEPROCESS;
Wnd := Application.Handle;
lpFile := PChar(ExecuteFile);
lpParameters := PChar(ParamString);
nShow := SW_HIDE;
end;
if ShellExecuteEx(#SEInfo) then
begin
repeat
Application.ProcessMessages;
GetExitCodeProcess(SEInfo.hProcess, ExitCode);
until (ExitCode <> STILL_ACTIVE) or Application.Terminated;
Result:=True;
end
else Result:=False;
end;
You are making life hard for yourself by using regsvr32. You've gone 99% of the way to doing without. Instead of calling regsvr32, just call DllRegisterServer. After all, that's all that regsvr32 is going to do!
Your code becomes:
if Assigned(ARegFunc) then
OleCheck(ARegFunc());
You can then remove ExecAndWait altogether. Which is nice because it saves me discussing the busy loop, and the leaked handle!
It would make sense to me to rename the variable that you called ARegFunc as DllRegisterServer. So the code might then look like this:
aHandle := LoadLibrary(PChar(ocxPath));
if aHandle = 0 then
RaiseLastWin32Error;
try
DllRegisterServer := GetProcAddress(aHandle,'DllRegisterServer');
if Assigned(DllRegisterServer) then
OleCheck(DllRegisterServer());
finally
FreeLibrary(aHandle);
end;
The most likely failure mode for a call to DllRegisterServer will be a failure to run your registration code elevated.
As an aside, LoadLibrary returns HMODULE rather than THandle.

select a Folder using the Firemonkey framework

i would like to port the following short code fragment from VCL to FM using Delphi XE2
with TFileOpenDialog.Create(nil) do
try
Title := 'Select Directory';
Options := [fdoPickFolders, fdoPathMustExist, fdoForceFileSystem];
OkButtonLabel := 'Select';
DefaultFolder := FDir;
FileName := FDir;
if Execute then
ShowMessage(FileName);
finally
Free;
end
I could not find the help to import the relevant units using FM framework. At least the filecrtl unit seem to be not available any longer
Furthermore the solution relevant question does nor come up with a window in my test application.
This works fine with a new FireMonkey HD application (running on Win7 64, both as a Win32 and Win64 target) in XE4.
It of course is specific to Windows. You can use OS-version specifics (WinVistaSelectFolder or WinXPSelectFolder), or just call the generic SelectFolder which does that for you.
unit WinFolderSelectUtils;
interface
uses
SysUtils;
function SelectFolder: string;
function WinVistaSelectFolder: string;
function WinXPSelectFolder: string;
implementation
uses
ShellAPI, ShlObj, ActiveX, Windows;
function SelectFolder: string;
begin
if TOSVersion.Check(6) then
Result := WinVistaSelectFolder
else
Result := WinXPSelectFolder;
end;
function WinXPSelectFolder: string;
var
BrowseInfo: TBrowseInfo;
ItemIDList: PItemIDList;
ItemSelected: PItemIDList;
NameBuffer: array[0..MAX_PATH] of Char;
begin
Result := '';
// Should be doing some error handling here. Omitted for clarity, but
// obviously should raise some sort of exception if anything fails instead
// of just returning an empty string.
ItemIDList := nil;
FillChar(BrowseInfo, SizeOf(BrowseInfo), 0);
BrowseInfo.hwndOwner := 0;
BrowseInfo.pidlRoot := ItemIDList;
BrowseInfo.pszDisplayName := NameBuffer;
BrowseInfo.lpszTitle := 'Select a directory';
BrowseInfo.ulFlags := BIF_RETURNONLYFSDIRS;
ItemSelected := SHBrowseForFolder(BrowseInfo);
if ItemSelected <> nil then
begin
SHGetPathFromIDList(ItemSelected, NameBuffer);
Result := NameBuffer;
end;
CoTaskMemFree(BrowseInfo.pidlRoot);
end;
function WinVistaSelectFolder: String;
var
FileDialog: IFileDialog;
hr: HRESULT;
IResult: IShellItem;
FileName: PWideChar;
Settings: Cardinal;
Title: String;
begin
hr := CoCreateInstance(CLSID_FileOpenDialog,
nil,
CLSCTX_INPROC_SERVER,
IFileDialog,
FileDialog);
if hr = S_OK then
begin
FileDialog.GetOptions(Settings);
Settings := Settings or FOS_PICKFOLDERS or FOS_FORCEFILESYSTEM;
FileDialog.SetOptions(Settings);
FileDialog.SetOkButtonLabel('Select');
Title := 'Select a directory';
FileDialog.SetTitle(PWideChar(Title));
hr := FileDialog.Show(0);
if hr = S_OK then
begin
hr := FileDialog.GetResult(IResult);
if hr = S_OK then
begin
IResult.GetDisplayName(SIGDN_FILESYSPATH, FileName);
Result := FileName;
end;
end;
end;
end;
end.
Since you are using Windows, you can use the code in the question even in a FireMonkey app. I think you need to put the code into a unit which does not use any FMX units, but otherwise it works fine. You'll need to use Vcl.Dialogs in that unit.

How to test if an application (.exe) is built with runtime package

How may I test in coding if my .exe Delphi application is built with runtime package or is single .exe?
Another possibility:
function UsesRuntimePackages: Boolean;
begin
Result := FindClassHInstance(TObject) <> HInstance;
end;
Another possibility, in case you need this for an external executable (without running it):
procedure InfoProc(const Name: string; NameType: TNameType; Flags: Byte; Param: Pointer);
begin
case NameType of
ntContainsUnit:
if Name = 'System' then
PBoolean(Param)^ := False;
end;
end;
function UsesRuntimePackages(const ExeName: TFileName): Boolean;
var
Module: HMODULE;
Flags: Integer;
begin
Result := True;
Module := LoadLibraryEx(PChar(ExeName), 0, LOAD_LIBRARY_AS_DATAFILE);
try
Flags := 0;
GetPackageInfo(Module, #Result, Flags, InfoProc);
finally
FreeLibrary(Module);
end;
end;
Use could use the EnumModules() procedure, like so:
function EnumModuleProc(HInstance: Integer; Data: Pointer): Boolean;
begin
Result := True;
if HInstance <> MainInstance then begin
Inc(PInteger(Data)^);
Result := False;
end;
end;
function UsesRuntimePackages: boolean;
var
PckgCount: integer;
begin
PckgCount := 0;
EnumModules(EnumModuleProc, #PckgCount);
Result := PckgCount > 0;
end;
Did you try "Islibrary" ?

How to determine Delphi Application Version

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);

Resources