{*******************************************************}
{ }
{ xTool - Component Collection }
{ }
{ Copyright (c) 1995 Stefan Böther }
{ stefc@fabula.com }
{*******************************************************}
{
Please look also for our xTools-Nails function toolkit.
More information you'll find under
http://ourworld.compuserve.com/homepages/stefc/xprocs.htm
Any comments and enhancements are welcome, if the're
sended to stefc@fabula.com.
21.02.96 added TMonth & TDay type Stefc
22.02.96 added strFileLoad & strFileSave Stefc
09.03.96 correct sysTempPath Stefc
09.03.96 added regXXXXX functions for access the registry Stefc
24.03.96 added IsWinNT constant Stefc
24.03.96 added SysMetric object Stefc
26.03.96 added dateQuicken for controling date input with keys Stefc
27.03.96 added TDesktopCanvas here Stefc
28.03.96 added LoadDIBitmap Stefc
01.04.96 added Question function here Stefc
09.04.96 added sysSaverRunning added Stefc
12.04.96 added timeZoneOffset Stefc
12.04.96 added timeToInt Stefc
17.04.96 added strCmdLine Stefc
17.04.96 added rectBounds Stefc
17.04.96 added TPersistentRect class Stefc
19.04.96 added strDebug method Stefc
21.04.96 changed TMonth added noneMonth km
21.04.96 added licence callback Stefc
21.04.96 added strNiceDateDefault km
21.04.96 added simple strEncrpyt & strDecrypt Stefc
24.04.96 backport to 16 bit Stefc
24.04.96 added Information method Stefc
24.04.96 use win messageBox with Win95 in Question & Information Stefc
09.05.96 new function ExtractName Stefc
10.05.96 Added TPersistentRegistry Stefc
12.05.96 fileExec Stefc
14.05.96 New function Confirmation Stefc
16.05.96 New function strChange Stefc
29.05.96 New functions comXXXXX Stefc
09.06.96 New function strSearchReplace km
09.06.96 ported assembler strHash to plain pascal Stefc
15.06.96 new variables xLanguage & xLangOfs Stefc
28.06.96 new method sysBeep Stefc
28.06.96 new method intPercent Stefc
10.07.96 make compatible with 16 Bit Delphi 1.0 Stefc
14.07.96 fileLongName & fileShortName defined Stefc
15.07.96 Correct sysTempPath method Stefc
21.07.96 New functions strContains & strContainsU Stefc
28.07.96 comIsCServe also check for xxx@compuServe.com Stefc
31.07.96 added strCapitalize after idea from Fred N. Read Stefc
04.08.96 strByteSize() now can also display Bytes Stefc
05.08.96 added regWriteShellExt() Stefc
06.08.96 added sysColorDepth() Stefc
07.08.96 added strSoundex() Stefc
}
unit xProcs;
interface
uses
{$IFDEF Win32} Windows, Registry, ShellAPI, {$ELSE} WinTypes, WinProcs, {$ENDIF}
Messages, Classes, Graphics;
type
Float = Extended; { our type for float arithmetic }
{$IFDEF Win32} { our type for integer functions, Int_ is ever 32 bit }
Int_ = Integer;
{$ELSE}
Int_ = Longint;
{$ENDIF}
const
XCOMPANY = 'Fabula Software';
const
{ several important ASCII codes }
NULL = #0;
BACKSPACE = #8;
TAB = #9;
LF = #10;
CR = #13;
EOF_ = #26; { 30.07.96 sb }
ESC = #27;
BLANK = #32;
SPACE = BLANK;
{ digits as chars }
ZERO = '0'; ONE = '1'; TWO = '2'; THREE = '3'; FOUR = '4';
FIVE = '5'; SIX = '6'; SEVEN = '7'; EIGHT = '8'; NINE = '9';
{ special codes }
SLASH = '\'; { used in filenames }
HEX_PREFIX = '$'; { prefix for hexnumbers }
CRLF : PChar = CR+LF;
{ common computer sizes }
KBYTE = Sizeof(Byte) shl 10;
MBYTE = KBYTE shl 10;
GBYTE = MBYTE shl 10;
{ Low floating point value }
FLTZERO : Float = 0.00000001;
DIGITS : set of Char = [ZERO..NINE];
{ important registry keys / items }
REG_CURRENT_VERSION = 'Software\Microsoft\Windows\CurrentVersion';
REG_CURRENT_USER = 'RegisteredOwner';
REG_CURRENT_COMPANY = 'RegisteredOrganization';
PRIME_16 = 65521;
PRIME_32 = 2147483647;
MINSHORTINT = -128; { 1.8.96 sb }
MAXSHORTINT = 127;
MINBYTE = 0;
MAXBYTE = 255;
MINWORD = 0;
MAXWORD = 65535;
type
TMonth = (NoneMonth,January,February,March,April,May,June,July,
August,September,October,November,December);
TDayOfWeek = (Sunday,Monday,Tuesday,Wednesday,Thursday,Friday,Saturday);
{ Online eMail Service Provider }
TMailProvider = (mpCServe, mpInternet, mpNone);
TLicCallback = function ( var Code: Integer): Integer;
TBit = 0..31;
{ Search and Replace options }
TSROption = (srWord,srCase,srAll);
TSROptions = set of TsrOption;
var
IsWin95,
IsWinNT : Boolean;
IsFabula : TLicCallBack;
xLanguage : Integer;
xLangOfs : Integer;
{ bit manipulating }
function bitSet(const Value: Int_; const TheBit: TBit): Boolean;
function bitOn(const Value: Int_; const TheBit: TBit): Int_;
function bitOff(const Value: Int_; const TheBit: TBit): Int_;
function bitToggle(const Value: Int_; const TheBit: TBit): Int_;
{ String functions }
function strHash(const S: String; LastBucket: Integer): Integer;
function strCut(const S: String; Len: Integer): String;
function strTrim(const S: String): String;
function strTrimA(const S: String): String;
function strTrimChA(const S: String; C: Char): String;
function strTrimChL(const S: String; C: Char): String;
function strTrimChR(const S: String; C: Char): String;
function strLeft(const S: String; Len: Integer): String;
function strLower(const S: String): String;
function strMake(C: Char; Len: Integer): String;
function strPadChL(const S: String; C: Char; Len: Integer): String;
function strPadChR(const S: String; C: Char; Len: Integer): String;
function strPadChC(const S: String; C: Char; Len: Integer): String;
function strPadL(const S: String; Len: Integer): String;
function strPadR(const S: String; Len: Integer): String;
function strPadC(const S: String; Len: Integer): String;
function strPadZeroL(const S: String; Len: Integer): String;
procedure strChange(var S:String; const Source, Dest: String);
function strRight(const S: String; Len: Integer): String;
function strAddSlash(const S: String): String;
function strDelSlash(const S: String): String;
function strSpace(Len: Integer): String;
function strToken(var S: String; Seperator: Char): String;
function strTokenCount(S: String; Seperator: Char): Integer;
function strTokenAt(const S:String; Seperator: Char; At: Integer): String;
function strUpper(const S: String): String;
function strOemAnsi(const S:String): String;
function strAnsiOem(const S:String): String;
function strEqual(const S1,S2: String): Boolean;
function strComp(const S1,S2: String): Boolean;
function strCompU(const S1,S2: String): Boolean;
function strContains(const S1,S2: String): Boolean;
function strContainsU(const S1,S2: String): Boolean;
function strNiceNum(const S: String): String;
function strNiceDateDefault(const S, Default: String): String;
function strNiceDate(const S: String): String;
function strNiceTime(const S: String): String;
function strNicePhone(const S: String): String;
function strReplace(const S: String; C: Char; const Replace: String): String;
function strCmdLine: String;
function strEncrypt(const S: String; Key: Word): String;
function strDecrypt(const S: String; Key: Word): String;
function strLastCh(const S: String): Char;
procedure strStripLast(var S: String);
function strByteSize(Value: Longint): String;
function strSoundex(S: String): String;
procedure strSearchReplace(var S:String; const Source, Dest: String; Options: TSRoptions);
function strProfile(const aFile, aSection, aEntry, aDefault: String): String;
function strCapitalize(const S: String): String; { 31.07.96 sb }
{$IFDEF Win32}
procedure strDebug(const S: String);
function strFileLoad(const aFile: String): String;
procedure strFileSave(const aFile,aString: String);
{$ENDIF}
{ Integer functions }
function intCenter(a,b: Int_): Int_;
function intMax(a,b: Int_): Int_;
function intMin(a,b: Int_): Int_;
function intPow(Base,Expo: Integer): Int_;
function intPow10(Exponent: Integer): Int_;
function intSign(a: Int_): Integer;
function intZero(a: Int_; Len: Integer): String;
function intPrime(Value: Integer): Boolean;
function intPercent(a, b: Int_): Int_;
{ Floatingpoint functions }
function fltAdd(P1,P2: Float; Decimals: Integer): Float;
function fltDiv(P1,P2: Float; Decimals: Integer): Float;
function fltEqual(P1,P2: Float; Decimals: Integer): Boolean;
function fltEqualZero(P: Float): Boolean;
function fltGreaterZero(P: Float): Boolean;
function fltLessZero(P: Float): Boolean;
function fltNeg(P: Float; Negate: Boolean): Float;
function fltMul(P1,P2: Float; Decimals: Integer): Float;
function fltRound(P: Float; Decimals: Integer): Float;
function fltSub(P1,P2: Float; Decimals: Integer): Float;
function fltUnEqualZero(P: Float): Boolean;
function fltCalc(const Expr: String): Float;
function fltPower(a,n: Float): Float;
{ Rectangle functions from Golden Software }
function rectHeight(const R: TRect): Integer;
function rectWidth(const R: TRect): Integer;
procedure rectGrow(var R: TRect; Delta: Integer);
procedure rectRelativeMove(var R: TRect; DX, DY: Integer);
procedure rectMoveTo(var R: TRect; X, Y: Integer);
function rectSet(Left, Top, Right, Bottom: Integer): TRect;
function rectInclude(const R1, R2: TRect): Boolean;
function rectPoint(const R: TRect; P: TPoint): Boolean;
function rectSetPoint(const TopLeft, BottomRight: TPoint): TRect;
function rectIntersection(const R1, R2: TRect): TRect;
function rectIsIntersection(const R1, R2: TRect): Boolean;
function rectIsValid(const R: TRect): Boolean;
function rectsAreValid(const Arr: array of TRect): Boolean;
function rectNull: TRect;
function rectIsNull(const R: TRect): Boolean;
function rectIsSquare(const R: TRect): Boolean;
function rectCentralPoint(const R: TRect): TPoint;
function rectBounds(aLeft,aTop,aWidth,aHeight: Integer): TRect;
{ date functions }
function dateYear(D: TDateTime): Integer;
function dateMonth(D: TDateTime): Integer;
function dateDay(D: TDateTime): Integer;
function dateBeginOfYear(D: TDateTime): TDateTime;
function dateEndOfYear(D: TDateTime): TDateTime;
function dateBeginOfMonth(D: TDateTime): TDateTime;
function dateEndOfMonth(D: TDateTime): TDateTime;
function dateWeekOfYear(D: TDateTime): Integer;
function dateDayOfYear(D: TDateTime): Integer;
function dateDayOfWeek(D: TDateTime): TDayOfWeek;
function dateLeapYear(D: TDateTime): Boolean;
function dateBeginOfQuarter(D: TDateTime): TDateTime;
function dateEndOfQuarter(D: TDateTime): TDateTime;
function dateBeginOfWeek(D: TDateTime;Weekday: Integer): TDateTime;
function dateDaysInMonth(D: TDateTime): Integer;
function dateQuicken(D: TDateTime; Key: Char): TDateTime;
{ time functions }
function timeHour(T: TDateTime): Integer;
function timeMin(T: TDateTime): Integer;
function timeSec(T: TDateTime): Integer;
function timeToInt(T: TDateTime): Integer;
{$IFDEF Win32}
function timeZoneOffset: Integer;
{$ENDIF}
{ com Functions }
function comIsCis(const S: String): Boolean;
function comIsInt(const S: String): Boolean;
function comCisToInt(const S: String): String;
function comIntToCis(const S: String): String;
function comFaxToCis(const S: String): String;
function comNormFax(const Name,Fax: String): String;
function comNormPhone(const Phone: String): String;
function comNormInt(const Name,Int: String): String;
function comNormCis(const Name,Cis: String): String;
{ file functions }
procedure fileShredder(const Filename: String);
function fileSize(const Filename: String): Longint;
function fileWildcard(const Filename: String): Boolean;
{$IFDEF Win32}
function fileTemp(const aExt: String): String;
function fileExec(const aCmdLine: String; aHide, aWait: Boolean): Boolean;
function fileLongName(const aFile: String): String;
function fileShortName(const aFile: String): String;
function fileShellOpen(const aFile: String): Boolean;
function fileShellPrint(const aFile: String): Boolean;
{$ENDIF}
function ExtractName(const Filename: String): String;
{ system functions }
function sysTempPath:String;
procedure sysDelay(aMs: Longint);
procedure sysBeep;
function sysColorDepth: Integer; { 06.08.96 sb }
{$IFDEF Win32}
procedure sysSaverRunning(Active: Boolean);
{$ENDIF}
{ registry functions }
{$IFDEF Win32}
function regReadString(aKey: hKey; const Path: String): String;
procedure regWriteString(aKey: hKey; const Path,Value: String);
function regInfoString(const Value: String): String;
function regCurrentUser: String;
function regCurrentCompany: String;
procedure regWriteShellExt(const aExt,aCmd,aMenu,aExec: String);
{$ENDIF}
{ several functions }
function Question(const Msg: String):Boolean;
procedure Information(const Msg: String);
function Confirmation(const Msg: String): Word;
type
{ TRect that can be used persistent as property for components }
TUnitConvertEvent = function (Sender: TObject;
Value: Integer; Get: Boolean): Integer of object;
TPersistentRect = class(TPersistent)
private
FRect : TRect;
FOnConvert : TUnitConvertEvent;
procedure SetLeft(Value: Integer);
procedure SetTop(Value: Integer);
procedure SetHeight(Value: Integer);
procedure SetWidth(Value: Integer);
function GetLeft: Integer;
function GetTop: Integer;
function GetHeight: Integer;
function GetWidth: Integer;
public
constructor Create;
procedure Assign(Source: TPersistent); override;
property Rect: TRect read FRect;
property OnConvert: TUnitConvertEvent read FOnConvert write FOnConvert;
published
property Left : Integer read GetLeft write SetLeft;
property Top : Integer read GetTop write SetTop;
property Height: Integer read GetHeight write SetHeight;
property Width : Integer read GetWidth write SetWidth;
end;
{$IFDEF Win32}
{ Persistent access of components from the registry }
TPersistentRegistry = class(TRegistry)
public
function ReadComponent(const Name: String; Owner, Parent: TComponent): TComponent;
procedure WriteComponent(const Name: String; Component: TComponent);
end;
{$ENDIF
{ easy access of the system metrics }
TSystemMetric = class
private
FColorDepth,
FMenuHeight,
FCaptionHeight : Integer;
FBorder,
FFrame,
FDlgFrame,
FBitmap,
FHScroll,
FVScroll,
FThumb,
FFullScreen,
FMin,
FMinTrack,
FCursor,
FIcon,
FDoubleClick,
FIconSpacing : TPoint;
protected
constructor Create;
procedure Update;
public
property MenuHeight: Integer read FMenuHeight;
property CaptionHeight: Integer read FCaptionHeight;
property Border: TPoint read FBorder;
property Frame: TPoint read FFrame;
property DlgFrame: TPoint read FDlgFrame;
property Bitmap: TPoint read FBitmap;
property HScroll: TPoint read FHScroll;
property VScroll: TPoint read FVScroll;
property Thumb: TPoint read FThumb;
property FullScreen: TPoint read FFullScreen;
property Min: TPoint read FMin;
property MinTrack: TPoint read FMinTrack;
property Cursor: TPoint read FCursor;
property Icon: TPoint read FIcon;
property DoubleClick: TPoint read FDoubleClick;
property IconSpacing: TPoint read FIconSpacing;
property ColorDepth: Integer read FColorDepth;
end;
var
SysMetric: TSystemMetric;
type
TDesktopCanvas = class(TCanvas)
private
DC : hDC;
public
constructor Create;
destructor Destroy; override;
end;
implementation
uses
SysUtils, Controls, Forms, Consts, Dialogs;
{ bit manipulating }
function bitSet(const Value: Int_; const TheBit: TBit): Boolean;
begin
Result:= (Value and (1 shl TheBit)) <> 0;
end;
function bitOn(const Value: Int_; const TheBit: TBit): Int_;
begin
Result := Value or (1 shl TheBit);
end;
function bitOff(const Value: Int_; const TheBit: TBit): Int_;
begin
Result := Value and ((1 shl TheBit) xor $FFFFFFFF);
end;
function bitToggle(const Value: Int_; const TheBit: TBit): Int_;
begin
result := Value xor (1 shl TheBit);
end;
{ string methods }
function strHash(const S: String; LastBucket: Integer): Integer;
var
i: Integer;
begin
Result:=0;
for i := 1 to Length(S) do
Result := ((Result shl 3) xor Ord(S[i])) mod LastBucket;
end;
function strTrim(const S: String): String;
begin
Result:=StrTrimChR(StrTrimChL(S,BLANK),BLANK);
end;
function strTrimA(const S: String): String;
begin
Result:=StrTrimChA(S,BLANK);
end;
function strTrimChA(const S: String; C: Char): String;
var
I : Word;
begin
Result:=S;
for I:=Length(Result) downto 1 do
if Result[I]=C then Delete(Result,I,1);
end;
function strTrimChL(const S: String; C: Char): String;
begin
Result:=S;
while (Length(Result)>0) and (Result[1]=C) do Delete(Result,1,1);
end;
function strTrimChR(const S: String; C: Char): String;
begin
Result:=S;
while (Length(Result)> 0) and (Result[Length(Result)]=C) do
Delete(Result,Length(Result),1);
end;
function strLeft(const S: String; Len: Integer): String;
begin
Result:=Copy(S,1,Len);
end;
function strLower(const S: String): String;
begin
Result:=AnsiLowerCase(S);
end;
function strMake(C: Char; Len: Integer): String;
begin
Result:=strPadChL('',C,Len);
end;
function strPadChL(const S: String; C: Char; Len: Integer): String;
begin
Result:=S;
while Length(Result)end;
function strPadChR(const S: String; C: Char; Len: Integer): String;
begin
Result:=S;
while Length(Result)end;
function strPadChC(const S: String; C: Char; Len: Integer): String;
begin
Result:=S;
while Length(Result) begin
Result:=Result+C;
if Length(Result) end;
end;
function strPadL(const S: String; Len: Integer): String;
begin
Result:=strPadChL(S,BLANK,Len);
end;
function strPadC(const S: String; Len: Integer): String;
begin
Result:=strPadChC(S,BLANK,Len);
end;
function strPadR(const S: String; Len: Integer): String;
begin
Result:=strPadChR(S,BLANK,Len);
end;
function strPadZeroL(const S: String; Len: Integer): String;
begin
Result:=strPadChL(strTrim(S),ZERO,Len);
end;
function strCut(const S: String; Len: Integer): String;
begin
Result:=strLeft(strPadR(S,Len),Len);
end;
function strRight(const S: String; Len: Integer): String;
begin
if Len>=Length(S) then
Result:=S
else
Result:=Copy(S,Succ(Length(S))-Len,Len);
end;
function strAddSlash(const S: String): String;
begin
Result:=S;
if strLastCh(Result)<>SLASH then Result:=Result+SLASH;
end;
function strDelSlash(const S: String): String;
begin
Result:=S;
if strLastCh(Result)=SLASH then Delete(Result,Length(Result),1);
end;
function strSpace(Len: Integer): String;
begin
Result:=StrMake(BLANK,Len);
end;
function strToken(var S: String; Seperator: Char): String;
var
I : Word;
begin
I:=Pos(Seperator,S);
if I<>0 then
begin
Result:=System.Copy(S,1,I-1);
System.Delete(S,1,I);
end else
begin
Result:=S;
S:='';
end;
end;
function strTokenCount(S: String; Seperator: Char): Integer;
begin
Result:=0;
while StrToken(S,Seperator)<>'' do Inc(Result);
end;
function strTokenAt(const S:String; Seperator: Char; At: Integer): String;
var
j,i: Integer;
begin
Result:='';
j := 1;
i := 0;
while (i<=At ) and (j<=Length(S)) do
begin
if S[j]=Seperator then
Inc(i)
else if i = At then
Result:=Result+S[j];
Inc(j);
end;
end;
function strUpper(const S: String): String;
begin
Result:=AnsiUpperCase(S);
end;
function strOemAnsi(const S:String):String;
begin
{$IFDEF Win32}
SetLength(Result,Length(S));
{$ELSE}
Result[0]:=Chr(Length(S));
{$ENDIF}
OemToAnsiBuff(@S[1],@Result[1],Length(S));
end;
function strAnsiOem(const S:String): String;
begin
{$IFDEF Win32}
SetLength(Result,Length(S));
{$ELSE}
Result[0]:=Chr(Length(S));
{$ENDIF}
AnsiToOemBuff(@S[1],@Result[1],Length(S));
end;
function strEqual(const S1,S2: String): Boolean;
begin
Result:=AnsiCompareText(S1,S2)=0;
end;
function strCompU(const S1,S2: String) : Boolean;
begin
Result:=strEqual(strLeft(S2,Length(S1)),S1);
end;
function strComp(const S1,S2: String) : Boolean;
begin
Result:=strLeft(S2,Length(S1))=S1;
end;
function strContains(const S1,S2: String): Boolean;
begin
Result:=Pos(S1,S2) > 0;
end;
function strContainsU(const S1,S2: String): Boolean;
begin
Result:=strContains(strUpper(S1),strUpper(S2));
end;
function strNiceNum(const S: String) : String;
var
i : Integer;
Seps : set of Char;
begin
Seps:=[ThousandSeparator,DecimalSeparator];
Result:= ZERO;
for i := 1 to Length(S) do
if S[i] in DIGITS + Seps then
begin
if S[i] = ThousandSeparator then
Result:=Result+DecimalSeparator
else
Result:=Result+S[i];
if S[i] In Seps then Seps:=[];
end
end;
function strNiceDate(const S: String): String;
begin
Result:=strNiceDateDefault(S, DateToStr(Date));
end;
function strNiceDateDefault(const S, Default: String): String;
(* sinn der Procedure:
Irgendeinen String übergeben und in ein leidlich brauchbares Datum verwandeln.
Im Wesentlichen zum Abfangen des Kommazeichens auf dem Zehnerfeld.
eingabe 10 = Rückgabe 10 des Laufenden Monats
eingabe 10.12 = Rückgabe des 10.12. des laufenden Jahres.
eingabe 10.12.96 = Rückgabe des Strings
eingabe 10,12,96 = Rückgabe 10.12.95 (wird dann won STRtoDATE() gefressen)
Eine Plausbilitätskontrolle des Datums findet nicht Statt.
Geplante Erweiterung:
eingabe: +14 = Rückgabe 14 Tage Weiter
eingabe: +3m = Rückgabe 3 Monate ab Heute
eingabe: +3w = Rückgabe 3 Wochen (3*7 Tage) ab Heute
Das gleiche auch Rückwärts mit Minuszeichen
eingabe: e oder E oder f = Nächster Erster
eingabe: e+1m Erster des übernächsten Monats
Da läßt sich aber noch trefflich weiterspinnen
EV. mit Quelle rausgeben, damit sich die Engländer und Franzosen an
Ihren Datumsformaten selbst erfreuen können und wir die passenden umsetzungen
bekommen. *)
var
a : array [0..2] of string[4];
heute : string;
i,j : integer;
begin
a[0]:='';
a[1]:='';
a[2]:='';
heute := Default;
j := 0;
for i := 0 to length(S) do
if S[i] in DIGITS then
a[j] := a[j]+S[i]
else if S[i] in [DateSeparator] then Inc(j);
for i := 0 to 2 do
if Length(a[i]) = 0 then
if I=2 then
a[i] :=copy(heute,i*3+1,4)
else
a[i] := copy(heute,i*3+1,2)
else
if length(a[i]) = 1 then
a[i] := '0'+a[i];
Result:=a[0]+DateSeparator+a[1]+DateSeparator+a[2];
try
StrToDate(Result);
except
Result:=DateToStr(Date);
end;
end;
function strNiceTime(const S: String): String;
var
a : array[0..2] of string[2];
i,j : integer;
begin
j:= 0;
a[0]:= '';
a[1]:='';
a[2]:='';
for i:= 1 to length(S) do
begin
if S[i] in DIGITS then
begin
a[j] := a[j]+S[i];
end
else if S[i] in ['.',',',':'] then
inc(J);
if j > 2 then exit;
end;
for J := 0 to 2 do
if length(a[j]) = 1 then a[j] := '0'+a[j] else
if length(a[j]) = 0 then a[j] := '00';
Result := a[0]+TimeSeparator+a[1]+TimeSeparator+a[2];
end;
function strNicePhone(const S: String): String;
var
L : Integer;
begin
if Length(S) > 3 then
begin
L:=(Length(S)+1) div 2;
Result:=strNicePhone(strLeft(S,L))+SPACE+strNicePhone(strRight(S,Length(S)-L));
end else
Result := S;
end;
function strReplace(const S: String; C: Char; const Replace: String): String;
var
i : Integer;
begin
Result:='';
for i:=Length(S) downto 1 do
if S[i]=C then Result:=Replace+Result
else Result:=S[i]+Result;
end;
procedure strChange(var S:String; const Source, Dest: String);
var
P : Integer;
begin
P:=Pos(Source,S);
while P<>0 do
begin
Delete(S,P,Length(Source));
Insert(Dest,S,P);
P:=Pos(Source,S);
end;
end;
function strCmdLine: String;
var
i: Integer;
begin
Result:='';
for i:=1 to ParamCount do Result:=Result+ParamStr(i)+' ';
Delete(Result,Length(Result),1);
end;
{ sends a string to debug windows inside the IDE }
{$IFDEF Win32}
procedure strDebug(const S: String);
var
P : PChar;
CPS : TCopyDataStruct;
aWnd : hWnd;
begin
aWnd := FindWindow('TfrmDbgTerm', nil);
if aWnd <> 0 then
begin
CPS.cbData := Length(S) + 2;
GetMem(P, CPS.cbData);
try
StrPCopy(P, S+CR);
CPS.lpData := P;
SendMessage(aWnd, WM_COPYDATA, 0, LParam(@CPS));
finally
FreeMem(P, Length(S)+2);
end;
end;
end;
{$ENDIF}
function strSoundex(S: String): String;
const
CvTable : array['B'..'Z'] of char = (
'1', '2', '3', '0', '1', {'B' .. 'F'}
'2', '0', '0', '2', '2', {'G' .. 'K'}
'4', '5', '5', '0', '1', {'L' .. 'P'}
'2', '6', '2', '3', '0', {'Q' .. 'U'}
'1', '0', '2', '0', '2' ); {'V' .. 'Z'}
var
i,j : Integer;
aGroup,Ch : Char;
function Group(Ch: Char): Char;
begin
if (Ch in ['B' .. 'Z']) and not (Ch In ['E','H','I','O','U','W','Y']) then
Result:=CvTable[Ch]
else
Result:='0';
end;
begin
Result := '000';
if S='' then exit;
S:= strUpper(S);
i:= 2;
j:= 1;
while (i <= Length(S)) and ( j<=3) do
begin
Ch := S[i];
aGroup := Group(Ch);
if (aGroup <> '0') and (Ch <> S[i-1]) and
((J=1) or (aGroup <> Result[j-1])) and
((i>2) or (aGroup <> Group(S[1]))) then
begin
Result[j] :=aGroup;
Inc(j);
end;
Inc(i);
end; {while}
Result:=S[1]+'-'+Result;
end;
function strByteSize(Value: Longint): String;
function FltToStr(F: Extended): String;
begin
Result:=FloatToStrF(Round(F),ffNumber,6,0);
end;
begin
if Value > GBYTE then
Result:=FltTostr(Value / GBYTE)+' GB'
else if Value > MBYTE then
Result:=FltToStr(Value / MBYTE)+' MB'
else if Value > KBYTE then
Result:=FltTostr(Value / KBYTE)+' KB'
else
Result:=FltTostr(Value / KBYTE)+' Byte'; { 04.08.96 sb }
end;
const
C1 = 52845;
C2 = 22719;
function strEncrypt(const S: String; Key: Word): String;
var
I: Integer;
begin
{$IFDEF Win32}
SetLength(Result,Length(S));
{$ELSE}
Result[0]:=Chr(Length(S));
{$ENDIF}
for I := 1 to Length(S) do begin
Result[I] := Char(Ord(S[I]) xor (Key shr 8));
Key := (Ord(Result[I]) + Key) * C1 + C2;
end;
end;
function strDecrypt(const S: String; Key: Word): String;
var
I: Integer;
begin
{$IFDEF Win32}
SetLength(Result,Length(S));
{$ELSE}
Result[0]:=Chr(Length(S));
{$ENDIF}
for I := 1 to Length(S) do begin
Result[I] := char(Ord(S[I]) xor (Key shr 8));
Key := (Ord(S[I]) + Key) * C1 + C2;
end;
end;
function strLastCh(const S: String): Char;
begin
Result:=S[Length(S)];
end;
procedure strStripLast(var S: String);
begin
if Length(S) > 0 then Delete(S,Length(S),1);
end;
procedure strSearchReplace(var S:String; const Source, Dest: String; Options: TSRoptions);
var hs,hs1,hs2,hs3: String;
var i,j : integer;
begin
if srCase in Options then
begin
hs := s;
hs3 := source;
end
else
begin
hs:= StrUpper(s);
hs3 := StrUpper(Source);
end;
hs1:= '';
I:= pos(hs3,hs);
j := length(hs3);
while i > 0 do
begin
delete(hs,1,i+j-1); {Anfang Rest geändert 8.7.96 KM}
hs1 := Hs1+copy(s,1,i-1); {Kopieren geändert 8.7.96 KM}
delete(s,1,i-1); {Löschen bis Anfang posgeändert 8.7.96 KM}
hs2 := copy(s,1,j); {Bis ende pos Sichern}
delete(s,1,j); {Löschen bis ende Pos}
if (not (srWord in Options))
or (pos(s[1],' .,:;-#''+*?=)(/&%$§"!{[]}\~<>|') > 0) then
begin
{Quelle durch ziel erstzen}
hs1 := hs1+dest;
end
else
begin
hs1 := hs1+hs2;
end;
if srall in options then
I:= pos(hs3,hs)
else
i :=0;
end;
s:= hs1+s;
end;
function strProfile(const aFile, aSection, aEntry, aDefault: String): String;
var
aTmp: array[0..255] of Char;
begin
{$IFDEF Win32}
GetPrivateProfileString(PChar(aSection), PChar(aEntry),
PChar(aDefault), aTmp, Sizeof(aTmp)-1, PChar(aFile));
Result:=StrPas(aTmp);
{$ENDIF}
end;
function strCapitalize(const S: String): String; { 31.07.96 sb }
var
i : Integer;
Ch : Char;
First : Boolean;
begin
First := True;
Result := '';
for i:=1 to Length(S) do
begin
Ch:=S[i];
if Ch in [SPACE,'-','.'] then
First:=True
else if First then
begin
Ch:=strUpper(Ch)[1];
First:=False;
end;
Result:=Result+Ch;
end;
end;
{$IFDEF Win32}
function strFileLoad(const aFile: String): String;
var
aStr : TStrings;
begin
Result:='';
aStr:=TStringList.Create;
try
aStr.LoadFromFile(aFile);
Result:=aStr.Text;
finally
aStr.Free;
end;
end;
procedure strFileSave(const aFile,aString: String);
var
Stream: TStream;
begin
Stream := TFileStream.Create(aFile, fmCreate);
try
Stream.WriteBuffer(Pointer(aString)^,Length(aString));
finally
Stream.Free;
end;
end;
{$ENDIF}
{ Integer stuff }
function IntCenter(a,b: Int_): Int_;
begin
Result:=a div 2 - b div 2;
end;
function IntMax(a,b: Int_): Int_;
begin
if a>b then Result:=a else Result:=b;
end;
function IntMin(a,b: Int_): Int_;
begin
if aend;
function IntPow(Base,Expo: Integer): Int_;
var
Loop : Word;
begin
Result:=1;
for Loop:=1 to Expo do Result:=Result*Base;
end;
function IntPow10(Exponent: Integer): Int_;
begin
Result:=IntPow(10,Exponent);
end;
function IntSign(a: Int_): Integer;
begin
if a<0 then Result:=-1 else if a>0 then Result:=+1 else Result:= 0;
end;
function IntZero(a: Int_; Len: Integer): String;
begin
Result:=strPadZeroL(IntToStr(a),Len);
end;
function IntPrime(Value: Integer): Boolean;
var
i : integer;
begin
Result:=False;
if Value mod 2 <> 0 then
begin
i := 1;
repeat
i := i + 2;
Result:= Value mod i = 0
until Result or ( i > Trunc(sqrt(Value)) );
Result:= not Result;
end;
end;
function IntPercent(a, b : Int_): Int_;
begin
Result := Trunc((a / b)*100);
end;
{ Floating point stuff }
function FltAdd(P1,P2: Float; Decimals: Integer): Float;
begin
P1 :=fltRound(P1,Decimals);
P2 :=fltRound(P2,Decimals);
Result:=fltRound(P1+P2,Decimals);
end;
function FltDiv(P1,P2: Float; Decimals: Integer): Float;
begin
P1:=fltRound(P1,Decimals);
P2:=fltRound(P2,Decimals);
if P2=0.0 then P2:=FLTZERO; { provide division by zero }
Result:=fltRound(P1/P2,Decimals);
end;
function FltEqual(P1,P2: Float; Decimals: Integer): Boolean;
var
Diff : Float;
begin
Diff:=fltSub(P1,P2,Decimals);
Result:=fltEqualZero(Diff);
end;
function FltEqualZero(P: Float): Boolean;
begin
Result:=(P>-FLTZERO) and (Pend;
function FltGreaterZero(P: Float): Boolean;
begin
Result:=P>FLTZERO;
end;
function FltLessZero(P: Float): Boolean;
begin
Result:=P<-FLTZERO;
end;
function FltNeg(P: Float; Negate: Boolean): Float;
begin
if Negate then Result:=-P else Result:=P;
end;
function FltMul(P1,P2: Float; Decimals: Integer): Float;
begin
P1 :=fltRound(P1,Decimals);
P2 :=fltRound(P2,Decimals);
Result:=fltRound(P1*P2,Decimals);
end;
function FltRound(P: Float; Decimals: Integer): Float;
var
Factor : LongInt;
Help : Float;
begin
Factor:=IntPow10(Decimals);
if P<0 then Help:=-0.5 else Help:=0.5;
Result:=Int(P*Factor+Help)/Factor;
if fltEqualZero(Result) then Result:=0.00;
end;
function FltSub(P1,P2: Float; Decimals: Integer): Float;
begin
P1 :=fltRound(P1,Decimals);
P2 :=fltRound(P2,Decimals);
Result:=fltRound(P1-P2,Decimals);
end;
function FltUnEqualZero(P: Float): Boolean;
begin
Result:=(P<-FLTZERO) or (P>FLTZERO)
end;
function FltCalc(const Expr: String): Float;
const
STACKSIZE = 10;
var
Stack : array[0..STACKSIZE] of double;
oStack : array[0..STACKSIZE] of char;
z,n : double;
i,j,m : integer;
Bracket : boolean;
begin
Bracket:= False; j := 0; n:= 1;z:=0; m:=1;
for i := 1 to Length(Expr) do
begin
if not Bracket then
case Expr[i] of
'0' .. '9': begin
z:=z*10+ord(Expr[i])-ord('0');
n:=n*m;
end;
',',#46 : m := 10;
'(' : Bracket := True; {hier Klammeranfang merken, Zähler!!}
'*','x',
'X',
'/','+' : begin
Stack[j] := z/n;
oStack[j] := Expr[i];
Inc(j);
m:=1;z:=0;n:=1;
end;
end {case}
else
Bracket:= Expr[i]<> ')'; {hier Rekursiver Aufruf, Zähler !!};
end;
Stack[j] := z/n;
for i := 1 to j do
case oStack[i-1] of
'*','x','X' : Stack[i]:= Stack[i-1]*Stack[i];
'/' : Stack[i]:= Stack[i-1]/Stack[i];
'+' : Stack[i]:= Stack[i-1]+Stack[i];
end;
Result:= Stack[j];
end;
function fltPower(a, n: Float): Float;
begin
Result:=Exp(n * Ln(a));
end;
{ Rectangle Calculations }
function RectHeight(const R: TRect): Integer;
begin
Result := R.Bottom - R.Top;
end;
function RectWidth(const R: TRect): Integer;
begin
Result := R.Right - R.Left;
end;
procedure RectGrow(var R: TRect; Delta: Integer);
begin
with R do
begin
Dec(Left, Delta);
Dec(Top, Delta);
Inc(Right, Delta);
Inc(Bottom, Delta);
end;
end;
procedure RectRelativeMove(var R: TRect; DX, DY: Integer);
begin
with R do
begin
Inc(Left, DX);
Inc(Right, DX);
Inc(Top, DY);
Inc(Bottom, DY);
end;
end;
procedure RectMoveTo(var R: TRect; X, Y: Integer);
begin
with R do
begin
Right := X + Right - Left;
Bottom := Y + Bottom - Top;
Left := X;
Top := Y;
end;
end;
function RectSet(Left, Top, Right, Bottom: Integer): TRect;
begin
Result.Left := Left;
Result.Top := Top;
Result.Right := Right;
Result.Bottom := Bottom;
end;
function RectSetPoint(const TopLeft, BottomRight: TPoint): TRect;
begin
Result.TopLeft := TopLeft;
Result.BottomRight := BottomRight;
end;
function RectInclude(const R1, R2: TRect): Boolean;
begin
Result := (R1.Left >= R2.Left) and (R1.Top >= R2.Top)
and (R1.Right <= R2.Right) and (R1.Bottom <= R2.Bottom);
end;
function RectPoint(const R: TRect; P: TPoint): Boolean;
begin
Result := (p.x>r.left) and (p.xr.top) and (p.yend;
function RectIntersection(const R1, R2: TRect): TRect;
begin
with Result do
begin
Left := intMax(R1.Left, R2.Left);
Top := intMax(R1.Top, R2.Top);
Right := intMin(R1.Right, R2.Right);
Bottom := intMin(R1.Bottom, R2.Bottom);
end;
if not RectIsValid(Result) then
Result := RectSet(0, 0, 0, 0);
end;
function RectIsIntersection(const R1, R2: TRect): Boolean;
begin
Result := not RectIsNull(RectIntersection(R1, R2));
end;
function RectIsValid(const R: TRect): Boolean;
begin
with R do
Result := (Left <= Right) and (Top <= Bottom);
end;
function RectsAreValid(const Arr: array of TRect): Boolean;
var
I: Integer;
begin
for I := Low(Arr) to High(Arr) do
if not RectIsValid(Arr[I]) then
begin
Result := False;
exit;
end;
Result := True;
end;
function RectNull: TRect;
begin
Result := RectSet(0, 0, 0, 0);
end;
function RectIsNull(const R: TRect): Boolean;
begin
with R do
Result := (Left = 0) and (Right = 0) and (Top = 0) and (Bottom = 0);
end;
function RectIsSquare(const R: TRect): Boolean;
begin
Result := RectHeight(R) = RectWidth(R);
end;
function RectCentralPoint(const R: TRect): TPoint;
begin
Result.X := R.Left + (RectWidth(R) div 2);
Result.Y := R.Top + (RectHeight(R) div 2);
end;
function rectBounds(aLeft,aTop,aWidth,aHeight: Integer): TRect;
begin
Result:=rectSet(aLeft,aTop,aLeft+aWidth,aTop+aHeight);
end;
{ file functions }
procedure fileShredder(const Filename: String);
var
aFile : Integer;
aSize : Integer;
P : Pointer;
begin
aSize:=fileSize(Filename);
aFile:=FileOpen(FileName,fmOpenReadWrite);
try
Getmem(P,aSize);
fillchar(P^,aSize,'X');
FileWrite(aFile,P^,aSize);
Freemem(P,aSize);
finally
FileClose(aFile);
DeleteFile(Filename);
end;
end;
function fileSize(const FileName: String): LongInt;
var
SearchRec : TSearchRec;
begin { !Win32! -> GetFileSize }
if FindFirst(FileName,faAnyFile,SearchRec)=0
then Result:=SearchRec.Size
else Result:=0;
end;
function fileWildcard(const Filename: String): Boolean;
begin
Result:=(Pos('*',Filename)<>0) or (Pos('?',Filename)<>0);
end;
{$IFDEF Win32}
function fileTemp(const aExt: String): String;
var
Buffer: array[0..1023] of Char;
aFile : String;
begin
GetTempPath(Sizeof(Buffer)-1,Buffer);
GetTempFileName(Buffer,'TMP',0,Buffer);
SetString(aFile, Buffer, StrLen(Buffer));
Result:=ChangeFileExt(aFile,aExt);
RenameFile(aFile,Result);
end;
function fileExec(const aCmdLine: String; aHide, aWait: Boolean): Boolean;
var
StartupInfo : TStartupInfo;
ProcessInfo : TProcessInformation;
begin
{setup the startup information for the application }
FillChar(StartupInfo, SizeOf(TStartupInfo), 0);
with StartupInfo do
begin
cb:= SizeOf(TStartupInfo);
dwFlags:= STARTF_USESHOWWINDOW or STARTF_FORCEONFEEDBACK;
if aHide then wShowWindow:= SW_HIDE
else wShowWindow:= SW_SHOWNORMAL;
end;
Result := CreateProcess(nil,PChar(aCmdLine), nil, nil, False,
NORMAL_PRIORITY_CLASS, nil, nil, StartupInfo, ProcessInfo);
if aWait then
if Result then
begin
WaitForInputIdle(ProcessInfo.hProcess, INFINITE);
WaitForSingleObject(ProcessInfo.hProcess, INFINITE);
end;
end;
function fileShellOpen(const aFile: String): Boolean;
begin
Result := ShellExecute( Application.Handle,
'open', PChar(aFile), nil, nil, SW_NORMAL) <= 32;
end;
function fileShellPrint(const aFile: String): Boolean;
begin
Result := ShellExecute( Application.Handle,
'print', PChar(aFile), nil, nil, SW_HIDE) <= 32;
end;
function fileLongName(const aFile: String): String;
var
aInfo: TSHFileInfo;
begin
if SHGetFileInfo(PChar(aFile),0,aInfo,Sizeof(aInfo),SHGFI_DISPLAYNAME)<>0 then
Result:=StrPas(aInfo.szDisplayName)
else
Result:=aFile;
end;
function fileShortName(const aFile: String): String;
var
aTmp: array[0..255] of char;
begin
if GetShortPathName(PChar(aFile),aTmp,Sizeof(aTmp)-1)=0 then
Result:=aFile
else
Result:=StrPas(aTmp);
end;
{$ENDIF}
function ExtractName(const Filename: String): String;
var
aExt : String;
aPos : Integer;
begin
aExt:=ExtractFileExt(Filename);
Result:=ExtractFileName(Filename);
if aExt <> '' then
begin
aPos:=Pos(aExt,Result);
if aPos>0 then
Delete(Result,aPos,Length(aExt));
end;
end;
{ date calculations }
function dateYear(D: TDateTime): Integer;
var
Year,Month,Day : Word;
begin
DecodeDate(D,Year,Month,Day);
Result:=Year;
end;
function dateMonth(D: TDateTime): Integer;
var
Year,Month,Day : Word;
begin
DecodeDate(D,Year,Month,Day);
Result:=Month;
end;
function dateBeginOfYear(D: TDateTime): TDateTime;
var
Year,Month,Day : Word;
begin
DecodeDate(D,Year,Month,Day);
Result:=EncodeDate(Year,1,1);
end;
function dateEndOfYear(D: TDateTime): TDateTime;
var
Year,Month,Day : Word;
begin
DecodeDate(D,Year,Month,Day);
Result:=EncodeDate(Year,12,31);
end;
function dateBeginOfMonth(D: TDateTime): TDateTime;
var
Year,Month,Day : Word;
begin
DecodeDate(D,Year,Month,Day);
Result:=EncodeDate(Year,Month,1);
end;
function dateEndOfMonth(D: TDateTime): TDateTime;
var
Year,Month,Day : Word;
begin
DecodeDate(D,Year,Month,Day);
if Month=12 then
begin
Inc(Year);
Month:=1;
end else
Inc(Month);
Result:=EncodeDate(Year,Month,1)-1;
end;
function dateWeekOfYear(D: TDateTime): Integer; { Armin Hanisch }
const
t1: array[1..7] of ShortInt = ( -1, 0, 1, 2, 3, -3, -2);
t2: array[1..7] of ShortInt = ( -4, 2, 1, 0, -1, -2, -3);
var
doy1,
doy2 : Integer;
NewYear : TDateTime;
begin
NewYear:=dateBeginOfYear(D);
doy1 := dateDayofYear(D) + t1[DayOfWeek(NewYear)];
doy2 := dateDayofYear(D) + t2[DayOfWeek(D)];
if doy1 <= 0 then
Result := dateWeekOfYear(NewYear-1)
else if (doy2 >= dateDayofYear(dateEndOfYear(NewYear))) then
Result:= 1
else
Result:=(doy1-1) div 7+1;
end;
function dateDayOfYear(D: TDateTime): Integer;
begin
Result:=Trunc(D-dateBeginOfYear(D))+1;
end;
function dateDayOfWeek(D: TDateTime): TDayOfWeek;
begin
Result:=TDayOfWeek(Pred(DayOfWeek(D)));
end;
function dateLeapYear(D: TDateTime): Boolean;
var
Year,Month,Day: Word;
begin
DecodeDate(D,Year,Month,Day);
Result:=(Year mod 4 = 0) and ((Year mod 100 <> 0) or (Year mod 400 = 0));
end;
function dateBeginOfQuarter(D: TDateTime):TDateTime;
var
Year,Month,Day : Word;
begin
DecodeDate(D,Year,Month,Day);
Result:=EncodeDate(Year,((Month-1 div 3) * 3)+1,1);
end;
function dateEndOfQuarter(D: TDateTime): TDateTime;
begin
Result:=dateBeginOfQuarter(dateBeginOfQuarter(D)+(3*31))-1;
end;
function dateBeginOfWeek(D: TDateTime; Weekday: Integer): TDateTime;
begin
Result:=D;
while DayOfWeek(Result)<>Weekday do Result:=Result-1;
end;
function dateDaysInMonth(D: TDateTime): Integer;
const
DaysPerMonth: array[1..12] of Byte= (31,28,31,30,31,30,31,31,30,31,30,31);
var
Month: Integer;
begin
Month:=dateMonth(D);
Result:=DaysPerMonth[Month];
if (Month=2) and dateLeapYear(D) then Inc(Result);
end;
function dateDay(D: TDateTime): Integer;
var
Year,Month,Day : Word;
begin
DecodeDate(D,Year,Month,Day);
Result:=Day;
end;
function dateQuicken(D: TDateTime; Key: Char): TDateTime;
const
{$IFDEF German}
_ToDay = 'H';
_PrevYear = 'J';
_NextYear = 'R';
_PrevMonth= 'M';
_NextMonth= 'T';
{$ELSE}
_ToDay = 'H'; { if someone knows US keys, please tell us }
_PrevYear = 'J';
_NextYear = 'R';
_PrevMonth= 'M';
_NextMonth= 'T';
{$ENDIF}
begin
case Upcase(Key) of { Quicken Date Fast Keys }
'+' : Result := D+1;
'-' : Result := D-1;
_ToDay : Result := Date;
_PrevYear : if D <> dateBeginOfYear(D) then Result:=dateBeginOfYear(D)
else Result:=dateBeginOfYear(D-1);
_NextYear : if D <> dateEndOfYear(D) then Result:=dateEndOfYear(D)
else Result:=dateEndOfYear(Date+1);
_PrevMonth : if D <> dateBeginOfMonth(D) then Result:=dateBeginOfMonth(D)
else Result:=dateBeginOfMonth(D-1);
_NextMonth : if D <> dateEndOfMonth(D) then Result:=dateEndOfMonth(D)
else Result:=dateEndOfMonth(D+1);
else Result := D;
end;
end;
{ time functions }
function timeHour(T: TDateTime): Integer;
var
Hour,Minute,Sec,Sec100: Word;
begin
DecodeTime(T,Hour,Minute,Sec,Sec100);
Result:=Hour;
end;
function timeMin(T: TDateTime): Integer;
var
Hour,Minute,Sec,Sec100: Word;
begin
DecodeTime(T,Hour,Minute,Sec,Sec100);
Result:=Minute;
end;
function timeSec(T: TDateTime): Integer;
var
Hour,Minute,Sec,Sec100: Word;
begin
DecodeTime(T,Hour,Minute,Sec,Sec100);
Result:=Sec;
end;
function timeToInt(T: TDateTime): Integer;
begin
Result:=Trunc((MSecsPerday * T) / 1000);
end;
{$IFDEF Win32}
function timeZoneOffset: Integer;
var
aTimeZoneInfo : TTimeZoneInformation;
begin
if GetTimeZoneInformation(aTimeZoneInfo)<>-1 then
Result := aTimeZoneInfo.Bias
else
Result := 0;
end;
{$ENDIF}
{ Communications Functions }
function comIsCis(const S: String): Boolean;
var
aSt: String;
PreId,
PostId: Integer;
begin
Result:=strContainsU('@compuserve.com',S); { 28.7.96 sb This is also on CIS }
if not Result then
if Pos(',',S) > 0 then
try
aSt:=S;
PreId:=StrToInt(strToken(aSt,','));
PostId:=StrToInt(aSt);
Result:=(PreId > 0) and (PostId > 0);
except
Result:=False;
end;
end;
function comIsInt(const S: String): Boolean;
var
aSt : String;
PreId,
PostId : String;
begin
try
aSt:=S;
PreId:=strToken(aSt,'@');
PostId:=aSt;
Result:=(Length(PreId)>0) and (Length(PostId)>0);
except
Result:=False;
end;
end;
{ converts a CIS adress to a correct Internet adress }
function comCisToInt(const S: String): String;
var
P : Integer;
begin
p:=Pos('INTERNET:',S);
if P=1 then
Result:=Copy(S,P+1,Length(S))
else
begin
Result:=S;
P:=Pos(',',Result);
if P>0 then Result[P]:='.';
Result:=Result+'@compuserve.com'; { 22.07.96 sb Error }
end;
end;
{ converts a internet adress to a correct CServe adress }
function comIntToCis(const S: String): String;
var
P : Integer;
begin
p:=Pos('@COMPUSERVE.COM',strUpper(S));
if p > 0 then
begin
Result:=strLeft(S,P-1);
P:=Pos('.',Result);
if P>0 then Result[P]:=',';
end else
Result:='INTERNET:'+S;
end;
{ converts a fax adress to a correct CServe adress }
function comFaxToCis(const S: String): String;
begin
Result:='FAX:'+S;
end;
function comNormFax(const Name, Fax: String): String;
begin
if Name<>'' then
Result:=Name+'[fax: '+Name+'@'+strTrim(Fax)+']'
else
Result:='[fax: '+strTrim(Fax)+']';
end;
function comNormInt(const Name,Int: String): String;
begin
Result:='';
if comIsInt(Int) then
if Name <> '' then
Result := Name + '|smtp: ' + strTrim(Int)
else
Result := 'smtp: ' + strTrim(Int);
end;
function comNormCis(const Name,Cis: String): String;
begin
Result:='';
if Name <> '' then
Result := Name + '[compuserve: ' + strTrim(Cis) + ']'
else
Result := '[compuserve: ' + strTrim(Cis) + ']';
end;
function comNormPhone(const Phone: String): String;
function strValueAt(const S:String; At: Integer): String;
const
Seperator = ',';
Str = '"';
var
j,i: Integer;
FSkip : Boolean;
begin
Result:='';
j := 1;
i := 0;
FSkip:= False;
while (i<=At ) and (j<=Length(S)) do
begin
if (S[j]=Str) then
FSkip:=not FSkip
else if (S[j]=Seperator) and not FSkip then
Inc(i)
else if i = At then
Result:=Result+S[j];
Inc(j);
end;
end;
var
aNumber,
aCountry,
aPrefix,
aDefault,
aLocation : String;
i : Integer;
begin
aDefault := '1,"Hamburg","","","40",49,0,0,0,"",1," "';
aLocation := strProfile('telephon.ini','Locations','CurrentLocation','');
if aLocation <> '' then
begin
aLocation:=strTokenAt(aLocation,',',0);
if aLocation <> '' then
begin
aLocation:=strProfile('telephon.ini','Locations','Location'+aLocation,'');
if aLocation <> '' then
aDefault := aLocation;
end;
end;
Result:='';
aNumber:=strTrim(Phone);
if aNumber <> '' then
for i:=Length(aNumber) downto 1 do
if not (aNumber[i] in DIGITS) then
begin
if aNumber[i] <> '+' then aNumber[i] := '-';
if i < Length(aNumber) then { remove duplicate digits }
if aNumber[i]=aNumber[i+1] then
Delete(aNumber,i,1);
end;
if aNumber <> '' then
begin
if aNumber[1] = '+' then
aCountry := strToken(aNumber,'-')
else
aCountry := '+'+strValueAt(aDefault,5);
aNumber:=strTrimChL(aNumber,'-');
if aNumber <> '' then
begin
if strTokenCount(aNumber,'-') > 1 then
aPrefix := strTrimChL(strToken(aNumber,'-'),'0')
else
aPrefix := strValueAt(aDefault,4);
aNumber:= strNicePhone(strTrimChA(aNumber,'-'));
Result := aCountry + ' ('+aPrefix+') '+aNumber;
end;
end;
end;
{ system functions }
{$IFDEF Win32}
function sysTempPath: String;
var
Buffer: array[0..1023] of Char;
begin
SetString(Result, Buffer, GetTempPath(Sizeof(Buffer)-1,Buffer));
end;
{$ELSE}
function sysTempPath:String;
var
Buffer: array[0..255] of char;
begin
GetTempFileName(#0,'TMP',0,Buffer); { 15.07.96 sb }
Result:=StrPas(Buffer);
DeleteFile(Result);
Result:=ExtractFilePath(Result);
end;
{$ENDIF}
procedure sysDelay(aMs: Longint);
var
TickCount : LongInt;
begin
TickCount:=GetTickCount;
while GetTickCount - TickCount < aMs do Application.ProcessMessages;
end;
procedure sysBeep;
begin
messageBeep($FFFF);
end;
function sysColorDepth: Integer;
var
aDC: hDC;
begin
Result:=0;
try
aDC := GetDC(0);
Result:=1 shl (GetDeviceCaps(aDC,PLANES) * GetDeviceCaps(aDC, BITSPIXEL));
finally
ReleaseDC(0,aDC);
end;
end;
{$IFDEF Win32}
procedure sysSaverRunning(Active: Boolean);
var
aParam: Longint;
begin
SystemParametersInfo (SPI_SCREENSAVERRUNNING, Word(Active),@aParam,0);
end;
{$ENDIF}
{ registry functions }
{$IFDEF Win32 }
function regReadString(aKey: HKEY; const Path: String): String;
var
aRegistry : TRegistry;
aPath : String;
aValue : String;
begin
aRegistry:=TRegistry.Create;
try
with aRegistry do
begin
RootKey:=aKey;
aPath:=Path;
aValue:='';
while (Length(aPath)>0) and (strLastCh(aPath)<>'\') do
begin
aValue:=strLastCh(aPath)+aValue;
strStripLast(aPath);
end;
OpenKey(aPath,True);
Result:=ReadString(aValue);
end;
finally
aRegistry.Free;
end;
end;
procedure regWriteString(aKey: HKEY; const Path,Value: String);
var
aRegistry : TRegistry;
aPath : String;
aValue : String;
begin
aRegistry:=TRegistry.Create;
try
with aRegistry do
begin
RootKey:=aKey;
aPath:=Path;
aValue:='';
while (Length(aPath)>0) and (strLastCh(aPath)<>'\') do
begin
aValue:=strLastCh(aPath)+aValue;
strStripLast(aPath);
end;
OpenKey(aPath,True);
WriteString(aValue,Value);
end;
finally
aRegistry.Free;
end;
end;
(*!!!
function regReadString(aKey: hKey; const Value: String): String;
var
aTmp : array[0..255] of char;
aCb,
aType : Integer;
begin
Result:='';
if aKey<> 0 then
begin
aCb:=Sizeof(aTmp)-1;
{ aData:=@aTmp; }
if RegQueryValueEx(aKey,PChar(Value),nil,@aType,@aTmp,@aCb)=ERROR_SUCCESS then
if aType=REG_SZ then Result:=String(aTmp);
end;
end; *)
function regInfoString(const Value: String): String;
var
aKey : hKey;
begin
Result:='';
if RegOpenKey(HKEY_LOCAL_MACHINE,REG_CURRENT_VERSION,aKey)=ERROR_SUCCESS then
begin
Result:=regReadString(aKey,Value);
RegCloseKey(aKey);
end;
end;
function regCurrentUser: String;
begin
Result:=regInfoString(REG_CURRENT_USER);
end;
function regCurrentCompany: String;
begin
Result:=regInfoString(REG_CURRENT_COMPANY);
end;
{ Add a shell extension to the registry }
procedure regWriteShellExt(const aExt,aCmd,aMenu,aExec: String);
var
s, aPath : String;
begin
with TRegistry.Create do
try
RootKey := HKEY_CLASSES_ROOT;
aPath := aExt;
if KeyExists(aPath) then
begin
OpenKey(aPath,False);
S:=ReadString('');
CloseKey;
if S<>'' then
if KeyExists(S) then
aPath:=S;
end;
OpenKey(aPath+'\Shell\'+aCmd,True);
WriteString('',aMenu);
CloseKey;
OpenKey(aPath+'\Shell\'+aCmd+'\Command',True);
WriteString('',aExec + ' %1');
CloseKey;
finally
Free;
end;
end;
{$ENDIF}
{ other stuff }
function MsgBox(const aTitle,aMsg: String; aFlag: Integer): Integer;
var
ActiveWindow : hWnd;
WindowList : Pointer;
TmpA : array[0..200] of char;
TmpB : array[0..100] of char;
begin
ActiveWindow:=GetActiveWindow;
WindowList:= DisableTaskWindows(0);
try
StrPCopy(TmpB,aTitle);
StrPCopy(TmpA,aMsg);
{$IFDEF Win32}
Result:=Windows.MessageBox(Application.Handle, TmpA, TmpB, aFlag);
{$ELSE}
Result:=WinProcs.MessageBox(Application.Handle, TmpA, TmpB, aFlag);
{$ENDIF}
finally
EnableTaskWindows(WindowList);
SetActiveWindow(ActiveWindow);
end;
end;
function Question(const Msg: String):Boolean;
begin
if IsWin95 or IsWinNT then
Result:=MsgBox(LoadStr(SMsgdlgConfirm),Msg, MB_ICONQUESTION or MB_YESNO)=IDYES
else
Result:=messageDlg(Msg,mtConfirmation,[mbYes,mbNo],0)=mrYes;
end;
procedure Information(const Msg: String);
begin
if IsWin95 or IsWinNT then
MsgBox(LoadStr(SMsgdlgInformation), Msg, MB_ICONINFORMATION or MB_OK )
else
messageDlg(Msg,mtInformation,[mbOk],0);
end;
function Confirmation(const Msg: String): Word;
begin
if IsWin95 or IsWinNT then
case MsgBox(LoadStr(SMsgDlgConfirm),Msg,MB_ICONQUESTION or MB_YESNOCANCEL) of
IDYES : Result := mrYes;
IDNO : Result := mrNo;
IDCANCEL : Result := mrCancel;
else Result := mrCancel;
end
else
Result:=MessageDlg(Msg,mtConfirmation,[mbYes,mbNo,mbCancel],0);
end;
{ TPersistentRect }
constructor TPersistentRect.Create;
begin
FRect:=rectSet(10,10,100,20);
end;
procedure TPersistentRect.Assign(Source: TPersistent);
var
Value: TPersistentRect;
begin
if Value is TPersistentRect then
begin
Value:=Source as TPersistentRect;
FRect:=rectBounds(Value.Left,Value.Top,Value.Width,Value.Height);
exit;
end;
inherited Assign(Source);
end;
procedure TPersistentRect.SetLeft(Value: Integer);
begin
if Value<>Left then
begin
if Assigned(FOnConvert) then
Value:=FOnConvert(Self,Value,False);
FRect:=rectBounds(Value,Top,Width,Height);
end;
end;
procedure TPersistentRect.SetTop(Value: Integer);
begin
if Value<>Top then
begin
if Assigned(FOnConvert) then
Value:=FOnConvert(Self,Value,False);
FRect:=rectBounds(Left,Value,Width,Height);
end;
end;
procedure TPersistentRect.SetHeight(Value: Integer);
begin
if Value<>Height then
begin
if Assigned(FOnConvert) then
Value:=FOnConvert(Self,Value,False);
FRect:=rectBounds(Left,Top,Width,Value);
end;
end;
procedure TPersistentRect.SetWidth(Value: Integer);
begin
if Value<>Width then
begin
if Assigned(FOnConvert) then
Value:=FOnConvert(Self,Value,False);
FRect:=rectBounds(Left,Top,Value,Height);
end;
end;
function TPersistentRect.GetLeft: Integer;
begin
Result:=FRect.Left;
if Assigned(FOnConvert) then
Result:=FOnConvert(Self,Result,True);
end;
function TPersistentRect.GetTop: Integer;
begin
Result:=FRect.Top;
if Assigned(FOnConvert) then
Result:=FOnConvert(Self,Result,True);
end;
function TPersistentRect.GetHeight: Integer;
begin
Result:=rectHeight(FRect);
if Assigned(FOnConvert) then
Result:=FOnConvert(Self,Result,True);
end;
function TPersistentRect.GetWidth: Integer;
begin
Result:=rectWidth(FRect);
if Assigned(FOnConvert) then
Result:=FOnConvert(Self,Result,True);
end;
{$IFDEF Win32}
{ TPersistentRegistry }
function TPersistentRegistry.ReadComponent(const Name: String;
Owner, Parent: TComponent): TComponent;
var
DataSize : Integer;
MemStream : TMemoryStream;
Reader : TReader;
begin
Result := nil;
DataSize:=GetDataSize(Name);
MemStream := TMemoryStream.Create;
try
MemStream.SetSize(DataSize);
ReadBinaryData(Name,MemStream.Memory^,DataSize);
MemStream.Position := 0;
Reader := TReader.Create(MemStream, 256);
try
Reader.Parent := Parent;
Result := Reader.ReadRootComponent(nil);
if Owner <> nil then
try
Owner.InsertComponent(Result);
except
Result.Free;
raise;
end;
finally
Reader.Free;
end;
finally
MemStream.Free;
end;
end;
procedure TPersistentRegistry.WriteComponent(const Name: String; Component: TComponent);
var
MemStream: TMemoryStream;
begin
MemStream := TMemoryStream.Create;
try
MemStream.WriteComponent(Component);
WriteBinaryData(Name, MemStream.Memory^, MemStream.Size);
finally
MemStream.Free;
end;
end;
{$ENDIF}
{ TSystemMetric }
constructor TSystemMetric.Create;
begin
inherited Create;
Update;
end;
procedure TSystemMetric.Update;
function GetSystemPoint(ax,ay: Integer):TPoint;
begin
Result:=Point(GetSystemMetrics(ax),GetSystemMetrics(ay));
end;
begin
FMenuHeight :=GetSystemMetrics(SM_CYMENU);
FCaptionHeight :=GetSystemMetrics(SM_CYCAPTION);
FBorder :=GetSystemPoint(SM_CXBORDER,SM_CYBORDER);
FFrame :=GetSystemPoint(SM_CXFRAME,SM_CYFRAME);
FDlgFrame :=GetSystemPoint(SM_CXDLGFRAME,SM_CYDLGFRAME);
FBitmap :=GetSystemPoint(SM_CXSIZE,SM_CYSIZE);
FHScroll :=GetSystemPoint(SM_CXHSCROLL,SM_CYHSCROLL);
FVScroll :=GetSystemPoint(SM_CXVSCROLL,SM_CYVSCROLL);
FThumb :=GetSystemPoint(SM_CXHTHUMB,SM_CYVTHUMB);
FFullScreen :=GetSystemPoint(SM_CXFULLSCREEN,SM_CYFULLSCREEN);
FMin :=GetSystemPoint(SM_CXMIN,SM_CYMIN);
FMinTrack :=GetSystemPoint(SM_CXMINTRACK,SM_CYMINTRACK);
FCursor :=GetSystemPoint(SM_CXCURSOR,SM_CYCURSOR);
FIcon :=GetSystemPoint(SM_CXICON,SM_CYICON);
FDoubleClick :=GetSystemPoint(SM_CXDOUBLECLK,SM_CYDOUBLECLK);
FIconSpacing :=GetSystemPoint(SM_CXICONSPACING,SM_CYICONSPACING);
FColorDepth :=sysColorDepth;
end;
{ TDesktopCanvas }
constructor TDesktopCanvas.Create;
begin
inherited Create;
DC:=GetDC(0);
Handle:=DC;
end;
destructor TDesktopCanvas.Destroy;
begin
Handle:=0;
ReleaseDC(0, DC);
inherited Destroy;
end;
{$IFNDEF Win32}
procedure DoneXProcs; far;
begin
SysMetric.Free;
end;
{$ENDIF}
initialization
Randomize;
SysMetric := TSystemMetric.Create;
IsWin95 := (GetVersion and $FF00) >= $5F00;
IsWinNT := (GetVersion < $80000000);
IsFabula := nil;
{$IFDEF Win32}
xLanguage := (LoWord(GetUserDefaultLangID) and $3ff);
case xLanguage of
LANG_GERMAN : xLangOfs := 70000;
LANG_ENGLISH : xLangOfs := 71000;
LANG_SPANISH : xLangOfs := 72000;
LANG_RUSSIAN : xLangOfs := 73000;
LANG_ITALIAN : xLangOfs := 74000;
LANG_FRENCH : xLangOfs := 75000;
LANG_PORTUGUESE: xLangOfs := 76000;
else xLangOfs := 71000;
end;
{$ENDIF}
{$IFDEF Win32}
finalization
SysMetric.Free;
{$ELSE}
AddExitProc(DoneXProcs);
{$ENDIF}
end.