Free Pascal / Lazarus : Why is the "FormCloseQuery" Event not called in my example? - lazarus

I wrote a small testprogram to try out the FormCreate and the FormCloseQuery procedure. The FormCreate works fine, but the FormCloseQuery just doesn't want to execute. Did I overlook something? Pressing the "X" on a form-window or using the close method, both doesn't work!
procedure FormCreate(Sender: TObject);
procedure FormCloseQuery(Sender: TObject; var CanClose: boolean);
(...)
procedure TForm1.FormCreate(Sender: TObject);
beginn
//gets executed without problems
end;
procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
case MessageDlg('Question', mtConfirmation, [mbyes, mbno, mbcancel], 0) of
mrYes:
begin
ShowMessage('yes');
CanClose := true;
end;
mrNo:
begin
ShowMessage('no');
CanClose := true;
end;
else
begin
ShowMessage('cancel');
CanClose := true;
end;
end;
end;
Here's the full code:
The lpr-File:
program project1;
{$mode objfpc}{$H+}
uses
{$IFDEF UNIX}{$IFDEF UseCThreads}
cthreads,
{$ENDIF}{$ENDIF}
Interfaces, // this includes the LCL widgetset
Forms, Unit1
{ you can add units after this };
{$R *.res}
begin
RequireDerivedFormResource:=True;
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.Run;
end.
The Unit-File:
unit Unit1;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls;
type
{ TForm1 }
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormCloseQuery(Sender: TObject; var CanClose: boolean);
private
{ private declarations }
public
{ public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.lfm}
{ TForm1 }
procedure TForm1.FormCreate(Sender: TObject);
begin
ShowMessage('FormCreate Procedure wurde gestartet');
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
Close;
end;
procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
case MessageDlg('Question', mtConfirmation, [mbyes, mbno, mbcancel], 0) of
mrYes:
begin
ShowMessage('yes');
CanClose := true;
end;
mrNo:
begin
ShowMessage('no');
CanClose := true;
end;
else
begin
ShowMessage('cancel');
CanClose := true;
end;
end;
end;
end.

The solution is/was to hook up the form's OnCloseQuery event of the form to this procedure. Here's a short description how to do it:
Bring up and select the form (in my case "Form1: TForm1") in the object inspector (see explanation below).
In the object inspector go to the tab "events"
Locate the "OnCloseQuery"-Event and select "FormCloseQuery" if you already declared and written the procedure as it was the case in my example. (If you haven't declared/implemented it double click in the dropdown box or click on the button next to it, the one with the three dots, an an empty "OnCloseQuery"-procedure procedure will be added automatically. The code editor will jump directly to the new procedure.)
To bring up / select the form in the object inspector, open the object inspector (F11). If you are looking at the code editor bring up the form first (F12) and click on it. This should bring it up in the object inspector. Make sure the form (the top element in the list) is selected and none of it's components (like buttons etc.).
Here's another explanation: http://www.delphigroups.info/2/b2/444056.html

Related

Delphi 11.2 How to set breakpoint when tbitbtn change enabled=true to enanbled=false [duplicate]

As an example, given the code extract below, I would like to define a breakpoint that triggers whenever the object field value changes and optionally, breaks on a condition (False or True in this case).
type
TForm1 = class(TForm)
EnableButton: TButton;
DisableButton: TButton;
procedure EnableButtonClick(Sender: TObject);
procedure DisableButtonClick(Sender: TObject);
private
FValue: Boolean; // <== Would like to define a breakpoint here whenever FValue changes.
public
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.DisableButtonClick(Sender: TObject);
begin
FValue := False;
end;
procedure TForm1.EnableButtonClick(Sender: TObject);
begin
FValue := True;
end;
Run the application under the debugger,
select 'Run' from the IDE menu then select 'Add Breakpoint' at the very bottom, then 'Data Breakpoint...'.
enter 'Form1.FValue' as input to the 'Adress:' field. You can also set your condition in the same dialog.
Some additional information thanks to Sertac answer and comment from David.
One can define a breakpoint based on changes in an array item with a condition.
In this case the data breakpoint is defined as follow:
Form1.FBooleans[0] = True
Code extract:
type
TBooleanArray = array of Boolean;
TForm1 = class(TForm)
EnableButton: TButton;
DisableButton: TButton;
procedure EnableButtonClick(Sender: TObject);
procedure DisableButtonClick(Sender: TObject);
private
FBooleans: TBooleanArray; // Breakpoint defined here with the condition
public
constructor Create(AOwner: TComponent); override;
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
constructor TForm1.Create(AOwner: TComponent);
var
AIndex: Integer;
begin
inherited;
SetLength(FBooleans, 3);
for AIndex := 0 to Length(FBooleans) - 1 do
begin
FBooleans[AIndex] := (AIndex mod 2) = 1;
end;
end;
procedure TForm1.DisableButtonClick(Sender: TObject);
begin
FBooleans[0] := False;
end;
procedure TForm1.EnableButtonClick(Sender: TObject);
begin
FBooleans[0] := True; // Beakpoint stops here on condition.
end;

How to fix an External: ACCESS VIOLATION error in Pascal?

I'm getting an error in Pascal, and according to my research it's due to a declaration error (class or variable). It has to be something small, since it was working just fine. I would really appreciate any help.
To be more specific, the error I'm getting is:
'External:ACCESS VIOLATION' with message: Accedd violation reading from address $000004A8. In line 66: Efa.Text:=D.Fa ;
unit UnidadProyectoInformaticaUno;
{$mode objfpc}{$H+}{$R+}{$Q+}
interface
uses
Classes, SysUtils, Forms, Controls, Graphics, Dialogs, StdCtrls,Math;
type
{ TForm1 }
TForm1 = class(TForm)
BNext: TButton;
BPrev: TButton;
BAdd: TButton;
BDel: TButton;
BClose: TButton;
EFa: TEdit;
EIm: TEdit;
EOch: TEdit;
EOt: TEdit;
ENum: TEdit;
LabFa: TLabel;
LabIm: TLabel;
LabOch: TLabel;
LabOt: TLabel;
LabNUM: TLabel;
procedure BAddClick(Sender: TObject);
procedure BCloseClick(Sender: TObject);
procedure BDelClick(Sender: TObject);
procedure BNextClick(Sender: TObject);
procedure BPrevClick(Sender: TObject);
private
public
end;
var
Form1: TForm1;
implementation
{$R *.lfm}
type
R= record
Fa,Im,Och: string[20];
Ot:array[1..5] of integer;
end;
Var F:file of R;
D,D1,D2:R;
Irec,i,j,k:integer;
note,grade,nada:string;
procedure OutRec;
begin
with Form1 do
IF Irec > 0 then
begin
seek(F,Irec-1);
read(F,D);
EFa.Text:=D.Fa;
EIm.Text:=D.Im;
for i:= 1 to 5 do
begin
grade:= grade +IntToStr(D.Ot[i])+' ';
end;
Eot.Text:=grade;
EOch.Text:=D.Och;
Enum.Text:= IntToStr(Irec);
end
else
begin
EFa.Text:=nada;
Enum.Text:=nada;
end;
end;
{ TForm1 }
procedure TForm1.BNextClick(Sender: TObject);
begin
If Irec = filesize(F) then
Exit
else
Irec:= Irec+1;
OutRec;
end;
procedure TForm1.BAddClick(Sender: TObject);
begin
D.Fa:=Efa.Text;
D.Im:=Eim.Text;
D.Och:=EOch.Text;
Note:= Eot.text;
for i:= 1 to 5 do
begin
k:=Pos(' ',Note);
D.Ot[i]:= strToInt(Copy(Note,1,k-1));
Delete(Note,1,k);
end;
seek(F,FileSize(F));
Write(F,D);
Irec:= FileSize(F);
OutRec;
end;
procedure TForm1.BCloseClick(Sender: TObject);
begin
close
end;
procedure TForm1.BDelClick(Sender: TObject);
begin
for i:= Irec+1 to Filesize(F) do
begin
seek(F,i-1);
read(F,D);
Seek(F,i-2);
Write(F,D);
end;
Seek(F,Filesize(f)-1);
Truncate(F);
Irec:= Min(Irec,FileSIze(F));
Outrec;
end;
procedure TForm1.BPrevClick(Sender: TObject);
begin
if Irec<2 then Exit;
Irec:= Irec-1;
OutRec;
end;
function Sort(Z:R):string;
begin
Result:=Z.Fa+' '+Z.Im+' '+Z.Och;
end;
procedure BStatus;
begin
with Form1 do
BNext.Enabled:= Irec < FileSize(f);
end;
procedure B1Status;
begin
with Form1 do
BPrev.Enabled:= Irec > 1;
end;
procedure B2Status;
begin
with Form1 do
BAdd.Enabled:= length(Eot.Text) > 0 ;
end;
procedure B3Status;
begin
with Form1 do
BDel.Enabled:= IRec > 0;
end;
begin
assignfile(F,'file.dat');
try reset(F);
except
rewrite(F);
end;
Irec:= Min(1,filesize(F));
OutRec;
for i :=1 to filesize(F)-1 do
for j:= Filesize(F) to i do
begin
seek(F,i);
read(F,D1,D2);
if Sort(D1)>Sort(D2) then
begin
write(f,D2,D1);
end;
end;
end.
In Free Pascal Reference guide, version 3.04 (May 2018), Paragraph 16.2 that deals with Units, it is said that a unit may have an initialization part and a finalization part. It is also said: "An initialization section by itself (i.e. without finalization) may simply be replaced by a statement block.", which is what you have in your code.
That statement block, between the begin and end of the unit, executes at program initialization before the Form1 (declared in the same unit) is created. Therefore you can not refer to anything belonging to the form, like fields, controls, methods, etc. in this statement block, neither directly nor indirectly.
You are calling procedure OutRec, which refers to Efa: TEdit of the form. Since the form is not yet created, you get the error of Access violation.
You must rearrange your code so it doesn't attempt to access any parts of the form from the statement block that replaces a unit initialization part.

Referencing Service.Name crashes after moving service code to ancestor

I had a unit for a Windows (32 bit) service that was built up like this:
unit uSvcBase;
interface
type
TMyServiceBase = class(TService)
procedure ServiceBeforeUninstall(Sender: TService);
procedure ServiceCreate(Sender: TObject);
procedure ServiceStop(Sender: TService; var Stopped: Boolean);
procedure ServiceExecute(Sender: TService);
procedure ServiceStart(Sender: TService; var Started: Boolean);
procedure ServiceAfterInstall(Sender: TService);
private
public
function GetServiceController: TServiceController; override;
end;
var
MyServiceBase: TMyServiceBase;
implementation
{$R *.DFM}
{$R SvcEventLogMessages.res}
procedure ServiceController(CtrlCode: DWord); stdcall;
begin
MyServiceBase.Controller(CtrlCode);
end;
function TMyServiceBase.GetServiceController: TServiceController;
begin
Result := ServiceController;
end;
const
rsServiceMessages =
'SYSTEM\CurrentControlSet\Services\EventLog\Application';
procedure TMyServiceBase.ServiceAfterInstall(Sender: TService);
var
lReg : TRegistry;
lAppName: String;
begin
lReg := TRegistry.create;
try
with lReg do
begin
Rootkey := HKEY_LOCAL_MACHINE;
if OpenKey(rsServiceMessages, False) then
begin
if OpenKey(MyServiceBase.Name, True) then
begin
lAppName := ParamStr(0);
WriteString('EventMessageFile', lAppName);
WriteString('CategoryMessageFile', lAppName);
WriteInteger('CategoryCount', 2);
WriteInteger('TypesSupported', EVENTLOG_ERROR_TYPE OR EVENTLOG_WARNING_TYPE OR EVENTLOG_INFORMATION_TYPE);
CloseKey;
end;
CloseKey;
end; { if OpenKey }
end; { with lReg }
finally
lReg.Free;
end;
end;
Because I needed to make a second service which was largely identical, I decided to make this a 'base' unit that others derive from (you can already see that in the names above):
unit uSvcTasks;
interface
uses
System.SysUtils, System.Classes, uSvcBase;
type
TMyServiceScheduler = class(TMyServiceBase)
procedure ServiceCreate(Sender: TObject);
private
public
end;
var
MyServiceScheduler: TMyServiceScheduler;
implementation
{%CLASSGROUP 'System.Classes.TPersistent'}
{$R *.dfm}
Uses uTypesAlgemeen;
procedure TMyServiceScheduler.ServiceCreate(Sender: TObject);
begin
inherited;
// Set some properties
end;
At design time, the MyServiceScheduler.Name in this descendant differs from the MyServiceBase.Name.
Issue: The AfterInstall now crashed. Trying to use the original code using OpenKey(MyServiceBase.Name was not allowed.
I worked around his by using a property for the name (setting it in the descendant Create), but I do not understand why referencing MyServiceBase.Name in the AfterInstall does not work. Can anyone explain?
Thanks to Uwe Raabe's comments I was able to figure out how to fix this:
The project had an Application.CreateForm(TMyServiceScheduler, MyServiceScheduler) in the project source which initializes MyServiceScheduler, but there was nothing initializing MyServiceBase, so refering to it was illegal.
Replace the reference to MyServiceBase.Name with Name in the AfterInstall(That should've been done anyway).
Move the code for the ServiceController from uSvcBase to uSvcTasks

How do I allow dragging files for specific control(s) in Delphi

I would like to accept files as soon as someone drops a file to a specific control (e.g. TMemo). I started with this example: http://delphi.about.com/od/windowsshellapi/a/accept-filedrop.htm and modified it like this:
procedure TForm1.FormCreate(Sender: TObject);
begin
DragAcceptFiles( Memo1.Handle, True ) ;
end;
This allows the control to show the dragging icon but the proper WM_DROPFILES message is not getting called because DragAcceptFiles needs a (Parent?)windowhandle. I could determine the MemoHandle in the WMDROPFILES procedure but I don't how, plus the dragging cursor applies for all the controls now. How do I allow dragging for a specific control (and block other controls from dragging)?
You should indeed pass the window handle of the memo control, but then you also need to listen to the WM_DROPFILES message sent to it:
unit Unit5;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ShellAPI;
type
TMemo = class(StdCtrls.TMemo)
protected
procedure WMDropFiles(var Message: TWMDropFiles); message WM_DROPFILES;
procedure CreateWnd; override;
procedure DestroyWnd; override;
end;
TForm5 = class(TForm)
Memo1: TMemo;
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form5: TForm5;
implementation
{$R *.dfm}
procedure TForm5.FormCreate(Sender: TObject);
begin
end;
{ TMemo }
procedure TMemo.CreateWnd;
begin
inherited;
DragAcceptFiles(Handle, true);
end;
procedure TMemo.DestroyWnd;
begin
DragAcceptFiles(Handle, false);
inherited;
end;
procedure TMemo.WMDropFiles(var Message: TWMDropFiles);
var
c: integer;
fn: array[0..MAX_PATH-1] of char;
begin
c := DragQueryFile(Message.Drop, $FFFFFFFF, fn, MAX_PATH);
if c <> 1 then
begin
MessageBox(Handle, 'Too many files.', 'Drag and drop error', MB_ICONERROR);
Exit;
end;
if DragQueryFile(Message.Drop, 0, fn, MAX_PATH) = 0 then Exit;
Text := fn;
end;
end.
The example above only accept a single file dropped. The file name will be put in the memo control. But you can also allow a multiple selection to be dropped:
var
c: integer;
fn: array[0..MAX_PATH-1] of char;
i: Integer;
begin
c := DragQueryFile(Message.Drop, $FFFFFFFF, fn, MAX_PATH);
Clear;
for i := 0 to c - 1 do
begin
if DragQueryFile(Message.Drop, i, fn, MAX_PATH) = 0 then Exit;
Lines.Add(fn);
end;

Delphi: ListView (vsReport) single column header caption with custom font color?

In a ListView with vsReport ViewStyle, how can I customize the font color of just any single column header caption? For example (the second column header caption has a red font color):
I would handle the NM_CUSTOMDRAW header notification code and respond to this notification message with the CDRF_NEWFONT return code at the CDDS_ITEMPREPAINT rendering stage. The following code shows how to extend list view controls to have the event for specifying header item font color:
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ComCtrls, CommCtrl, StdCtrls;
type
TGetHeaderItemFontColorEvent = procedure(Sender: TCustomListView;
ItemIndex: Integer; var FontColor: TColor) of object;
TListView = class(ComCtrls.TListView)
private
FHeaderHandle: HWND;
FOnGetHeaderItemFontColor: TGetHeaderItemFontColorEvent;
procedure WMNotify(var AMessage: TWMNotify); message WM_NOTIFY;
protected
procedure CreateWnd; override;
published
property OnGetHeaderItemFontColor: TGetHeaderItemFontColorEvent read
FOnGetHeaderItemFontColor write FOnGetHeaderItemFontColor;
end;
type
TForm1 = class(TForm)
ListView1: TListView;
procedure FormCreate(Sender: TObject);
private
procedure GetHeaderItemFontColor(Sender: TCustomListView;
ItemIndex: Integer; var FontColor: TColor);
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
{ TListView }
procedure TListView.CreateWnd;
begin
inherited;
FHeaderHandle := ListView_GetHeader(Handle);
end;
procedure TListView.WMNotify(var AMessage: TWMNotify);
var
FontColor: TColor;
NMCustomDraw: TNMCustomDraw;
begin
if (AMessage.NMHdr.hwndFrom = FHeaderHandle) and
(AMessage.NMHdr.code = NM_CUSTOMDRAW) then
begin
NMCustomDraw := PNMCustomDraw(TMessage(AMessage).LParam)^;
case NMCustomDraw.dwDrawStage of
CDDS_PREPAINT:
AMessage.Result := CDRF_NOTIFYITEMDRAW;
CDDS_ITEMPREPAINT:
begin
FontColor := Font.Color;
if Assigned(FOnGetHeaderItemFontColor) then
FOnGetHeaderItemFontColor(Self, NMCustomDraw.dwItemSpec, FontColor);
SetTextColor(NMCustomDraw.hdc, ColorToRGB(FontColor));
AMessage.Result := CDRF_NEWFONT;
end;
else
AMessage.Result := CDRF_DODEFAULT;
end;
end
else
inherited;
end;
{ TForm1 }
procedure TForm1.FormCreate(Sender: TObject);
begin
ListView1.OnGetHeaderItemFontColor := GetHeaderItemFontColor;
end;
procedure TForm1.GetHeaderItemFontColor(Sender: TCustomListView;
ItemIndex: Integer; var FontColor: TColor);
begin
case ItemIndex of
0: FontColor := clRed;
1: FontColor := clGreen;
2: FontColor := clBlue;
end;
end;
end.
The whole project you can download from here. Here's the result of the above example:
You can get the native header control from the listview and then mark the specific item of your column as owner drawn. You only need to change the text color (if you don't remove the string flag) when the header item requests to be drawn. The drawing message will be sent to the header's parent - the listview, hence you need to handle the message there. See here for owner drawn header controls.
Example code:
type
TForm1 = class(TForm)
ListView1: TListView;
procedure FormCreate(Sender: TObject);
...
private
FLVHeader: HWND;
FSaveLVWndProc: TWndMethod;
procedure LVWndProc(var Msg: TMessage);
procedure SetHeaderItemStyle(Index: Integer);
end;
..
uses commctrl;
..
procedure TForm1.FormCreate(Sender: TObject);
begin
FLVHeader := ListView_GetHeader(ListView1.Handle);
SetHeaderItemStyle(1);
FSaveLVWndProc := ListView1.WindowProc;
ListView1.WindowProc := LVWndProc;
end;
procedure TForm1.SetHeaderItemStyle(Index: Integer);
var
HeaderItem: THDItem;
begin
HeaderItem.Mask := HDI_FORMAT or HDI_TEXT or HDI_LPARAM;
Header_GetItem(FLVHeader, 1, HeaderItem);
HeaderItem.Mask := HDI_FORMAT;
HeaderItem.fmt := HeaderItem.fmt or HDF_OWNERDRAW;
Header_SetItem(FLVHeader, 1, HeaderItem);
end;
procedure TForm1.LVWndProc(var Msg: TMessage);
begin
FSaveLVWndProc(Msg); // thanks to #Kobik (cause SO if called later then WM_NOTIFY case on some (all other then mine?) machines)
case Msg.Msg of
WM_DRAWITEM:
if (TWmDrawItem(Msg).DrawItemStruct.CtlType = ODT_HEADER) and
(TWmDrawItem(Msg).DrawItemStruct.hwndItem = FLVHeader) and
(TWmDrawItem(Msg).DrawItemStruct.itemID = 1) then
SetTextColor(TWmDrawItem(Msg).DrawItemStruct.hDC, ColorToRGB(clRed));
WM_NOTIFY:
if (TWMNotify(Msg).NMHdr.hwndFrom = FLVHeader) and
(TWMNotify(Msg).NMHdr.code = HDN_ITEMCHANGED) then
// also try 'HDN_ENDTRACK' if it doesn't work as expected
SetHeaderItemStyle(1);
WM_DESTROY: ListView1.WindowProc := FSaveLVWndProc;
end;
end;

Resources