How can my Delphi app easily write to the Windows Event Log?
What is the difference between TEventLogger and ReportEvent?
How do I use the ReportEvent function?
If you are writing a Windows Service and need to write to the local machine's Windows Event Log then you can call
TService.LogMessage as mentioned here.
//TMyTestService = class(TService)
procedure TMyTestService.ServiceStart(Sender: TService; var Started: Boolean);
begin
LogMessage('This is an error.');
LogMessage('This is another error.', EVENTLOG_ERROR_TYPE);
LogMessage('This is information.', EVENTLOG_INFORMATION_TYPE);
LogMessage('This is a warning.', EVENTLOG_WARNING_TYPE);
end;
For any other type of applications you can use the SvcMgr.TEventLogger undocumented helper class for TService to write the the local machine's Windows Event Log as mentioned here, here and here.
uses
SvcMgr;
procedure TForm1.EventLoggerExampleButtonClick(Sender: TObject);
begin
with TEventLogger.Create('My Test App Name') do
begin
try
LogMessage('This is an error.');
LogMessage('This is another error.', EVENTLOG_ERROR_TYPE);
LogMessage('This is information.', EVENTLOG_INFORMATION_TYPE);
LogMessage('This is a warning.', EVENTLOG_WARNING_TYPE);
finally
Free;
end;
end;
end;
You can also use the Windows API ReportEvent function as mentioned here and here.
I've created a simple class to make it easier, it is available on GitHub.
//----------------- EXAMPLE USAGE: ---------------------------------
uses
EventLog;
procedure TForm1.EventLogExampleButtonClick(Sender: TObject);
begin
TEventLog.Source := 'My Test App Name';
TEventLog.WriteError('This is an error.');
TEventLog.WriteInfo('This is information.');
TEventLog.WriteWarning('This is a warning.');
end;
//------------------------------------------------------------------
unit EventLog;
interface
type
TEventLog = class
private
class procedure CheckEventLogHandle;
class procedure Write(AEntryType: Word; AEventId: Cardinal; AMessage: string); static;
public
class var Source: string;
class destructor Destroy;
class procedure WriteInfo(AMessage: string); static;
class procedure WriteWarning(AMessage: string); static;
class procedure WriteError(AMessage: string); static;
class procedure AddEventSourceToRegistry; static;
end;
threadvar EventLogHandle: THandle;
implementation
uses Windows, Registry, SysUtils;
class destructor TEventLog.Destroy;
begin
if EventLogHandle > 0 then
begin
DeregisterEventSource(EventLogHandle);
end;
end;
class procedure TEventLog.WriteInfo(AMessage: string);
begin
Write(EVENTLOG_INFORMATION_TYPE, 2, AMessage);
end;
class procedure TEventLog.WriteWarning(AMessage: string);
begin
Write(EVENTLOG_WARNING_TYPE, 3, AMessage);
end;
class procedure TEventLog.WriteError(AMessage: string);
begin
Write(EVENTLOG_ERROR_TYPE, 4, AMessage);
end;
class procedure TEventLog.CheckEventLogHandle;
begin
if EventLogHandle = 0 then
begin
EventLogHandle := RegisterEventSource(nil, PChar(Source));
end;
if EventLogHandle <= 0 then
begin
raise Exception.Create('Could not obtain Event Log handle.');
end;
end;
class procedure TEventLog.Write(AEntryType: Word; AEventId: Cardinal; AMessage: string);
begin
CheckEventLogHandle;
ReportEvent(EventLogHandle, AEntryType, 0, AEventId, nil, 1, 0, #AMessage, nil);
end;
// This requires admin rights. Typically called once-off during the application's installation
class procedure TEventLog.AddEventSourceToRegistry;
var
reg: TRegistry;
begin
reg := TRegistry.Create;
try
reg.RootKey := HKEY_LOCAL_MACHINE;
if reg.OpenKey('\SYSTEM\CurrentControlSet\Services\Eventlog\Application\' + Source, True) then
begin
reg.WriteString('EventMessageFile', ParamStr(0)); // The application exe's path
reg.WriteInteger('TypesSupported', 7);
reg.CloseKey;
end
else
begin
raise Exception.Create('Error updating the registry. This action requires administrative rights.');
end;
finally
reg.Free;
end;
end;
initialization
TEventLog.Source := 'My Application Name';
end.
ReportEvent supports writing a log entry to either a local or remote machine's Event Log. For a remote example see John Kaster's EDN article.
Note that you would also have to create a message file and register your event source otherwise all your log messages will be starting with something like this:
The description for Event ID xxx from source xxxx cannot be
found. Either the component that raises this event is not installed on
your local computer or the installation is corrupted. You can install
or repair the component on the local computer.
If the event originated on another computer, the display information
had to be saved with the event.
The following information was included with the event:
1, For more information on how to create a message file see Finn Tolderlund's tutorial or Michael Hex's article
or you can use an existing MC and RES file included in the GitHub project.
2, Embed the RES file into your application by including the MessageFile.res in your DPR file. Alternatively you can create a dll for the messages.
program MyTestApp;
uses
Forms,
FormMain in 'FormMain.pas' {MainForm},
EventLog in 'EventLog.pas';
{$R *.res}
{$R MessageFile\MessageFile.res}
begin
Application.Initialize;
3, The once-off registration requires admin rights writing to the registry so it us usually done as part of your application's installation process.
//For example
AddEventSourceToRegistry('My Application Name', ParamStr(0));
//or
AddEventSourceToRegistry('My Application Name', 'C:\Program Files\MyApp\Messages.dll');
//--------------------------------------------------
procedure AddEventSourceToRegistry(ASource, AFilename: string);
var
reg: TRegistry;
begin
reg := TRegistry.Create;
try
reg.RootKey := HKEY_LOCAL_MACHINE;
if reg.OpenKey('\SYSTEM\CurrentControlSet\Services\Eventlog\Application\' + ASource, True) then
begin
reg.WriteString('EventMessageFile', AFilename);
reg.WriteInteger('TypesSupported', 7);
reg.CloseKey;
end
else
begin
raise Exception.Create('Error updating the registry. This action requires administrative rights.');
end;
finally
reg.Free;
end;
end;
If you have need Windows event logging and other logging requirements you can also use logging frameworks such as log4d and TraceTool
See here if you want to write to the Event Log window in the Delphi IDE.
Related
I have ported an application from ADO to FireDAC applying several RegExp replaces on the source code to convert the ADOQuery, ADOTables, ADOCommands, ADOStoredProcs, etc. ... to the corresponding FireDAC components.
It has worked fine, but now when running that application plenty of forms raise errors because of the type of the persistent fields being different than the type expected (the one defined from ADO when the persistent field was created).
I'm trying to make a list of those errors, creating an instance of all my forms and opening their datasets with persistent fields, and logging the errors. I can get the list of forms from the project source code, but when I try to use FindClass to create each form I get an error telling that the class has not been found.
Is there any other way to create a Form/DataModule from its class name ?.
This is my current code:
class procedure TfrmCheckFormularis.CheckDatasets(ProjecteFile: string);
var frmCheckFormularis: TfrmCheckFormularis;
Projecte: string;
rm: TMatch;
cc: TComponentClass;
c: TComponent;
i: integer;
Dataset: TFDQuery;
begin
Projecte := TFile.ReadAllText(ProjecteFile);
frmCheckFormularis := TfrmCheckFormularis.Create(Application);
try
with frmCheckFormularis do begin
Show;
qryForms.CreateDataSet;
qryErrors.CreateDataSet;
// I get a list of all the forms and datamodules on my project
for rm in TRegEx.Matches(Projecte, '^(?:.* in '')(?<File>.*)(?:'' {)(?<Class>.*)(?:},)', [roMultiline]) do begin
qryForms.AppendRecord([rm.Groups['File'].Value, rm.Groups['Class'].Value]);
end;
// Check every form and datamodule
qryForms.First;
while not qryForms.Eof do begin
cc := TComponentClass(FindClass(qryFormsClass.Value));
c := cc.Create(frmCheckFormularis);
try
for i := 0 to c.ComponentCount - 1 do begin
if c.Components[i] is TFDQuery then begin
Dataset := c.Components[i] as TFDQuery;
// When the Dataset has persistent fields, I open it to check if the persistent fields are correct
if Dataset.FieldDefs.Count > 1 then begin
try
Dataset.Open;
except
on E: Exception do qryErrors.AppendRecord([c.Name, Dataset.Name, E.Message]);
end;
end;
end;
end;
finally
c.Free;
end;
qryForms.Next;
end;
end;
finally
frmCheckFormularis.Free;
end;
end;
Thank you.
Using the "new" RTTI in Delphi is quite easy. The following code will (hopefully*) create one instance of each form in your application:
procedure TForm1.Button1Click(Sender: TObject);
var
Context: TRttiContext;
&Type: TRttiType;
InstanceType: TRttiInstanceType;
begin
Context := TRttiContext.Create;
for &Type in Context.GetTypes do
begin
if (&Type.TypeKind = tkClass) and &Type.IsInstance then
begin
InstanceType := TRttiInstanceType(&Type);
if InstanceType.MetaclassType.InheritsFrom(TForm) and (InstanceType.MetaclassType <> TForm) then
TFormClass(InstanceType.MetaclassType).Create(Application){.Show}; // optionally show it
end;
end;
end;
* Technically, it will create one instance of each proper descendant class of TForm.
I would like to know how to save the contents of a "variable" after program is closed and reopened.
for eg:
iCount:=0;
inc(iCount)=1;
when i close the program and reopen i want iCount to contain 1.
Thank you.
There are many ways to do this. You need to save the value somewhere: in a file, in the Windows registry, in the cloud, ...
File
Perhaps the easiest approach is to use an INI file. Try this:
Create a new VCL application.
Add a field FMyNumber: Integer to the main form.
To the main form, add the following methods (and make sure to include IniFiles and IOUtils in the implementation section's uses list):
function TForm1.GetSettingsFileName: TFileName;
begin
Result := TPath.GetHomePath + '\Fuzail\TestApp';
ForceDirectories(Result);
Result := Result + '\settings.ini';
end;
procedure TForm1.LoadSettings;
var
Ini: TMemIniFile;
begin
Ini := TMemIniFile.Create(GetSettingsFileName);
try
FMyNumber := Ini.ReadInteger('Settings', 'MyNumber', 0);
finally
Ini.Free;
end;
end;
procedure TForm1.SaveSettings;
var
Ini: TMemIniFile;
begin
Ini := TMemIniFile.Create(GetSettingsFileName);
try
Ini.WriteInteger('Settings', 'MyNumber', FMyNumber);
Ini.UpdateFile;
finally
Ini.Free;
end;
end;
Now make sure to call these when your application is starting and shutting down:
procedure TForm1.FormCreate(Sender: TObject);
begin
LoadSettings;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
SaveSettings;
end;
Now the value of FMyNumber is saved between the sessions!
Registry
Another common approach, probably, is to use the registry. Try this:
Create a new VCL application.
Add a field FMyNumber: Integer to the main form.
To the main form, add the following methods (and make sure to include Registry in the implementation section's uses list):
procedure TForm1.LoadSettings;
var
Reg: TRegistry;
begin
Reg := TRegistry.Create;
try
Reg.RootKey := HKEY_CURRENT_USER;
if Reg.OpenKey('\Software\Fuzail\TestApp', False) then
try
if Reg.ValueExists('MyNumber') then
FMyNumber := Reg.ReadInteger('MyNumber')
finally
Reg.CloseKey;
end;
finally
Reg.Free;
end;
end;
procedure TForm1.SaveSettings;
var
Reg: TRegistry;
begin
Reg := TRegistry.Create;
try
Reg.RootKey := HKEY_CURRENT_USER;
if Reg.OpenKey('\Software\Fuzail\TestApp', True) then
try
Reg.WriteInteger('MyNumber', FMyNumber);
finally
Reg.CloseKey;
end;
finally
Reg.Free;
end;
end;
Now make sure to call these when your application is starting and shutting down:
procedure TForm1.FormCreate(Sender: TObject);
begin
LoadSettings;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
SaveSettings;
end;
Again the value of FMyNumber is saved between the sessions!
I'm trying to write a plugin for Delphi 5 that will store the paths to our testing exes in the DOF so that there is a direct association between the project and the tests for that project. When I go to add my own module to the DOF file, something like
[DUint Plugin]
IntegrationTestExe=Somepath
UnitTestExeList=Some;Path;
Anytime I go to add this either manually or through code, when I save the project, the lines I add are removed. I chalked this up to maybe the IDE just doesn't allow custom modules in the DOF.
However, we use a third party plugin called EurekaLog. EurekaLog injects its own vars into the DOF and when you save, those vars are not removed. I copied much of the code over so I could test if the EurekaLog code would work properly (through some magic) but their code just wrote their module to the DOF and did nothing else special.
Does anyone know how this is accomplished in EurekaLog? Do I need to register my module somewhere so that the IDE knows not to remove it?
Update After a bit of experimenting, it seems that saving settings to the DOF is actually noticeably more reliable than saving them to the DSK file.
Add another TEdit to the form and create LoadDOFSettings and SaveDOFSettings
analogous to the existing LoadSettings and SaveSettings and call them on receipt
of the DesktopLoad and DesktoSave notifications. The SaveDOFSettings doesn't need to be called via the Timer1 event because the renaming doesn't seem to happen to the DOF.
Original answer
I suggest that before reading this answer, you do a File | Close All in the IDE,
create a new package, add the unit below into it and install it in the IDE.
The purpose of the package is two-fold, firstly to show how to save custom settings in the DSK file and secondly to give you an idea of what event information about project
files you can get from the IDE via the services in the ToolsAPI unit..
Once you've installed the package, keep an eye on its form, which shows you file notifications in the upper memo as you open, work on and close a project. There are
several things to notice:
When you open a project, the last notification you receive is about its DSK file having been opened.
Not every file type is the subject of a notification. In particular, you don't receive any notifications specifically about the DOF file, so if you want to write to it and later read from it, you have to make assumptions about when it's safe (or not) to do so, and this is possibly why you have run into the problem you are asking about.
When you do a Close All on the project, the last file change you get notified about is the DSK being written. The catch is that it's initially written to a file of the same name but with the extension .$$$. Very soon afterwards, but asaics you can't tell exactly when, this .$$$ file is renamed to .DSK.
The form created by the code below has an edit box, edMyValue' which can be used to set a value in a section of the DSK file calledMySettingsand which is reloaded the next time the project is opened. The writing of theMySettings` section of the DSK file is triggered aby a TTimer with a 2-second delay to give the IDE time to write and rename the DSK file as I've described. This obviously provides the opportunity for a race condition.
You might like to refer to
http://www.gexperts.org/open-tools-api-faq/#dsk
(GExperts is the IDE add-in tool that's been around since very early days of Delphi)
The section of the article is talking about the current project's .DSK file. Like the DOF, this is in INI file format, with sections like
[Closed Files]
[Modules]
[EditWindow0]
[View0]
As you'll see it says
check for the ofnProjectDesktopLoad and ofnProjectDesktopSave NotifyCode values. When you see one of those, you can save/load values from the file indicated by the FileName parameter using a class such as TIniFile.
Perhaps it's a bit trickier than the article suggests, because of the renaming business.
Have fun!
unit IDEEventsu;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ExtCtrls, ToolsAPI, Grids, IniFiles;
type
TFileEventsForm = class(TForm)
Panel1: TPanel;
Memo1: TMemo;
edMyValue: TEdit;
btnClear: TButton;
Timer1: TTimer;
Memo2: TMemo;
procedure btnClearClick(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
private
function GetCurrentProject: IOTAProject;
public
// The following are using interfaces accessible via the ToolsAPI
Services: IOTAServices;
ProjectGroup : IOTAProjectGroup;
Project: IOTAProject;
Options : IOTAProjectOptions;
ModServices: IOTAModuleServices;
Module: IOTAModule;
NotifierIndex: Integer; // This is used to disconnect our notifier from the IDE
IsSetUp : Boolean;
SetUpCount : Integer;
DskFileName : String;
procedure SetUp;
procedure SaveSettings;
procedure LoadSettings;
end;
var
FileEventsForm: TFileEventsForm;
procedure Register;
[...]
uses
typinfo;
type
TIdeNotifier = class(TNotifierObject, IOTANotifier, IOTAIDENotifier)
// This is the class we use to receive file notication events from the IDE via the
// interfaces in ToolsAPI.Pas
//
// It needs to implement the IOTANotifier and IOTAIDENotifier interfaces and,
// once registered with the IDE, the IDE calls its methods as a kind of call-back
// mechanism so that it gets notified of file events
//
// Note that this file also provides a form for displaying the received event
// notifications and that the IOTANotifier and IOTAIDENotifier interfaces could
// just as easily be implemented by the form itself
protected
procedure AfterCompile(Succeeded: Boolean);
procedure BeforeCompile(const Project: IOTAProject; var Cancel: Boolean);
procedure FileNotification(NotifyCode: TOTAFileNotification;
const FileName: string; var Cancel: Boolean);
end;
procedure Register;
// This is necessary to register the package in the IDE
var
Notifier : TIdeNotifier;
begin
FileEventsForm:= TFileEventsForm.Create(Nil);
FileEventsForm.Services := BorlandIDEServices as IOTAServices;
Notifier := TIdeNotifier.Create;
Notifier.Form := FileEventsForm;
FileEventsForm.NotifierIndex := FileEventsForm.Services.AddNotifier(TIdeNotifier.Create);
end;
procedure CloseDown;
begin
FileEventsForm.Services.RemoveNotifier(FileEventsForm.NotifierIndex);
FileEventsForm.Close;
FileEventsForm.Free;
end;
function NotifyCodeString(NotifyCode : TOTAFileNotification) : String;
begin
Result := Copy(GetEnumName(TypeInfo(TOTAFileNotification), Ord(NotifyCode)), 4, MaxInt);
end;
procedure TIdeNotifier.AfterCompile(Succeeded: Boolean);
begin
end;
procedure TIdeNotifier.BeforeCompile(const Project: IOTAProject; var Cancel: Boolean);
begin
end;
procedure TIdeNotifier.FileNotification(NotifyCode: TOTAFileNotification;
const FileName: string; var Cancel: Boolean);
begin
if True {NotifyCode in [ofnProjectDesktopLoad, ofnActiveProjectChanged]} then begin
FileEventsForm.Show;
FileEventsForm.Memo1.Lines.Add(Format('%s file: %s', [NotifyCodeString(NotifyCode), FileName]));
case NotifyCode of
ofnProjectDesktopLoad,
ofnDefaultDesktopLoad : begin
FileEventsForm.DskFileName := FileName;
FileEventsForm.LoadSettings;
end;
ofnProjectDesktopSave,
ofnDefaultDesktopSave : begin
if True{CompareText(ExtractFileExt(FileName), '.DSK') = 0} then begin
FileEventsForm.Caption := FileName;
FileEventsForm.Timer1.Enabled := True; // causes DSK file to be updated after Timer1.Interval (=2000ms)
end;
end;
end; { case }
end;
end;
procedure TFileEventsForm.btnClearClick(Sender: TObject);
begin
Memo1.Lines.Clear;
end;
function TFileEventsForm.GetCurrentProject: IOTAProject;
var
i: Integer;
begin
Result := nil;
ModServices := BorlandIDEServices as IOTAModuleServices;
for i := 0 to ModServices.ModuleCount - 1 do
begin
Module := ModServices.Modules[i];
if Supports(Module, IOTAProjectGroup, ProjectGroup) then begin
Result := ProjectGroup.ActiveProject;
Options := Result.ProjectOptions;
Exit;
end
else if Supports(Module, IOTAProject, Project) then
begin // In the case of unbound packages, return the 1st
if Result = nil then begin
Result := Project;
Options := Result.ProjectOptions;
end;
end;
end;
end;
procedure TFileEventsForm.SetUp;
begin
Project := GetCurrentProject;
Inc(SetUpCount);
Caption := 'Setup done ' + IntToStr(SetUpCount);
IsSetUp := True;
end;
procedure TFileEventsForm.LoadSettings;
var
Ini : TMemIniFile;
S : String;
begin
Ini := TMemIniFile.Create(DSKFileName);
try
S := Ini.ReadString('MySettings', 'Name', 'no value');
edMyValue.Text := S;
finally
Ini.Free;
end;
end;
procedure TFileEventsForm.SaveSettings;
var
Ini : TMemIniFile;
S : String;
begin
S := DSKFileName;
Caption := 'Saving: ' + S;
Ini := TMemIniFile.Create(S);
try
Ini.WriteString('MySettings', 'Name', edMyValue.Text);
Ini.UpdateFile;
Ini.ReadSections(Memo2.Lines);
Memo2.Lines.Add('This file : ' + DSKFileName);
edMyValue.Text := '?';
finally
Ini.Free;
end;
end;
procedure TFileEventsForm.Timer1Timer(Sender: TObject);
begin
Timer1.Enabled := False;
SaveSettings;
end;
initialization
finalization
CloseDown;
end.
Is it possible to make readonly source code (eg., .pas & .dfm) writable from within the Delphi IDE? The right click option to make files Readonly/Writable within the IDE doesn't change the properties on the file system. Is there an IDE extension or similar that can achieve this?
A way to do this without having to integrate a source control system would be preferable. I am using Delphi XE and Delphi 6.
Thanks!
sse
This is how I would do it.
Create a new package which will be installed into the IDE at designtime. If you have an existing package handy then you could carry on using it. Make sure the package requires the designide package. You can do this in the project manager, or just by viewing the project source and adding designide to the requires clause.
Now add the following unit to your package.
unit MakeEditable;
interface
procedure Register;
implementation
uses
Windows, SysUtils, Menus, ToolsAPI;
type
TMakeEditable = class(TObject)
private
FEditorServices: IOTAEditorServices;
FFileMenu: TMenuItem;
FMakeEditable: TMenuItem;
function MenuItemWithCaptionLike(const Menu: TMenuItem; const DesiredCaption: string): TMenuItem;
procedure MakeEditableClick(Sender: TObject);
public
constructor Create;
destructor Destroy; override;
end;
constructor TMakeEditable.Create;
var
Index: Integer;
PreviousMenuItem: TMenuItem;
begin
inherited;
FEditorServices := (BorlandIDEServices as IOTAEditorServices);
FFileMenu := MenuItemWithCaptionLike((BorlandIDEServices as INTAServices40).MainMenu.Items, 'File');
if Assigned(FFileMenu) then begin
PreviousMenuItem := MenuItemWithCaptionLike(FFileMenu, 'Reopen');
if Assigned(PreviousMenuItem) then begin
Index := PreviousMenuItem.MenuIndex;
if Index>=0 then begin
FMakeEditable := TMenuItem.Create(FFileMenu);
FMakeEditable.Caption := 'Ma&ke Editable';
FMakeEditable.OnClick := MakeEditableClick;
FFileMenu.Insert(Index, FMakeEditable);
end;
end;
end;
end;
destructor TMakeEditable.Destroy;
begin
FMakeEditable.Free;
inherited;
end;
function TMakeEditable.MenuItemWithCaptionLike(const Menu: TMenuItem; const DesiredCaption: string): TMenuItem;
var
i: Integer;
Target, Found: string;
begin
Target := StringReplace(LowerCase(Trim(DesiredCaption)), '&', '', [rfReplaceAll, rfIgnoreCase]);
for i := 0 to Menu.Count-1 do begin
Result := Menu.Items[i];
Found := StringReplace(LowerCase(Trim(Result.Caption)), '&', '', [rfReplaceAll, rfIgnoreCase]);
if Pos(Target, Found)>0 then begin
exit;
end;
end;
Result := nil;
end;
procedure TMakeEditable.MakeEditableClick(Sender: TObject);
procedure MakeFileEditable(const FileName: string);
var
Attributes: DWORD;
begin
Attributes := GetFileAttributes(PChar(FileName));
SetFileAttributes(PChar(FileName), Attributes and not FILE_ATTRIBUTE_READONLY);
end;
var
FileName: string;
FileExt: string;
LinkedFileName: string;
EditBuffer: IOTAEditBuffer;
begin
EditBuffer := FEditorServices.TopBuffer;
FileName := EditBuffer.FileName;
if FileExists(FileName) then begin
MakeFileEditable(FileName);
EditBuffer.IsReadOnly := False;
FileExt := ExtractFileExt(FileName);
if SameText(FileExt,'.dfm') then begin
LinkedFileName := ChangeFileExt(FileName, '.pas');
end else if SameText(FileExt,'.pas') then begin
LinkedFileName := ChangeFileExt(FileName, '.dfm');
end else begin
LinkedFileName := '';
end;
if (LinkedFileName<>'') and FileExists(LinkedFileName) then begin
MakeFileEditable(LinkedFileName);
end;
end;
end;
var
MakeEditableInstance: TMakeEditable;
procedure Register;
begin
MakeEditableInstance := TMakeEditable.Create;
end;
initialization
finalization
MakeEditableInstance.Free;
end.
When you compile and install this package you will now have a new menu item on the File menu which both clears the read-only flag in the input buffer and makes the file writeable.
You can call a .bat file from the tools menu. So you could write a .bat file to do the work for you, and call it with $EDNAME as the parameter.
Your .bat file should see the filename as %1. Then you'd need a little bit of logic to change the read-only flag (attrib command?) and then see if there is a .dfm and do that one as well.
You could also (obviously) make a Delphi command-line app to do this, if you're not comfortable with .bat files.
This idea inspired by this article that talks about how to use a .bat file to integrate SVN commands with the Delphi tools menu:
http://delphi.wikia.com/wiki/Adding_TortoiseSVN_to_the_Tools_menu
Another idea: Just add an option to the tools menu: "open command prompt here". It lets you do all sorts of things from the command line, such as running the attrib command.
Add a new entry to the Tools menu, and use these settings:
Title: Open Command Prompt Here
Program: cmd.exe
Working Dir (leave blank)
Parameters: cd $PATH($EDNAME)
Also, make yourself an "Open Folder Here" entry:
Title: Open Folder Here
Program: explorer.exe
Working Dir (leave blank)
Parameters: $PATH($EDNAME)
I have code which is used both in services and within VCL Form applications (win32 application). How can I determine if the underlying application is running as a NT Service or as an application?
Thanks.
BEGIN OF EDIT
Since this still seems to be getting some attention I decided to update the answer with missing info and newer windows patches. In any case you should not copy / paste the code. The code is just a showcase on how the things should be done.
END OF EDIT:
You can check if the parent process is SCM (service control manager). If you are running as service this is always the case and never the case if running as standard application. Also I think that SCM has always the same PID.
You can check it like this:
type
TAppType = (atUnknown, atDesktop, atService);
var
AppType: TAppType;
function InternalIsService: Boolean;
var
PL: TProcessList;
MyProcessId: DWORD;
MyProcess: PPROCESSENTRY32;
ParentProcess: PPROCESSENTRY32;
GrandParentProcess: PPROCESSENTRY32;
begin
Result := False;
PL := TProcessList.Create;
try
PL.CreateSnapshot;
MyProcessId := GetCurrentProcessId;
MyProcess := PL.FindProcess(MyProcessId);
if MyProcess <> nil then
begin
ParentProcess := PL.FindProcess(MyProcess^.th32ParentProcessID);
if ParentProcess <> nil then
begin
GrandParentProcess := PL.FindProcess(ParentProcess^.th32ParentProcessID);
if GrandParentProcess <> nil then
begin
Result := SameText(string(ParentProcess^.szExeFile), 'services.exe') and
(SameText(string(GrandParentProcess^.szExeFile), 'winlogon.exe') or
SameText(string(GrandParentProcess^.szExeFile), 'wininit.exe'));
end;
end;
end;
finally
PL.Free;
end;
end;
function IsService: Boolean;
begin
if AppType = atUnknown then
begin
try
if InternalIsService then
AppType := atService
else
AppType := atDesktop;
except
AppType := atService;
end;
end;
Result := AppType = atService;
end;
initialization
AppType := atUnknown;
The TProcessList is implemented like this (again THashTable is not included but any hash table should be fine):
type
TProcessEntryList = class(TList)
private
function Get(Index: Integer): PPROCESSENTRY32;
procedure Put(Index: Integer; const Value: PPROCESSENTRY32);
public
property Items[Index: Integer]: PPROCESSENTRY32 read Get write Put; default;
function Add(const Entry: TProcessEntry32): Integer; reintroduce;
procedure Clear; override;
end;
TProcessList = class
private
ProcessIdHashTable: THashTable;
ProcessEntryList: TProcessEntryList;
public
constructor Create; reintroduce;
destructor Destroy; override;
procedure CreateSnapshot;
function FindProcess(const ProcessId: DWORD): PPROCESSENTRY32;
end;
implementation
{ TProcessEntryList }
procedure TProcessEntryList.Clear;
var
i: Integer;
begin
i := 0;
while i < Count do
begin
FreeMem(Items[i]);
Inc(i);
end;
inherited;
end;
procedure TProcessEntryList.Put(Index: Integer; const Value: PPROCESSENTRY32);
var
Item: Pointer;
begin
Item := inherited Get(Index);
CopyMemory(Item, Value, SizeOf(tagPROCESSENTRY32));
end;
function TProcessEntryList.Get(Index: Integer): PPROCESSENTRY32;
begin
Result := PPROCESSENTRY32(inherited Get(Index));
end;
function TProcessEntryList.Add(const Entry: TProcessEntry32): Integer;
var
EntryCopy: PPROCESSENTRY32;
begin
GetMem(EntryCopy, SizeOf(tagPROCESSENTRY32));
CopyMemory(EntryCopy, #Entry, SizeOf(tagPROCESSENTRY32));
Result := inherited Add(EntryCopy);
end;
{ TProcessList }
constructor TProcessList.Create;
begin
inherited;
ProcessEntryList := TProcessEntryList.Create;
ProcessIdHashTable := THashTable.Create;
end;
destructor TProcessList.Destroy;
begin
FreeAndNil(ProcessIdHashTable);
FreeAndNil(ProcessEntryList);
inherited;
end;
function TProcessList.FindProcess(const ProcessId: DWORD): PPROCESSENTRY32;
var
ItemIndex: Integer;
begin
Result := nil;
if not ProcessIdHashTable.ContainsKey(IntToStr(ProcessId)) then
Exit;
ItemIndex := Integer(ProcessIdHashTable.Item[IntToStr(ProcessId)]);
Result := ProcessEntryList.Items[ItemIndex];
end;
procedure TProcessList.CreateSnapshot;
var
SnapShot: THandle;
ProcessEntry: TProcessEntry32;
ItemIndex: Integer;
begin
SnapShot := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
if SnapShot <> 0 then
try
ProcessEntry.dwSize := SizeOf(ProcessEntry);
if Process32First(SnapShot, ProcessEntry) then
repeat
ItemIndex := ProcessEntryList.Add(ProcessEntry);
ProcessIdHashTable.Add(IntToStr(ProcessEntry.th32ProcessID), TObject(ItemIndex));
until not Process32Next(SnapShot, ProcessEntry);
finally
CloseHandle(SnapShot);
end;
end;
The application object (Forms.application) mainform will be nil if it is not a forms based application.
uses
Forms, ... ;
function IsFormBased : boolean;
begin
Result := Assigned(Forms.Application.MainForm);
end;
How about matching GetCurrentProcessId against EnumServicesStatusEx?
The lpServices parameter points to a buffer that receives an array of ENUM_SERVICE_STATUS_PROCESS structures.
The match is done against the enumerated service process ID: ServiceStatusProcess.dwProcessId in that structure.
Another option is using WMI to query for Win32_Service instances where ProcessId=GetCurrentProcessId.
I doubt that
System.IsConsole
System.IsLibrary
will give you the expected results.
All I can think of is to pass an Application object as TObject to the method where you need to make that distinction and test for the passed object's classname being a
TServiceApplication
or
TApplication
That said, there shouldn't be a need for you to know if your code is running in a service or a GUI. You should probably rethink your design and make the caller to pass an object to handle messages you want (or don't want) to show. (I assume it is for showing messages/exceptions you'd like to know).
You can try something like this
Function IsMyformInsideaWindowsService(aForm:TObject) :Boolean;
Begin
Result:=aForm.ClassParent.ClassName='TService'; //When a form is running under a service the Class Parent is a TService
End;
A single project cannot (or I should say ideally is not) both a service and a forms application, at least not if you are able to distinguish between the Forms Application object and the SvcMgr Application object - you must presumably have separate projects for the forms code and the service code.
So perhaps the easiest solution is a project conditional define. i.e. in your project settings for the service project add "SERVICEAPP" to the Conditional Defines.
Then whenever you need to change behaviour simply:
{$ifdef SERVICEAPP}
{$else}
{$endif}
For belts and braces you might adopt one of the previously described tests within some startup code to ensure that your project has been compiled with the expected symbol defined.
program ... ;
:
begin
{$ifdef SERVICEAPP}
// test for service app - ASSERT if not
{$else}
// test for forms app - ASSERT if not
{$endif}
:
end.
It is possible that your Forms app is actually running as a service, using the crude technique that allows any application to be running as a service.
In that case of course your app will always be a Forms application and the easiest way to handle that situation is to have a command line switch that you specify only in the service definition for your executable so that your app can respond appropriate by testing for that command line switch.
This does allow you to more easily test your "service mode" behaviour of course, since you can run your app in "debug" mode with that switch defined from within the IDE, but it's not an ideal way to build a service application so I would not recommend it on the strength of that alone. It's a technique that is usually only used when you have an EXE that you wish to run as a service but have no way to modify the source code to turn it into a "proper" service.
The answer from "Runner" ( https://stackoverflow.com/a/1568462 ) looked very helpful, but I could not use it since neither TProcessList, nor CreateSnapshot is defined. Searching for "TProcessList CreateSnapshot" in Google will just find 7 pages, including this one and mirrors/quotes of this page. No code exists. Alas, my reputation is too low to send him a comment, asking where I can find the code of TProcessList.
Another problem: At my computer (Win7 x64), the "services.exe" is NOT inside "winlogon.exe". It is inside "wininit.exe". Since it seems to be an implementation detail of Windows, I would suggest not querying the grand parent. Also, services.exe does not need to be the direct parent, since processes could be forked.
So this is my version using TlHelp32 directly, solving all the problems:
uses
Classes, TlHelp32;
function IsRunningAsService: boolean;
function FindProcess(FSnapshotHandle: THandle; PID: DWORD; var lppe: TProcessEntry32): boolean;
var
ContinueLoop: BOOL;
begin
ContinueLoop := Process32First(FSnapshotHandle, lppe);
while Integer(ContinueLoop) <> 0 do
begin
if lppe.th32ProcessID = PID then
begin
result := true;
Exit;
end;
ContinueLoop := Process32Next(FSnapshotHandle, lppe);
end;
result := false;
end;
var
CurProcessId: DWORD;
FSnapshotHandle: THandle;
FProcessEntry32: TProcessEntry32;
ExeName, PrevExeName: string;
DeadlockProtection: TList<Integer>;
begin
Result := false;
FSnapshotHandle := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
DeadlockProtection := TList<Integer>.Create;
try
CurProcessId := GetCurrentProcessId;
FProcessEntry32.dwSize := SizeOf(FProcessEntry32);
ExeName := '';
while FindProcess(FSnapshotHandle, CurProcessId, FProcessEntry32) do
begin
if DeadlockProtection.IndexOf(FProcessEntry32.th32ProcessID) > -1 then break;
DeadlockProtection.Add(FProcessEntry32.th32ProcessID);
PrevExeName := ExeName;
ExeName := FProcessEntry32.szExeFile;
(*
Result := SameText(PrevExeName, 'services.exe') and // Parent
SameText(ExeName, 'winlogon.exe'); // Grandparent
*)
Result := SameText(ExeName, 'services.exe'); // Parent
if Result then Exit;
CurProcessId := FProcessEntry32.th32ParentProcessID;
end;
finally
CloseHandle(FSnapshotHandle);
DeadlockProtection.Free;
end;
end;
This code works, also even in applications without MainForm (e.g. CLI apps).
you can use GetStdHandle method for get out console handle.when applications run as windows service has not output console.if GetStdHandle equals zero means your application run as windows service.
{$APPTYPE CONSOLE} // important
uses
uServerForm in 'uServerForm.pas' {ServerForm},
uWinService in 'uWinService.pas' {mofidWinServer: TService},
Windows,
System.SysUtils,
WinSvc,
SvcMgr,
Forms,etc;
function RunAsWinService: Boolean;
var
H: THandle;
begin
if FindCmdLineSwitch('install', ['-', '/'], True) then
Exit(True);
if FindCmdLineSwitch('uninstall', ['-', '/'], True) then
Exit(True);
H := GetStdHandle(STD_OUTPUT_HANDLE);
Result := H = 0;
end;
begin
if RunAsWinService then
begin
SvcMgr.Application.Initialize;
SvcMgr.Application.CreateForm(TmofidWinServer, mofidWinServer);
SvcMgr.Application.Run;
end
else
begin
Forms.Application.Initialize;
Forms.Application.CreateForm(TServerForm, ServerForm);
Forms.Application.Run;
end;
end.
I didn't find the simple answer which can be used easily and does not require recompilation and allows using one exe as a service and an application. You can install your program as a service with the command line parameter like āā¦\myapp.exe āsā and then check it from the program:
if ParamStr(ParamCount) = '-s' then
You can base the check on checking the session ID of the current process. All services runs with session ID = 0.
function IsServiceProcess: Boolean;
var
LSessionID, LSize: Cardinal;
LToken: THandle;
begin
Result := False;
LSize := 0;
if not OpenProcessToken(GetCurrentProcess, TOKEN_QUERY, LToken) then
Exit;
try
if not GetTokenInformation(LToken, TokenSessionId, #LSessionID, SizeOf(LSessionID), LSize) then
Exit;
if LSize = 0 then
Exit;
Result := LSessionID = 0;
finally
CloseHandle(LToken);
end;
end;
I actually ended up checking the application.showmainform variable.
The problem with skamradt's isFormBased is that some of this code is called before the main form is created.
I am using a software library called SvCom_NTService from aldyn-software. One of purposes is for errors; either to log them or show a message. I totally agree with #Rob; our code should be better maintained and handle this outside of the functions.
The other intention is for failed database connections and queries; I have different logic in my functions to open queries. If it is a service then it will return nil but continue the process. But if failed queries/connections occur in an application then I would like to display a messaage and halt the application.
Check if your Applicatoin is an instance of TServiceApplication:
IsServiceApp := Application is TServiceApplication;