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've been working with Word2010.pas for the past week and everything went well, until I found out that if you open a document manually, edit it (but don't save), press Alt+F4, a prompt will show up saying if you want to save your document or not, leave it like that. Go into code and try to access that document, all calls will result in EOleException: Call was rejected by callee. Once you cancel that Word save prompt, everything works fine.
I came across this while writing code that periodically checks if a document is open. Here is the function that checks if the document is open: (function runs in a timer every 2 seconds)
function IsWordDocumentOpen(FileName: string): Boolean;
var
WordApp: TWordApplication;
I: Integer;
begin
Result := False;
try
WordApp := TWordApplication.Create(nil);
try
WordApp.Connect;
for I := 1 to WordApp.Documents.Count do
begin
try
if WordApp.Documents.Item(I).FullName = FileName then
begin
Result := True;
System.Break;
end;
except
on E: EOleException do
// I always end up here while the document has the prompt
end;
end;
finally
FreeAndNil(WordApp);
end;
finally
//
end;
end;
Does anyone have any experience with this? Is there some sort of a lock that I'm not aware of?
UPDATE #1: So far the only solution I could find was to implement IOleMessageFilter, this way I do not receive any exceptions but the program stops and waits on the line WordApp.Documents.Item(I).FullName, but that is not what I want. Implementation of IOleMessageFilter goes like this:
type
IOleMessageFilter = class(TInterfacedObject, IMessageFilter)
public
function HandleInComingCall(dwCallType: Longint; htaskCaller: HTask;
dwTickCount: Longint; lpInterfaceInfo: PInterfaceInfo): Longint;stdcall;
function RetryRejectedCall(htaskCallee: HTask; dwTickCount: Longint;
dwRejectType: Longint): Longint;stdcall;
function MessagePending(htaskCallee: HTask; dwTickCount: Longint;
dwPendingType: Longint): Longint;stdcall;
procedure RegisterFilter();
procedure RevokeFilter();
end;
implementation
function IOleMessageFilter.HandleInComingCall(dwCallType: Integer; htaskCaller: HTask; dwTickCount: Integer; lpInterfaceInfo: PInterfaceInfo): Longint;
begin
Result := 0;
end;
function IOleMessageFilter.MessagePending(htaskCallee: HTask; dwTickCount, dwPendingType: Integer): Longint;
begin
Result := 2 //PENDINGMSG_WAITDEFPROCESS
end;
procedure IOleMessageFilter.RegisterFilter;
var
OldFilter: IMessageFilter;
NewFilter: IMessageFilter;
begin
OldFilter := nil;
NewFilter := IOleMessageFilter.Create;
CoRegisterMessageFilter(NewFilter,OldFilter);
end;
function IOleMessageFilter.RetryRejectedCall(htaskCallee: HTask; dwTickCount, dwRejectType: Integer): Longint;
begin
Result := -1;
if dwRejectType = 2 then
Result := 99;
end;
procedure IOleMessageFilter.RevokeFilter;
var
OldFilter: IMessageFilter;
NewFilter: IMessageFilter;
begin
OldFilter := nil;
NewFilter := nil;
CoRegisterMessageFilter(NewFilter,OldFilter);
end;
end;
BEST SOLUTION SO FAR: I used IOleMessageFilter implementation like this: (remember this will stop and wait on the line where I previously got an exception)
function IsWordDocumentOpen(FileName: string): Boolean;
var
OleMessageFilter: IOleMessageFilter;
WordApp: TWordApplication;
I: Integer;
begin
Result := False;
try
OleMessageFilter := IOleMessageFilter.Create;
OleMessageFilter.RegisterFilter;
WordApp := TWordApplication.Create(nil);
try
WordApp.Connect;
for I := 1 to WordApp.Documents.Count do
begin
if WordApp.Documents.Item(I).FullName = FileName then
begin
Result := True;
System.Break;
end;
end;
finally
OleMessageFilter.RevokeFilter;
FreeAndNil(WordApp);
FreeAndNil(OleMessageFilter);
end;
finally
//
end;
end;
Actually, I think that the problem is simply that Word is busy doing a modal dialog and so can't respond to external COM calls. This trivial code produces the same error:
procedure TForm1.Button1Click(Sender: TObject);
begin
Caption := MSWord.ActiveDocument.Name;
end;
Probably the simplest way to avoid this problem is to head it off before if happens. If you are using the TWordApplication server that comes with Delphi (on the Servers components tab), you can attach an event handler to its OnDocumentBeforeClose and use that to present your own "Save Y/N?" dialog and set the event's Cancel param to True to prevent Word's dialog from appearing.
Update: If you try experimenting with this code while the Save dialog is popped up
procedure TForm1.Button1Click(Sender: TObject);
var
vWin,
vDoc,
vApp : OleVariant;
begin
vWin := MSWord.ActiveWindow;
Caption := vWin.Caption;
vDoc := vWin.Document;
vApp := vDoc.Application; // Attempt to read Word Document property
Caption := vDoc.Path + '\';
Caption := Caption + vDoc.Name;
end;
I think you'll find that any attempt to read from the vDoc object will result in the "Call was rejected ..." message, so I am beginning to think that this behaviour is by design - it's telling you that the object is not in a state that it can be interacted with.
Interestingly, it is possible to read the Caption property of the vWin Window object, which will tell you the filename of the file but not the file's path.
Realistically, I still think your best option is to try and get the OnDocumentBeforeClose event working. I don't have Word 2010 installed on this machine by Word 2007 works fine with the Word server objects derived from Word2000.Pas so you might try those instead of Word2010.Pas, just to see.
Another possibility is simply to catch the "Call was rejected ..." exception, maybe return "Unavailable" as the document FullName, and try again later.
If you're not using TWordApplication and don't know how to catch the OnDocumentBeforeClose for the method your using to access Word, let me know how you are accessing it and I'll see if I can dig out some code to do it.
I vaguely recall there's a way of detecting that Word is busy with a modal dialog - I'll see if I can find where I saw that a bit later if you still need it. Your IOleMessageFilter looks more promising than anything I've found as yet, though.
I am trying to find a safe/deterministic way to release an interface which is encapsulated in an OleVariant.
AFAICS Delphi releases interface references at the end of a procedure, but in my case I have to do it earlier, because I have to shut down COM.
procedure Test;
var
LLibrary: OleVariant;
begin
CoInitialize(nil);
try
LLibrary := Null;
try
LLibrary := CreateOleObject(LibraryName);
finally
LLibrary := Unassigned; // <-- I would like to release the interface here
end;
finally
CoUninitialize; // <-- Shutdown of COM
end;
end; // <-- The compiler releases the interface here
I though of putting the OleVariant in an extra class instance that I can free before I call CoUninitialize.
procedure Test;
var
Container: TLibraryContainer; // Holds the OleVariant
begin
CoInitialize(nil);
try
Container := TLibraryContainer.Create;
try
{...}
finally
Container.Free;
end;
finally
CoUninitialize;
end;
end;
Is this solution safe or is there a better solution I have overlooked?
The compiler is clearly using an implicit local interface variable for the return value from CreateOleObject. This is then released at the end of the routine, too late for you.
There are a couple of ways to defeat this. First of all you could be explicit about the IDispatch interface reference returned by CreateOleObject. This allows you to control its lifetime.
procedure Test;
var
intf: IDispatch;
LLibrary: OleVariant;
begin
CoInitialize(nil);
try
intf := CreateOleObject(LibraryName);
try
LLibrary := intf;
finally
VarClear(LLibrary);
intf := nil;
end;
finally
CoUninitialize;
end;
end;
An alternative would be to move the code that called CreateOleObject into a separate routine with its own scope.
procedure DoWork;
var
LLibrary: OleVariant;
begin
LLibrary := CreateOleObject(LibraryName);
//do stuff with LLibrary
end;
procedure Test;
begin
CoInitialize(nil);
try
DoWork;
finally
CoUninitialize;
end;
end;
Since the implicit local reference is within the scope of DoWork it is released at the end of DoWork and therefore before you run CoUninitialize.
My recommendation is to use the second option which is cleaner and forces the compiler to do the work on your behalf.
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;
I need to know if my program can write files to the disk (HDD, floppy, flash, CD) from where it is running.
I have tried something like:
{$I-}
Rewrite(myFile);
{$I+}
Result:= (IOResult = 0);
The problem is that if the disk is read-only, Windows gives me an error message telling me that
"appName.exe - Write Protect Error The disk cannot be written to because it is write protected. Please remove the write protection from the volume
USB_BOOT in drive D:. Cancel TryAgain Continue"
How can I test for write access without raising any error/warning messages?
Thanks.
Edit:
Ok. The "bug" has nothing to do with the above mentioned piece of code. I only thought that it appears there. I move the code to the read-only disk and ran it from there. The bug appears in a function called "CreateShortcutEx", on this line:
MyPFile.Save(PWChar(WFileName),False);
MyPFile is declared like this:
var
MyObject : IUnknown;
MySLink : IShellLink;
MyPFile : IPersistFile;
Directory : String;
WFileName : WideString;
MyReg : TRegIniFile;
begin
MyObject := CreateComObject(CLSID_ShellLink);
MySLink := MyObject as IShellLink;
MyPFile := MyObject as IPersistFile;
.....
end;
So, why is MyPFile trying to write to the application's drive (the one that is read-only) if the WFileName parameter is "C:\documents and settings\bla bla" ?
Call the Windows API SetErrorMode() function to disable the error message box.
Edit:
I just tried, and this:
procedure TForm1.Button1Click(Sender: TObject);
var
Str: TStream;
OldMode: Cardinal;
begin
OldMode := SetErrorMode(SEM_FAILCRITICALERRORS);
try
try
Str := TFileStream.Create('z:\foo.txt', fmOpenReadWrite);
try
finally
Str.Free;
end;
except end;
finally
SetErrorMode(OldMode);
end;
end;
works as expected.
Not really pretty but this seems to work for me.
function CanWrite(drive: string): boolean;
var
OldMode: Cardinal;
begin
OldMode := SetErrorMode(SEM_FAILCRITICALERRORS);
try
with TStringList.Create do
try
SaveToFile(drive + ':\file.txt');
result := true;
try
deletefile(drive + ':\file.txt');
except
end;
except
result := false;
end;
finally
SetErrorMode(OldMode);
end;
end;
Call to it with
if CanWrite('g') = true then
begin
showmessage('Can Write');
end
else
begin
showmessage('Can not write');
end;
What happens when you put your code inside an try/except?
Also, you can try (something like) this:
function CanWrite: boolean;
begin
result := true;
with TStringList.Create do
try
SaveToFile('file.txt');
except
result := false;
finally
Free;
end;
end;
Sorry, but I don't code in Delphi anymore and I don't have Delphi installed anywhere.
There exist a small freeware "Drive ready?" utility (dready.com) written by Horst Schaeffer that also can check write access. I have not tested it but as far as I can see this could be used as a solution; call it for instance as "DREADY C: /W" and check the return value.