Progressbar in splash while copying a file on program load - delphi

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?

Related

Memoryleak with TBgraBitmap an ZXING in Lazarus

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.

Processing Server data

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;

Delphi Open two files and re size whatever application they open in so they fit in the screen 50% 50%

If you have two random files e.g. .txt, .csv, .jpg, and you wanted to open two of them and make them take up the screen 50% 50%.
How would you find the window handle that was opened so that you can re size the right one?
I have edited below to be closer to the answer thanks to suggestions from David Heffernan and Rob Kennedy
The code below kind of works if everything goes right but i'm sure there are ways to improve the code.
Using ShellExecuteEx can return a process ID, you can get a window handle off the process ID by using EnumWindows checking against the process id. Then if everything works you can re size the form using MoveWindow
i have an example in the unit uFileStuff below
There are a few issues that i'm not sure can be resolved
Files can be opened in the same application e.g. notepad++.
ShellExecuteEx may not return a process id
EnumWindows may not find the window
Unit uFileStuff
unit uFileStuff;
interface
uses Winapi.Windows, System.SysUtils, Generics.Collections, shellapi, Winapi.Messages, Vcl.Dialogs, Vcl.Forms;
type
PWindowSearch = ^TWindowSearch;
TWindowSearch = record
TargetProcessID: DWord;
ResultList: TList<HWnd>;
end;
TMyFile = class
private
sFileNameAndPath : String;
MyProcessID : DWord;
MyParentProcessID : Dword;
Procedure OpenFile(sFile: String);
procedure UpdateWindowListByProcessID;
public
WindowsLinkedToProcessID : TList<HWnd>;
function GetWindowInformation(Wnd: HWnd) : String;
function GetAllWindowInformation : String;
property ProcessID : Dword read MyProcessID;
property ParentProcessID : Dword read MyParentProcessID;
constructor Create(sFile : String);
destructor Destroy; override;
end;
implementation
constructor TMyFile.Create(sFile: String);
begin
MyProcessID := 0;
MyParentProcessID := 0;
sFileNameAndPath := sFile;
WindowsLinkedToProcessID := TList<HWnd>.Create;
if (sFile <> '') and FileExists(sFile) then
OpenFile(sFileNameAndPath);
end;
destructor TMyFile.Destroy;
begin
WindowsLinkedToProcessID.Free;
Inherited;
end;
function TMyFile.GetAllWindowInformation: String;
var i : Integer;
sMessage : String;
begin
result := '';
for I := 0 to WindowsLinkedToProcessID.Count -1 do begin
sMessage := sMessage + #13#10 + GetWindowInformation(WindowsLinkedToProcessID[i]);
end;
result := result + sMessage;
end;
function TMyFile.GetWindowInformation(Wnd: HWnd): String;
var Buffer: array[0..255] of char;
begin
result := inttostr(Wnd);
SendMessage(Wnd, WM_GETTEXT, 255, LongInt(#Buffer[0]));
if Buffer <> '' then begin
result := result + ', ' + Buffer;
end;
end;
procedure TMyFile.OpenFile(sFile: String);
var i : Integer;
SEInfo: TShellExecuteInfo;
ExitCode: DWORD;
ExecuteFile, ParamString, StartInString, sMessage: string;
begin
ExecuteFile:=sFile;
FillChar(SEInfo, SizeOf(SEInfo), 0);
SEInfo.cbSize := SizeOf(TShellExecuteInfo);
with SEInfo do
begin
fMask := SEE_MASK_NOCLOSEPROCESS;
Wnd := Application.Handle;
lpFile := PChar(sFile);
nShow := SW_SHOWNORMAL;
end;
if ShellExecuteEx(#SEInfo) then
begin
if SEInfo.hProcess > 0 then begin
Sleep(100);
WaitForInputIdle(SEInfo.hProcess, 10000 );
MyProcessID := GetProcessId( SEInfo.hProcess );
UpdateWindowListByProcessID;
end else begin
ShowMessage('No Process ' + SysErrorMessage(GetLastError) );
end;
end else
ShowMessage('Error starting "'+ sFile +'"' + #13#10 + SysErrorMessage(GetLastError));
end;
procedure TMyFile.UpdateWindowListByProcessID;
function SelectWindowByProcessID(Wnd: HWnd; Param: LParam): Bool; stdcall;
var
pSearchRec: PWindowSearch;
WindowPid: DWord;
begin
pSearchRec := PWindowSearch(Param);
Assert(Assigned(pSearchRec));
GetWindowThreadProcessID(Wnd, WindowPid);
if (WindowPid = pSearchRec.TargetProcessID) and IsWindowVisible(Wnd) then
pSearchRec.ResultList.Add(Wnd);
Result := True;
end;
var
SearchRec: TWindowSearch;
begin
if MyProcessID > 0 then begin
SearchRec.TargetProcessID := MyProcessID;
SearchRec.ResultList := WindowsLinkedToProcessID;
EnumWindows(#SelectWindowByProcessID, LParam(#SearchRec));
end;
end;
end.
Form Creating Files on create - has button to open them
unit fFileOpen;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls;
type
TfrmFileOpen = class(TForm)
btn1: TButton;
procedure btn1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
sApplicationPath : String;
sFile1, sFile2 : String;
public
{ Public declarations }
end;
var
frmFileOpen: TfrmFileOpen;
implementation
uses uFileStuff;
{$R *.dfm}
procedure TfrmFileOpen.btn1Click(Sender: TObject);
var File1 : TMyFile;
File2 : TMyFile;
begin
File1 := TMyFile.Create( sFile1 );
try
if sFile2 <> sFile1 then
File2 := TMyFile.Create( sFile2 )
else
File2 := TMyFile.Create( '' );
try
if (File1.ProcessID > 0) and (File2.ProcessID > 0) then begin
if (File1.ParentProcessID > 0) and (File2.ParentProcessID > 0) and (File1.ParentProcessID = File2.ParentProcessID) then begin
showmessage('Both Files opened in same process');
end else if (File1.WindowsLinkedToProcessID.Count > 0) and (File2.WindowsLinkedToProcessID.Count > 0) then begin
if File1.WindowsLinkedToProcessID.Count > 1 then
ShowMessage('Warning returned more than 1 window Moving the first window' + #13#10 + File1.GetAllWindowInformation);
MoveWindow(File1.WindowsLinkedToProcessID[0], 0, 0, Trunc(Screen.WorkAreaWidth / 2), Screen.WorkAreaHeight, True);
if File2.WindowsLinkedToProcessID.Count > 1 then
ShowMessage('Warning returned more than 1 window Moving the first window' + #13#10 + File2.GetAllWindowInformation);
MoveWindow(File2.WindowsLinkedToProcessID[0], Round(Screen.WorkAreaWidth / 2)+1, 0, Trunc(Screen.WorkAreaWidth / 2), Screen.WorkAreaHeight, True);
end;
end;
finally
File2.Free;
end;
finally
File1.Free;
end;
end;
procedure TfrmFileOpen.FormCreate(Sender: TObject);
var slTemp : TStringList;
img : TBitmap;
begin
ReportMemoryLeaksOnShutdown := true;
sApplicationPath := ExtractFileDir(application.ExeName);
sFile1 := IncludeTrailingPathDelimiter( sApplicationPath ) + 'File1.txt';
sFile2 := IncludeTrailingPathDelimiter( sApplicationPath ) + 'File2.csv';
{
if not FileExists( sFile1 ) then begin
img := TBitmap.Create;
img.SetSize(300,300);
img.SaveToFile( sFile1 );
img.Free;
end; }
if not FileExists(sFile1) then begin
slTemp := TStringList.Create;
slTemp.Add('File1');
slTemp.SaveToFile(sFile1);
slTemp.Free;
end;
if not FileExists(sFile2) then begin
slTemp := TStringList.Create;
slTemp.Add('File2');
slTemp.SaveToFile(sFile2);
slTemp.Free;
end;
end;
end.

Delphi synapse UDP client/server

I need to create server and client programs with synapse using UDP protocol.
I have created the server program to listen to any coming messages like this
procedure TForm1.Timer1Timer(Sender: TObject);
var
resive:string;
begin
InitSocket;
resive:=UDPResiveSocket.RecvPacket(1000);
if resive<>'' then Memo1.Lines.Add('>' + resive);
DeInitSocket;
end;
procedure TForm1.InitSocket;
begin
if UDPResiveSocket <> nil then
DeInitSocket;
UDPResiveSocket := TUDPBlockSocket.Create;
UDPResiveSocket.CreateSocket;
UDPResiveSocket.Bind('0.0.0.0','22401');
UDPResiveSocket.AddMulticast('234.5.6.7');
UDPResiveSocket.MulticastTTL := 1;
end;
procedure TForm1.DeInitSocket;
begin
UDPResiveSocket.CloseSocket;
UDPResiveSocket.Free;
UDPResiveSocket := nil;
end;
So i get all incoming messages.
But i want to send a response from the source of this messages.
How can i do that? Does my method is good for server/client?
My UDP Echo client / server code. First the server:
unit UE_Server;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils,
// synapse
blcksock;
type
{ TUEServerThread }
TUEServerThread = class(TThread)
protected
procedure Execute; override;
end;
TUEServer = class
private
FUEServerThread: TUEServerThread;
function GetRunning: Boolean;
public
procedure Stop;
procedure Start;
property Running: Boolean read GetRunning;
end;
implementation
{ TUEServer }
function TUEServer.GetRunning: Boolean;
begin
Result := FUEServerThread <> nil;
end;
procedure TUEServer.Start;
begin
FUEServerThread := TUEServerThread.Create(False);
end;
procedure TUEServer.Stop;
begin
if FUEServerThread <> nil then
begin
FUEServerThread.Terminate;
FUEServerThread.WaitFor;
FreeAndNil(FUEServerThread);
end;
end;
{ TUEServerThread }
procedure TUEServerThread.Execute;
var
Socket: TUDPBlockSocket;
Buffer: string;
Size: Integer;
begin
Socket := TUDPBlockSocket.Create;
try
Socket.Bind('0.0.0.0', '7');
try
if Socket.LastError <> 0 then
begin
raise Exception.CreateFmt('Bind failed with error code %d', [Socket.LastError]);
Exit;
end;
while not Terminated do
begin
// wait one second for new packet
Buffer := Socket.RecvPacket(1000);
if Socket.LastError = 0 then
begin
// just send the same packet back
Socket.SendString(Buffer);
end;
// minimal sleep
if Buffer = '' then
Sleep(10);
end;
finally
Socket.CloseSocket;
end;
finally
Socket.Free;
end;
end;
end.
Then the client:
unit UE_Client;
{$mode objfpc}{$H+}
interface
uses
{$IFDEF WINDOWS}Windows,{$ENDIF}Classes, SysUtils, DateUtils,
// synapse
blcksock;
const
cReceiveTimeout = 2000;
cBatchSize = 100;
type
{ TUEClient }
TUEClient = class
private
FSocket: TUDPBlockSocket;
FResponseTime: Int64;
public
constructor Create;
destructor Destroy; override;
procedure Disconnect;
function Connect(const Address: string): Boolean;
function SendEcho(const Message: string): string;
property ReponseTime: Int64 read FResponseTime;
end;
{ TUEAnalyzer }
{ TUEAnalyzerThread }
TUEAnalyzerThread = class(TThread)
private
FAddress: string;
FBatchDelay: Cardinal;
FDropedPackets: Cardinal;
FAverageResponse: Extended;
FCriticalSection: TRTLCriticalSection;
function GetAverageResponse: Extended;
function GetDropedPackets: Cardinal;
protected
procedure Execute; override;
public
destructor Destroy; override;
constructor Create(const Address: string; const BatchDelay: Cardinal);
property DropedPackets: Cardinal read GetDropedPackets;
property AverageResponse: Extended read GetAverageResponse;
end;
TUEAnalyzer = class
private
FAddress: string;
FBatchDelay: Cardinal;
FAnalyzerThread: TUEAnalyzerThread;
function GetAverageResponse: Extended;
function GetDropedPackets: Cardinal;
function GetRunning: Boolean;
public
procedure StopAnalyzer;
procedure StartAnalyzer;
property Running: Boolean read GetRunning;
property Address: string read FAddress write FAddress;
property DropedPackets: Cardinal read GetDropedPackets;
property AverageResponse: Extended read GetAverageResponse;
property BatchDelay: Cardinal read FBatchDelay write FBatchDelay;
end;
implementation
{ TUEAnalyzerThread }
function TUEAnalyzerThread.GetAverageResponse: Extended;
begin
EnterCriticalsection(FCriticalSection);
try
Result := FAverageResponse;
finally
LeaveCriticalsection(FCriticalSection);
end;
end;
function TUEAnalyzerThread.GetDropedPackets: Cardinal;
begin
EnterCriticalsection(FCriticalSection);
try
Result := FDropedPackets;
finally
LeaveCriticalsection(FCriticalSection);
end;
end;
procedure TUEAnalyzerThread.Execute;
var
UEClient: TUEClient;
Connected: Boolean;
SendString: string;
SendCounter: Int64;
SumResponse: Cardinal;
SumDropedPackets: Cardinal;
begin
UEClient := TUEClient.Create;
try
Connected := UEClient.Connect(FAddress);
try
if not Connected then
begin
raise Exception.CreateFmt('Could not connect UPD client to address %s', [FAddress]);
Exit;
end;
SumDropedPackets := 0;
FAverageResponse := 0;
FDropedPackets := 0;
SumResponse := 0;
SendCounter := 1;
while not Terminated do
begin
SendString := IntToStr(SendCounter);
if not (UEClient.SendEcho(SendString) = SendString) then
Inc(SumDropedPackets);
Inc(SumResponse, UEClient.ReponseTime);
Inc(SendCounter);
if (SendCounter mod cBatchSize) = 0 then
begin
EnterCriticalsection(FCriticalSection);
try
FAverageResponse := SumResponse / cBatchSize;
FDropedPackets := SumDropedPackets;
finally
LeaveCriticalsection(FCriticalSection);
end;
// sleep for specified batch time
Sleep(FBatchDelay * 1000);
SumDropedPackets := 0;
SumResponse := 0;
end;
// minimal sleep
Sleep(10);
end;
finally
UEClient.Disconnect;
end;
finally
UEClient.Free;
end;
end;
destructor TUEAnalyzerThread.Destroy;
begin
{$IFDEF MSWINDOWS}
DeleteCriticalSection(FCriticalSection)
{$ELSE}
DoneCriticalSection(FCriticalSection)
{$ENDIF};
inherited Destroy;
end;
constructor TUEAnalyzerThread.Create(const Address: string; const BatchDelay: Cardinal);
begin
{$IFDEF MSWINDOWS}
InitializeCriticalSection(FCriticalSection)
{$ELSE}
InitCriticalSection(FCriticalSection)
{$ENDIF};
FBatchDelay := BatchDelay;
FreeOnTerminate := True;
FAddress := Address;
inherited Create(False);
end;
{ TUEAnalyzer }
procedure TUEAnalyzer.StartAnalyzer;
begin
FAnalyzerThread := TUEAnalyzerThread.Create(FAddress, FBatchDelay);
end;
function TUEAnalyzer.GetRunning: Boolean;
begin
Result := FAnalyzerThread <> nil;
end;
function TUEAnalyzer.GetAverageResponse: Extended;
begin
Result := FAnalyzerThread.AverageResponse;
end;
function TUEAnalyzer.GetDropedPackets: Cardinal;
begin
Result := FAnalyzerThread.DropedPackets;
end;
procedure TUEAnalyzer.StopAnalyzer;
begin
if Running then
begin
FAnalyzerThread.Terminate;
FAnalyzerThread := nil;
end;
end;
{ TUEClient }
constructor TUEClient.Create;
begin
FSocket := TUDPBlockSocket.Create;
end;
destructor TUEClient.Destroy;
begin
FreeAndNil(FSocket);
inherited Destroy;
end;
procedure TUEClient.Disconnect;
begin
FSocket.CloseSocket;
end;
function TUEClient.Connect(const Address: string): Boolean;
begin
FSocket.Connect(Address, '7');
Result := FSocket.LastError = 0;
end;
function TUEClient.SendEcho(const Message: string): string;
var
StartTime: TDateTime;
begin
Result := '';
StartTime := Now;
FSocket.SendString(Message);
if FSocket.LastError = 0 then
begin
Result := FSocket.RecvPacket(cReceiveTimeout);
FResponseTime := MilliSecondsBetween(Now, StartTime);
if FSocket.LastError <> 0 then
begin
FResponseTime := -1;
Result := '';
end;
end;
end;
end.
The code is written in free pascal, but works equally well in Delphi. The client unit is actually a line analyzer that calculates average response times and dropped packets. It is ideal to check the quality of your internet line to a certain server. You put the echo server to the server part and client on the client side.
Simple client-server in two program
client send two string "Hello world" and "exit"
server wait for client message and stop after client send "exit"
write on free pascal(Lazarus)
client
unit Unit1;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls,
//ADD
blcksock;
type
{ TForm1 }
TForm1 = class(TForm)
Button1: TButton;
Memo1: TMemo;
procedure Button1Click(Sender: TObject);
private
procedure OnStatus(Sender: TObject; Reason: THookSocketReason; const Value: string );
{ private declarations }
public
{ public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.lfm}
{ TForm1 }
procedure TForm1.OnStatus(Sender: TObject; Reason: THookSocketReason; const Value: string);
var
sReason : String;
begin
case Reason of
HR_ResolvingBegin : sReason := 'HR_ResolvingBegin';
HR_ResolvingEnd : sReason := 'HR_ResolvingEnd';
HR_SocketCreate : sReason := 'HR_SocketCreate';
HR_SocketClose : sReason := 'HR_SocketClose';
HR_Bind : sReason := 'HR_Bind';
HR_Connect : sReason := 'HR_Connect';
HR_CanRead : sReason := 'HR_CanRead';
HR_CanWrite : sReason := 'HR_CanWrite';
HR_Listen : sReason := 'HR_Listen';
HR_Accept : sReason := 'HR_Accept';
HR_ReadCount : sReason := 'HR_ReadCount';
HR_WriteCount : sReason := 'HR_WriteCount';
HR_Wait : sReason := 'HR_Wait';
HR_Error : sReason := 'HR_Error';
end;
Memo1.Lines.Add( sReason + ': ' + Value );
end;
procedure TForm1.Button1Click(Sender: TObject);
var
UDP: TUDPBlockSocket;
s:string;
begin
UDP := TUDPBlockSocket.Create;
try
UDP.OnStatus := #OnStatus;
//send to server
s:='Hello world from client';
UDP.Connect( '127.0.0.1', '12345' );
UDP.SendString('------'+s+'--------');
memo1.Append(s);
//for server stop send string "exit"
s:='exit';
UDP.SendString(s);
memo1.Append('---');
memo1.Append(s);
memo1.Append('---');
UDP.CloseSocket;
finally
UDP.Free;
end;
end;
end.
SERVER
unit Unit1;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls,
//ADD
blcksock;
type
{ TForm1 }
TForm1 = class(TForm)
Button1: TButton;
Memo1: TMemo;
procedure Button1Click(Sender: TObject);
private
procedure OnStatus(Sender: TObject; Reason: THookSocketReason; const Value: string );
{ private declarations }
public
{ public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.lfm}
{ TForm1 }
procedure TForm1.OnStatus(Sender: TObject; Reason: THookSocketReason; const Value: string);
var
sReason : String;
begin
case Reason of
HR_ResolvingBegin : sReason := 'HR_ResolvingBegin';
HR_ResolvingEnd : sReason := 'HR_ResolvingEnd';
HR_SocketCreate : sReason := 'HR_SocketCreate';
HR_SocketClose : sReason := 'HR_SocketClose';
HR_Bind : sReason := 'HR_Bind';
HR_Connect : sReason := 'HR_Connect';
HR_CanRead : sReason := 'HR_CanRead';
HR_CanWrite : sReason := 'HR_CanWrite';
HR_Listen : sReason := 'HR_Listen';
HR_Accept : sReason := 'HR_Accept';
HR_ReadCount : sReason := 'HR_ReadCount';
HR_WriteCount : sReason := 'HR_WriteCount';
HR_Wait : sReason := 'HR_Wait';
HR_Error : sReason := 'HR_Error';
end;
Memo1.Append( sReason + ': ' + Value );
end;
procedure TForm1.Button1Click(Sender: TObject);
var
Sock:TUDPBlockSocket;
size:integer;
buf:string;
begin
Sock:=TUDPBlockSocket.Create;
try
//On status show error and other
//enable on status if you can more seen
//sock.OnStatus := #OnStatus;
sock.CreateSocket;
//create server
sock.bind('127.0.0.1','12345');
//send string to this server in this program(not client)
sock.Connect( '127.0.0.1', '12345' );
sock.SendString('test send string to sever');
if sock.LastError<>0 then exit;
//shutdown while client send "exit"
while buf<>'exit' do
begin
//get data client
buf := sock.RecvPacket(1000);
Memo1.Append(buf);
sleep(1);
end;
sock.CloseSocket;
finally
sock.free;
end;
end;
end.

What program lock the file

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.

Resources