type//DAS IST DER RECORD DER DANN NICHT MEHR "GÜLTIG IST" orso...
TDaPrtData =
record
Typ: TDaPrtMsgType;
Msg:
String;
Cls: ShortString;
Code: Integer;
SQL:
String;
Details:
String;
DoId: Integer;
ConfigId: Integer;
end;
//This is based on the example found in the indy newsgroup
TLog =
class(TIdSync)
protected
FPrtData: TDaPrtData;
procedure DoSynchronize;
override;
constructor Create(
const APrtData: TDaPrtData);
public
class procedure Add(
const APrtData: TDaPrtData);
overload;
end;
//---------------------------------------------------//
//------------------------ TLog ---------------------//
constructor TLog.Create(
const APrtData: TDaPrtData);
begin
FPrtData := APrtData;
//SOLLTE DOCH AUSREICHEN, ODER? VARS WERDEN
inherited Create;
//DOCH BEI DER ZUWEISEUNG KOPIERT, ODER NICHT?
end;
procedure TLog.DoSynchronize;
var
lFileStream: TFileStream;
lMode: Word;
lString:
String;
procedure TruncateStream;
var
Buffer: TMemoryStream;
c, n1, n2, Len: Int64;
begin
Buffer := TMemoryStream.Create;
try
Buffer.Size := konPrtLowFileSize;
lFileStream.Position := lFileStream.Position - konPrtLowFileSize;
Len := Buffer.CopyFrom(lFileStream, konPrtLowFileSize);
Buffer.Position := 0;
lFileStream.Position := 0;
//TODO 1: Alternative. Works but sure slow??
lFileStream.Size := 0;
lFileStream.Size := konPrtLowFileSize;
lFileStream.Position := 0;
lFileStream.CopyFrom(Buffer, Len);
QueryPerformanceCounter(n2);
OutputDebugString(PChar(FloatToStr(n2-n1/c, formatSet)));
finally
Buffer.Free;
end;
end;
procedure LogToScreen;
begin
try
frmProt.memLog.Lines.BeginUpdate;
if frmProt.memLog.Lines.Count > frmProt.PrtOptions.PrtSize
then begin
while frmProt.memLog.Lines.Count > frmProt.PrtOptions.PrtSize-50
do//Cut off 50 Lines
frmProt.memLog.Lines.Delete(0);
frmProt.memLog.Lines.Add('
$$$'+konPrtColDel+DateTimeToStr(Now, formatSet)+'
LOG TRUNCATE'+konPrtLineDel);
end;
frmProt.memLog.Lines.Add(lString);
// if True{Optionen_Form.miscAutoScrollLog }then begin
frmProt.memLog.Perform(EM_LINESCROLL, 0, frmProt.memLog.Lines.Count);
// end;
frmProt.memLog.Lines.EndUpdate;
except
frmProt.PrtOptions.AbledPrtModes := frmProt.PrtOptions.AbledPrtModes -
[pmScreen];
end;
end;
//procedure LogToScreen
procedure LogToFile;
begin
try
if FileExists(frmProt.PrtOptions.PrtFileName)
then
lMode := fmOpenReadWrite
or fmShareDenyWrite
else
lMode := fmCreate;
lFileStream := TFileStream.Create(frmProt.PrtOptions.PrtFileName, lMode);
try
if lMode <> fmCreate
then
lFileStream.Seek(0, soFromEnd);
lFileStream.
Write(LString[1], Length(lString));
lFileStream.
Write(sLineBreak, Length(sLineBreak));
// <-- sLineBreak is defined by VCL
if lFileStream.Size > konPrtHighFileSize
then begin
TruncateStream;
end;
finally
lFileStream.Free;
end;
except
frmProt.PrtOptions.AbledPrtModes := frmProt.PrtOptions.AbledPrtModes -
[pmFile];
end
end;
//procedure LogToFile
begin
lString := '
';
try //DIE TRY-EXCEPTS DIENTEN DER FEHLERSUCHE. UNTER UNBEKANNTEN
//UMSTÄNDEN KOMMEN HIER BEIM ZUGRIFF AUF FPrtData AVs!
//(VLLT WENN TLog.Add() VON 2 THREAD GLEICHZEITIG AUFGERUFEN WIRD?)
case FPrtData.Typ
of
pmtInformation: lString := '
###' + konPrtColDel;
pmtConfirmation: lString := '
???' + konPrtColDel;
pmtWarning: lString := '
x!x' + konPrtColDel;
pmtError: lString := '
XXX' + konPrtColDel;
end;
except
on e:
exception do begin
MessageBeep(MB_ICONERROR);
ShowMessage(e.
Message+#13#10+e.ClassName);
end;
end;
//Using a formatSetting var it is thread save.
try
lString := lString + DateTimeToStr(Now, formatSet) + konPrtColDel +
FPrtData.Msg + konPrtColDel + FPrtData.Cls + konPrtColDel + FPrtData.SQL + konPrtColDel +
FPrtData.Details + konPrtColDel + IntToStr(FPrtData.DoId) + konPrtColDel +
IntToStr(FPrtData.ConfigId) +
konPrtLineDel;
//2006_01_29 We need a Line-Delimiter cause of multiline prt entries!
except
on e:
exception do begin
MessageBeep(MB_ICONERROR);
ShowMessage(e.
Message+#13#10+e.ClassName);
end;
end;
try
case frmProt.PrtOptions.PrtUsage
of
cbChecked:
begin
if pmScreen
in frmProt.PrtOptions.AbledPrtModes
then
// LogToScreen; //REMED OUT FORM DEBUGGING PURPOSES
if pmFile
in frmProt.PrtOptions.AbledPrtModes
then
// LogToFile; //REMED OUT FORM DEBUGGING PURPOSES
end;
cbGrayed:
begin
if pmScreen
in frmProt.PrtOptions.AbledPrtModes
then
// LogToScreen; //REMED OUT FORM DEBUGGING PURPOSES
end;
cbUnchecked:;
//nothing
end;
//case cbUseProt.State
except
on e:
exception do begin
MessageBeep(MB_ICONERROR);
ShowMessage(e.
Message+#13#10+e.ClassName);
end;
end;
end;
class procedure TLog.Add(
const APrtData: TDaPrtData);
begin
with TLog.Create(APrtData)
do try
Synchronize;
finally
Free;
end;
end;
class procedure TLog.Add(
const AStr:
String);
var
LPrtData: TDaPrtData;
begin
FillChar(LPrtData, SizeOf(LPrtData), #0);
LPrtData.Msg := AStr;
with TLog.Create(LPrtData)
do try
Synchronize;
finally
Free;
end;
end;
//------------------------ TLog ---------------------//
//---------------------------------------------------//