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
Related
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;
I'm getting an EOutOfResources exception 'Cannot remove shell notification icon' when trying to implement code to restore the tray icon after an Explorer crash/restart. My code is based on the old solution found here. The exception occurs when trying to hide the trayicon. Why does the Delphi XE code below not work?
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ImgList, ExtCtrls;
type
TForm1 = class(TForm)
TrayIcon1: TTrayIcon;
ImageListTray: TImageList;
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
protected
procedure WndProc(var Message: TMessage); Override;
public
{ Public declarations }
end;
var
Form1: TForm1;
msgTaskbarRestart : Cardinal; {custom systemwide message}
implementation
{$R *.dfm}
//ensure systray icon recreated on explorer crash
procedure TForm1.FormCreate(Sender: TObject);
begin
msgTaskbarRestart := RegisterWindowMessage('TaskbarCreated');
end;
procedure TForm1.WndProc(var Message: TMessage);
begin
if (msgTaskbarRestart <> 0) and (Message.Msg = msgTaskbarRestart) then begin
TrayIcon1.Visible := False; {Destroy the systray icon here}//EOutOfResources exception here
TrayIcon1.Visible := True; {Replace the systray icon}
Message.Result := 1;
end;
inherited WndProc(Message);
end;
end.
The TTrayIcon.Visible property setter raises EOutOfResources when a NIM_DELETE request fails:
procedure TCustomTrayIcon.SetVisible(Value: Boolean);
begin
if FVisible <> Value then
begin
FVisible := Value;
...
if not (csDesigning in ComponentState) then
begin
if FVisible then
...
else if not (csLoading in ComponentState) then
begin
if not Refresh(NIM_DELETE) then
raise EOutOfResources.Create(STrayIconRemoveError); // <-- HERE
end;
...
end;
end;
end;
Where Refresh() is just a call to the Win32 Shell_NotifyIcon() function:
function TCustomTrayIcon.Refresh(Message: Integer): Boolean;
...
begin
Result := Shell_NotifyIcon(Message, FData);
...
end;
When you receive the TaskbarCreated message, your previous icons are no longer present in the Taskbar, so Shell_NotifyIcon(NIM_DELETE) returns False. When the Taskbar is (re-)created, you are not supposed to try to remove old icons at all, only re-add new icons with Shell_NotifyIcon(NIM_ADD) as needed.
TTrayIcon has a public Refresh() method, but that uses NIM_MODIFY instead of NIM_ADD, so that will not work in this situation, either:
procedure TCustomTrayIcon.Refresh;
begin
if not (csDesigning in ComponentState) then
begin
...
if Visible then
Refresh(NIM_MODIFY);
end;
end;
However, you don't actually need to handle the TaskbarCreated message manually when using TTrayIcon, because it already handles that message internally for you, and it will call Shell_NotifyIcon(NIM_ADD) if Visible=True:
procedure TCustomTrayIcon.WindowProc(var Message: TMessage);
...
begin
case Message.Msg of
...
else
if (Cardinal(Message.Msg) = RM_TaskBarCreated) and Visible then
Refresh(NIM_ADD); // <-- HERE
end;
end;
...
initialization
...
TCustomTrayIcon.RM_TaskBarCreated := RegisterWindowMessage('TaskbarCreated');
end.
If, for some reason, that is not working correctly, and/or you need to handle TaskbarCreated manually, then I would suggest calling the protected TCustomTrayIcon.Refresh() method directly, eg:
type
TTrayIconAccess = class(TTrayIcon)
end;
procedure TForm1.WndProc(var Message: TMessage);
begin
if (msgTaskbarRestart <> 0) and (Message.Msg = msgTaskbarRestart) then begin
if TrayIcon1.Visible then begin
// TrayIcon1.Refresh;
TTrayIconAccess(TrayIcon1).Refresh(NIM_ADD);
end;
Message.Result := 1;
end;
inherited WndProc(Message);
end;
Otherwise, simply don't use TTrayIcon at all. It is known to be buggy. I have seen a lot of people have a lot of problems with TTrayIcon over the years. I would suggest using Shell_NotifyIcon() directly instead. I have never had any problems using it myself.
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
Sorry for my English, as I am from Germany.
I built a program: http://i.epvpimg.com/I0xie.png
And I want an exponent calculator (I am learning for test in school), but I have a problem...
If I do the number "Zahl" (meaning "number" in German). For example: Number= "2", then I do exponent = "1".
Normally I should get the result 2 but I am getting a 4, why?
What is the problem?
Here is my Code:
unit unit_oberflaeche;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls,
ExtCtrls, unit_inhalt;
type
{ TForm1 }
TForm1 = class(TForm)
Button1: TButton;
Edit1: TEdit;
Edit2: TEdit;
Label1: TLabel;
Label2: TLabel;
Panel1: TPanel;
procedure Button1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
{ private declarations }
public
{ public declarations }
end;
var
Form1: TForm1;
rechner: Texponentrechner;
implementation
{$R *.lfm}
{ TForm1 }
procedure TForm1.FormCreate(Sender: TObject);
begin
rechner := Texponentrechner.Create;
end;
procedure TForm1.Button1Click(Sender: TObject);
VAR i, LVexponent, LVzahl, result: INTEGER;
BEGIN
LVexponent := StrToInt(Edit2.Text);
LVzahl := StrToInt(Edit1.Text);
rechner.set_exponent(LVexponent);
rechner.set_zahl(LVzahl);
FOR i := 1 TO LVexponent DO
BEGIN
result := result * LVzahl
end;
//result := LVzahl;
Panel1.Caption := IntToStr(result);
end;
end.
And here is the other part:
unit unit_inhalt;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils;
TYPE
Texponentrechner = class
private
{ private declarations }
Fexponent : INTEGER;
Fzahl : INTEGER;
public
{ public declarations }
procedure set_exponent (WPexponent:INTEGER);
procedure set_zahl (WPzahl:INTEGER);
function berechne_betrag():INTEGER;
end;
implementation
procedure Texponentrechner.set_exponent(WPexponent:INTEGER);
BEGIN
Fexponent := WPexponent;
end;
procedure Texponentrechner.set_zahl(WPzahl:INTEGER);
BEGIN
Fzahl := WPzahl;
end;
function Texponentrechner.berechne_betrag():INTEGER;
BEGIN
result := Fzahl * Fzahl;
end;
end.
I assume that your exponent calculation has to be done in Texponentrechner class. First, your calculation there is wrong because it returns your number multiplied by itself, and second you are never calling that function in the first place.
So your berechne_betrag function should look like this:
function Texponentrechner.berechne_betrag(): integer;
var i: integer;
begin
Result := 1;
for i := 1 to Fexponent do
Result := Result * Fzahl;
end;
Then you should actually call that function to get the result
rechner.set_exponent(LVexponent);
rechner.set_zahl(LVzahl);
result := rechner.berechne_betrag;
Panel1.Caption := IntToStr(result);
Also you are creating rechner object instance in FormCreate, but you are never releasing it and thus you are creating memory leak. You should call rechner.Free when you are finished using object. Since you have made it global var you create in FormCreate, proper place to release it will be in FormDestroy
But even better practice would be to make it local to Button1Click method.
...
type
TForm1 = class(TForm)
Button1: TButton;
Edit1: TEdit;
Edit2: TEdit;
Label1: TLabel;
Label2: TLabel;
Panel1: TPanel;
procedure Button1Click(Sender: TObject);
end;
var
Form1: TForm1;
implementation
{$R *.lfm}
{ TForm1 }
procedure TForm1.Button1Click(Sender: TObject);
var
LVexponent, LVzahl, result: integer;
rechner: Texponentrechner;
begin
rechner := Texponentrechner.Create;
try
LVexponent := StrToInt(Edit2.Text);
LVzahl := StrToInt(Edit1.Text);
rechner.set_exponent(LVexponent);
rechner.set_zahl(LVzahl);
result := rechner.berechne_betrag;
Panel1.Caption := IntToStr(result);
finally
rechner.Free;
end;
end;
end.
Is there any way to know which verion of Windows we are working on?
I need to set image to TBitButton in Windows XP and no image in Windows7. It should be done automatically.
Check the SysUtils.Win32MajorVersion (in Delphi 7, you'll need to add SysUtils to your uses clause if it's not there already - later versions add it automatically). The easiest way is to assign the Glyph as usual in the IDE, and clear it if you're running on Vista or higher:
if SysUtils.Win32MajorVersion >= 6 then // Windows Vista or higher
BitBtn1.Glyph := nil;
For more info on detecting specific Windows editions and versions, see this post. It hasn't been updated for the latest Windows versions and editions, but it'll get you started. You can also search SO for [delphi] GetVersionEx to see other examples.
This is actually a little project of mine - a drop-in component which provides info of the operating system - even preview it in design-time...
unit JDOSInfo;
interface
uses
Classes, Windows, SysUtils, StrUtils, Forms, Registry;
type
TJDOSInfo = class(TComponent)
private
fReg: TRegistry;
fKey: String;
fMinor: Integer;
fMajor: Integer;
fBuild: Integer;
fPlatform: Integer;
fIsServer: Bool;
fIs64bit: Bool;
fProductName: String;
function GetProductName: String;
procedure SetProductName(Value: String);
procedure SetMajor(Value: Integer);
procedure SetMinor(Value: Integer);
procedure SetBuild(Value: Integer);
procedure SetPlatform(Value: Integer);
procedure SetIs64Bit(const Value: Bool);
procedure SetIsServer(const Value: Bool);
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
property Major: Integer read fMajor write SetMajor;
property Minor: Integer read fMinor write SetMinor;
property Build: Integer read fBuild write SetBuild;
property Platf: Integer read fPlatform write SetPlatform;
property ProductName: String read GetProductName write SetProductName;
property IsServer: Bool read fIsServer write SetIsServer;
property Is64Bit: Bool read fIs64bit write SetIs64Bit;
end;
function IsWOW64: Boolean;
function GetOSInfo: TOSVersionInfo;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('JD Custom', [TJDOSInfo]);
end;
function GetOSInfo: TOSVersionInfo;
begin
FillChar(Result, SizeOf(Result), 0);
Result.dwOSVersionInfoSize := SizeOf(Result);
if not GetVersionEx(Result) then
raise Exception.Create('Error calling GetVersionEx');
end;
function IsWOW64: Boolean;
type
TIsWow64Process = function( // Type of IsWow64Process API fn
Handle: THandle;
var Res: BOOL): BOOL; stdcall;
var
IsWow64Result: BOOL; // result from IsWow64Process
IsWow64Process: TIsWow64Process; // IsWow64Process fn reference
begin
// Try to load required function from kernel32
IsWow64Process:= GetProcAddress(GetModuleHandle('kernel32'),'IsWow64Process');
if Assigned(IsWow64Process) then
begin
// Function is implemented: call it
if not IsWow64Process(GetCurrentProcess, IsWow64Result) then
raise Exception.Create('Bad process handle');
// Return result of function
Result := IsWow64Result;
end else
// Function not implemented: can't be running on Wow64
Result:= False;
end;
constructor TJDOSInfo.Create(AOwner: TComponent);
var
Info: TOSVersionInfo;
Str: String;
begin
inherited Create(AOwner);
fReg:= TRegistry.Create(KEY_READ);
fReg.RootKey:= HKEY_LOCAL_MACHINE;
fKey:= 'Software\Microsoft\Windows NT\CurrentVersion';
fReg.OpenKey(fKey, False);
Info:= GetOSInfo;
fMajor:= Info.dwMajorVersion;
fMinor:= Info.dwMinorVersion;
fBuild:= Info.dwBuildNumber;
fIsServer:= False;
fIs64bit:= False;
fPlatform:= Info.dwPlatformId;
if fMajor >= 5 then begin
//After 2000
if fReg.ValueExists('ProductName') then
Str:= fReg.ReadString('ProductName')
else begin
Str:= 'Unknown OS: '+IntToStr(fMajor)+'.'+IntToStr(fMinor)+'.'+
IntToStr(fBuild)+'.'+IntToStr(fPlatform);
end;
if fReg.ValueExists('InstallationType') then begin
if UpperCase(fReg.ReadString('InstallationType')) = 'SERVER' then
fIsServer:= True;
end;
fIs64bit:= IsWOW64;
if fIs64bit then
Str:= Str + ' 64 Bit';
end else begin
//Before 2000
case fMajor of
4: begin
case fMinor of
0: Str:= 'Windows 95';
10: Str:= 'Windows 98';
90: Str:= 'Windows ME';
end;
end;
else begin
Str:= 'Older than 95';
end;
end;
end;
Self.fProductName:= Str;
end;
destructor TJDOSInfo.Destroy;
begin
if assigned(fReg) then begin
if fReg.Active then
fReg.CloseKey;
fReg.Free;
end;
inherited Destroy;
end;
function TJDOSInfo.GetProductName: String;
begin
Result:= Self.fProductName;
end;
procedure TJDOSInfo.SetProductName(Value: String);
begin
//Do Nothing Here!
end;
procedure TJDOSInfo.SetMinor(Value: Integer);
begin
//Do Nothing Here!
end;
procedure TJDOSInfo.SetMajor(Value: Integer);
begin
//Do Nothing Here!
end;
procedure TJDOSInfo.SetBuild(Value: Integer);
begin
//Do Nothing Here!
end;
procedure TJDOSInfo.SetPlatform(Value: Integer);
begin
//Do Nothing Here!
end;
procedure TJDOSInfo.SetIs64Bit(const Value: Bool);
begin
//Do Nothing Here!
end;
procedure TJDOSInfo.SetIsServer(const Value: Bool);
begin
//Do Nothing Here!
end;
end.