You've already forked lazarus-ccr
435 lines
14 KiB
ObjectPascal
435 lines
14 KiB
ObjectPascal
|
//******************************************************************************
|
||
|
|
//*** COMMON FUNCTIONS ***
|
||
|
|
//*** ***
|
||
|
|
//*** (c) Massimo Magnano 2000-2005 ***
|
||
|
|
//*** ***
|
||
|
|
//*** ***
|
||
|
|
//******************************************************************************
|
||
|
|
// File : EnvironmentStrings.pas
|
||
|
|
//
|
||
|
|
// Description : Functions for expand String with Environment Variables inside.
|
||
|
|
//
|
||
|
|
//******************************************************************************
|
||
|
|
// Exported Variables :
|
||
|
|
// - All the System Variables like %SYSTEMROOT% , %TEMP% etc...
|
||
|
|
//
|
||
|
|
// %SYSTEM-PATH% Path to System Folder
|
||
|
|
// %PROGRAM-PATH% Application or Dll Path
|
||
|
|
// %PROGRAM-EXE% Application or Dll Full Name
|
||
|
|
// %OS% Operating System Type
|
||
|
|
// 'WIN9X\'
|
||
|
|
// 'WINNT\'
|
||
|
|
// 'WIN32S\'
|
||
|
|
// 'OTHER\'
|
||
|
|
// %OS-MAJOR-VER% Operating System Major Version Number
|
||
|
|
// %OS-MINOR-VER% Operating System Minor Version Number
|
||
|
|
// %MAJOR-VER% Application Major Version Number
|
||
|
|
// %MINOR-VER% Application Minor Version Number
|
||
|
|
// %DATE-TIME% Current Date-Time in the form yyyy-mm-dd-hh-nn-ss-z
|
||
|
|
//
|
||
|
|
// For all Variables (except System Variables) the last char is always '\'
|
||
|
|
//
|
||
|
|
// All Variables can be specified in the form :
|
||
|
|
// %VarName:MaxLength%
|
||
|
|
// In this Case the Var Value is Truncated (if Length>MaxLength)
|
||
|
|
// or Expanded with spaces (if Length<MaxLength)
|
||
|
|
|
||
|
|
unit EnvironmentStrings;
|
||
|
|
|
||
|
|
interface
|
||
|
|
|
||
|
|
uses Windows, SysUtils, ShlObj;
|
||
|
|
|
||
|
|
type
|
||
|
|
TShellPaths = record
|
||
|
|
VAR_NAME :String;
|
||
|
|
nFolder :Integer;
|
||
|
|
end;
|
||
|
|
|
||
|
|
const
|
||
|
|
MAX_Vars =5;
|
||
|
|
|
||
|
|
VAR_SYSTEM_PATH ='SYSTEM-PATH';
|
||
|
|
VAR_PROGRAM_PATH ='PROGRAM-PATH';
|
||
|
|
VAR_PROGRAM_EXE ='PROGRAM-EXE';
|
||
|
|
VAR_APPDATA ='APPDATA';
|
||
|
|
VAR_OS ='OS';
|
||
|
|
VAR_OS_MAJOR_VER ='OS-MAJOR-VER';
|
||
|
|
VAR_OS_MINOR_VER ='OS-MINOR-VER';
|
||
|
|
VAR_MAJOR_VER ='MAJOR-VER';
|
||
|
|
VAR_MINOR_VER ='MINOR-VER';
|
||
|
|
VAR_DATE_TIME ='DATE-TIME';
|
||
|
|
|
||
|
|
NumExcludedInStringASPARAM =5;
|
||
|
|
Vars_ExcludedInStringASPARAM :array[0..NumExcludedInStringASPARAM-1] of String = (
|
||
|
|
VAR_OS_MAJOR_VER,
|
||
|
|
VAR_OS_MINOR_VER,
|
||
|
|
VAR_MAJOR_VER,
|
||
|
|
VAR_MINOR_VER,
|
||
|
|
VAR_DATE_TIME
|
||
|
|
);
|
||
|
|
|
||
|
|
Vars :array[0..MAX_Vars-1] of String = (
|
||
|
|
VAR_SYSTEM_PATH,
|
||
|
|
VAR_PROGRAM_PATH,
|
||
|
|
VAR_PROGRAM_EXE,
|
||
|
|
VAR_APPDATA,
|
||
|
|
VAR_OS
|
||
|
|
);
|
||
|
|
|
||
|
|
MAX_VAR_Shell =16;
|
||
|
|
VAR_Shell : array [0..MAX_VAR_Shell-1] of TShellPaths =(
|
||
|
|
(VAR_NAME :'DESKTOP_DIR'; nFolder :CSIDL_DESKTOPDIRECTORY),
|
||
|
|
(VAR_NAME :'DESKTOP'; nFolder :CSIDL_DESKTOP),
|
||
|
|
(VAR_NAME :'STARTMENU'; nFolder :CSIDL_STARTMENU),
|
||
|
|
(VAR_NAME :'RECYCLEBIN'; nFolder :CSIDL_BITBUCKET),
|
||
|
|
(VAR_NAME :'CONTROLPANEL'; nFolder :CSIDL_CONTROLS),
|
||
|
|
(VAR_NAME :'MYCOMPUTER'; nFolder :CSIDL_DRIVES),
|
||
|
|
(VAR_NAME :'FONTS'; nFolder :CSIDL_FONTS),
|
||
|
|
(VAR_NAME :'NETHOOD'; nFolder :CSIDL_NETHOOD),
|
||
|
|
(VAR_NAME :'NETWORK'; nFolder :CSIDL_NETWORK),
|
||
|
|
(VAR_NAME :'PERSONAL'; nFolder :CSIDL_PERSONAL),
|
||
|
|
(VAR_NAME :'PRINTERS'; nFolder :CSIDL_PRINTERS),
|
||
|
|
(VAR_NAME :'PROGRAMS'; nFolder :CSIDL_PROGRAMS),
|
||
|
|
(VAR_NAME :'RECENT'; nFolder :CSIDL_RECENT),
|
||
|
|
(VAR_NAME :'SENDTO'; nFolder :CSIDL_SENDTO),
|
||
|
|
(VAR_NAME :'STARTUP'; nFolder :CSIDL_STARTUP),
|
||
|
|
(VAR_NAME :'TEMPLATES'; nFolder :CSIDL_TEMPLATES)
|
||
|
|
);
|
||
|
|
|
||
|
|
MAX_ExportedVars =(MAX_Vars+MAX_VAR_Shell+NumExcludedInStringASPARAM);
|
||
|
|
|
||
|
|
type
|
||
|
|
TOnGetVariableFunction = function (Tag :TObject; Campo :String; var VarValue :String) :Boolean;
|
||
|
|
|
||
|
|
Var
|
||
|
|
ExportedVars :array[0..MAX_ExportedVars-1] of String;
|
||
|
|
MyVer :String ='';
|
||
|
|
MyMajorVer :String ='';
|
||
|
|
MyMinorVer :String ='';
|
||
|
|
MyLang :String ='';
|
||
|
|
ProgramPath :String ='';
|
||
|
|
ProgramEXE :String ='';
|
||
|
|
SystemPath :String ='';
|
||
|
|
|
||
|
|
function ProcessPARAMString(Value: String;
|
||
|
|
OnGetVariable :TOnGetVariableFunction =Nil;
|
||
|
|
OnGetVariableTag :TObject =Nil): String;
|
||
|
|
|
||
|
|
function StringASPARAM(Value: String; AddVars :array of string;
|
||
|
|
ProcessInternalVars :Boolean=False;
|
||
|
|
OnGetVariable :TOnGetVariableFunction =Nil;
|
||
|
|
OnGetVariableTag :TObject =Nil): String;
|
||
|
|
|
||
|
|
implementation
|
||
|
|
|
||
|
|
uses WindowsID, FileVer, Registry, ShellApi, ActiveX;
|
||
|
|
|
||
|
|
const
|
||
|
|
APPDATA_PATH ='Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders';
|
||
|
|
|
||
|
|
|
||
|
|
function GetApplicationDataPath :String;
|
||
|
|
Var
|
||
|
|
Reg :TRegistry;
|
||
|
|
|
||
|
|
begin
|
||
|
|
SetLength(Result, MAX_PATH);
|
||
|
|
ExpandEnvironmentStrings('%APPDATA%', PChar(Result), MAX_PATH);
|
||
|
|
Result :=PChar(Result);
|
||
|
|
if (Result='') or not(DirectoryExists(Result)) then
|
||
|
|
begin
|
||
|
|
Reg :=TRegistry.Create;
|
||
|
|
Reg.OpenKeyReadOnly(APPDATA_PATH);
|
||
|
|
try
|
||
|
|
Result :=Reg.ReadString('AppData');
|
||
|
|
except
|
||
|
|
Result :=ExtractFilePath(ParamStr(0));
|
||
|
|
end;
|
||
|
|
Reg.CloseKey;
|
||
|
|
Reg.Free;
|
||
|
|
end;
|
||
|
|
if (Result<>'') then
|
||
|
|
begin
|
||
|
|
if (Result[Length(Result)]<>'\')
|
||
|
|
then Result :=Result+'\';
|
||
|
|
end;
|
||
|
|
end;
|
||
|
|
|
||
|
|
|
||
|
|
function ProcessPARAMString(Value: String;
|
||
|
|
OnGetVariable :TOnGetVariableFunction =Nil;
|
||
|
|
OnGetVariableTag :TObject =Nil): String;
|
||
|
|
Var
|
||
|
|
auxStr,
|
||
|
|
auxStr2,
|
||
|
|
Campo :String;
|
||
|
|
index2,
|
||
|
|
xpos1, xpos2,
|
||
|
|
oldLength,
|
||
|
|
toDel,
|
||
|
|
maxChars :Integer;
|
||
|
|
Exist :Boolean;
|
||
|
|
LocalVarValue :String; //Non Posso Usare Result in GetStringProc, per problemi di stack
|
||
|
|
|
||
|
|
function GetStringProc(Campo :String; var Exist :Boolean) :String;
|
||
|
|
Var
|
||
|
|
xStr :String;
|
||
|
|
i :Integer;
|
||
|
|
shellAlloc :IMAlloc;
|
||
|
|
IDList :PItemIDList;
|
||
|
|
|
||
|
|
|
||
|
|
begin
|
||
|
|
Exist :=False;
|
||
|
|
|
||
|
|
if Assigned(OnGetVariable) //new
|
||
|
|
then Exist :=OnGetVariable(OnGetVariableTag, Campo, LocalVarValue);//new
|
||
|
|
|
||
|
|
if Exist
|
||
|
|
then Result :=LocalVarValue
|
||
|
|
else begin
|
||
|
|
if (Campo=VAR_SYSTEM_PATH)
|
||
|
|
then begin
|
||
|
|
Result :=SystemPath;
|
||
|
|
Exist :=(SystemPath<>'');
|
||
|
|
end
|
||
|
|
else
|
||
|
|
if (Campo=VAR_PROGRAM_PATH)
|
||
|
|
then begin
|
||
|
|
Result :=ProgramPath;
|
||
|
|
Exist :=(ProgramPath<>'');
|
||
|
|
end
|
||
|
|
else
|
||
|
|
if (Campo=VAR_PROGRAM_EXE)
|
||
|
|
then begin
|
||
|
|
Result :=ProgramEXE;
|
||
|
|
Exist :=(ProgramEXE<>'');
|
||
|
|
end
|
||
|
|
else
|
||
|
|
if (Campo=VAR_APPDATA)
|
||
|
|
then begin
|
||
|
|
Result :=GetApplicationDataPath;
|
||
|
|
Exist :=(Result<>'');
|
||
|
|
end
|
||
|
|
else
|
||
|
|
if (Campo=VAR_OS)
|
||
|
|
then begin
|
||
|
|
Exist :=Win32_IsValidInfos;
|
||
|
|
if Exist then
|
||
|
|
Case Win32Platform of
|
||
|
|
VER_PLATFORM_WIN32_WINDOWS : Result :='WIN9X\';
|
||
|
|
VER_PLATFORM_WIN32_NT : Result :='WINNT\';
|
||
|
|
VER_PLATFORM_WIN32s : Result :='WIN32S\';
|
||
|
|
else Result :='OTHER\';
|
||
|
|
end;
|
||
|
|
end
|
||
|
|
else
|
||
|
|
if (Campo=VAR_OS_MAJOR_VER)
|
||
|
|
then begin
|
||
|
|
Exist :=Win32_IsValidInfos;
|
||
|
|
if Exist
|
||
|
|
then Result :=IntToStr(Win32MajorVersion)+'\';
|
||
|
|
end
|
||
|
|
else
|
||
|
|
if (Campo=VAR_OS_MINOR_VER)
|
||
|
|
then begin
|
||
|
|
Exist :=Win32_IsValidInfos;
|
||
|
|
if Exist
|
||
|
|
then Result :=IntToStr(Win32MinorVersion)+'\';
|
||
|
|
end
|
||
|
|
else
|
||
|
|
if (Campo=VAR_MAJOR_VER)
|
||
|
|
then begin
|
||
|
|
Exist :=(MyMajorVer<>'');
|
||
|
|
if Exist
|
||
|
|
then Result :=MyMajorVer+'\';
|
||
|
|
end
|
||
|
|
else
|
||
|
|
if (Campo=VAR_MINOR_VER)
|
||
|
|
then begin
|
||
|
|
Exist :=(MyMinorVer<>'');
|
||
|
|
if Exist
|
||
|
|
then Result :=MyMinorVer+'\';
|
||
|
|
end
|
||
|
|
else
|
||
|
|
if (Campo=VAR_DATE_TIME)
|
||
|
|
then begin
|
||
|
|
Exist :=True;
|
||
|
|
DateTimeToString(Result, 'yyyy-mm-dd-hh-nn-ss-z', Now);
|
||
|
|
end
|
||
|
|
else
|
||
|
|
begin
|
||
|
|
for i:=0 to MAX_VAR_Shell-1 do
|
||
|
|
begin
|
||
|
|
if (Campo=VAR_Shell[i].VAR_NAME)
|
||
|
|
then begin
|
||
|
|
if (SHGetMalloc(shellAlloc)=NO_ERROR)
|
||
|
|
then begin
|
||
|
|
SHGetSpecialFolderLocation(GetDesktopWindow,
|
||
|
|
VAR_Shell[i].nFolder, IDList);
|
||
|
|
if (IDList<>Nil) then
|
||
|
|
begin
|
||
|
|
SetLength(xStr, MAX_PATH);
|
||
|
|
SHGetPathFromIDList(IDList, PChar(xStr));
|
||
|
|
xStr :=PChar(xStr);
|
||
|
|
shellAlloc.Free(IDList);
|
||
|
|
end;
|
||
|
|
end;
|
||
|
|
Exist := (xStr<>'');
|
||
|
|
Break;
|
||
|
|
end;
|
||
|
|
end;
|
||
|
|
|
||
|
|
if not(Exist) then
|
||
|
|
begin
|
||
|
|
SetLength(xStr, MAX_PATH);
|
||
|
|
ExpandEnvironmentStrings(PChar('%'+Campo+'%'), PChar(xStr), MAX_PATH);
|
||
|
|
xStr :=PChar(xStr);
|
||
|
|
Exist:=(pos('%', xStr)<=0); //Se non c'� % e' una variable di sistema
|
||
|
|
end;
|
||
|
|
if Exist
|
||
|
|
then Result :=xStr;
|
||
|
|
end;
|
||
|
|
end;
|
||
|
|
end;
|
||
|
|
|
||
|
|
begin
|
||
|
|
auxStr :=Value;
|
||
|
|
xpos1 :=Pos('%', auxStr);
|
||
|
|
While (xpos1>0) do
|
||
|
|
begin
|
||
|
|
auxStr[xpos1] :=' ';
|
||
|
|
toDel :=Pos('%', auxStr)-xpos1+1;
|
||
|
|
auxStr2 :=Copy(auxStr, xpos1+1, toDel-2);
|
||
|
|
xpos2 :=Pos(':', auxStr2);
|
||
|
|
if (xpos2>0) then begin
|
||
|
|
//E' stata specificata la lunghezza massima della
|
||
|
|
//Variabile nella forma %VarName:LunghezzaMax%
|
||
|
|
Campo :=Copy(auxStr2, 1, xpos2-1);
|
||
|
|
maxChars :=StrToInt(Copy(auxStr2, xpos2+1, MaxInt))
|
||
|
|
end
|
||
|
|
else begin
|
||
|
|
Campo :=auxStr2;
|
||
|
|
maxChars :=-1;
|
||
|
|
end;
|
||
|
|
|
||
|
|
Exist :=False;
|
||
|
|
auxStr2 :=GetStringProc(Uppercase(Campo), Exist);
|
||
|
|
if Exist then
|
||
|
|
begin
|
||
|
|
if (maxChars>0) then
|
||
|
|
begin
|
||
|
|
oldLength :=Length(auxStr2);
|
||
|
|
SetLength(auxStr2, maxChars);
|
||
|
|
if (oldLength<maxChars) then
|
||
|
|
for index2 :=oldLength+1 to maxChars do
|
||
|
|
auxStr2[index2] :=' ';
|
||
|
|
end;
|
||
|
|
Delete(auxStr, xpos1, toDel);
|
||
|
|
Insert(auxStr2, auxStr, xpos1);
|
||
|
|
end
|
||
|
|
else Delete(auxStr, xpos1, toDel);
|
||
|
|
xpos1 :=Pos('%', auxStr);
|
||
|
|
end;
|
||
|
|
Result :=auxStr;
|
||
|
|
end;
|
||
|
|
|
||
|
|
function StringASPARAM(Value: String; AddVars :array of string;
|
||
|
|
ProcessInternalVars :Boolean=False;
|
||
|
|
OnGetVariable :TOnGetVariableFunction =Nil;
|
||
|
|
OnGetVariableTag :TObject =Nil): String;
|
||
|
|
Var
|
||
|
|
i :Integer;
|
||
|
|
UValue :String;
|
||
|
|
|
||
|
|
procedure TryReplace(VarValue :String; VarName :String; var xResult :String);
|
||
|
|
Var
|
||
|
|
UVarValue :String;
|
||
|
|
LVarValue,
|
||
|
|
xpos :Integer;
|
||
|
|
|
||
|
|
begin
|
||
|
|
UVarValue := Uppercase(VarValue);
|
||
|
|
LVarValue := Length(UVarValue);
|
||
|
|
|
||
|
|
xpos :=Pos(UVarValue, UValue);
|
||
|
|
while (xpos>0) do
|
||
|
|
begin
|
||
|
|
Delete(UValue, xpos, LVarValue);
|
||
|
|
Delete(xResult, xpos, LVarValue);
|
||
|
|
Insert(VarName, UValue, xpos);
|
||
|
|
Insert(VarName, xResult, xpos);
|
||
|
|
xpos :=Pos(UVarValue, UValue);
|
||
|
|
end;
|
||
|
|
end;
|
||
|
|
|
||
|
|
begin
|
||
|
|
UValue :=Uppercase(Value);
|
||
|
|
Result :=Value;
|
||
|
|
|
||
|
|
for i:=0 to Length(AddVars)-1 do
|
||
|
|
TryReplace(ProcessPARAMString(AddVars[i], OnGetVariable, OnGetVariableTag),
|
||
|
|
AddVars[i], Result);
|
||
|
|
|
||
|
|
if ProcessInternalVars
|
||
|
|
then for i:=0 to MAX_ExportedVars-1 do
|
||
|
|
begin
|
||
|
|
if (ExportedVars[i]=Vars_ExcludedInStringASPARAM[0])
|
||
|
|
then Break;//Exclude All Versions numbers from replace (ex. MyDir 1\ maybe replaced with "MyDir %OS-MINOR-VER%")
|
||
|
|
|
||
|
|
TryReplace(ProcessPARAMString('%'+ExportedVars[i]+'%', OnGetVariable, OnGetVariableTag),
|
||
|
|
'%'+ExportedVars[i]+'%', Result);
|
||
|
|
end;
|
||
|
|
end;
|
||
|
|
|
||
|
|
procedure CalcValues;
|
||
|
|
Var
|
||
|
|
i :Integer;
|
||
|
|
|
||
|
|
begin
|
||
|
|
SetLength(ProgramEXE, MAX_PATH);
|
||
|
|
GetModuleFileName(HInstance, PChar(ProgramEXE), MAX_PATH);
|
||
|
|
ProgramEXE :=PChar(ProgramEXE);
|
||
|
|
|
||
|
|
ProgramPath :=ExtractFilePath(ProgramEXE);
|
||
|
|
if (ProgramPath<>'') and (ProgramPath[Length(ProgramPath)]<>'\')
|
||
|
|
then ProgramPath :=ProgramPath+'\';
|
||
|
|
|
||
|
|
SetLength(SystemPath, MAX_PATH);
|
||
|
|
GetSystemDirectory(PChar(SystemPath), MAX_PATH);
|
||
|
|
SystemPath :=PChar(SystemPath);
|
||
|
|
if (SystemPath<>'') and (SystemPath[Length(SystemPath)]<>'\')
|
||
|
|
then SystemPath :=SystemPath+'\';
|
||
|
|
|
||
|
|
MyVer :=GetFileVerLang(ParamStr(0), MyLang);
|
||
|
|
if (MyVer<>'')
|
||
|
|
then begin
|
||
|
|
MyMajorVer :=Copy(MyVer, 1, Pos('.', MyVer)-1);
|
||
|
|
MyMinorVer :=Copy(MyVer, Length(MyMajorVer)+1, Length(MyVer));
|
||
|
|
end;
|
||
|
|
|
||
|
|
for i:=0 to MAX_Vars-1 do
|
||
|
|
begin
|
||
|
|
ExportedVars[i] :=Vars[i];
|
||
|
|
end;
|
||
|
|
|
||
|
|
for i:=0 to MAX_VAR_Shell-1 do
|
||
|
|
begin
|
||
|
|
ExportedVars[i+MAX_Vars] :=VAR_Shell[i].VAR_NAME;
|
||
|
|
end;
|
||
|
|
|
||
|
|
//All Variables from this point are excluded in StringASPARAM
|
||
|
|
for i :=0 to NumExcludedInStringASPARAM-1 do
|
||
|
|
begin
|
||
|
|
ExportedVars[i+MAX_Vars+MAX_VAR_Shell] :=Vars_ExcludedInStringASPARAM[i];
|
||
|
|
end;
|
||
|
|
end;
|
||
|
|
|
||
|
|
|
||
|
|
initialization
|
||
|
|
CalcValues;
|
||
|
|
|
||
|
|
|
||
|
|
end.
|