You've already forked lazarus-ccr
initial checkin
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
This commit is contained in:
christian_u
724
applications/wikihelp/src/Utils.pas
Normal file
724
applications/wikihelp/src/Utils.pas
Normal file
@ -0,0 +1,724 @@
|
||||
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.
|
||||
|
||||
|
||||
Reference in New Issue
Block a user