What program lock the file - delphi

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.

Related

Can I use a variable created for a component with an on click event?

I have 56 panels, and I created a loop running through them, selecting a random panel. After a random panel is selected, I use FindComponent() with the name of the random panel, and assign a variable to the random panel. Now I have the random panel as a variable, and what I want to do is use the OnClick event with the variable, but I have trouble using it. I want to display a ShowMessage() once that panel has been clicked.
procedure TForm1.btnStartClick(Sender: TObject);
var
iRandomNum, iCharRandom, iCnt: integer;
cChar: char;
sPanelName: string;
begin
Randomize;
iRandomNum := Random(7 - 1 + 1) + 1;
iCharRandom := Random(8 - 1 + 1) + 1;
case iCharRandom of
1:
cChar := 'A';
2:
cChar := 'B';
3:
cChar := 'C';
4:
cChar := 'D';
5:
cChar := 'E';
6:
cChar := 'F';
7:
cChar := 'G';
8:
cChar := 'H';
end;
sPanelName := 'pnl' + cChar + IntToStr(iRandomNum);
for iCnt := 1 to 56 do
begin
pnlCorrect := FindComponent(sPanelName) as TPanel;
end;
pnlCorrect.OnClick := showmessage('Correct panel');
end;
I tried to just display a ShowMessage() with the OnClick event of the variable, but it doesn’t work. I keep getting a runtime error.
Edit:
My new code is added below...
procedure btnTest1Click(Sender: TObject);
private
procedure pnlCorrectClick(Sender: TObject);
procedure pnlWrongClick(Sender: TObject);
{ Private declarations }
public
{ Public declarations }
end;
...
procedure TForm1.btnTest1Click(Sender: TObject);
var
i, j: Integer;
function FindPanel(iChar, iNum: Integer): TPanel;
var
cChar: Char;
sPanelName: string;
begin
cChar := Char(Ord('A') + iChar);
sPanelName := 'pnl' + cChar + IntToStr(iNum);
Result := FindComponent(sPanelName) as TPanel;
redGameTest.Lines.Add(sPanelName);
end;
begin
// reset the OnClick events of the panels first...
for i := 0 to 6 do
begin
for j := 1 to 8 do
FindPanel(i, j).OnClick := pnlWrongClick;
end;
// now, pick a random panel and assign its OnClick event...
FindPanel(Random(8), Random(7) + 1).OnClick := pnlCorrectClick;
end;
...
procedure TForm1.FormCreate(Sender: TObject);
begin
Randomize;
end;
...
procedure TForm1.pnlCorrectClick(Sender: TObject);
begin
ShowMessage('Correct panel');
end;
procedure TForm1.pnlWrongClick(Sender: TObject);
begin
ShowMessage('Wrong panel');
end;
The Debugger Exception Notification says:
Project PAT_P.exe raised exception class $C0000005 with message 'access violation at 0x0062a218: write of address 0x00000124'.
You can't assign an expression like showmessage('Correct panel'); directly to an OnClick event as you are trying to do. Events expect to be assigned a class method instead.
Try something more like the following:
type
TForm1 = class(TForm)
published
btnStart: TButton;
PanelA1: TPanel;
...
procedure FormCreate(Sender: TObject);
procedure btnStartClick(Sender: TObject);
...
private
...
procedure pnlCorrectClick(Sender: TObject);
procedure pnlWrongClick(Sender: TObject);
...
end;
...
procedure TForm1.FormCreate(Sender: TObject);
begin
Randomize;
end;
procedure TForm1.btnStartClick(Sender: TObject);
var
i, j: Integer;
function FindPanel(iChar, iNum: Integer): TPanel;
var
cChar: Char;
sPanelName: string;
begin
cChar := Char(Ord('A') + iChar);
sPanelName := 'pnl' + cChar + IntToStr(iNum);
Result := FindComponent(sPanelName) as TPanel;
end;
begin
// reset the OnClick events of the panels first...
for i := 0 to 7 do
begin
for j := 1 to 7 do
FindPanel(i, j).OnClick := pnlWrongClick;
end;
// now, pick a random panel and assign its OnClick event...
FindPanel(Random(8), Random(7) + 1).OnClick := pnlCorrectClick;
end;
procedure TForm1.pnlCorrectClick(Sender: TObject);
begin
ShowMessage('Correct panel');
end;
procedure TForm1.pnlWrongClick(Sender: TObject);
begin
ShowMessage('Wrong panel');
end;
That being said, I would suggest putting all of the Panels into an array up front, then you don't have to search for any panels by name when the button is clicked, eg:
type
TForm1 = class(TForm)
published
btnStart: TButton;
PanelA1: TPanel;
...
procedure FormCreate(Sender: TObject);
procedure btnStartClick(Sender: TObject);
...
private
Panels: array[0..55] of TPanel;
procedure pnlCorrectClick(Sender: TObject);
procedure pnlWrongClick(Sender: TObject);
...
end;
...
procedure TForm1.FormCreate(Sender: TObject);
var
i, j, k: Integer;
function FindPanel(iChar, iNum: Integer): TPanel;
var
cChar: Char;
sPanelName: string;
begin
cChar := Char(Ord('A') + iChar);
sPanelName := 'pnl' + cChar + IntToStr(iNum);
Result := FindComponent(sPanelName) as TPanel;
end;
begin
Randomize;
k := 0;
for i := 0 to 7 do
begin
for j := 1 to 7 do
begin
Panels[k] := FindPanel(i, j);
Inc(k);
end;
end;
end;
procedure TForm1.btnStartClick(Sender: TObject);
var
i: integer;
begin
// reset the OnClick event of the panels first...
for i := Low(Panels) to High(Panels) do
Panels[i].OnClick := pnlWrongClick;
// now, pick a random panel and assign its OnClick event...
Panels[Random(56)].OnClick := pnlCorrectClick;
end;
procedure TForm1.pnlCorrectClick(Sender: TObject);
begin
ShowMessage('Correct panel');
end;
procedure TForm1.pnlWrongClick(Sender: TObject);
begin
ShowMessage('Wrong panel');
end;

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.

Problems getting the JSON data from DLL using SuperObject and OmniThreadLibrary

I'm using Delphi XE, I have the following code for my program and DLL:
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, superobject,
OtlCommon, OtlCollections, OtlParallel;
type
TForm1 = class(TForm)
btnStart: TButton;
btnStop: TButton;
procedure btnStartClick(Sender: TObject);
procedure btnStopClick(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure FormCreate(Sender: TObject);
private
FLogger : IOmniBackgroundWorker;
FPipeline: IOmniPipeline;
FLogFile: TextFile;
strict protected
procedure Async_Log(const workItem: IOmniWorkItem);
procedure Async_Files(const input, output: IOmniBlockingCollection);
procedure Async_Parse(const input: TOmniValue; var output: TOmniValue);
procedure Async_JSON(const input, output: IOmniBlockingCollection);
end;
var
Form1: TForm1;
function GetJSON(AData: PChar): ISuperObject; stdcall; external 'my.dll';
implementation
uses OtlTask, IOUtils;
{$R *.dfm}
function GetJSON_local(AData: PChar): ISuperObject;
var
a: ISuperObject;
sl: TStringList;
begin
sl := TStringList.Create;
try
sl.Text := StrPas(AData);
Result := SO();
Result.O['array'] := SA([]);
a := SO;
a.S['item1'] := sl[14];
Result.A['array'].Add(a);
a := nil;
a := SO;
a.S['item2'] := sl[15];
Result.A['array'].Add(a);
finally
sl.Free;
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
var
s: string;
begin
// log
s := ExtractFilePath(Application.ExeName) + 'Logs';
if not TDirectory.Exists(s) then TDirectory.CreateDirectory(s);
s := Format(s+'\%s.txt', [FormatDateTime('yyyy-mm-dd_hh-nn-ss', Now)]);
AssignFile(FLogFile, s);
Rewrite(FLogFile);
end;
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
CloseFile(FLogFile);
end;
procedure TForm1.Async_Log(const workItem: IOmniWorkItem);
begin
WriteLn(FLogFile, workItem.Data.AsString);
end;
procedure TForm1.Async_Files(const input, output: IOmniBlockingCollection);
var
f: string;
begin
while not input.IsCompleted do begin
for f in TDirectory.GetFiles(ExtractFilePath(Application.ExeName), '*.txt') do
output.TryAdd(f); // output as FileName
Sleep(1000);
end;
end;
procedure TForm1.Async_Parse(const input: TOmniValue; var output: TOmniValue);
var
sl: TStringList;
begin
sl := TStringList.Create;
try
sl.LoadFromFile(input.AsString);
// output := GetJSON_local(PChar(sl.Text)); // output as ISuperObject --- local function
output := GetJSON(PChar(sl.Text)); // output as ISuperObject --- DLL function
finally
sl.Free;
end;
FLogger.Schedule(FLogger.CreateWorkItem(Format('%s - File processed: %s', [DateTimeToStr(Now), input.AsString])));
end;
procedure TForm1.Async_JSON(const input, output: IOmniBlockingCollection);
var
value: TOmniValue;
JSON: ISuperObject;
begin
for value in input do begin
if value.IsException then begin
FLogger.Schedule(FLogger.CreateWorkItem(value.AsException.Message));
value.AsException.Free;
end
else begin
JSON := value.AsInterface as ISuperObject;
FLogger.Schedule(FLogger.CreateWorkItem(JSON.AsString));
end;
end;
end;
//
procedure TForm1.btnStartClick(Sender: TObject);
begin
btnStart.Enabled := False;
FLogger := Parallel.BackgroundWorker.NumTasks(1).Execute(Async_Log);
FPipeline := Parallel.Pipeline
.Stage(Async_Files)
.Stage(Async_Parse)
.Stage(Async_JSON)
.Run;
end;
procedure TForm1.btnStopClick(Sender: TObject);
begin
if Assigned(FPipeline) and Assigned(FLogger) then begin
FPipeline.Input.CompleteAdding;
FPipeline := nil;
FLogger.Terminate(INFINITE);
FLogger := nil;
end;
btnStart.Enabled := True;
end;
end.
// DLL code
library my;
uses
SysUtils,
Classes, superobject;
function GetJSON(AData: PChar): ISuperObject; stdcall;
var
a: ISuperObject;
sl: TStringList;
begin
sl := TStringList.Create;
try
sl.Text := StrPas(AData);
Result := SO();
Result.O['array'] := SA([]);
a := SO;
a.S['item1'] := sl[14];
Result.A['array'].Add(a);
a := nil;
a := SO;
a.S['item2'] := sl[15];
Result.A['array'].Add(a);
finally
sl.Free;
end;
end;
exports
GetJSON;
begin
end.
When I try to run with debugging my code, after a few calls of the dll GetJSON function i get the following error:
"Project test_OTL_SO.exe raised exception class EAccessViolation with message 'Access violation at address 005A2F8A in module 'my.dll'. Write of address 00610754'."
However, this issue does not occur when I use the same local function GetJSON_local.
Could anyone suggest what am I doing wrong here?
EDIT: (solution)
I write this code for my DLL:
procedure GetJSON_(const AData: PChar; out Output: WideString); stdcall;
var
json, a: ISuperObject;
sl: TStringList;
begin
sl := TStringList.Create;
try
sl.Text := AData;
json := SO();
json.O['array'] := SA([]);
a := SO;
a.S['item1'] := sl[14];
json.A['array'].Add(a);
a := nil;
a := SO;
a.S['item2'] := sl[15];
json.A['array'].Add(a);
Output := json.AsString;
finally
sl.Free;
end;
end;
and changed the code of Async_Parse procedure:
procedure TForm1.Async_Parse(const input: TOmniValue; var output: TOmniValue);
var
sl: TStringList;
ws: WideString;
begin
sl := TStringList.Create;
try
sl.LoadFromFile(input.AsString);
GetJSON_(PChar(sl.Text), ws); // DLL procedure
output := SO(ws); // output as ISuperObject
finally
sl.Free;
end;
FLogger.Schedule(FLogger.CreateWorkItem(Format('%s - File processed: %s', [DateTimeToStr(Now), input.AsString])));
end;
The problem is your passing of ISuperObject interfaces across a module boundary. Although interfaces can be safely used that way, the methods of the interface are not safe. Some of the methods of the interface accept, or return, strings, objects, etc. That is, types that are not safe for interop.
Some examples of methods that are not safe:
function GetEnumerator: TSuperEnumerator; // TSuperEnumerator is a class
function GetS(const path: SOString): SOString; // returns a Delphi string
function SaveTo(stream: TStream; indent: boolean = false;
escape: boolean = true): integer; overload; // TStream is a class
function AsArray: TSuperArray; // TSuperArray is a class
// etc.
You should serialize the JSON to text, and pass that text between your modules.

How do I detect the Enter key in an edit box?

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.

Progressbar in splash while copying a file on program load

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?

Resources