Summary Table

Categories Total Count
PII 0
URL 0
DNS 0
EKL 0
IP 0
PORT 0
VsID 0
CF 0
AI 0
VPD 0
PL 0
Other 0

File Content

{ ******************************************************************************

___ __ ____ _ _ _ ____ __ ____ ____ ____
/ __)/ \( _ \( \/ ) / ) ( _ \ / _\ / ___)(_ _)( __)
( (__( O )) __/ ) / / / ) __// \\___ \ )( ) _)
\___)\__/(__) (__/ (_/ (__) \_/\_/(____/ (__) (____)


Utilities unit

Components:

TLogComponent = Handles application logging through out the
CopyPaste tracking project

TStopWatch = Handles timming and allows the ability to gather
control metrics

Functions:

BreakUpLongLines = Breaks a string up so it can be sent via the
RPC broker

BreakUpLongListLines = Breake up a stringlist lines at a certain
length

DateTimeToFMDateTime = converts a Delphi date/time type to a Fileman
date/time

FilteredStringCP = Remove special characters

Piece = Returns the Nth piece (PieceNum) of a string delimited by
Delim

Pieces = returns several contiguous pieces

DelimCount = Return number of delimeters in string

TrimBlankLines = Removes leading and trailing blank lines from a stringlist

SetPiece = sets the Nth piece (PieceNum) of a string to NewPiece, adding
delimiters as necessary

SetPieces = Sets multiple pieces at once

{ ****************************************************************************** }

unit U_CPTUtils;

interface

Uses
Classes, System.SyncObjs, Winapi.Windows, System.SysUtils,
System.DateUtils, Winapi.SHFolder, Vcl.Forms, U_CPTCommon;

type

TLogfileLevel = (LOG_SUM, LOG_DETAIL);

TLogComponent = class
private
FOwner: TObject;
FCriticalSection: TCriticalSection;
fLogToFile: TLogfileLevel;
fOurLogFile: String;
function GetLogFileName(): String;
public
constructor Create(AOwner: TComponent);
destructor Destroy; override;
function Dump(Instance: TPasteArray): string;
procedure LogText(Action, MessageTxt: String);
property LogToFile: TLogfileLevel read fLogToFile write fLogToFile;
property LogFile: String read fOurLogFile;
end;

TStopWatch = class
private
FOwner: TObject;
fFrequency: TLargeInteger;
fIsRunning: Boolean;
fIsHighResolution: Boolean;
fStartCount, fStopCount: TLargeInteger;
fActive: Boolean;
procedure SetTickStamp(var lInt: TLargeInteger);
function GetElapsedTicks: TLargeInteger;
function GetElapsedMilliseconds: TLargeInteger;
Function GetElapsedNanoSeconds: TLargeInteger;
function GetElapsed: string;
public
constructor Create(AOwner: TComponent; const IsActive: Boolean = false;
const startOnCreate: Boolean = false);
destructor Destroy; override;
procedure Start;
procedure Stop;
property IsHighResolution: Boolean read fIsHighResolution;
property ElapsedTicks: TLargeInteger read GetElapsedTicks;
property ElapsedMilliseconds: TLargeInteger read GetElapsedMilliseconds;
property ElapsedNanoSeconds: TLargeInteger read GetElapsedNanoSeconds;
property Elapsed: string read GetElapsed;
property IsRunning: Boolean read fIsRunning;
end;

procedure BreakUpLongLines(var SaveList: TStringList; BaseNode: String;
const OrigList: TStringList; BreakLimit: Integer);

procedure BreakUpLongListLines(var aList: TStringList; BreakLimit: Integer);

function DateTimeToFMDateTime(ADateTime: TDateTime): Double;
function FilteredStringCP(const X: string; ATabWidth: Integer = 8): string;
function FormatFMDateTime(AFormat: string; ADateTime: Double): string;
function Piece(const S: string; Delim: char; PieceNum: Integer): string;
function Pieces(const S: string; Delim: char;
FirstNum, LastNum: Integer): string;
function DelimCount(const Str, Delim: string): Integer;
procedure TrimBlankLines(const InList: TStrings; OutList: TStrings;
AllBlanks: Boolean = false);
procedure TrimBlankValueLines(const InList: TStrings; OutList: TStrings;
AllBlanks: Boolean = false);
procedure SetPiece(var X: string; Delim: char; PieceNum: Integer;
const NewPiece: string);
procedure SetPieces(var X: string; Delim: char; Pieces: Array of Integer;
FromString: string);
procedure StatusText(const S: string);

implementation

const
{ names of months used by FormatFMDateTime }
MONTH_NAMES_SHORT: array [1 .. 12] of string = ('Jan', 'Feb', 'Mar', 'Apr',
'May', 'Jun', 'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec');
MONTH_NAMES_LONG: array [1 .. 12] of string = ('January', 'February', 'March',
'April', 'May', 'June', 'July', 'August', 'September', 'October',
'November', 'December');

{$REGION 'Misc'}

function Piece(const S: string; Delim: char; PieceNum: Integer): string;
var
I: Integer;
Strt, Next: PChar;
begin
I := 1;
Strt := PChar(S);
Next := StrScan(Strt, Delim);
while (I < PieceNum) and (Next <> nil) do
begin
Inc(I);
Strt := Next + 1;
Next := StrScan(Strt, Delim);
end;
if Next = nil then
Next := StrEnd(Strt);
if I < PieceNum then
Result := ''
else
SetString(Result, Strt, Next - Strt);
end;

function FormatFMDateTime(AFormat: string; ADateTime: Double): string;
var
X: string;
Y, m, d, h, n, S: Integer;

function CharAt(const X: string; APos: Integer): char;
{ returns a character at a given position in a string or the null character if past the end }
begin
if Length(X) < APos then
Result := #0
else
Result := X[APos];
end;

function TrimFormatCount: Integer;
{ delete repeating characters and count how many were deleted }
var
c: char;
begin
Result := 0;
c := AFormat[1];
repeat
delete(AFormat, 1, 1);
Inc(Result);
until CharAt(AFormat, 1) <> c;
end;

begin { FormatFMDateTime }
Result := '';
if not(ADateTime > 0) then
Exit;
X := FloatToStrF(ADateTime, ffFixed, 15, 6) + '0000000';
Y := StrToIntDef(Copy(X, 1, 3), 0) + 1700;
m := StrToIntDef(Copy(X, 4, 2), 0);
d := StrToIntDef(Copy(X, 6, 2), 0);
h := StrToIntDef(Copy(X, 9, 2), 0);
n := StrToIntDef(Copy(X, 11, 2), 0);
S := StrToIntDef(Copy(X, 13, 2), 0);
while Length(AFormat) > 0 do
begin
case UpCase(AFormat[1]) of
'"':
begin // literal
delete(AFormat, 1, 1);
while not(CharInSet(CharAt(AFormat, 1), [#0, '"'])) do
begin
Result := Result + AFormat[1];
delete(AFormat, 1, 1);
end;
if CharAt(AFormat, 1) = '"' then
delete(AFormat, 1, 1);
end;
'D':
case TrimFormatCount of // day/date
1:
if d > 0 then
Result := Result + IntToStr(d);
2:
if d > 0 then
Result := Result + FormatFloat('00', d);
end;
'H':
case TrimFormatCount of // hour
1:
Result := Result + IntToStr(h);
2:
Result := Result + FormatFloat('00', h);
end;
'M':
case TrimFormatCount of // month
1:
if m > 0 then
Result := Result + IntToStr(m);
2:
if m > 0 then
Result := Result + FormatFloat('00', m);
3:
if m in [1 .. 12] then
Result := Result + MONTH_NAMES_SHORT[m];
4:
if m in [1 .. 12] then
Result := Result + MONTH_NAMES_LONG[m];
end;
'N':
case TrimFormatCount of // minute
1:
Result := Result + IntToStr(n);
2:
Result := Result + FormatFloat('00', n);
end;
'S':
case TrimFormatCount of // second
1:
Result := Result + IntToStr(S);
2:
Result := Result + FormatFloat('00', S);
end;
'Y':
case TrimFormatCount of // year
2:
if Y > 0 then
Result := Result + Copy(IntToStr(Y), 3, 2);
4:
if Y > 0 then
Result := Result + IntToStr(Y);
end;
else
begin // other
Result := Result + AFormat[1];
delete(AFormat, 1, 1);
end;
end; { case }
end;
end; { FormatFMDateTime }

function DateTimeToFMDateTime(ADateTime: TDateTime): Double;
var
Y, m, d, h, n, S, l: Word;
DatePart, TimePart: Integer;
begin
DecodeDate(ADateTime, Y, m, d);
DecodeTime(ADateTime, h, n, S, l);
DatePart := ((Y - 1700) * 10000) + (m * 100) + d;
TimePart := (h * 10000) + (n * 100) + S;
Result := DatePart + (TimePart / 1000000);
end;

function FilteredStringCP(const X: string; ATabWidth: Integer = 8): string;
var
I, J: Integer;
c: char;
begin
Result := '';
for I := 1 to Length(X) do
begin
c := X[I];
if c = #9 then
begin
for J := 1 to (ATabWidth - (Length(Result) mod ATabWidth)) do
Result := Result + ' ';
end
else if CharInSet(c, [#32 .. #127]) then
begin
Result := Result + c;
end
else if CharInSet(c, [#10, #13, #160]) then
begin
Result := Result + ' ';
end
else if CharInSet(c, [#128 .. #159]) then
begin
Result := Result + '?';
end
else if CharInSet(c, [#161 .. #255]) then
begin
Result := Result + X[I];
end;
end;

if Copy(Result, Length(Result), 1) = ' ' then
Result := TrimRight(Result) + ' ';
end;

procedure BreakUpLongLines(var SaveList: TStringList; BaseNode: String;
const OrigList: TStringList; BreakLimit: Integer);
const
BreakChars = [' ', '-'];
var
BrCnt, I, Z, LastBreakPos: Integer;
LineText: WideString;
BrokenUpList: TStringList;

begin

BrokenUpList := TStringList.Create;
try
BrCnt := 0;
for I := 0 to OrigList.Count - 1 do
begin
// break up long lines for the save
if Length(OrigList[I]) > BreakLimit then
begin
// break this line up
LineText := OrigList[I];

// loop through and break up line at FBreakUpLimit
while Length(LineText) > BreakLimit do
begin
Inc(BrCnt);
LastBreakPos := BreakLimit;

if not CharInSet(LineText[BreakLimit + 1], BreakChars) then
begin
for Z := BreakLimit downto 1 do
if LineText[Z] = ' ' then
begin
LastBreakPos := Z;
Break;
end;
end;

BrokenUpList.Add(BaseNode + ',' + IntToStr(BrCnt) + '=' +
FilteredStringCP(Copy(LineText, 1, LastBreakPos)));
LineText := Copy(LineText, LastBreakPos + 1, Length(LineText));

end;
// add any remainder
if Length(LineText) > 0 then
begin
Inc(BrCnt);
BrokenUpList.Add(BaseNode + ',' + IntToStr(BrCnt) + '=' +
FilteredStringCP(LineText));
end;
end
else
begin
Inc(BrCnt);
BrokenUpList.Add(BaseNode + ',' + IntToStr(BrCnt) + '=' +
FilteredStringCP(OrigList[I]));
end;

end;

// add our final line count
SaveList.Add(BaseNode + ',-1=' + IntToStr(BrCnt));
// Add our text
for I := 0 to BrokenUpList.Count - 1 do
SaveList.Add(BrokenUpList.Strings[I]);

finally
BrokenUpList.Free;
end;
end;

procedure BreakUpLongListLines(var aList: TStringList; BreakLimit: Integer);
const
BreakChars = [' ', '-'];
var
I, Z, LastBreakPos: Integer;
LineText: WideString;
WithWraps: TStringList;
begin
WithWraps := TStringList.Create;
try
for I := 0 to aList.Count - 1 do
begin
// break up long lines for the save
if Length(aList[I]) > BreakLimit then
begin
// WithWraps.Add( WrapText(aList[I], #13#10,BreakChars, BreakLimit));

// break this line up
LineText := aList[I];

// loop through and break up line at FBreakUpLimit
while Length(LineText) > BreakLimit do
begin
LastBreakPos := BreakLimit;

if not CharInSet(LineText[BreakLimit + 1], BreakChars) then
begin
for Z := BreakLimit downto 1 do
if LineText[Z] = ' ' then
begin
LastBreakPos := Z;
Break;
end;
end;

WithWraps.Add(FilteredStringCP(Copy(LineText, 1, LastBreakPos)));
LineText := Copy(LineText, LastBreakPos + 1, Length(LineText));

end;
// add any remainder
if Length(LineText) > 0 then
begin;
WithWraps.Add(FilteredStringCP(LineText));
end;
end
else
begin
WithWraps.Add(FilteredStringCP(aList[I]));
end;

end;
aList.Assign(WithWraps);
finally
WithWraps.Free;
end;

end;

procedure TrimBlankValueLines(const InList: TStrings; OutList: TStrings;
AllBlanks: Boolean = false);
var
I, X, Y, MainCnt, SubCnt, UpdateCnt, UpdateMain, UpdateCntMain: Integer;
StartCopy, txtFound: Boolean;
begin
OutList.Clear;

MainCnt := StrToIntDef(InList.Values['(0)'], 0);
UpdateMain := 1;
UpdateCntMain := 0;
for I := 1 to MainCnt do
begin
StartCopy := false;
UpdateCnt := 0;
SubCnt := StrToIntDef(InList.Values['(' + IntToStr(I) + ',0)'], 0);

for X := 1 to SubCnt do
begin
if AllBlanks then
StartCopy := false;

If Trim(InList.Values['(' + IntToStr(I) + ',' + IntToStr(X) + ')']) <> ''
then
StartCopy := true;

if not AllBlanks then
begin
if StartCopy then
begin
// Look ahead for text
txtFound := false;
for Y := X + 1 to SubCnt do
begin
if Trim(InList.Values['(' + IntToStr(I) + ',' + IntToStr(Y) + ')'])
<> '' then
begin
// We found text so we know we are not at the end
txtFound := true;
Break;
end;

end;

// the rest is blank so we are done adding
if not txtFound then
begin
Inc(UpdateCnt);
OutList.Add('(' + IntToStr(UpdateMain) + ',' + IntToStr(UpdateCnt) +
')=' + InList.Values['(' + IntToStr(I) + ',' +
IntToStr(X) + ')']);

Break;
end;
end;
end;

if StartCopy then
begin
Inc(UpdateCnt);
OutList.Add('(' + IntToStr(UpdateMain) + ',' + IntToStr(UpdateCnt) +
')=' + InList.Values['(' + IntToStr(I) + ',' + IntToStr(X) + ')']);
end;

end;
if UpdateCnt > 0 then
begin
OutList.Add('(' + IntToStr(UpdateMain) + ',0)=' + IntToStr(UpdateCnt));
Inc(UpdateMain);
Inc(UpdateCntMain);
end;
end;
OutList.Add('(0)=' + IntToStr(UpdateCntMain));
end;

procedure TrimBlankLines(const InList: TStrings; OutList: TStrings;
AllBlanks: Boolean = false);
var
I, X: Integer;
StartCopy, txtFound: Boolean;
begin
{ if CheckValuesOnly then
begin
if Trim(InList.ValueFromIndex[i]) <> '' then
StartCopy := True
end }
OutList.Clear;

StartCopy := false;
for I := 0 to InList.Count - 1 do
begin
if AllBlanks then
StartCopy := false;

if Trim(InList.Strings[I]) <> '' then
StartCopy := true;

if not AllBlanks then
begin
if StartCopy then
begin
// Look ahead for text
txtFound := false;
for X := I + 1 to InList.Count - 1 do
begin
if Trim(InList.Strings[X]) <> '' then
begin
// We found text so we know we are not at the end
txtFound := true;
Break;
end;

end;

// the rest is blank so we are done adding
if not txtFound then
begin
OutList.Add(InList.Strings[I]);
Break;
end;
end;
end;

if StartCopy then
OutList.Add(InList.Strings[I])
end;

end;

function DelimCount(const Str, Delim: string): Integer;
var
I, dlen, slen: Integer;

begin
Result := 0;
I := 1;
dlen := Length(Delim);
slen := Length(Str) - dlen + 1;
while (I <= slen) do
begin
if (Copy(Str, I, dlen) = Delim) then
begin
Inc(Result);
Inc(I, dlen);
end
else
Inc(I);
end;
end;

function Pieces(const S: string; Delim: char;
FirstNum, LastNum: Integer): string;
{ returns several contiguous pieces }
var
PieceNum: Integer;
begin
Result := '';
for PieceNum := FirstNum to LastNum do
Result := Result + Piece(S, Delim, PieceNum) + Delim;
if Length(Result) > 0 then
delete(Result, Length(Result), 1);
end;

procedure SetPiece(var X: string; Delim: char; PieceNum: Integer;
const NewPiece: string);
{ sets the Nth piece (PieceNum) of a string to NewPiece, adding delimiters as necessary }
var
I: Integer;
Strt, Next: PChar;
begin
I := 1;
Strt := PChar(X);
Next := StrScan(Strt, Delim);
while (I < PieceNum) and (Next <> nil) do
begin
Inc(I);
Strt := Next + 1;
Next := StrScan(Strt, Delim);
end;
if Next = nil then
Next := StrEnd(Strt);
if I < PieceNum then
X := X + StringOfChar(Delim, PieceNum - I) + NewPiece
else
X := Copy(X, 1, Strt - PChar(X)) + NewPiece + StrPas(Next);
end;

procedure SetPieces(var X: string; Delim: char; Pieces: Array of Integer;
FromString: string);
var
I: Integer;

begin
for I := low(Pieces) to high(Pieces) do
SetPiece(X, Delim, Pieces[I], Piece(FromString, Delim, Pieces[I]));
end;

procedure StatusText(const S: string);
{ sends a user defined message to the main window of an application to display the text
found in lParam. Only useful if the main window has message event for this message }
begin
if (Application.MainForm <> nil) and (Application.MainForm.HandleAllocated)
then
SendMessage(Application.MainForm.Handle, UM_STATUSTEXT, 0,
Integer(PChar(S)));
end;

{$ENDREGION}
{$REGION 'TStopWatch'}

Const
NSecsPerSec = 1000000000;

constructor TStopWatch.Create(AOwner: TComponent;
const IsActive: Boolean = false; const startOnCreate: Boolean = false);
begin
inherited Create();
FOwner := AOwner;
fIsRunning := false;
fActive := IsActive;
fIsHighResolution := QueryPerformanceFrequency(fFrequency);
if NOT fIsHighResolution then
fFrequency := MSecsPerSec;

if startOnCreate then
Start;
end;

destructor TStopWatch.Destroy;
begin
Stop;
inherited Destroy;
end;

function TStopWatch.GetElapsedTicks: TLargeInteger;
begin
Result := fStopCount - fStartCount;
end;

procedure TStopWatch.SetTickStamp(var lInt: TLargeInteger);
begin
if fIsHighResolution then
QueryPerformanceCounter(lInt)
else
lInt := MilliSecondOf(Now);
end;

function TStopWatch.GetElapsed: string;
begin
Result := FloatToStr(ElapsedMilliseconds / 1000) + ' Sec / ' +
FloatToStr(ElapsedMilliseconds) + ' Ms / ' +
FloatToStr(ElapsedNanoSeconds) + ' Ns';
end;

function TStopWatch.GetElapsedMilliseconds: TLargeInteger;
var
Crnt: TLargeInteger;
begin
if fIsRunning then
begin
SetTickStamp(Crnt);
Result := (MSecsPerSec * (Crnt - fStartCount)) div fFrequency;
end
else
Result := (MSecsPerSec * (fStopCount - fStartCount)) div fFrequency;
end;

function TStopWatch.GetElapsedNanoSeconds: TLargeInteger;
begin
Result := (NSecsPerSec * (fStopCount - fStartCount)) div fFrequency;
end;

procedure TStopWatch.Start;
begin
if fActive then
begin
SetTickStamp(fStartCount);
fIsRunning := true;
end;
end;

procedure TStopWatch.Stop;
begin
if fActive then
begin
SetTickStamp(fStopCount);
fIsRunning := false;
end;
end;
{$ENDREGION}
{$REGION 'TLogComponent'}

constructor TLogComponent.Create(AOwner: TComponent);
begin
inherited Create();
FOwner := AOwner;
FCriticalSection := TCriticalSection.Create;
end;

destructor TLogComponent.Destroy;
begin
FCriticalSection.Free;
inherited Destroy;
end;

function TLogComponent.Dump(Instance: TPasteArray): string;
var
I: Integer;

function DumpRecordPasteRec(RecToUse: TPasteText): String;
var
X, Y: Integer;
begin
Result := '[RecToUse.CopiedFromApplication]: ' +
RecToUse.CopiedFromApplication;
Result := Result + #13#10 + '[RecToUse.CopiedFromAuthor]: ' +
RecToUse.CopiedFromAuthor;
Result := Result + #13#10 + '[RecToUse.CopiedFromDocument]: ' +
RecToUse.CopiedFromDocument;
Result := Result + #13#10 + '[RecToUse.CopiedFromLocation]: ' +
RecToUse.CopiedFromLocation;
Result := Result + #13#10 + '[RecToUse.CopiedFromPatient]: ' +
RecToUse.CopiedFromPatient;
Result := Result + #13#10 + '[RecToUse.DateTimeOfPaste]: ' +
RecToUse.DateTimeOfPaste;
Result := Result + #13#10 + '[RecToUse.DateTimeOfOriginalDoc]: ' +
RecToUse.DateTimeOfOriginalDoc;
Result := Result + #13#10 + '[RecToUse.GroupItems]';
for X := Low(RecToUse.GroupItems) to High(RecToUse.GroupItems) do
begin
with RecToUse.GroupItems[X] do
begin
Result := Result + #13#10#9 + '[GroupParent]' + BoolToStr(GroupParent);
Result := Result + #13#10#9 + '[GroupText]' + GroupText.Text;
Result := Result + #13#10#9 + '[GroupParent]' + IntToStr(ItemIEN);
Result := Result + #13#10#9 + '[VisibleOnNote]' +
BoolToStr(VisibleOnNote);
Result := Result + #13#10#9 + '[HiglightLines]:';
for Y := Low(HiglightLines) to High(HiglightLines) do
begin
Result := Result + #13#10#9#9 + '[LineToHighlight]: ' + HiglightLines
[Y].LineToHighlight;
Result := Result + #13#10#9#9 + '[LineToHighlight]: ' +
BoolToStr(HiglightLines[Y].AboveWrdCnt);
end;
end;
end;
Result := Result + #13#10 + '[HiglightLines]:';
for Y := Low(RecToUse.HiglightLines) to High(RecToUse.HiglightLines) do
begin
Result := Result + #13#10#9 + '[LineToHighlight]: ' +
RecToUse.HiglightLines[Y].LineToHighlight;
Result := Result + #13#10#9 + '[LineToHighlight]: ' +
BoolToStr(RecToUse.HiglightLines[Y].AboveWrdCnt);
end;
Result := Result + #13#10 + '[RecToUse.IdentFired]: ' +
BoolToStr(RecToUse.IdentFired);
Result := Result + #13#10 + '[RecToUse.InfoPanelIndex]: ' +
IntToStr(RecToUse.InfoPanelIndex);

if RecToUse.Status = PasteNew then
Result := Result + #13#10 + '[RecToUse.Status]: PasteNew'
else if RecToUse.Status = PasteModify then
Result := Result + #13#10 + '[RecToUse.Status]: PasteModify'
else if RecToUse.Status = PasteNA then
Result := Result + #13#10 + '[RecToUse.Status]: PasteNA';

if Assigned(RecToUse.OriginalText) then
Result := Result + #13#10 + '[RecToUse.OriginalText]: ' +
RecToUse.OriginalText.Text;
Result := Result + #13#10 + '[RecToUse.PasteDBID]: ' +
IntToStr(RecToUse.PasteDBID);
Result := Result + #13#10 + '[RecToUse.PastedPercentage]: ' +
RecToUse.PastedPercentage;
Result := Result + #13#10 + '[RecToUse.PastedText]: ' +
RecToUse.PastedText.Text;
Result := Result + #13#10 + '[RecToUse.UserWhoPasted]: ' +
RecToUse.UserWhoPasted;
Result := Result + #13#10 + '[RecToUse.VisibleOnList]: ' +
BoolToStr(RecToUse.VisibleOnList);
Result := Result + #13#10 + '[RecToUse.VisibleOnNote]: ' +
BoolToStr(RecToUse.VisibleOnNote);
end;

begin
Result := '';
for I := Low(Instance) to High(Instance) do
Result := Result + '(' + IntToStr(I) + ')' + DumpRecordPasteRec(Instance[I]
) + #13#10;
end;

function TLogComponent.GetLogFileName(): String;
Var
OurLogFile, LocalOnly, AppDir: string;

// Finds the users special directory
function LocalAppDataPath: string;
const
SHGFP_TYPE_CURRENT = 0;
var
path: array [0 .. MaxChar] of char;
begin
SHGetFolderPath(0, CSIDL_LOCAL_APPDATA, 0, SHGFP_TYPE_CURRENT, @path[0]);
Result := StrPas(path);
end;

begin
OurLogFile := LocalAppDataPath;
if (Copy(OurLogFile, Length(OurLogFile), 1) <> '\') then
OurLogFile := OurLogFile + '\';

LocalOnly := OurLogFile;

// Now set the application level
OurLogFile := OurLogFile + ExtractFileName(Application.ExeName);
if (Copy(OurLogFile, Length(OurLogFile), 1) <> '\') then
OurLogFile := OurLogFile + '\';
AppDir := OurLogFile;

// try to create or use base direcrtory
if not DirectoryExists(AppDir) then
if not ForceDirectories(AppDir) then
OurLogFile := LocalOnly;

OurLogFile := OurLogFile + 'CPRS_' + IntToStr(GetCurrentProcessID)
{ FormatDateTime('hhmmsszz', now) } + '_CopyPaste.TXT';

Result := OurLogFile;
end;

procedure TLogComponent.LogText(Action, MessageTxt: string);
const
PadLen: Integer = 18;
VAR
AddText: TStringList;
FS: TFileStream;
Flags: Word;
X, CenterPad: Integer;
TextToAdd, Suffix, Suffix2: String;
begin
FCriticalSection.Acquire;
try
if Trim(fOurLogFile) = '' then
fOurLogFile := GetLogFileName;

If FileExists(fOurLogFile) then
Flags := fmOpenReadWrite
else
Flags := fmCreate;

AddText := TStringList.Create;
try
AddText.Text := MessageTxt;

if UpperCase(Action) = 'TEXT' then
begin
Suffix := FormatDateTime('hh:mm:ss', Now) + ' [' +
UpperCase(Action) + ']';
for X := 1 to AddText.Count - 1 do
begin
Suffix2 := '[' + IntToStr(X) + ' of ' +
IntToStr(AddText.Count - 1) + ']';
// center text
CenterPad := round((PadLen - Length(Suffix2)) / 2);
Suffix2 := StringOfChar(' ', CenterPad) + Suffix2;
AddText.Strings[X] := Suffix2.PadRight(PadLen) + ' - ' +
AddText.Strings[X];
end;
end
else
begin
Suffix := FormatDateTime('hh:mm:ss', Now) + ' [' +
UpperCase(Action) + ']';
if AddText.Count > 1 then
begin
Suffix2 := FormatDateTime('hh:mm:ss', Now) + ' [' +
StringOfChar('^', Length(Action)) + ']';
for X := 1 to AddText.Count - 1 do
AddText.Strings[X] := Suffix2.PadRight(PadLen) + ' - ' +
AddText.Strings[X];
end;
end;
TextToAdd := Suffix.PadRight(PadLen) + ' - ' + AddText.Text;

FS := TFileStream.Create(fOurLogFile, Flags);
try
FS.Position := FS.Size;
FS.Write(TextToAdd[1], Length(TextToAdd) * SizeOf(char));
finally
FS.Free;
end;
finally
AddText.Free;
end;
finally
FCriticalSection.Release;
end;
end;

{$ENDREGION}

end.