I have a memory problem with TBgraBitmap in combination with the barcode detection ZXING in Lazarus. Does anyone see my problem?
After resize the image for a better detection, the memory grows and grows.
It works, but it crashes because of running as a 32-bit assembly. I work with ca. 10 source tifs in color scanned mode and 300 dpi.
unit frmmain;
{$IFDEF FPC}
//{$mode objfpc}{$H+}
{$mode delphi}{$H+}
{$ENDIF}
interface
uses
{$ifdef FPC}
LResources,
{$endif}
{$ifdef MSWindows}Windows, {$endif}
Classes, SysUtils, Forms, Controls, Graphics, Dialogs, ComCtrls,
StdCtrls, ExtCtrls, Clipbrd, Buttons, fpimage,
Generics.Collections,
ZXing.ReadResult,
ZXing.BarCodeFormat,
ZXing.DecodeHintType,
ZXing.ResultPoint,
ZXing.Scanmanager,
UConvert, dateutils,
{zum Vergrößern }BgraBitmap, BGRABitmapTypes,
{für enum namen}typinfo;
type
{ TMainForm }
TMainForm = class(TForm)
Button1: TButton;
Button2: TButton;
Image1: TImage;
Label1: TLabel;
Label2: TLabel;
ListBoxFiles: TListBox;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure ListBoxFilesClick(Sender: TObject);
private
function GetAppPath(): string;
function GetFiles(LPfad: string): TStringList;
function Resample(Src: string; percent: integer): TBitmap;
public
end;
var
MainForm: TMainForm;
maxZoom: integer;
implementation
{$R *.lfm}
{ TMainForm }
procedure TMainForm.Button1Click(Sender: TObject);
var
scanner: TScanmanager;
readResult: TReadResult;
barcodeInt, zoom: integer;
// pic: TPicture;
bmp: TBitmap;
begin
Button1.Enabled := False;
ListBoxFiles.Enabled := False;
application.ProcessMessages;
zoom := 100;
while zoom <= 180 do
begin
//erkennen
bmp := Resample(Label2.Caption, zoom);
scanner := TScanmanager.Create(TBarcodeFormat.QR_CODE, nil); //TBarcodeFormat.auto
readResult := scanner.Scan(bmp);
//free mem
FreeAndNil(bmp);
//free mem
FreeAndNil(scanner);
application.ProcessMessages;
if readResult <> nil then
begin
barcodeInt := Ord(readResult.BarcodeFormat);
{barcodeTypeStr := TypInfo.GetEnumName(
System.TypeInfo(ZXing.BarCodeFormat.TBarcodeFormat), barcodeInt);
}
Text := 'Zoom: ' + IntToStr(zoom) + ' : ' + readResult.Text +
' Code: ' + IntToStr(barcodeInt);
if zoom > maxZoom then
maxZoom := zoom;
break;
end
else
Text := 'Zoom: ' + IntToStr(zoom) + '-';
zoom := zoom + 10;
application.ProcessMessages;
//free mem
FreeAndNil(readResult);
end;
//show result
Label1.Caption := 'Max. Zoom: ' + IntToStr(maxzoom);
Button1.Enabled := True;
ListBoxFiles.Enabled := True;
end;
function TMainForm.Resample(Src: string; percent: integer): TBitmap;
var
Width, Height: integer;
reSampleBitmap: TBgraBitmap;
pic: TPicture;
begin
//if percent = 100 then
//begin
// Result := TBitmap.Create;
// Result.Assign(Src);
// exit;
//end;
// reSampleBitmap := TBgraBitmap.Create();
// reSampleBitmap.LoadFromFile(Src);
pic := TPicture.Create;
pic.LoadFromFile(src);
reSampleBitmap := TBgraBitmap.Create(pic.Bitmap);
Width := round(reSampleBitmap.Height * percent / 100);
Height := round(reSampleBitmap.Height * percent / 100);
reSampleBitmap.ResampleFilter := rfBestQuality;
reSampleBitmap := reSampleBitmap.Resample(Width, Height);// as TBGRABitmap;
Result := TBitmap.Create;
Result.Assign(reSampleBitmap);
FreeAndNil(reSampleBitmap);
FreeAndNil(pic);
end;
procedure TMainForm.Button2Click(Sender: TObject);
var
i: integer;
begin
maxZoom := 0;
for i := 0 to ListBoxFiles.Count - 1 do
begin
ListBoxFiles.ClearSelection;
ListBoxFiles.Selected[i] := True;
ListBoxFilesClick(self);
end;
end;
procedure TMainForm.ListBoxFilesClick(Sender: TObject);
var
fullFilename: string;
obj: TObject;
bmp: TPicture;
begin
obj := ListBoxFiles.Items.Objects[ListBoxFiles.ItemIndex];
if obj <> nil then
begin
fullfilename := string(obj);
Label2.Caption := fullfilename;
bmp := TPicture.Create;
bmp.LoadFromFile(fullfilename);
Image1.Picture.Assign(bmp);
FreeAndNil(bmp);
obj := nil;
Button1Click(self);
end;
end;
procedure TMainForm.FormCreate(Sender: TObject);
var
sourceFolder, fileName: string;
files: TStringList;
i: integer;
begin
ListBoxFiles.Clear;
Label2.Caption := '';
maxZoom := 100;
sourceFolder := GetAppPath() + 'Tifs\';
//D:\EigeneDateien\Lazarus\ZXing\Tifs
files := Getfiles(sourcefolder);
for i := 0 to files.Count - 1 do
begin
fileName := ExtractFileName(files[i]);
ListBoxFiles.AddItem(fileName, TObject(files[i]));
end;
end;
function TMainForm.GetFiles(LPfad: string): TStringList;
var
LSearchRec: TSearchRec;
begin
Result := TStringList.Create;
if FindFirst(LPfad + '*.*', faAnyFile, LSearchRec) = 0 then
begin
repeat
if LSearchRec.Attr and faDirectory = 0 then
begin
Result.Add(LPfad + LSearchRec.Name);
end;
until FindNext(LSearchRec) <> 0;
FindClose(LSearchRec);
end;
end;
function TMainForm.GetAppPath(): string;
var
appDir: string;
begin
appDir := ExpandFileName(ExtractFileDir(Application.ExeName));
appDir := IncludeTrailingPathDelimiter(appDir);
Result := appDir;
end;
end.
Related
I have an Indy TCPServer that connects a device with several clients.
When device-data arrives, the server sends it to every client.
When client-data arrives, it is sent to the device. (And the device will send it to the server again (echo)).
I only process 2 bytes per cycle.
The above works perfect.
Now i want to process/save that data.
Only when data arrives via the device port, i want to 'Translate' the data.
I need to save the data to a clientdatset.
Then i want to take the bytes apart and compare them with som other info
...
The translated data is also saved in another clientdataset.
unit BusServer;
interface
uses
Winapi.Windows, Winapi.Messages,
System.SysUtils, System.Classes, System.Variants,
Vcl.Graphics, Vcl.Controls, Vcl.SvcMgr, Vcl.Dialogs,
IdContext, IdAntiFreezeBase, IdAntiFreeze, IdBaseComponent, IdComponent,
IdCustomTCPServer, IdTCPServer,
Data.DB, Datasnap.DBClient;
type
TBus_Server = class(TService)
tcpBusDataServer: TIdTCPServer;
IdAntiFreeze1: TIdAntiFreeze;
cdsBusMonitor: TClientDataSet;
cdsBusMonitorNr: TIntegerField;
cdsBusMonitorDate: TStringField;
cdsBusMonitorTime: TStringField;
cdsBusMonitorAad: TIntegerField;
cdsBusMonitorAgr: TIntegerField;
cdsBusMonitorAName: TStringField;
cdsBusMonitorAFct: TStringField;
cdsBusMonitorOrigin: TStringField;
cdsIncoming: TClientDataSet;
cdsMemberState: TClientDataSet;
cdsMemberStateMemberID: TStringField;
cdsMemberStateState: TStringField;
cdsMemberStateDateTime: TDateTimeField;
cdsMemberStateTotaal: TFloatField;
procedure tcpBusDataServerExecute(AContext: TIdContext);
procedure ServiceCreate(Sender: TObject);
private
{ Private declarations }
functionmon: String;
DevicePort: Integer;
ClientPort: Integer;
ClientLSB, ClientMSB: Byte;
DeviceLSB, DeviceMSB: Byte;
FunctionList: TStringList;
procedure TranslateData;
function CodeValue: String;
public
function GetServiceController: TServiceController; override;
{ Public declarations }
end;
var
Bus_Server: TBus_Server;
implementation
uses
CodesiteLogging;
{$R *.dfm}
procedure ServiceController(CtrlCode: DWord); stdcall;
begin
Bus_Server.Controller(CtrlCode);
end;
function TBus_Server.CodeValue: String;
begin
if (cdsIncoming.FieldbyName('MemberType').AsInteger = 11) or
(cdsIncoming.FieldbyName('MemberType').AsInteger = 22)or
(cdsIncoming.FieldbyName('MemberType').AsInteger = 33) then
begin
Result := FunctionMon
end
else
begin
// TODO:
end
end;
function TBus_Server.GetServiceController: TServiceController;
begin
Result := ServiceController;
end;
procedure TBus_Server.ServiceCreate(Sender: TObject);
var
DataSetName: String;
begin
DevicePort := 10001;
ClientPort := 10012;
tcpBusDataServer.Bindings.Clear;
tcpBusDataServer.Bindings.Add.Port := DevicePort;
tcpBusDataServer.Bindings.Add.Port := ClientPort;
tcpBusDataServer.Active := True;
FunctionList := TStringList.Create;
FunctionList.Add('Null');
FunctionList.Add('Reset');
FunctionList.Add('Toggle');
FunctionList.Add('Set');
FunctionList.Add('Misc');
FunctionList.Add('Status');
FunctionList.Add('Timer/Direct');
FunctionList.Add('Value');
FunctionList.Add('Dimmer');
FunctionList.Add('Readout');
FunctionList.Add('Teller');
FunctionList.Add('System');
FunctionList.Add('Settings');
FunctionList.Add('Select');
FunctionList.Add('Data');
FunctionList.Add('Program');
ForceDirectories('c:\Test\');
DataSetName := 'c:\Test\BusMonitor' + FormatDateTime('YYYY-MM-DD', Now) + '.xml';
if cdsBusMonitor.Active then
cdsBusMonitor.Close;
cdsBusMonitor.Filename := DataSetName;
if not System.SysUtils.FileExists(DataSetName) then
begin
cdsBusMonitor.CreateDataSet;
cdsBusMonitor.SaveToFile
end;
DataSetName := 'c:\Test\MemberState' + FormatDateTime('YYYY-MM-DD', Now) + '.xml';
if cdsMemberState.Active then
cdsMemberState.Close;
cdsMemberState.Filename := DataSetName;
if not System.SysUtils.FileExists(DataSetName) then
begin
cdsMemberState.CreateDataSet;
cdsMemberState.SaveToFile
end;
end;
procedure TBus_Server.tcpBusDataServerExecute(AContext: TIdContext);
var
Ctx: TIdContext;
List: TList;
begin
if AContext.Binding.Port = ClientPort then // Client
begin
DeviceLSB := AContext.Connection.IOHandler.ReadByte;
DeviceMSB := AContext.Connection.IOHandler.ReadByte;
List := tcpBusDataServer.Contexts.LockList;
try
for var i := 0 to List.count - 1 do
begin
Ctx := TIdContext(List[I]);
if (Ctx <> AContext) and (Ctx.Binding.Port = DevicePort) then
begin
Ctx.Connection.IOHandler.Write(DeviceLSB);
Ctx.Connection.IOHandler.Write(DeviceMSB);
// Since only 1 has to be written to
Break
end
end
finally
tcpBusDataServer.Contexts.UnlockList
end
end
else
begin
if AContext.Binding.Port = DevicePort then // Device
begin
ClientLSB := AContext.Connection.IOHandler.ReadByte;
ClientMSB := AContext.Connection.IOHandler.ReadByte;
List := tcpBusDataServer.Contexts.LockList;
try
for var i := 0 to List.count - 1 do
begin
Ctx := TIdContext(List[I]);
if (Ctx <> AContext) and (Ctx.Binding.Port = ClientPort) then
begin
Ctx.Connection.IOHandler.Write(ClientLSB);
Ctx.Connection.IOHandler.Write(ClientMSB)
end
end
finally
TIdNotify.NotifyMethod(TranslateData);
tcpBusDataServer.Contexts.UnlockList
end
end
end
end;
procedure TBus_Server.TranslateData;
const {$J+}
LastSave: TDateTime = 0;
type
TProgramState = (psNone,psProgram,psIgnore1,psIgnore2);
const
ProgramState: TProgramState = psNone;
const
ValueMode: Boolean = False;
var
i: Integer;
fct: Integer;
GroupMon: Integer;
AddressMon: Integer;
CorrecteSettings: Boolean;
TmpStr: String;
begin
fct := 0;
// Functie uit MSB halen
if ClientMSB >= 128 then
begin
ClientMSB := ClientMSB - 128;
fct := 8
end;
if ClientMSB >= 64 then
begin
ClientMSB := ClientMSB - 64;
fct := fct + 4
end;
if ClientMSB >= 32 then
begin
ClientMSB := ClientMSB - 32;
fct := fct + 2
end;
if ClientMSB >= 16 then
begin
ClientMSB := ClientMSB - 16;
fct := fct + 1
end;
// Variabelen voor monitor bepalen
functionMon := FunctionList[fct];
if cdsBusMonitor.Active then
begin
cdsBusMonitor.Filtered := False;
cdsBusMonitor.Append;
cdsBusMonitor.FieldByName('Nr').AsInteger := cdsBusMonitor.RecordCount + 1;
cdsBusMonitor.FieldByName('AFct').Asstring := functionMon;
cdsBusMonitor.FieldByName('Aad').AsInteger := ClientLSB;
cdsBusMonitor.FieldByName('Agr').AsInteger := ClientMSB;
cdsBusMonitor.FieldByName('Time').Asstring := TimeToStr(Now);
cdsBusMonitor.FieldByName('Origin').AsString := 'Van de Bus: '{ + UserPeerIP};
cdsBusMonitor.Post;
end;
if ProgramState = psNone then
begin
CodeSite.Send('New situation...');
try
if cdsIncoming.Locate('Group;Address', VarArrayOf([IntToStr(DeviceMsb),IntToStr(DeviceLsb)]), []) then
begin
CodeSite.Send('After locate...');
if cdsMemberState.Locate('MemberID', cdsIncoming.FieldByName('MemberID').AsString, []) then
cdsMemberState.Edit
else
cdsMemberState.Append;
if cdsMemberStateState.AsString = Codevalue then
begin
CodeSite.Send('New state ' + Codevalue + ' already known');
cdsMemberState.Cancel
end
else
begin
CodeSite.Send('New state ' + Codevalue);
cdsMemberStateState.AsString := Codevalue;
if Codevalue.ToLower = 'reset' then
cdsMemberStateTotaal.AsFloat := cdsMemberStateTotaal.AsFloat + (Now - cdsMemberStateDateTime.AsDateTime);
cdsMemberStateDateTime.AsDateTime := Now;
cdsMemberState.Post
end
end
else
CodeSite.SendError('ServerMethodsBServer.cdsIncoming Locate Fail');
except
on E: Exception do
CodeSite.SendException(E);
end
end;
if ((cdsBusMonitor.RecordCount mod 100) = 0) or ((Now - LastSave) > (1/24/60)) then
begin
LastSave := Now;
cdsBusMonitor.MergeChangeLog;
cdsBusMonitor.SaveToFile;
cdsMemberState.MergeChangeLog;
cdsMemberState.SaveToFile
end
end;
In the clientdataset, i occasionally see "wrong data", meaning:
First i have a correct record, followed by a record with the same lsb and a wrong msb.
I split up the msb in the procedure(Translatedata) in a 'high nibble' and a 'low nibble'.
So now i'm trying to find out where this comes from.
As you can see in my code i call the procedure via TIdNotify.NotifyMethod(TranslateData);
Is this te correct way?
Could appending/posting data in a clientdataset (whilst in the serverthread) be a problem?
Is this a timing issue?
Has anyone an idea of what could be wrong?
Your code is not very thread-safe. You are not protecting your data values from concurrent access across thread boundaries, if multiple clients send data to the server at the same time.
Also, you should not be doing all of your service initializations in the OnCreate event, use the OnStart event instead. The OnCreate event is triggered whenever your TService object is created for any reason, which includes not only running the service, but also (un)installing the service.
Try something more like this:
unit BusServer;
interface
uses
Winapi.Windows, Winapi.Messages,
System.SysUtils, System.Classes, System.Variants,
Vcl.Graphics, Vcl.Controls, Vcl.SvcMgr, Vcl.Dialogs,
IdContext, IdBaseComponent, IdComponent,
IdCustomTCPServer, IdTCPServer, IdThreadSafe,
Data.DB, Datasnap.DBClient, System.SyncObjs;
type
TBus_Server = class(TService)
tcpBusDataServer: TIdTCPServer;
cdsBusMonitor: TClientDataSet;
cdsBusMonitorNr: TIntegerField;
cdsBusMonitorDate: TStringField;
cdsBusMonitorTime: TStringField;
cdsBusMonitorAad: TIntegerField;
cdsBusMonitorAgr: TIntegerField;
cdsBusMonitorAName: TStringField;
cdsBusMonitorAFct: TStringField;
cdsBusMonitorOrigin: TStringField;
cdsIncoming: TClientDataSet;
cdsMemberState: TClientDataSet;
cdsMemberStateMemberID: TStringField;
cdsMemberStateState: TStringField;
cdsMemberStateDateTime: TDateTimeField;
cdsMemberStateTotaal: TFloatField;
procedure tcpBusDataServerExecute(AContext: TIdContext);
procedure ServiceStart(Sender: TObject; var Started: Boolean);
procedure ServiceStop(Sender: TObject; var Stopped: Boolean);
procedure ServiceShutdown(Sender: TObject);
private
{ Private declarations }
FunctionMon: TIdThreadSafeString;
DevicePort: Integer;
ClientPort: Integer;
DeviceLSB, DeviceMSB: Byte;
DeviceDataLock: TCriticalSection;
FunctionList: TStringList;
procedure TranslateData(ClientLSB, ClientMSB: Byte);
function CodeValue: String;
public
function GetServiceController: TServiceController; override;
{ Public declarations }
end;
var
Bus_Server: TBus_Server;
implementation
uses
CodesiteLogging;
{$R *.dfm}
procedure ServiceController(CtrlCode: DWord); stdcall;
begin
Bus_Server.Controller(CtrlCode);
end;
function TBus_Server.CodeValue: String;
begin
case cdsIncoming.FieldByName('MemberType').AsInteger of
11, 22, 33: begin
Result := FunctionMon.Value;
end;
else
// TODO
Result := '';
end;
end;
function TBus_Server.GetServiceController: TServiceController;
begin
Result := ServiceController;
end;
procedure TBus_Server.ServiceStart(Sender: TObject; var Started: Boolean);
var
DataSetName: String;
begin
DevicePort := 10001;
ClientPort := 10012;
DeviceDataLock := TCriticalSection.Create;
FunctionMon := TIdThreadSafeString.Create;
FunctionList := TStringList.Create;
FunctionList.Add('Null');
FunctionList.Add('Reset');
FunctionList.Add('Toggle');
FunctionList.Add('Set');
FunctionList.Add('Misc');
FunctionList.Add('Status');
FunctionList.Add('Timer/Direct');
FunctionList.Add('Value');
FunctionList.Add('Dimmer');
FunctionList.Add('Readout');
FunctionList.Add('Teller');
FunctionList.Add('System');
FunctionList.Add('Settings');
FunctionList.Add('Select');
FunctionList.Add('Data');
FunctionList.Add('Program');
ForceDirectories('c:\Test\');
DataSetName := 'c:\Test\BusMonitor' + FormatDateTime('YYYY-MM-DD', Now) + '.xml';
if cdsBusMonitor.Active then
cdsBusMonitor.Close;
cdsBusMonitor.Filename := DataSetName;
if not System.SysUtils.FileExists(DataSetName) then
begin
cdsBusMonitor.CreateDataSet;
cdsBusMonitor.SaveToFile;
end;
DataSetName := 'c:\Test\MemberState' + FormatDateTime('YYYY-MM-DD', Now) + '.xml';
if cdsMemberState.Active then
cdsMemberState.Close;
cdsMemberState.Filename := DataSetName;
if not System.SysUtils.FileExists(DataSetName) then
begin
cdsMemberState.CreateDataSet;
cdsMemberState.SaveToFile;
end;
tcpBusDataServer.Bindings.Clear;
tcpBusDataServer.Bindings.Add.Port := DevicePort;
tcpBusDataServer.Bindings.Add.Port := ClientPort;
tcpBusDataServer.Active := True;
Started := True;
end;
procedure TBus_Server.ServiceStop(Sender: TObject; var Stopped: Boolean);
begin
ServiceShutdown(Sender);
Stopped := True;
end;
procedure TBus_Server.ServiceShutdown(Sender: TObject);
begin
tcpBusDataServer.Active := False;
cdsBusMonitor.Close;
cdsMemberState.Close;
DeviceDataLock.Free;
FunctionMon.Free;
FunctionList.Free;
end;
procedure TBus_Server.tcpBusDataServerExecute(AContext: TIdContext);
var
LSB, MSB: Byte;
List: TList;
Ctx: TIdContext;
begin
LSB := AContext.Connection.IOHandler.ReadByte;
MSB := AContext.Connection.IOHandler.ReadByte;
if AContext.Binding.Port = ClientPort then // Client
begin
DeviceDataLock.Enter;
try
DeviceLSB := LSB;
DeviceMSB := MSB;
finally
DeviceDataLock.Leave;
end;
List := tcpBusDataServer.Contexts.LockList;
try
for var i := 0 to List.count - 1 do
begin
Ctx := TIdContext(List[I]);
if (Ctx <> AContext) and (Ctx.Binding.Port = DevicePort) then
begin
Ctx.Connection.IOHandler.Write(LSB);
Ctx.Connection.IOHandler.Write(MSB);
// Since only 1 has to be written to
Break;
end;
end;
finally
tcpBusDataServer.Contexts.UnlockList;
end;
end
else if AContext.Binding.Port = DevicePort then // Device
begin
List := tcpBusDataServer.Contexts.LockList;
try
for var i := 0 to List.count - 1 do
begin
Ctx := TIdContext(List[I]);
if (Ctx <> AContext) and (Ctx.Binding.Port = ClientPort) then
begin
Ctx.Connection.IOHandler.Write(LSB);
Ctx.Connection.IOHandler.Write(MSB)
end;
end
finally
tcpBusDataServer.Contexts.UnlockList;
TThread.Queue(nil,
procedure
begin
TranslateData(LSB, MSB);
end
);
end;
end;
end;
procedure TBus_Server.TranslateData(ClientLSB, ClientMSB: Byte);
const {$J+}
LastSave: TDateTime = 0;
type
TProgramState = (psNone,psProgram,psIgnore1,psIgnore2);
const
ProgramState: TProgramState = psNone;
const
ValueMode: Boolean = False;
var
i: Integer;
fct: Integer;
GroupMon: Integer;
AddressMon: Integer;
CorrecteSettings: Boolean;
TmpFunc, TmpCodeValue: string;
TmpDeviceLSB, TmpDeviceMSB: Byte;
begin
fct := 0;
// Functie uit MSB halen
if ClientMSB >= 128 then
begin
Dec(ClientMSB, 128);
fct := 8;
end;
if ClientMSB >= 64 then
begin
Dec(ClientMSB, 64);
Inc(fct, 4);
end;
if ClientMSB >= 32 then
begin
Dec(ClientMSB, 32);
Inc(fct, 2);
end;
if ClientMSB >= 16 then
begin
Dec(ClientMSB, 16);
Inc(fct, 1);
end;
// Variabelen voor monitor bepalen
TmpFunc := FunctionList[fct];
FunctionMon.Value := TmpFunc;
if cdsBusMonitor.Active then
begin
cdsBusMonitor.Filtered := False;
cdsBusMonitor.Append;
try
cdsBusMonitor.FieldByName('Nr').AsInteger := cdsBusMonitor.RecordCount + 1;
cdsBusMonitor.FieldByName('AFct').Asstring := TmpFunc;
cdsBusMonitor.FieldByName('Aad').AsInteger := ClientLSB;
cdsBusMonitor.FieldByName('Agr').AsInteger := ClientMSB;
cdsBusMonitor.FieldByName('Time').AsString := TimeToStr(Now);
cdsBusMonitor.FieldByName('Origin').AsString := 'Van de Bus: '{ + UserPeerIP};
cdsBusMonitor.Post;
except
cdsBusMonitor.Cancel;
raise;
end;
end;
if ProgramState = psNone then
begin
CodeSite.Send('New situation...');
try
DeviceDataLock.Enter;
try
TmpDeviceLSB := DeviceLSB;
TmpDeviceMSB := DeviceMSB;
finally
DeviceDataLock.Leave;
end;
if cdsIncoming.Locate('Group;Address', VarArrayOf([IntToStr(TmpDeviceMSB),IntToStr(TmpDeviceLSB)]), []) then
begin
CodeSite.Send('After locate...');
if cdsMemberState.Locate('MemberID', cdsIncoming.FieldByName('MemberID').AsString, []) then
cdsMemberState.Edit
else
cdsMemberState.Append;
try
TmpCodeValue := CodeValue;
if cdsMemberStateState.AsString = TmpCodeValue then
begin
CodeSite.Send('New state ' + TmpCodeValue + ' already known');
cdsMemberState.Cancel;
end
else
begin
CodeSite.Send('New state ' + TmpCodeValue);
cdsMemberStateState.AsString := TmpCodeValue;
if TmpCodeValue = 'Reset' then
cdsMemberStateTotaal.AsFloat := cdsMemberStateTotaal.AsFloat + (Now - cdsMemberStateDateTime.AsDateTime);
cdsMemberStateDateTime.AsDateTime := Now;
cdsMemberState.Post;
end;
except
cdsMemberState.Cancel;
raise;
end;
end
else
CodeSite.SendError('ServerMethodsBServer.cdsIncoming Locate Fail');
except
on E: Exception do
CodeSite.SendException(E);
end
end;
if ((cdsBusMonitor.RecordCount mod 100) = 0) or ((Now - LastSave) > (1/24/60)) then
begin
LastSave := Now;
cdsBusMonitor.MergeChangeLog;
cdsBusMonitor.SaveToFile;
cdsMemberState.MergeChangeLog;
cdsMemberState.SaveToFile;
end;
end;
I have a UDP messenger with a Send button, but it annoys me that I have to press the button instead of just hitting Enter. So I have created procedure TForm1.Edit2KeyPress. Now I have no idea how to define the Enter button in if (enter is pressed) then {code for sending message}.
After answering i have new problem. Anything I type is sended , letter by letter.. here is my code
unit chat1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, IdSocketHandle, StdCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
Memo1: TMemo;
Edit1: TEdit;
Button2: TButton;
Edit2: TEdit;
Label1: TLabel;
procedure Button1Click(Sender: TObject);
procedure FormActivate(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure Edit2KeyPress(Sender: TObject; var Key: Char);
private
Activated: Boolean;
procedure SearchEvent(ResultIP, ResultName: String);
procedure UDPRead(Sender: TObject; AData: TStream;
ABinding: TIdSocketHandle);
procedure UDPException(Sender: TObject);
public
end;
var
Form1: TForm1;
ss:string ;
implementation
uses UDP;
{$R *.dfm}
procedure TForm1.Button1Click(Sender: TObject);
begin
UDPSearchForm.SearchEvent := SearchEvent;
UDPSearchForm.Left := Left;
UDPSearchForm.Top := Top;
UDPSearchForm.AktIP := Edit1.Text;
UDPSearchForm.SearchPartner;
end;
procedure TForm1.SearchEvent(ResultIP, ResultName: String);
begin
Edit1.Text := ResultIP;
Label1.Caption := ResultName;
end;
procedure TForm1.FormActivate(Sender: TObject);
var
s, s2: String;
begin
if Activated then exit;
Memo1.Clear;
Activated := true;
UDPSearchForm.OnUDPRead := UDPRead;
UDPSearchForm.OnException := UDPException;
UDPSearchForm.Active := true;
s := UDPSearchForm.LocalAddress;
s2 := UDPSearchForm.WSGetHostByAddr(s);
Memo1.Lines.Add('I''m (' + s + ') ' + s2);
end;
procedure TForm1.UDPRead(Sender: TObject; AData: TStream;
ABinding: TIdSocketHandle);
var
Buffer: Array [0..2047] of Byte;
count: Integer;
PeerIP: String;
PeerPort: Integer;
s: String;
i: Integer;
begin
PeerIP := ABinding.PeerIP;
PeerPort:= ABinding.PeerPort;
count := AData.Size;
if count > Length(Buffer) then begin
exit;
end;
AData.Read(Buffer, count);
if (Buffer[0] <> $00) and (Buffer[0] <> $01) then begin // not search
Edit1.Text:= PeerIP;
end;
case Buffer[0] of
$00: begin // search request
case count of
4: begin
case Buffer[1] of
0: begin
Buffer[0] := $01;
UDPSearchForm.Host := PeerIP;
UDPSearchForm.DoSend(Buffer, 4, Length(Buffer));
Memo1.Lines.Add('Inquiry [' + UDPSearchForm.WSGetHostByAddr(PeerIP) + '(' + PeerIP + ')' + ' Port: ' + IntToStr(PeerPort) +
']');
end;
end;
end;
end;
end;
$01: begin // Search Reply
case count of
4: begin
case Buffer[1] of 0:
begin
ss := UDPSearchForm.WSGetHostByAddr(PeerIP);
s := '[' + ss + '(' + PeerIP + ')' +
' Client Port: ' + IntToStr(PeerPort) +
']';
Memo1.Lines.Add('Inquiry Reply ' + s);
if PeerIp = UDPSearchForm.LocalAddress then begin
ss := '<myself>' + ss;
end;
UDPSearchForm.Add(PeerIP, ss);
end;
end;
end;
end;
end;
$10: begin // Text
case Buffer[1] of
0: begin
s := '';
for i := 4 to count-1 do begin
s := s + char(Buffer[i]);
end;
Memo1.Lines.Add(ss+' says: ' + s);
end;
end;
end;
end;
end;
procedure TForm1.UDPException(Sender: TObject);
begin
//nothing
end;
procedure TForm1.Button2Click(Sender: TObject);
var
x: Array[0..100] of Byte;
i: Integer;
begin
UDPSearchForm.Host := Edit1.Text;
UDPSearchForm.Active := true;
x[0] := $10; // Text
x[1] := 0; // Type 0
for i := 1 to Length(Edit2.Text) do begin
x[i+3] := Byte(Edit2.Text[i]);
end;
UDPSearchForm.DoSend(x, 4+Length(Edit2.Text), length(x));
Memo1.Text:=Memo1.Text+Edit2.Text+#13#10;
end;
procedure TForm1.Edit2KeyPress(Sender: TObject; var Key: Char);
var
x: Array[0..100] of Byte;
i: Integer;
begin
if Ord(Key) = VK_RETURN then
UDPSearchForm.Host := Edit1.Text;
UDPSearchForm.Active := true;
x[0] := $10; // Text
x[1] := 0; // Type 0
for i := 1 to Length(Edit2.Text) do begin
x[i+3] := Byte(Edit2.Text[i]);
end;
UDPSearchForm.DoSend(x, 4+Length(Edit2.Text), length(x));
Memo1.Text:=Memo1.Text+Edit2.Text+#13#10;
end;
end.
Set the Default property of the Send button to True. Its OnClick event will fire automatically when the user presses Enter.
I have been having a play around with the TListBox control, and drawing images and changing the font styles etc. I want to step it up a little, and try manipulating the items some more with indentation and multi level indenting.
Take a look at this image for a better idea:
The idea is that items in the list that are positioned between start and end items should be indented accordingly.
So, to give an idea I edited the screenshot in Paint, so it would look something like this:
What would be the way to approach this? My thought was to iterate through the listbox and return in 2 separate variable the amount of start and end items, then somehow determine where the other items are and if the fit between - but my logic is never so good :(
For ease of use, I have provided below the code to show how I am drawing the images and styles:
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ImgList, ComCtrls;
type
TForm1 = class(TForm)
ImageList1: TImageList;
PageControl1: TPageControl;
TabSheet1: TTabSheet;
ListBox1: TListBox;
TabSheet2: TTabSheet;
ListBox2: TListBox;
TabSheet3: TTabSheet;
ListBox3: TListBox;
procedure FormCreate(Sender: TObject);
procedure ListBox1MeasureItem(Control: TWinControl; Index: Integer;
var Height: Integer);
procedure ListBox1DrawItem(Control: TWinControl; Index: Integer;
Rect: TRect; State: TOwnerDrawState);
procedure ListBox2MeasureItem(Control: TWinControl; Index: Integer;
var Height: Integer);
procedure ListBox2DrawItem(Control: TWinControl; Index: Integer;
Rect: TRect; State: TOwnerDrawState);
procedure ListBox3MeasureItem(Control: TWinControl; Index: Integer;
var Height: Integer);
procedure ListBox3DrawItem(Control: TWinControl; Index: Integer;
Rect: TRect; State: TOwnerDrawState);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
// assign quick identifiers to image indexes
const
imgLayout = 0;
imgCalculator = 1;
imgComment = 2;
imgTime = 3;
imgStart = 4;
imgEnd = 5;
implementation
{$R *.dfm}
procedure TForm1.FormCreate(Sender: TObject);
var
ListStyle: TListBoxStyle;
begin
// set the listbox style here
ListStyle := lbOwnerDrawVariable;
ListBox1.Style := ListStyle;
ListBox2.Style := ListStyle;
ListBox3.Style := ListStyle;
end;
{******************************************************************************}
procedure TForm1.ListBox1DrawItem(Control: TWinControl; Index: Integer;
Rect: TRect; State: TOwnerDrawState);
var
TextPosition: Integer;
Images: TImageList;
begin
TListBox(Control).Canvas.FillRect(Rect);
Images := ImageList1;
// draw the images
if TListBox(Control).Items.Strings[Index] = 'Layout' then
begin
Images.Draw(TListBox(Control).Canvas, Rect.Left + 4, Rect.Top, imgLayout);
end else
if TListBox(Control).Items.Strings[Index] = 'Calculator' then
begin
Images.Draw(TListBox(Control).Canvas, Rect.Left + 4, Rect.Top,
imgCalculator);
end else
if TListBox(Control).Items.Strings[Index] = 'Comment' then
begin
Images.Draw(TListBox(Control).Canvas, Rect.Left + 4, Rect.Top, imgComment);
end else
if TListBox(Control).Items.Strings[Index] = 'Time' then
begin
Images.Draw(TListBox(Control).Canvas, Rect.Left + 4, Rect.Top, imgTime);
end;
// positions the text
TextPosition := (Rect.Bottom - Rect.Top - TListBox(Control).Canvas.TextHeight
(Text)) div 2;
// displays the text
TListBox(Control).Canvas.TextOut(Rect.Left + Images.Width + 8,
Rect.Top + TextPosition, TListBox(Control).Items.Strings[index]);
end;
procedure TForm1.ListBox1MeasureItem(Control: TWinControl; Index: Integer;
var Height: Integer);
begin
Height := ImageList1.Height;
end;
{******************************************************************************}
procedure TForm1.ListBox2DrawItem(Control: TWinControl; Index: Integer;
Rect: TRect; State: TOwnerDrawState);
var
TextPosition: Integer;
Images: TImageList;
begin
TListBox(Control).Canvas.FillRect(Rect);
Images := ImageList1;
// draw the images
if TListBox(Control).Items.Strings[Index] = 'Layout' then
begin
Images.Draw(TListBox(Control).Canvas, Rect.Left + 4, Rect.Top, imgLayout);
TListBox(Control).Canvas.Font.Style := [fsBold];
end else
if TListBox(Control).Items.Strings[Index] = 'Calculator' then
begin
Images.Draw(TListBox(Control).Canvas, Rect.Left + 4, Rect.Top,
imgCalculator);
TListBox(Control).Canvas.Font.Color := clBlue;
TListBox(Control).Canvas.Font.Style := [fsItalic];
end else
if TListBox(Control).Items.Strings[Index] = 'Comment' then
begin
Images.Draw(TListBox(Control).Canvas, Rect.Left + 4, Rect.Top, imgComment);
TListBox(Control).Canvas.Font.Color := clRed;
end else
if TListBox(Control).Items.Strings[Index] = 'Time' then
begin
Images.Draw(TListBox(Control).Canvas, Rect.Left + 4, Rect.Top, imgTime);
end;
// positions the text
TextPosition := (Rect.Bottom - Rect.Top - TListBox(Control).Canvas.TextHeight
(Text)) div 2;
// displays the text
TListBox(Control).Canvas.TextOut(Rect.Left + Images.Width + 8,
Rect.Top + TextPosition, TListBox(Control).Items.Strings[index]);
end;
procedure TForm1.ListBox2MeasureItem(Control: TWinControl; Index: Integer;
var Height: Integer);
begin
Height := ImageList1.Height;
end;
{******************************************************************************}
procedure TForm1.ListBox3DrawItem(Control: TWinControl; Index: Integer;
Rect: TRect; State: TOwnerDrawState);
var
TextPosition: Integer;
Images: TImageList;
begin
TListBox(Control).Canvas.FillRect(Rect);
Images := ImageList1;
// draw the images
if TListBox(Control).Items.Strings[Index] = 'Layout' then
begin
Images.Draw(TListBox(Control).Canvas, Rect.Left + 4, Rect.Top, imgLayout);
end else
if TListBox(Control).Items.Strings[Index] = 'Calculator' then
begin
Images.Draw(TListBox(Control).Canvas, Rect.Left + 4, Rect.Top,
imgCalculator);
end else
if TListBox(Control).Items.Strings[Index] = 'Comment' then
begin
Images.Draw(TListBox(Control).Canvas, Rect.Left + 4, Rect.Top, imgComment);
end else
if TListBox(Control).Items.Strings[Index] = 'Time' then
begin
Images.Draw(TListBox(Control).Canvas, Rect.Left + 4, Rect.Top, imgTime);
end else
if TListBox(Control).Items.Strings[Index] = 'Start' then
begin
Images.Draw(TListBox(Control).Canvas, Rect.Left + 4, Rect.Top,
imgStart);
TListBox(Control).Canvas.Font.Style := [fsBold];
end else
if TListBox(Control).Items.Strings[Index] = 'End' then
begin
Images.Draw(TListBox(Control).Canvas, Rect.Left + 4, Rect.Top, imgEnd);
TListBox(Control).Canvas.Font.Style := [fsBold];
end;
// positions the text
TextPosition := (Rect.Bottom - Rect.Top - TListBox(Control).Canvas.TextHeight
(Text)) div 2;
// displays the text
TListBox(Control).Canvas.TextOut(Rect.Left + Images.Width + 8,
Rect.Top + TextPosition, TListBox(Control).Items.Strings[index]);
end;
procedure TForm1.ListBox3MeasureItem(Control: TWinControl; Index: Integer;
var Height: Integer);
begin
Height := ImageList1.Height;
end;
{******************************************************************************}
end.
I would appreciate some tips on how I could determine manipulating the items. I know I can change where the bitmap and texts are placed, but it is identifying if an item falls between the groups or not, and if it does set the correct indent level.
I hope this makes sense thats why I put some mock pictures up.
Thanks :)
PS, I never write small posts sorry!
UPDATE WITH WORKING DEMO
I have accepted Sertac's answer which I have working perfectly thanks Sertac.
To help others who may be viewing - and because I have been learning OOP I want to show my code to see if it is any good :)
I have made 2 units, Lib.pas contains the classes for the list items, and Unit1.pas is the Form1 unit (I shortened unit 1 to make it clearer to see what is going on):
Lib.pas
unit Lib;
interface
uses
Classes, StdCtrls;
type
TMyListData = class(TObject)
public
fCaption: string;
fImageIndex: integer;
public
property Caption: string read fCaption write fCaption;
property ImageIndex: integer read fImageIndex write fImageIndex;
constructor Create;
destructor Destroy; override;
end;
type
TLayoutItem = class(TMyListData);
TCalculatorItem = class(TMyListData);
TCommentItem = class(TMyListData);
TTimeItem = class(TMyListData);
TStartItem = class(TMyListData);
TEndItem = class(TMyListData);
const
imgLayout = 0;
imgCalculator = 1;
imgComment = 2;
imgTime = 3;
imgStart = 4;
imgEnd = 5;
procedure NewLayoutItem(aListBox: TListBox);
procedure NewCalculatorItem(aListBox: TListBox);
procedure NewCommentItem(aListBox: TListBox);
procedure NewTimeItem(aListBox: TListBox);
procedure NewStartItem(aListBox: TListBox);
procedure NewEndItem(aListBox: TListBox);
procedure DeleteItem(aListBox: TListBox; aIndex: integer);
procedure CalculateIndents(aListBox: TListBox);
implementation
{ TMyListData }
constructor TMyListData.Create;
begin
inherited Create;
end;
destructor TMyListData.Destroy;
begin
inherited;
end;
procedure NewLayoutItem(aListBox: TListBox);
var
Obj: TLayoutItem;
begin
Obj := TLayoutItem.Create;
try
Obj.Caption := 'Layout';
Obj.ImageIndex := imgLayout;
aListBox.AddItem(Obj.Caption, Obj);
finally
Obj.Free;
end;
CalculateIndents(aListBox);
end;
procedure NewCalculatorItem(aListBox: TListBox);
var
Obj: TCalculatorItem;
begin
Obj := TCalculatorItem.Create;
try
Obj.Caption := 'Calculator';
Obj.ImageIndex := imgCalculator;
aListBox.AddItem(Obj.Caption, Obj);
finally
Obj.Free;
end;
CalculateIndents(aListBox);
end;
procedure NewCommentItem(aListBox: TListBox);
var
Obj: TCommentItem;
begin
Obj := TCommentItem.Create;
try
Obj.Caption := 'Comment';
Obj.ImageIndex := imgComment;
aListBox.AddItem(Obj.Caption, Obj);
finally
Obj.Free;
end;
CalculateIndents(aListBox);
end;
procedure NewTimeItem(aListBox: TListBox);
var
Obj: TTimeItem;
begin
Obj := TTimeItem.Create;
try
Obj.Caption := 'Time';
Obj.ImageIndex := imgTime;
aListBox.AddItem(Obj.Caption, Obj);
finally
Obj.Free;
end;
CalculateIndents(aListBox);
end;
procedure NewStartItem(aListBox: TListBox);
var
Obj: TStartItem;
begin
Obj := TStartItem.Create;
try
Obj.Caption := 'Start';
Obj.ImageIndex := imgStart;
aListBox.AddItem(Obj.Caption, Obj);
finally
Obj.Free;
end;
CalculateIndents(aListBox);
end;
procedure NewEndItem(aListBox: TListBox);
var
Obj: TEndItem;
begin
Obj := TEndItem.Create;
try
Obj.Caption := 'End';
Obj.ImageIndex := imgEnd;
aListBox.AddItem(Obj.Caption, Obj);
finally
Obj.Free;
end;
CalculateIndents(aListBox);
end;
procedure DeleteItem(aListBox: TListBox; aIndex: integer);
begin
aListBox.Items.Delete(aIndex);
aListBox.Items.Objects[aIndex] := nil;
CalculateIndents(aListBox);
end;
procedure CalculateIndents(aListBox: TListBox);
var
i: Integer;
Indent: Integer;
begin
Indent := 0;
for i := 0 to aListBox.Items.Count - 1 do
begin
if aListBox.Items[i] = 'End' then
Dec(Indent);
if Indent > -1 then
aListBox.Items.Objects[i] := Pointer(Indent);
if aListBox.Items[i] = 'Start' then
Inc(Indent);
end;
for i := aListBox.Items.Count - 1 downto 0 do
begin
if (aListBox.Items[i] = 'End') and (Indent = -1) then
begin
DeleteItem(aListBox, i);
Break;
end;
end;
end;
end.
Unit1.pas
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ImgList, ComCtrls, Buttons;
type
TForm1 = class(TForm)
ImageList1: TImageList;
lbMain: TListBox;
btnLayout: TBitBtn;
btnCalculator: TBitBtn;
btnComment: TBitBtn;
btnTime: TBitBtn;
btnStartGroup: TBitBtn;
btnEndGroup: TBitBtn;
btnDelete: TBitBtn;
procedure FormCreate(Sender: TObject);
procedure lbMainMeasureItem(Control: TWinControl; Index: Integer;
var Height: Integer);
procedure lbMainDrawItem(Control: TWinControl; Index: Integer;
Rect: TRect; State: TOwnerDrawState);
procedure btnLayoutClick(Sender: TObject);
procedure btnCalculatorClick(Sender: TObject);
procedure btnCommentClick(Sender: TObject);
procedure btnTimeClick(Sender: TObject);
procedure btnStartGroupClick(Sender: TObject);
procedure btnEndGroupClick(Sender: TObject);
procedure btnDeleteClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
uses
Lib;
{$R *.dfm}
procedure TForm1.FormCreate(Sender: TObject);
begin
// set the listbox style here
lbMain.Style := lbOwnerDrawVariable;
end;
procedure TForm1.lbMainDrawItem(Control: TWinControl; Index: Integer;
Rect: TRect; State: TOwnerDrawState);
var
TextPosition: Integer;
Images: TImageList;
begin
TListBox(Control).Canvas.FillRect(Rect);
Images := ImageList1;
// draw the images
if TListBox(Control).Items.Strings[Index] = 'Layout' then
begin
Images.Draw(TListBox(Control).Canvas, Rect.Left + 4 +
8 * Integer(TListBox(Control).Items.Objects[Index]),
Rect.Top, imgLayout);
end
else if TListBox(Control).Items.Strings[Index] = 'Calculator' then
begin
Images.Draw(TListBox(Control).Canvas, Rect.Left + 4 +
8 * Integer(TListBox(Control).Items.Objects[Index]),
Rect.Top, imgCalculator);
end
else if TListBox(Control).Items.Strings[Index] = 'Comment' then
begin
Images.Draw(TListBox(Control).Canvas, Rect.Left + 4 +
8 * Integer(TListBox(Control).Items.Objects[Index]),
Rect.Top, imgComment);
end
else if TListBox(Control).Items.Strings[Index] = 'Time' then
begin
Images.Draw(TListBox(Control).Canvas, Rect.Left + 4 +
8 * Integer(TListBox(Control).Items.Objects[Index]),
Rect.Top, imgTime);
end
else if TListBox(Control).Items.Strings[Index] = 'Start' then
begin
Images.Draw(TListBox(Control).Canvas, Rect.Left + 4 +
8 * Integer(TListBox(Control).Items.Objects[Index]),
Rect.Top, imgStart);
end
else if TListBox(Control).Items.Strings[Index] = 'End' then
begin
Images.Draw(TListBox(Control).Canvas, Rect.Left + 4 +
8 * Integer(TListBox(Control).Items.Objects[Index]),
Rect.Top, imgEnd);
end;
// positions the text
TextPosition := (Rect.Bottom - Rect.Top - TListBox(Control).Canvas.TextHeight
(Text)) div 2;
// displays the text
TListBox(Control).Canvas.TextOut(
Rect.Left + Images.Width + 8 + 8 * Longint(TListBox(Control).Items.Objects[Index]),
Rect.Top + TextPosition, TListBox(Control).Items.Strings[index]);
end;
procedure TForm1.lbMainMeasureItem(Control: TWinControl; Index: Integer;
var Height: Integer);
begin
Height := ImageList1.Height;
end;
procedure TForm1.btnLayoutClick(Sender: TObject);
begin
NewLayoutItem(lbMain);
end;
procedure TForm1.btnCalculatorClick(Sender: TObject);
begin
NewCalculatorItem(lbMain);
end;
procedure TForm1.btnCommentClick(Sender: TObject);
begin
NewCommentItem(lbMain);
end;
procedure TForm1.btnTimeClick(Sender: TObject);
begin
NewTimeItem(lbMain);
end;
procedure TForm1.btnStartGroupClick(Sender: TObject);
begin
NewStartItem(lbMain);
end;
procedure TForm1.btnEndGroupClick(Sender: TObject);
begin
NewEndItem(lbMain);
end;
procedure TForm1.btnDeleteClick(Sender: TObject);
begin
if lbMain.ItemIndex <> -1 then
begin
DeleteItem(lbMain, lbMain.ItemIndex);
end;
end;
end.
It can be made better, ie assigning the image indexes based on the Items.Objects[] property but this works perfectly :)
One way is to iterate over items and modify the text to indicate indentation:
procedure TForm1.FormCreate(Sender: TObject);
var
i: Integer;
Indent: Integer;
begin
...
Indent := 0;
for i := 0 to ListBox3.Items.Count - 1 do begin
if Pos('End', ListBox3.Items[i]) > 0 then
Dec(Indent);
if Indent > 0 then
ListBox3.Items[i] := StringOfChar(#32, 2 * Indent) + ListBox3.Items[i];
if Pos('Start', ListBox3.Items[i]) > 0 then
Inc(Indent);
end;
end;
Since items' text are changed, this approach requires to test the text accordingly when drawing:
procedure TForm1.ListBox3DrawItem(Control: TWinControl; Index: Integer;
Rect: TRect; State: TOwnerDrawState);
var
TextPosition: Integer;
Images: TImageList;
begin
TListBox(Control).Canvas.FillRect(Rect);
Images := ImageList1;
// draw the images
if Pos('Layout', TListBox(Control).Items.Strings[Index]) > 0 then
begin
Images.Draw(TListBox(Control).Canvas, Rect.Left + 4, Rect.Top, imgLayout);
end else
if Pos('Calculator', TListBox(Control).Items.Strings[Index]) > 0 then
..
(With this approach, indenting images would be a little work, count the leading spaces in item text, and so on..)
If items' objects are not used already, a slightly better approach can be to store indentation as an integer, and use that information when drawing. E.g. when iterating:
Indent := 0;
for i := 0 to ListBox3.Items.Count - 1 do begin
if ListBox3.Items[i] = 'Start' then
Inc(Indent);
ListBox3.Items.Objects[i] := Pointer(Indent);
if ListBox3.Items[i] = 'End' then
Dec(Indent);
end;
When drawing:
..
if TListBox(Control).Items.Strings[Index] = 'Layout' then
begin
Images.Draw(TListBox(Control).Canvas, Rect.Left + 4 +
8 * Integer(TListBox(Control).Items.Objects[Index]),
Rect.Top, imgLayout);
..
// displays the text
TListBox(Control).Canvas.TextOut(
Rect.Left + Images.Width + 8 + 8 * Longint(TListBox(Control).Items.Objects[Index]),
Rect.Top + TextPosition, TListBox(Control).Items.Strings[index]);
..
I think you should probably use the TTreeView instead, which already supports indenting child items.
To answer your question, I think you could use recursion to draw the items in your TListBox. Using recursion, it is easy to see how many levels deep you are.
This is how most parsers work, such as HTML parsers.
Here's some pseudo code that illustrates the concept:
procedure DrawBranch(branch: TMyList; indent: Integer);
var
i: Integer;
begin
// Draw the current branch, using the indent value
branch.Draw;
// Iterate through all of the child branches
for i := 0 to branch.Children.Count - 1 do
begin
// Each time we recurse further, we add 1 to the indent
DrawBranch(branch.Child[i], indent + 1);
end;
end;
procedure DrawTree;
begin
// Start the whole thing off with the root branch
// We start the indent at 0
DrawBranch(root, 0);
end;
You'll want a "hidden" root node in your case.
You'd use similar same logic to add your items to a TTreeView.
I need a program to overwrite the file, but sometimes some process is lock it. How to check which process locks a file, and how to unlock it? What functions should I use?
I found on the Internet such a code, but it doesn't work me.
unit proc;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ExtCtrls, StdCtrls, ComCtrls, Grids, ValEdit, MTSUtilsUnit, TLHelp32,
Menus, PsAPI;
type
TApp = class
fPID: Integer;
fPArentPID: Integer;
fPIDName: string;
fThread: Integer;
fDLLName: TStringList;
fDLLPath: TStringList;
fDescription: string;
end;
TForm2 = class(TForm)
StatusBar1: TStatusBar;
Panel1: TPanel;
Panel2: TPanel;
Panel3: TPanel;
Panel4: TPanel;
Splitter2: TSplitter;
Edit1: TEdit;
Button1: TButton;
Label1: TLabel;
RichEdit1: TRichEdit;
PopupMenu1: TPopupMenu;
kill1: TMenuItem;
StringGrid1: TStringGrid;
function GetApps(AppName: string): TStringList;
function GetInfo(PID: Integer): string;
function Kill(PID: Integer): Boolean;
procedure kill1Click(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure StringGrid1SelectCell(Sender: TObject; ACol, ARow: Integer;
var CanSelect: Boolean);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form2: TForm2;
ApplicationList: TStringList;
row: Integer;
implementation
{$R *.dfm}
function TForm2.Kill(PID: Integer): Boolean;
var fHandle: THandle;
begin
fHandle := OpenProcess(PROCESS_TERMINATE, BOOL(0), PID);
if TerminateProcess(fHandle, 0) then
Result := True
else
Result := False;
CloseHandle(fHandle);
end;
procedure TForm2.kill1Click(Sender: TObject);
var i: Integer;
fApp: TApp;
begin
if Kill(StrToInt(StringGrid1.Cells[1, row])) then
begin
ApplicationList.Delete(row);
StringGrid1.RowCount := ApplicationList.Count;
for i := 1 to ApplicationList.Count - 1 do
begin
fApp := TApp(ApplicationList.Objects[i]);
Form2.StringGrid1.Cells[0,i] := fApp.fPIDName;
Form2.StringGrid1.Cells[1,i] := IntToStr(fApp.fPID);
end;
MessageBox(0, 'Terminate successfully', 'Kill', MB_ICONINFORMATION or MB_OK);
end
else
MessageBox(0, 'Could not terminate process', 'Kill', MB_ICONINFORMATION or MB_OK);
end;
procedure TForm2.StringGrid1SelectCell(Sender: TObject; ACol, ARow: Integer;
var CanSelect: Boolean);
var fApp: TApp;
begin
row := ARow;
RichEdit1.Lines.Clear();
if ApplicationList.Count >= row then
begin
fApp := TApp(ApplicationList.Objects[row]);
RichEdit1.Lines.Add(fApp.fDescription);
end;
end;
procedure TForm2.Button1Click(Sender: TObject);
var i: Integer;
fApp: TApp;
sItem: string;
CanSelect: Boolean;
begin
for i := 0 to ApplicationList.Count - 1 do
begin
fApp := TApp(ApplicationList.Objects[i]);
FreeAndNil(fApp.fDLLName);
FreeAndNil(fApp.fDLLPath);
FreeAndNil(fApp);
end;
FreeAndNil(ApplicationList);
ApplicationList := GetApps(Edit1.Text);
StringGrid1.RowCount := ApplicationList.Count;
for i := 0 to ApplicationList.Count - 1 do
begin
fApp := TApp(ApplicationList.Objects[i]);
StringGrid1.Cells[0,i] := fApp.fPIDName;
StringGrid1.Cells[1,i] := IntToStr(fApp.fPID);
end;
StringGrid1.OnSelectCell(Self, 0, 1, CanSelect);
end;
procedure TForm2.FormCreate(Sender: TObject);
begin
StringGrid1.Cells[0,0] := 'Name';
StringGrid1.Cells[1,0] := 'PID';
end;
function TForm2.GetInfo(PID: Integer): string;
var fHandle: THandle;
fModule: TModuleEntry32;
sInfo: string;
begin
Result := '';
sInfo := 'DLL Name: %s'#13#10 +
'DLL Path: %s'#13#10 +
'ModuleId: %d'#13#10;
fHandle := CreateToolhelp32Snapshot(TH32CS_SNAPMODULE, PID);
if fHandle <> INVALID_HANDLE_VALUE then
if Module32First(fHandle, fModule) then
repeat
if SameText(ExtractFileExt(fModule.szModule), '.dll') then
begin
sInfo := Format(sInfo, [fModule.szModule, fModule.szExePath, fModule.th32ModuleID]);
Result := Result + sInfo;
end;
until not Module32Next(fHandle, fModule);
end;
function TForm2.GetApps(AppName: string): TStringList;
var fHandle: THandle;
fModHandle: THandle;
fProcess: TProcessEntry32;
fModule: TMODULEENTRY32;
App: TApp;
i: Integer;
IsDLL: Boolean;
IsProcess: Boolean;
fDesc: string;
sPath: string;
begin
IsDLL := False;
IsProcess := False;
Result := TStringList.Create();
Result.Clear();
fDesc := 'DLL Name: %s'#13#10 +
'DLL Path: %s'#13#10 +
'ModuleId: %d'#13#10;
fHandle := CreateToolHelp32SnapShot(TH32CS_SNAPPROCESS, 0);
fProcess.dwSize := SizeOf(fProcess);
IsProcess := Process32First(fHandle, fProcess);
while IsProcess do
begin
App := TApp.Create();
App.fDLLName := TStringList.Create();
App.fDLLPath := TStringList.Create();
fModHandle := CreateToolHelp32SnapShot(TH32CS_SNAPMODULE, fProcess.th32ProcessID);
IsDLL := Module32First(fModHandle, fModule);
while IsDLL do
begin
if Edit1.Text <> '' then
sPath := fModule.szModule
else
sPath := ExtractFileExt(fModule.szModule);
if SameText(sPath, Edit1.Text + '.dll') then
begin
App.fPID := fProcess.th32ProcessID;
App.fPIDName := fProcess.szExeFile;
App.fDLLName.Add(fModule.szModule);
App.fDLLPath.Add(fModule.szExePath);
App.fDescription := App.fDescription +
Format(fDesc, [fModule.szModule, fModule.szExePath, fModule.th32ModuleID]);
end;
IsDLL := Module32Next(fModHandle, fModule)
end;
if App.fDLLName.Count > 0 then
Result.AddObject(IntToStr(App.fPID), App);
IsProcess := Process32Next(fHandle, fProcess);
end;
CloseHandle(fHandle);
Result.Count;
end;
end.
You should not unlock the file yourself this will lead to lost data! Leave it to the user and instead show an error and explaining which process holds open the file.
This solution here will help you to do so:
http://www.remkoweijnen.nl/blog/2011/01/03/cannot-access-files-but-need-the-origin
Check out Process Explorer. It will show you which processes have which files opened, and will allow you to close individual files.
OK, here is the complete code for the Splashbar.pas, still have three progressbars, as I want to see what they look like before I choose one. It also includes some stuff that's disabled, as I can't get them to work.
unit Splashbar;
interface
uses ExtActns, Windows, SysUtils, Classes, Graphics, Forms, Controls, StdCtrls,
Buttons, ExtCtrls, AdvProgr, ComCtrls, NetAPI32, SHFolder, WinInet, ActnList,
AdvSmoothSplashScreen, AdvSmoothProgressBar, AdvSmoothProgressBarReg,
UTCT1b, GIFImg;
type
TSplashBar1 = class(TForm)
Bevel1: TBevel;
ProgressBar1: TProgressBar;
AdvProgress1: TAdvProgress;
Timer1: TTimer;
Label1: TLabel;
AdvSmoothProgressBar1: TAdvSmoothProgressBar;
ActionList1: TActionList;
DatabaseCopy: TAction;
procedure FormCreate(Sender: TObject);
procedure DatabaseCopyExecute(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
private { Private declarations }
{ procedure URLOnDownloadProgress (Sender: TDownLoadURL;
Progress, ProgressMax: Cardinal;
StatusCode: TURLDownloadStatus;
StatusText: String; var Cancel: Boolean) ; }
public { Public declarations }
procedure OpenSplash;
procedure ShowProgress;
procedure CloseSplash;
end;
var
SplashBar1 : TSplashBar1;
dirpath: string;
Total: Integer;
Percent: Integer;
implementation
{$R *.dfm}
function GetSpecialFolderPath(folder : integer) : string;
const
SHGFP_TYPE_CURRENT = 0;
var
path: array [0..MAX_PATH] of char;
begin
if SUCCEEDED(SHGetFolderPath(0,folder,0,SHGFP_TYPE_CURRENT,#path[0])) then
Result := path
else
Result := '';
end;
function GetInetFile(const fileURL, FileName: String): boolean;
const BufferSize = 1024;
var
hSession, hURL: HInternet;
Buffer: array[1..BufferSize] of Byte;
BufferLen: DWORD;
f: File;
sAppName: string;
begin
Result:=False;
sAppName := ExtractFileName(Application.ExeName);
hSession := InternetOpen(PChar(sAppName),
INTERNET_OPEN_TYPE_PRECONFIG,
nil, nil, 0);
try
hURL := InternetOpenURL(hSession,
PChar(fileURL),
nil,0,0,0);
try
AssignFile(f, FileName);
Rewrite(f,1);
repeat
InternetReadFile(hURL, #Buffer,
SizeOf(Buffer), BufferLen);
BlockWrite(f, Buffer, BufferLen)
until BufferLen = 0;
CloseFile(f);
Result:=True;
finally
InternetCloseHandle(hURL)
end
finally
InternetCloseHandle(hSession)
end
end;
procedure TSplashBar1.FormCreate(Sender: TObject);
begin
Timer1.Enabled := True;
DatabaseCopy.Execute;
dirpath:=GetSpecialFolderPath($0023)+'\UTCT\';
end;
procedure TSplashBar1.DatabaseCopyExecute(Sender: TObject);
var
InternetFile,LocalFile: string;
begin
InternetFile:='http://160.14.20.20/log/Docs/test.xls';
LocalFile:=(dirpath + 'test.xls');
if GetInetFile(InternetFile,LocalFile)=True then
Label1.Caption := 'Working...';
//OnDownloadProgress := URLOnDownloadProgress;
//else
// StatusBar1.Panels[2].Text := 'MTable Offline!' ;
CopyFile(PChar(internetFile), PChar(LocalFile), False);
end;
procedure TSplashBar1.Timer1Timer(Sender: TObject);
const cnt: integer = 1;
begin
ProgressBar1.Position := cnt;
if cnt = 1 then Label1.Caption := 'Waiting...'
else
if cnt = 100 then begin
Label1.Caption := 'Done!';
Timer1.Enabled := False;
end
else begin
Label1.Caption := 'Working...';
end;
end;
procedure TSplashBar1.OpenSplash;
begin
Label1.Caption := '';
Show;
Update;
end;
procedure TSplashBar1.CloseSplash;
begin
Close;
end;
procedure TSplashBar1.ShowProgress;
var
xs: integer;
begin
Label1.caption:='';
Total := 1000;
for xs := 1 to Total do
begin
Sleep(5);
Percent := (xs * 100) div Total;
Label1.caption := StringOfChar('|', Percent) + IntToStr(Percent) + '%';
Label1.Repaint;
end;
end;
end.
// {procedure TSplashBar1.URLOnDownloadProgress;
// begin
// ProgressBar1.Max:= ProgressMax;
// ProgressBar1.Position:= Progress;
// AdvProgress1.Max:= ProgressMax;
// AdvProgress1.Position:= Progress;
// AdvSmoothProgressBar1.Position:= Progress;
//
// end; }
First error (W1056):
Make sure that
{$R *.RES}
is not entered twice in your dpr (Project|View Source)
Second error (H2077):
Somewhere else in your code, can't help with it
Third error (W1019):
You have to put
var
X: integer
right after
procedure TSplashBar1.ShowProgress;
You seem to have defined X somewhere other than the procedure, which the loop control variable error is indicating.
Did you include TSplashBar's unit in your .dpr file's 'uses' clause, and does it define a global SplashBar variable?