You've already forked lazarus-ccr
c3ab0f1439
new festures than in package: *langauge independent *removes notoc *removes page templates git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@95 8e941d3f-bd1b-0410-a28a-d453659cc2b4
725 lines
19 KiB
ObjectPascal
725 lines
19 KiB
ObjectPascal
UNIT Utils;
|
|
|
|
INTERFACE
|
|
|
|
{$H+}
|
|
|
|
uses Classes,SysUtils,Graphics,Forms,Process,Dialogs,Clipbrd,FileUtil,Translations
|
|
{$IFDEF MSWINDOWS}
|
|
,Registry,Windows
|
|
{$ENDIF}
|
|
;
|
|
|
|
{$IFNDEF FPC}
|
|
CONST
|
|
DirectorySeparator = '\';
|
|
{$ENDIF}
|
|
|
|
type
|
|
TRoundToRange = -37..37;
|
|
TProcessinfoTyp = (piOpen,piPrint);
|
|
{$ifdef WINDOWS}
|
|
PFNSHGetFolderPath = Function(Ahwnd: HWND; Csidl: Integer; Token: THandle; Flags: DWord; Path: PChar): HRESULT; stdcall;
|
|
{$endif}
|
|
|
|
function ClearDir (Path: string): boolean;
|
|
function RPos(const Substr: string; const S: string): Integer;
|
|
FUNCTION IsNumeric(s: STRING): boolean;
|
|
FUNCTION StrTimeToValue(val : string) : LongInt;
|
|
procedure DrawText(Canvas : TCanvas;Rect : TRect;Str : string;CenterV : Boolean = False;CenterH : Boolean = False);
|
|
function InstallExt(Extension, ExtDescription, FileDescription,OpenWith, ParamString: string; IconIndex: Integer = 0): Boolean;
|
|
function SystemUserName : string;
|
|
function HTTPEncode(const str : String) : string;
|
|
function StripHTML(S: string): string;
|
|
function ValidateFileName(old : string) : string;
|
|
function ValidateFileDir(old : string) : string;
|
|
function ValidateDate(D : string) : string;
|
|
function GetTempPath : string;
|
|
function GetConfigDir(app : string) : string;
|
|
function GetGlobalConfigDir(app : string) : string;
|
|
function SizeToText(size : Longint) : string;
|
|
function GetMainIconHandle : Cardinal;
|
|
function CanWriteToProgramDir : Boolean;
|
|
function OpenBrowser(Site : string) : Boolean;
|
|
function HexToBin(h: STRING): dword;
|
|
procedure LoadLanguage(lang : string);
|
|
function RoundTo(const AValue : extended ; const ADigit : TRoundToRange) : extended ;
|
|
function TimeTotext(Seconds : Integer) : string;
|
|
procedure ExecProcess(CommandLine : string;CurDir : string = '';Waitfor : Boolean = True);
|
|
procedure ExecVisualProcess(CommandLine : string;CurDir : string = '';Waitfor : Boolean = True);
|
|
function ExecProcessEx(CommandLine : string;CurDir : string = '') : string;
|
|
function GetProcessforExtension(InfoTyp : TProcessinfoTyp;Extension : string) : string;
|
|
function GetMimeTypeforExtension(Extension : string) : string;
|
|
function GetSystemLang : string;
|
|
|
|
IMPLEMENTATION
|
|
|
|
function ExecProcessEx(CommandLine : string;CurDir : string = '') : string;
|
|
const
|
|
READ_BYTES = 2048;
|
|
var
|
|
process : TProcess;
|
|
ms: tmemorystream;
|
|
bytesread: integer;
|
|
n: longint;
|
|
tmps: tstringlist;
|
|
err : string;
|
|
begin
|
|
BytesRead := 0;
|
|
Process := TProcess.Create(nil);
|
|
Process.Options := [poUsePipes];
|
|
Process.ShowWindow := swoHide;
|
|
Process.CommandLine := CommandLine;
|
|
if CurDir <> '' then
|
|
Process.CurrentDirectory := CurDir;
|
|
BytesRead := 0;
|
|
MS := TmemoryStream.create;
|
|
try
|
|
Process.Execute;
|
|
while Process.Running do
|
|
begin
|
|
MS.SetSize(BytesRead+READ_BYTES);
|
|
n := Process.OutPut.Read((MS.Memory+BytesRead)^,READ_BYTES);
|
|
if n > 0 then
|
|
inc(BytesRead,n)
|
|
else
|
|
sleep(50);
|
|
end;
|
|
except
|
|
on e : exception do
|
|
err := err+#13+e.Message;
|
|
end;
|
|
MS.SetSize(BytesRead+READ_BYTES);
|
|
n := Process.OutPut.Read((MS.Memory+BytesRead)^,READ_BYTES);
|
|
if n > 0 then
|
|
inc(Bytesread,n);
|
|
MS.SetSize(BytesRead);
|
|
Process.Free;
|
|
tmps := TStringList.Create;
|
|
tmps.LoadFromStream(MS);
|
|
Result := tmps.Text;
|
|
tmps.Free;
|
|
MS.Free;
|
|
if err <> '' then
|
|
Result := 'errors:'+err+#13+Result;
|
|
end;
|
|
|
|
procedure ExecProcess(CommandLine : string;CurDir : string = '';Waitfor : Boolean = True);
|
|
var
|
|
{$IFDEF WINDOWS}
|
|
SUInfo: TStartupInfo;
|
|
ProcInfo: TProcessInformation;
|
|
CmdLine: string;
|
|
Res: Boolean;
|
|
{$ELSE}
|
|
process : TProcess;
|
|
{$ENDIF}
|
|
begin
|
|
{$IFDEF WINDOWS}
|
|
FillChar(SUInfo, SizeOf(SUInfo), #0);
|
|
with SUInfo do begin
|
|
cb := SizeOf(SUInfo);
|
|
dwFlags := STARTF_USESHOWWINDOW;
|
|
wShowWindow := SW_HIDE
|
|
end;
|
|
Res := CreateProcess(NIL, PChar(CommandLine), NIL, NIL, FALSE,
|
|
CREATE_NEW_CONSOLE or
|
|
NORMAL_PRIORITY_CLASS, NIL,
|
|
PChar(CurDir),
|
|
SUInfo, ProcInfo);
|
|
{ Wait for it to finish. }
|
|
if Res and Waitfor then
|
|
WaitForSingleObject(ProcInfo.hProcess, INFINITE);
|
|
{$ELSE}
|
|
Process := TProcess.Create(nil);
|
|
if CurDir <> '' then
|
|
Process.CurrentDirectory := CurDir;
|
|
Process.CommandLine := CommandLine;
|
|
if Waitfor then
|
|
Process.Options := [poNewConsole{poNoConsole},poWaitOnExit]
|
|
else
|
|
Process.Options := [poNewConsole{poNoConsole}];
|
|
// Process.ShowWindow := swoHide;
|
|
Process.Execute;
|
|
if Waitfor then Process.Free;
|
|
{$ENDIF}
|
|
end;
|
|
|
|
procedure ExecVisualProcess(CommandLine : string;CurDir : string = '';Waitfor : Boolean = True);
|
|
var
|
|
process : TProcess;
|
|
begin
|
|
Process := TProcess.Create(nil);
|
|
if CurDir <> '' then
|
|
Process.CurrentDirectory := CurDir;
|
|
Process.CommandLine := CommandLine;
|
|
if Waitfor then
|
|
Process.Options := [poWaitOnExit]
|
|
else
|
|
Process.Options := [];
|
|
Process.Execute;
|
|
if Waitfor then Process.Free;
|
|
end;
|
|
|
|
function TimeTotext(Seconds : Integer) : string;
|
|
var
|
|
tmp : Integer;
|
|
begin
|
|
if Seconds > 60*60 then
|
|
begin
|
|
Result := IntToStr(Trunc(Seconds/(60*60))) +' h';
|
|
tmp := Seconds mod (60*60);
|
|
Result := Result +' '+IntToStr(Trunc(tmp/(60))) +' m';
|
|
tmp := Seconds mod 60;
|
|
Result := Result +' '+IntToStr(tmp) +' s';
|
|
end
|
|
else if Seconds > 60 then
|
|
begin
|
|
Result := IntToStr(Trunc(Seconds/(60))) +' m';
|
|
tmp := Seconds mod 60;
|
|
Result := Result +' '+IntToStr(tmp) +' s';
|
|
end
|
|
else
|
|
begin
|
|
Result := IntToStr(Seconds)+' s';
|
|
end
|
|
end;
|
|
|
|
function RoundTo(const AValue : extended ; const ADigit : TRoundToRange) : extended ;
|
|
var X : extended ; i : integer ;
|
|
begin
|
|
X := 1.0 ;
|
|
for i := 1 to Abs(ADigit) do X := X * 10 ;
|
|
if ADigit<0 then
|
|
Result := Round(AValue * X) / X
|
|
else
|
|
Result := Round(AValue / X) * X;
|
|
end;
|
|
|
|
function HexToBin(h: STRING): dword;
|
|
FUNCTION HexDigitToInt(c: Char): Integer;
|
|
BEGIN
|
|
IF (c >= '0') AND (c <= '9') THEN Result := Ord(c) - Ord('0')
|
|
ELSE IF (c >= 'A') AND (c <= 'F') THEN Result := Ord(c) - Ord('A') + 10
|
|
ELSE IF (c >= 'a') AND (c <= 'f') THEN Result := Ord(c) - Ord('a') + 10
|
|
ELSE Result := -1;
|
|
END;
|
|
VAR
|
|
buf: ARRAY[0..16] OF Byte;
|
|
digit1: Integer;
|
|
bytes: Integer;
|
|
index: Integer;
|
|
BEGIN
|
|
bytes := 0;
|
|
index := 0;
|
|
result := 0;
|
|
IF frac(length(h) / 2) = 0.5 THEN
|
|
h := '0' + h;
|
|
WHILE (bytes < 16) DO
|
|
BEGIN
|
|
if length(h) > index+1 then
|
|
digit1 := HexDigitToInt(h[index + 1])
|
|
else
|
|
digit1 := -1;
|
|
IF digit1 < 0 THEN
|
|
break;
|
|
buf[bytes] := (digit1 SHL 4) OR HexDigitToInt(h[index + 2]);
|
|
Inc(index, 2);
|
|
Inc(bytes);
|
|
END;
|
|
dec(bytes);
|
|
FOR index := bytes DOWNTO 0 DO
|
|
Result := Result + (buf[index] shl ((bytes-index)*8));
|
|
END;
|
|
|
|
procedure LoadLanguage(lang: string);
|
|
begin
|
|
if FileExists(ProgramDirectory+'languages'+Directoryseparator+Lang+'.po') then
|
|
TranslateUnitResourceStrings('uintfstrconsts',ProgramDirectory+'languages'+Directoryseparator+Lang+'.po');
|
|
// TranslateResourcestrings(ProgramDirectory+'languages'+Directoryseparator+Lang+'.mo');
|
|
end;
|
|
|
|
function GetProcessforExtension(InfoTyp : TProcessinfoTyp;Extension : string) : string;
|
|
{$ifdef MSWINDOWS}
|
|
var
|
|
reg : TRegistry;
|
|
ot : string;
|
|
FileClass: string;
|
|
chrResult: array[0..1023] of Char;
|
|
wrdReturn: DWORD;
|
|
{$endif}
|
|
begin
|
|
{$ifdef WINDOWS}
|
|
case InfoTyp of
|
|
piOpen:ot := 'open';
|
|
piPrint:ot := 'print';
|
|
end;
|
|
Result := '';
|
|
Reg := TRegistry.Create(KEY_READ);
|
|
Reg.RootKey := HKEY_CLASSES_ROOT;
|
|
FileClass := '';
|
|
if Reg.OpenKeyReadOnly(ExtractFileExt('.'+Extension)) then
|
|
begin
|
|
FileClass := Reg.ReadString('');
|
|
Reg.CloseKey;
|
|
end;
|
|
if FileClass <> '' then begin
|
|
if Reg.OpenKeyReadOnly(FileClass + '\Shell\'+ot+'\Command') then
|
|
begin
|
|
wrdReturn := ExpandEnvironmentStrings(PChar(StringReplace(Reg.ReadString(''),'%1','%s',[rfReplaceAll])), chrResult, 1024);
|
|
if wrdReturn = 0 then
|
|
Result := StringReplace(Reg.ReadString(''),'%1','%s',[rfReplaceAll])
|
|
else
|
|
Result := Trim(chrResult);
|
|
Reg.CloseKey;
|
|
end;
|
|
end;
|
|
Reg.Free;
|
|
{$ELSE}
|
|
{$endif}
|
|
end;
|
|
|
|
function GetMimeTypeforExtension(Extension : string) : string;
|
|
{$ifdef MSWINDOWS}
|
|
var
|
|
reg : TRegistry;
|
|
{$endif}
|
|
begin
|
|
{$ifdef WINDOWS}
|
|
Result := '';
|
|
Reg := TRegistry.Create(KEY_READ);
|
|
Reg.RootKey := HKEY_CLASSES_ROOT;
|
|
if Reg.OpenKeyReadOnly(ExtractFileExt('.'+Extension)) then
|
|
begin
|
|
Result := Reg.ReadString('Content Type');
|
|
Reg.CloseKey;
|
|
end;
|
|
Reg.Free;
|
|
{$ELSE}
|
|
{$endif}
|
|
end;
|
|
|
|
function GetSystemLang: string;
|
|
{$IFDEF WINDOWS}
|
|
var
|
|
Ident: Integer;
|
|
MyLang: PChar;
|
|
const
|
|
Size: Integer = 250;
|
|
{$ENDIF}
|
|
begin
|
|
{$IFDEF WINDOWS}
|
|
GetMem(MyLang, Size);
|
|
Ident:=GetSystemDefaultLangID;
|
|
VerLanguageName(Ident, MyLang, Size);
|
|
Result:=StrPas(MyLang);
|
|
FreeMem(MyLang);
|
|
{$ELSE}
|
|
Result := GetEnvironmentVariable('LANG');
|
|
{$ENDIF}
|
|
end;
|
|
|
|
function OpenBrowser(Site : string) : Boolean;
|
|
var
|
|
cmd : string;
|
|
proc : TProcess;
|
|
begin
|
|
cmd := GetProcessforExtension(piOpen,'html');
|
|
{$ifndef WINDOWS}
|
|
cmd := ExecProcessEx('gconftool-2 --get /desktop/gnome/url-handlers/http/command');
|
|
if (cmd = '') or (pos('errors',cmd) > 0) then
|
|
cmd := GetEnvironmentVariable('BROWSER');
|
|
if (cmd = '') then
|
|
cmd := 'kfmclient openURL %s';
|
|
{$ENDIF}
|
|
if cmd = '' then exit;
|
|
proc := TProcess.Create(nil);
|
|
proc.CommandLine := StringReplace(cmd,'%s',Site,[rfReplaceAll]);
|
|
proc.Options := [poNewConsole];
|
|
proc.Execute;
|
|
while Proc.Running do
|
|
Application.ProcessMessages;
|
|
proc.free;
|
|
end;
|
|
|
|
|
|
function CanWriteToProgramDir : Boolean;
|
|
var
|
|
f : TextFile;
|
|
begin
|
|
AssignFile(f,ExtractFilePath(Application.Exename)+'writetest.tmp');
|
|
try
|
|
Rewrite(f);
|
|
except
|
|
Result := False;
|
|
exit;
|
|
end;
|
|
CloseFile(f);
|
|
SysUtils.DeleteFile(ExtractFilePath(Application.Exename)+'writetest.tmp');
|
|
Result := True;
|
|
end;
|
|
|
|
function SizeToText(size : Longint) : string;
|
|
begin
|
|
if size > 1024*1024*1024 then
|
|
Result := FormatFloat('0.00',size/(1024*1024*1024))+' Gb'
|
|
else if size > 1024*1024 then
|
|
Result := FormatFloat('0.00',size/(1024*1024))+' Mb'
|
|
else if size > 1024 then
|
|
Result := FormatFloat('0.00',size/(1024))+' Kb'
|
|
else
|
|
Result := IntToStr(size)+' byte'
|
|
end;
|
|
|
|
function GetMainIconHandle : Cardinal;
|
|
begin
|
|
{$ifdef MSWINDOWS}
|
|
Result := LoadIcon(hInstance, 'MAINICON');
|
|
{$else}
|
|
Result := 0;
|
|
{$endif}
|
|
end;
|
|
|
|
function GetConfigDir(app : string) : string;
|
|
begin
|
|
{$IFDEF MSWINDOWS}
|
|
Result := copy(GetAppConfigDir(False),0,length(GetAppConfigDir(False))-length(ApplicationName))+app;
|
|
{$ELSE}
|
|
Result:=GetEnvironmentVariable('HOME');
|
|
If (Result<>'') then
|
|
Result:=IncludeTrailingPathDelimiter(Result)+'.'+app;
|
|
{$ENDIF}
|
|
Result := IncludeTrailingPathDelimiter(result);
|
|
end;
|
|
|
|
function GetGlobalConfigDir(app : string) : string;
|
|
{$IFDEF MSWINDOWS}
|
|
const
|
|
CSIDL_COMMON_APPDATA = $0023; // All Users\Application Data
|
|
CSIDL_FLAG_CREATE = $8000; { (force creation of requested folder if it doesn't exist yet) }
|
|
var
|
|
Path: array [0..1024] of char;
|
|
P : Pointer;
|
|
SHGetFolderPath : PFNSHGetFolderPath = Nil;
|
|
CFGDLLHandle : THandle = 0;
|
|
{$ENDIF}
|
|
begin
|
|
{$IFDEF MSWINDOWS}
|
|
CFGDLLHandle:=LoadLibrary('shell32.dll');
|
|
if (CFGDLLHandle<>0) then
|
|
begin
|
|
P:=GetProcAddress(CFGDLLHandle,'SHGetFolderPathA');
|
|
If (P=Nil) then
|
|
begin
|
|
FreeLibrary(CFGDLLHandle);
|
|
CFGDllHandle:=0;
|
|
end
|
|
else
|
|
SHGetFolderPath:=PFNSHGetFolderPath(P);
|
|
end;
|
|
If (P=Nil) then
|
|
begin
|
|
CFGDLLHandle:=LoadLibrary('shfolder.dll');
|
|
if (CFGDLLHandle<>0) then
|
|
begin
|
|
P:=GetProcAddress(CFGDLLHandle,'SHGetFolderPathA');
|
|
If (P=Nil) then
|
|
begin
|
|
FreeLibrary(CFGDLLHandle);
|
|
CFGDllHandle:=0;
|
|
end
|
|
else
|
|
ShGetFolderPath:=PFNSHGetFolderPath(P);
|
|
end;
|
|
end;
|
|
Result := ExtractFilePath(Application.Exename);
|
|
If (@ShGetFolderPath<>Nil) then
|
|
if SHGetFolderPath(0,CSIDL_COMMON_APPDATA or CSIDL_FLAG_CREATE,0,0,@PATH[0])=S_OK then
|
|
Result:=IncludeTrailingPathDelimiter(StrPas(@Path[0]))+app;
|
|
{$ELSE}
|
|
{$ENDIF}
|
|
Result := IncludeTrailingPathDelimiter(result);
|
|
end;
|
|
|
|
function GetTempPath : string;
|
|
{$IFDEF MSWINDOWS}
|
|
var
|
|
TD : PChar;
|
|
{$ENDIF}
|
|
begin
|
|
{$IFDEF MSWINDOWS}
|
|
GetMem(TD, 256);
|
|
try
|
|
FillChar(TD^, 256, 0);
|
|
Windows.GetTempPath(256, TD);
|
|
Result := TD;
|
|
finally
|
|
FreeMem(TD, 256);
|
|
end;
|
|
{$ELSE}
|
|
Result := '/temp';
|
|
{$ENDIF}
|
|
end;
|
|
|
|
function ValidateFileDir(old: string): string;
|
|
begin
|
|
Result := old;
|
|
if DirectorySeparator <> '/' then
|
|
Result := StringReplace(Result,'/','',[rfReplaceAll]);
|
|
Result := StringReplace(Result,'@','',[rfReplaceAll]);
|
|
Result := StringReplace(Result,';','',[rfReplaceAll]);
|
|
end;
|
|
|
|
function ValidateDate(D : string) : string;
|
|
begin
|
|
if pos('.',D) > 0 then
|
|
Result := StringReplace(D,'-','.',[rfReplaceAll]);
|
|
if length(D) = 4 then
|
|
Result := '01.01.'+D;
|
|
end;
|
|
|
|
function ValidateFileName(old : string) : string;
|
|
begin
|
|
Result := StringReplace(old,'\','',[rfReplaceAll]);
|
|
Result := StringReplace(Result,'/','',[rfReplaceAll]);
|
|
Result := StringReplace(Result,'@','',[rfReplaceAll]);
|
|
Result := StringReplace(Result,';','',[rfReplaceAll]);
|
|
end;
|
|
|
|
function StripHTML(S: string): string;
|
|
var
|
|
TagBegin, TagEnd, TagLength: integer;
|
|
begin
|
|
TagBegin := Pos( '<', S); // search position of first <
|
|
|
|
while (TagBegin > 0) do begin // while there is a < in S
|
|
TagEnd := Pos('>', S); // find the matching >
|
|
TagLength := TagEnd - TagBegin + 1;
|
|
Delete(S, TagBegin, TagLength); // delete the tag
|
|
TagBegin:= Pos( '<', S); // search for next <
|
|
end;
|
|
|
|
S := Stringreplace(S,' ',' ',[rfReplaceAll]);
|
|
S := Stringreplace(S,'&','&',[rfReplaceAll]);
|
|
S := Stringreplace(S,'<','<',[rfReplaceAll]);
|
|
S := Stringreplace(S,'>','>',[rfReplaceAll]);
|
|
S := Stringreplace(S,'"','"',[rfReplaceAll]);
|
|
Result := S; // give the result
|
|
end;
|
|
|
|
function HTTPEncode(const str : String) : string;
|
|
const
|
|
noconvert = ['A'..'Z','a'..'z','*','@','.','_','-','0'..'9','$','!','''','(',')'];
|
|
hex2str : array[0..15] of char = '0123456789ABCDEF';
|
|
var
|
|
i : integer;
|
|
c : char;
|
|
begin
|
|
Result := '';
|
|
for i:=1 to length(str) do
|
|
begin
|
|
c:=str[i];
|
|
if c in noconvert then
|
|
Result:=Result+c
|
|
else
|
|
Result:=Result+'%'+hex2str[ord(c) shr 4]+hex2str[ord(c) and $f];
|
|
end;
|
|
end;
|
|
|
|
{$IFDEF MSWINDOWS}
|
|
function SystemUserName : string;
|
|
var userNameBuffer : string[255];
|
|
sizeBuffer : DWord;
|
|
begin
|
|
SizeBuffer := 256;
|
|
getUserName(@userNameBuffer+1, sizeBuffer);
|
|
result := userNameBuffer;
|
|
end;
|
|
{$ELSIF LINUX}
|
|
{$IFNDEF WINDOWS}
|
|
function SystemUserName : string;
|
|
begin
|
|
Result := GetEnvironmentVariable('USERNAME');
|
|
if Result = '' then
|
|
Result := GetEnvironmentVariable('USER');
|
|
end;
|
|
{$ENDIF}
|
|
{$ELSE}
|
|
function SystemUserName : string;
|
|
begin
|
|
end;
|
|
{$ENDIF}
|
|
|
|
function InstallExt(Extension, ExtDescription, FileDescription,OpenWith, ParamString: string; IconIndex: Integer = 0): Boolean;
|
|
{$IFDEF MSWINDOWS}
|
|
var
|
|
Reg: TRegistry;
|
|
{$ENDIF}
|
|
begin
|
|
Result := False;
|
|
if Extension <> '' then
|
|
begin
|
|
{$IFDEF MSWINDOWS}
|
|
if Extension[1] <> '.' then
|
|
Extension := '.' + Extension;
|
|
Reg := TRegistry.Create;
|
|
try
|
|
Reg.RootKey := HKEY_CLASSES_ROOT;
|
|
if Reg.OpenKey(Extension, True) then
|
|
begin
|
|
Reg.WriteString('', ExtDescription);
|
|
if Reg.OpenKey('\' + ExtDescription, True) then
|
|
begin
|
|
Reg.WriteString('', FileDescription);
|
|
if Reg.OpenKey('DefaultIcon', True) then
|
|
begin
|
|
Reg.WriteString('', Format('%s,%d', [OpenWith, IconIndex]));
|
|
if Reg.OpenKey('\' + ExtDescription + '\Shell\Open\Command', True) then
|
|
begin
|
|
Reg.WriteString('', Format('"%s" "%s"', [OpenWith, ParamString]));
|
|
Result:=True;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
finally
|
|
Reg.Free;
|
|
end;
|
|
{$ENDIF}
|
|
end;
|
|
end;
|
|
|
|
procedure DrawText(Canvas : TCanvas;Rect : TRect;Str : string;CenterV : Boolean = False;CenterH : Boolean = False);
|
|
var
|
|
TextPosY,
|
|
TextPosX: Integer;
|
|
begin
|
|
TextPosX := Rect.Left;
|
|
if CenterH then
|
|
TextPosX := TextPosX+((Rect.Right-Rect.Left-Canvas.TextWidth(Str)) div 2);
|
|
TextPosY := Rect.Top;
|
|
if CenterV then
|
|
TextPosY := TextPosY+((Rect.Bottom-Rect.Top)-Canvas.TextHeight(Str)) div 2;
|
|
Canvas.TextOut(TextPosX,TextPosY,Str);
|
|
end;
|
|
|
|
FUNCTION StrTimeToValue(val : string) : LongInt;
|
|
var
|
|
i : Integer;
|
|
un : string;
|
|
begin
|
|
//TODO:replace ',' with system delemiter
|
|
un := '';
|
|
FOR i := 1 TO length(val) DO
|
|
IF NOT ((Char(Val[i]) IN ['0'..'9']) or (Char(Val[i]) = DecimalSeparator)) THEN
|
|
begin
|
|
un := trim(copy(Val,i,length(Val)));
|
|
break;
|
|
end;
|
|
if copy(Val,0,i-1) = '' then
|
|
begin
|
|
Result := -1;
|
|
exit;
|
|
end;
|
|
if (UpperCase(un) = 'MS') or (un = '') then
|
|
Result := Round(StrToFloat(copy(Val,0,i-1)))
|
|
else if UpperCase(un) = 'S' then
|
|
Result := Round(1000*StrToFloat(copy(Val,0,i-1)))
|
|
else if UpperCase(un) = 'M' then
|
|
Result := Round(60*1000*StrToFloat(copy(Val,0,i-1)))
|
|
else
|
|
Result := -1;
|
|
end;
|
|
|
|
FUNCTION IsNumeric(s: STRING): boolean;
|
|
VAR
|
|
i : integer;
|
|
hassign: boolean;
|
|
BEGIN
|
|
// TODO:Replace ',' with Systemdelemiter
|
|
// ge�ndert von schnullerbacke
|
|
// DecimalSeparator auf . gesetzt falls ,
|
|
// doppeltes Vorkommen von sign verhindert
|
|
if DecimalSeparator = ',' then begin
|
|
// replace DecimalSeparator wenn n�tig
|
|
i:= Pos(',', s);
|
|
s[i]:= '.';
|
|
end;
|
|
Result:= (Pos('.', s) > 0) and (length(s) > 0);
|
|
if Result then begin
|
|
// l�sche DecimalSeparator
|
|
Delete(s, i, 1);
|
|
hassign:= (Pos('-', s) > 0) or (Pos('+',s) > 0);
|
|
if hassign then begin
|
|
// l�sche Vorkommen eines signs
|
|
i:= Pos('-', s);
|
|
if i = 0 then i:= Pos('+', s);
|
|
if i > 0 then Delete(s, i, 1);
|
|
end;
|
|
i:= 1;
|
|
while (i <= length(s)) and Result do begin
|
|
// nur noch Test auf Digit n�tig
|
|
Result:= (Char(s[i]) IN ['0'..'9']);
|
|
IF Result then inc(i);
|
|
END; // of while (i <= length(s)) and Result do begin
|
|
end; // of if Result then begin
|
|
END;
|
|
|
|
function RPos(const Substr: string; const S: string): Integer;
|
|
var
|
|
SL, i : Integer;
|
|
begin
|
|
SL := Length(Substr);
|
|
i := Length(S);
|
|
if (Substr = '') or (S = '') or (SL > i) then begin
|
|
Result := 0;
|
|
Exit;
|
|
end;
|
|
|
|
while i >= SL do begin
|
|
if S[i] = Substr[SL] then begin
|
|
if Copy(S, i - SL + 1, SL) = Substr then begin
|
|
Result := i - SL + 1;
|
|
Exit;
|
|
end;
|
|
end;
|
|
Dec(i);
|
|
end;
|
|
Result := i;
|
|
end;
|
|
|
|
{ Make sure given file path is ended with backslash ("\") }
|
|
{ Clears Directory: Removes all files and directories contained }
|
|
function ClearDir (Path: string): boolean;
|
|
var
|
|
Res: integer;
|
|
SRec: SysUtils.TSearchRec;
|
|
begin
|
|
Result := false;
|
|
try
|
|
if copy(path,length(path)-1,1) <> DirectorySeparator then
|
|
Path := Path+DirectorySeparator;
|
|
Res := FindFirst (Path + '*.*', faAnyFile, SRec);
|
|
while Res = 0 do
|
|
begin
|
|
if (SRec.Attr = faDirectory) and (SRec.Name[1] <> '.') then
|
|
begin
|
|
ClearDir (Path + SRec.Name); { Clear before removing }
|
|
if not RemoveDir (pchar(Path + SRec.Name)) then
|
|
exit;
|
|
end
|
|
else
|
|
SysUtils.DeleteFile(Path + SRec.Name);
|
|
Res := FindNext(SRec);
|
|
end;
|
|
SysUtils.FindClose(SRec);
|
|
Result := true;
|
|
except
|
|
end;
|
|
end;
|
|
|
|
|
|
END.
|
|
|
|
|