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);
Related
I use lockbox3 for years, util now with delphi xe7. Now I'm migrating to Alexandria and facing the problem.
With XE7 I used version 3.4 (or so - I cannot find version number in sources). With Alexandria I use whatever comes from Getit package manager.
My code is like follow.
function TForm1.md5(src: string): string;
function Display(Buf: TBytes): String;
var i: Integer;
begin
Result := '';
for i := 0 to 15 do
Result := Result + Format('%0.2x', [Buf[i]]);
Result := LowerCase(Trim(Result));
end;
var
output : AnsiString;
bytes : TBytes;
P, Sz: integer;
aByte: byte;
s: string;
MyHash : THash;
Lib : TCryptographicLibrary;
begin
Lib := TCryptographicLibrary.Create(nil);
MyHash := THash.Create(nil);
MyHash.CryptoLibrary := Lib;
MyHash.HashId := 'native.hash.MD5';
MyHash.Begin_Hash;
MyHash.HashAnsiString(src);
if not assigned(MyHash.HashOutputValue) then
output := 'nil'
else
begin
SetLength(Bytes, 16);
Sz := MyHash.HashOutputValue.Size;
if Sz <> 16 then
output := Format('wrong size: %d', [Sz])
else
begin
P := 0;
MyHash.HashOutputValue.Position := 0;
while MyHash.HashOutputValue.Read(aByte, 1) = 1 do
begin
bytes[P] := aByte;
Inc(P);
end;
result := Display(Bytes);
end;
end;
MyHash.Destroy;
Lib.Destroy;
end;
This works like a charm in old environment. In Alexandria it throws 'Integer overflow' exception at
MyHash.HashAnsiString(src);
Does any body know, how to solve this problem?
regards
M.
Delphi offers the library System.Win.Registry to manipulate the windows registry.
Unfortunately it doesn't contain read/write procedures for the registry datatype REG_MULTI_SZ (=list of strings).
The following code returns an ERegistryException with "invalid datatype" - it seems only to work with datatype REG_SZ:
Registry := TRegistry.Create;
Registry.RootKey := HKEY_LOCAL_MACHINE;
Registry.OpenKey(cKey, false);
sValue := Registry.ReadString('MyRegEntry');
Meanwhile I am able to read the REG_MULTI_SZ value with
Registry.ReadBinaryData('MyRegEntry', pBuf, sizeof(pBuf));
but if I write it back using WriteBinaryData() it will be written to the registry as datatype REG_BINARY instead of REG_MULTI_SZ. So that's not working properly.
How can I manipulate registry data of datatype REG_MULTI_SZ using Delphi?
I have written two functions (a class helper) to extend the functionality of TRegistry:
unit Common.RegistryHelper;
interface
uses
System.Classes, System.Win.Registry, Winapi.Windows, System.Math;
type
TRegistryHelper = class helper for TRegistry
public
function ReadMultiSz(const name: string; var Strings: TStrings): boolean;
function WriteMultiSz(const name: string; const value: TStrings): boolean;
end;
implementation
function TRegistryHelper.ReadMultiSz(const name: string; var Strings: TStrings): boolean;
var
iSizeInByte: integer;
Buffer: array of WChar;
iWCharsInBuffer: integer;
z: integer;
sString: string;
begin
iSizeInByte := GetDataSize(name);
if iSizeInByte > 0 then begin
SetLength(Buffer, Floor(iSizeInByte / sizeof(WChar)));
iWCharsInBuffer := Floor(ReadBinaryData(name, Buffer[0],
iSizeInByte) / sizeof(WChar));
sString := '';
for z := 0 to iWCharsInBuffer do begin
if Buffer[z] <> #0 then begin
sString := sString + Buffer[z];
end else begin
if sString <> '' then begin
Strings.Append(sString);
sString := '';
end;
end;
end;
result := true;
end else begin
result := false;
end;
end;
function TRegistryHelper.WriteMultiSz(const name: string; const value: TStrings): boolean;
var
sContent: string;
x: integer;
begin
sContent := '';
for x := 0 to pred(value.Count) do begin
sContent := sContent + value.Strings[x] + #0;
end;
sContent := sContent + #0;
result := RegSetValueEx(CurrentKey, pchar(name), 0, REG_MULTI_SZ,
pointer(sContent), Length(sContent)*sizeof(Char)) = 0;
end;
end.
Using the functions above you can simply write in your program the following code to add a value to a REG_MULTI_SZ entry:
procedure AddValueToRegistry();
const
cKey = '\SYSTEM\ControlSet001\services\TcSysSrv';
var
Registry: TRegistry;
MyList: TStrings;
begin
Registry := TRegistry.Create;
Registry.RootKey := HKEY_LOCAL_MACHINE;
Registry.OpenKey(cKey, false);
try
MyList := TStringList.Create();
Registry.ReadMultiSz('MyRegEntry', MyList);
MyList.Add('NewEntry');
Registry.WriteMultiSz('MyRegEntry', MyList);
finally
MyList.Free;
end;
Registry.Free;
end;
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'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).
How can i get the name of the target executable given an IOTAProject?
From GExpert's OpenTools API FAQ:
How can I determine the filename of the binary/exe/dll/bpl/ocx/etc. generated by a compile or build?
- For Delphi 8 or greater, use IOTAProjectOptions.TargetName.
- For earlier releases, the method is a lot more complex to implement because it involves potentially scanning for the $E directive that specifies the executable file extension for the project, and then looking for the binary file on the path specified by the "OptputDir" project option, or the project directory if that option is blank (among many other possibilities and complexities). The best way to implement such a tool might be to start with the sample code in CodeGear CodeCentral sample ID 19823.
In my case i fit into the latter. Given an IOTAProject interface, what would be the guts of:
function GetTargetName(Project: IOTAProject): TFilename;
begin
//todo
end;
If it's Delphi 8 or greater, the (untested) answer is:
{$I compilers.inc}
function GetTargetName(Project: IOTAProject): TFilename;
begin
{$IFDEF COMPILER_8_UP}
Result := Project.ProjectOptions.TargetName;
{$ELSE}
raise Exception.Create('Not yet implemented');
{$ENDIF}
end;
But it's the complicated pre-Delphi 8 that's harder.
The Jedi JCL has a dozen methods in the internal TJclOTAExpert that together can be used to simulate:
Project.ProjectOptions.TargetName
i will be working to slog through that code. In a few weeks i'll hopefully be able to post an answer to my own question.
But in the meantime i'll open it up to let someone else get reputation for being able to answer my question.
The link you mentioned is, as far as I know, working fine for pre-Delphi 8 versions. You just need to copy the GetTargetFileName function and a few functions it uses.
Edit: Thanks to Premature Optimization I now know that Delphi 6+ $LibPrefix and related directives, when used in the source code, are missed/ignored by this function. This should cause no trouble in Delphi 5, though.
The function does the following:
determines the output directory for the current project, based on the type of the project and its project options
translates $(...) variable references, if any, by evaluating variables from the registry and from the system environment
determines the target file name (based on the type of the project, extension override directive, prefix and suffix project options, if any)
The code should give you everything you need to get the correct target file name for a project in Delphi 5 to 7.
Edit: here is the code (copy+pasted from the link):
{$IFDEF VER130}
{$DEFINE DELPHI_5_UP}
{$ENDIF}
{$IFDEF VER140}
{$DEFINE DELPHI_5_UP}
{$DEFINE DELPHI_6_UP}
{$ENDIF}
{$IFDEF VER150}
{$DEFINE DELPHI_5_UP}
{$DEFINE DELPHI_6_UP}
{$DEFINE DELPHI_7_UP}
{$ENDIF}
{$IFNDEF DELPHI_5_UP}
Delphi 5 or higher required.
{$ENDIF}
{$IFNDEF DELPHI_6_UP}
function ExcludeTrailingPathDelimiter(const S: string): string; forward;
function IncludeTrailingPathDelimiter(const S: string): string; forward;
{$ENDIF}
// get Delphi root directory
function GetDelphiRootDirectory: string;
{$IFNDEF DELPHI_7_UP}
var
Registry: TRegistry;
{$ENDIF}
begin
{$IFDEF DELPHI_7_UP}
Result := (BorlandIDEServices as IOTAServices).GetRootDirectory;
{$ELSE}
Registry := TRegistry.Create(KEY_READ);
try
if Registry.OpenKeyReadOnly((BorlandIDEServices as IOTAServices).GetBaseRegistryKey) then
Result := Registry.ReadString('RootDir');
finally
Registry.Free;
end;
{$ENDIF}
end;
// get Delphi environment variables (name-value pairs) from the registry
procedure GetEnvVars(Strings: TStrings);
var
Registry: TRegistry;
I: Integer;
begin
Registry := TRegistry.Create(KEY_READ);
try
Registry.RootKey := HKEY_CURRENT_USER;
if Registry.OpenKeyReadOnly((BorlandIDEServices as IOTAServices).GetBaseRegistryKey + '\Environment Variables') then
begin
Registry.GetValueNames(Strings);
for I := 0 to Strings.Count - 1 do
Strings[I] := Strings[I] + '=' + Registry.ReadString(Strings[I]);
end;
finally
Registry.Free;
end;
end;
// get output directory of a project
function GetProjectOutputDir(const Project: IOTAProject): string;
begin
if Project.ProjectOptions.Values['GenPackage'] then // package project
begin
// use project options if specified
Result := Project.ProjectOptions.Values['PkgDllDir'];
// otherwise use environment options
if Result = '' then
Result := (BorlandIDEServices as IOTAServices).GetEnvironmentOptions.Values['PackageDPLOutput'];
end
else // non-package project, use project options
Result := Project.ProjectOptions.Values['OutputDir'];
// default is the project's path
if Result = '' then
Result := ExtractFilePath(Project.FileName);
Result := IncludeTrailingPathDelimiter(Result);
end;
// get project source editor
function GetProjectSourceEditor(const Project: IOTAProject): IOTASourceEditor;
var
I: Integer;
begin
Result := nil;
for I := 0 to Project.GetModuleFileCount - 1 do
if Supports(Project.GetModuleFileEditor(I), IOTASourceEditor, Result) then
Break;
end;
// get system environment variables
procedure GetSysVars(Strings: TStrings);
var
P: PChar;
begin
P := GetEnvironmentStrings;
try
repeat
Strings.Add(P);
P := StrEnd(P);
Inc(P);
until P^ = #0;
finally
FreeEnvironmentStrings(P);
end;
end;
function GetTargetExtOverride(const Project: IOTAProject): string; overload; forward;
// get target extension
function GetTargetExt(const Project: IOTAProject): string;
begin
// use {$E ...} override if specified
Result := GetTargetExtOverride(Project);
// otherwise use defaults
if Result = '' then
begin
if Project.ProjectOptions.Values['GenPackage'] then // package
Result := '.bpl'
else if Project.ProjectOptions.Values['GenDll'] then // DLL
Result := '.dll'
else // application
Result := '.exe';
end;
end;
// read {$E ...} directive from project source
function GetTargetExtOverride(const ProjectSource: string): string; overload;
var
P: PChar;
procedure SkipComment(var P: PChar);
begin
case P^ of
'{':
begin
while not (P^ in [#0, '}']) do
Inc(P);
if P^ = '}' then
Inc(P);
end;
'/':
if (P + 1)^ = '/' then
begin
while not (P^ in [#0, #10, #13]) do
Inc(P);
while (P^ in [#10, #13]) do
Inc(P);
end;
'(':
if (P + 1)^ = '*' then
repeat
Inc(P);
case P^ of
#0:
Break;
'*':
if (P + 1)^ = ')' then
begin
Inc(P, 2);
Break;
end;
end;
until False;
end;
end;
procedure SkipStringLiteral(var P: PChar);
begin
if P^ <> '''' then
Exit;
Inc(P);
repeat
case P^ of
#0:
Break;
'''':
begin
Inc(P);
if P^ = '''' then
Inc(P)
else
Break;
end;
else
Inc(P);
end;
until False;
end;
procedure SkipNonDirectives(var P: PChar);
begin
repeat
case P^ of
#0:
Break;
'''':
SkipStringLiteral(P);
'/':
case (P + 1)^ of
'/':
SkipComment(P);
else
Inc(P);
end;
'(':
case (P + 1)^ of
'*':
SkipComment(P);
else
Inc(P);
end;
'{':
begin
case (P + 1)^ of
'$':
Break;
else
SkipComment(P);
end;
end;
else
Inc(P);
end;
until False;
end;
begin
P := PChar(ProjectSource);
repeat
SkipNonDirectives(P);
case P^ of
#0:
Break;
'{':
if StrLIComp(P, '{$E ', 4) = 0 then
begin
Inc(P, 4);
Result := '.';
while P^ = ' ' do
Inc(P);
while not (P^ in [#0, '}']) do
begin
if P^ <> ' ' then
Result := Result + P^;
Inc(P);
end;
Break;
end
else
SkipComment(P);
end;
until False;
end;
// read {$E ...} directive from project source module
function GetTargetExtOverride(const Project: IOTAProject): string; overload;
const
BufferSize = 1024;
var
SourceEditor: IOTASourceEditor;
EditReader: IOTAEditReader;
Buffer: array[0..BufferSize - 1] of Char;
Stream: TStringStream;
ReaderPos, CharsRead: Integer;
begin
SourceEditor := GetProjectSourceEditor(Project);
if Assigned(SourceEditor) then
begin
EditReader := SourceEditor.CreateReader;
Stream := TStringStream.Create('');
try
ReaderPos := 0;
repeat
CharsRead := EditReader.GetText(ReaderPos, Buffer, BufferSize - 1);
Inc(ReaderPos, CharsRead);
Buffer[CharsRead] := #0;
Stream.WriteString(Buffer);
until CharsRead < BufferSize - 1;
Result := GetTargetExtOverride(Stream.DataString);
finally
Stream.Free;
end;
end;
end;
// get project target file name (with path), resolve $(...) macros if used
function GetTargetFileName(const Project: IOTAProject): string;
var
PStart, PEnd: PChar;
EnvVar, Value, FileName, Ext, S: string;
EnvVars, SysVars: TStringList;
I: Integer;
begin
EnvVars := nil;
SysVars := nil;
try
Result := GetProjectOutputDir(Project);
PStart := StrPos(PChar(Result), '$(');
while PStart <> nil do
begin
Value := '';
PEnd := StrPos(PStart, ')');
if PEnd = nil then
Break;
SetString(EnvVar, PStart + 2, PEnd - PStart - 2);
if CompareText(EnvVar, 'DELPHI') = 0 then // $(DELPHI) macro is hardcoded
Value := GetDelphiRootDirectory
else
begin
// try Delphi environment variables from the registry
if not Assigned(EnvVars) then
begin
EnvVars := TStringList.Create;
GetEnvVars(EnvVars);
end;
for I := 0 to EnvVars.Count -1 do
if CompareText(EnvVar, EnvVars.Names[I]) = 0 then
begin
{$IFDEF DELPHI_7_UP}
Value := ExcludeTrailingPathDelimiter(EnvVars.ValueFromIndex[I]);
{$ELSE}
Value := ExcludeTrailingPathDelimiter(EnvVars.Values[EnvVars.Names[I]]);
{$ENDIF}
Break;
end;
if Value = '' then
begin
// try system environment variables
if not Assigned(SysVars) then
begin
SysVars := TStringList.Create;
GetSysVars(SysVars);
end;
for I := 0 to SysVars.Count - 1 do
if CompareText(EnvVar, SysVars.Names[I]) = 0 then
begin
{$IFDEF DELPHI_7_UP}
Value := ExcludeTrailingPathDelimiter(SysVars.ValueFromIndex[I]);
{$ELSE}
Value := ExcludeTrailingPathDelimiter(SysVars.Values[SysVars.Names[I]]);
{$ENDIF}
Break;
end;
end;
end;
I := PStart - PChar(Result) + 1;
Delete(Result, I, Length(EnvVar) + 3);
Insert(Value, Result, I);
PStart := StrPos(PChar(Result), '$(');
end;
Ext := GetTargetExt(Project);
FileName := ChangeFileExt(ExtractFileName(Project.FileName), '');
// include prefix/suffix/version for DLL and package projects
if Project.ProjectOptions.Values['GenDll'] then
begin
S := Project.ProjectOptions.Values['SOPrefix'];
if Project.ProjectOptions.Values['SOPrefixDefined'] then
FileName := S + FileName;
S := Project.ProjectOptions.Values['SOSuffix'];
if (S <> '') then
FileName := FileName + S;
FileName := FileName + Ext;
S := Project.ProjectOptions.Values['SOVersion'];
if S <> '' then
FileName := FileName + '.' + S;
end
else
FileName := FileName + Ext;
Result := Result + FileName;
finally
EnvVars.Free;
SysVars.Free;
end;
end;
{$IFNDEF DELPHI_6_UP}
function ExcludeTrailingPathDelimiter(const S: string): string;
begin
Result := ExcludeTrailingBackslash(S);
end;
function IncludeTrailingPathDelimiter(const S: string): string;
begin
Result := IncludeTrailingBackslash(S);
end;
{$ENDIF}