Why I don't need call CoInitialize in a thread created inside a COM Thread? - windows

In order to learn multithreading, I've created a thread inside a COM Thread (TRemoteDataModule).
This is my Component Factory:
TComponentFactory.Create(ComServer, TServerConn2, Class_ServerConn2, ciMultiInstance, tmApartment);
Inside the Thread, I didn't needed to Call CoInitialize to use TADOQuery.Create, .Open... .Exec
I read that I need to initialize the COM library on a thread before you call any of the library functions except CoGetMalloc, to get a pointer to the standard allocator, and the memory allocation functions.
But in this case, the absence of CoInitialize didn't brought me any trouble.
Is this related with Thread Model?
Where can I Find the explanation for this subject?
UPDATE:
When I say INSIDE, it means inside the COM method context:
interface
type
TWorker = class(TThread);
TServerConn2 = class(TRemoteDataModule, IServerConn2)
public
procedure Method(); safecall;
end;
implementation
procedure TServerConn2.Method();
var W: TWorker;
begin
W := TWorkerTread.Create(Self);
end;
UPDATE 2:
The TADOConnection used to connect to database are currently being created in the COM Thread context (TThread.Create constructor). Although, TADOConnection.Open and TADOQuery.Create/.Open are both being performed inside TThread.Execute .
UPDATE 3 - Simulacrum
Interface:
type
TServerConn2 = class;
TWorker = class(TThread)
private
FDB: TADOConnection;
FOwner: TServerConn2;
protected
procedure Execute; override;
public
constructor Create(Owner: TServerConn2);
destructor Destroy; override;
end;
TServerConn2 = class(TRemoteDataModule, IServerConn2)
ADOConnection1: TADOConnection;
procedure RemoteDataModuleCreate(Sender: TObject);
private
{ Private declarations }
protected
class procedure UpdateRegistry(Register: Boolean; const ClassID, ProgID: string); override;
procedure CheckException; safecall;
public
User, Pswd, Str: String;
Ok: Boolean;
end;
Implementation:
class procedure TServerConn2.UpdateRegistry(Register: Boolean; const ClassID, ProgID: string);
begin
if Register then
begin
inherited UpdateRegistry(Register, ClassID, ProgID);
EnableSocketTransport(ClassID);
EnableWebTransport(ClassID);
end else
begin
DisableSocketTransport(ClassID);
DisableWebTransport(ClassID);
inherited UpdateRegistry(Register, ClassID, ProgID);
end;
end;
{ TWorker }
constructor TWorker.Create(Owner: TServerConn2);
begin
inherited Create(False);
FreeOnTerminate := True;
FDB := TADOConnection.Create(nil);
FOwner := Owner;
end;
destructor TWorker.Destroy;
begin
FDB.Free;
FOwner.Ok := True;
inherited;
end;
procedure TWorker.Execute;
var Qry: TADOQuery;
begin
FDB.LoginPrompt := False;
FDB.ConnectionString := FOwner.Str;
FDB.Open(FOwner.User, FOwner.Pswd);
Qry := TADOQuery.Create(nil);
try
Qry.Connection := FDB;
Qry.LockType := ltReadOnly;
Qry.SQL.Text := 'SELECT TOP 1 * FROM MyTable';
Qry.Open;
finally
Qry.Free;
end;
end;
procedure TServerConn2.CheckException;
var W: TWorker;
begin
W := TWorker.Create(Self);
while not Ok do Sleep(100);
end;
procedure TServerConn2.RemoteDataModuleCreate(Sender: TObject);
begin
User := 'user';
Pswd := 'pass';
Str := ADOConnection1.ConnectionString;
end;
initialization
TComponentFactory.Create(ComServer, TServerConn2,
Class_ServerConn2, ciMultiInstance, tmApartment);
end.
UPDATE 4
The error should happen here:
function CreateADOObject(const ClassID: TGUID): IUnknown;
var
Status: HResult;
FPUControlWord: Word;
begin
asm
FNSTCW FPUControlWord
end;
Status := CoCreateInstance(ClassID, nil, CLSCTX_INPROC_SERVER or
CLSCTX_LOCAL_SERVER, IUnknown, Result);
asm
FNCLEX
FLDCW FPUControlWord
end;
if (Status = REGDB_E_CLASSNOTREG) then
raise Exception.CreateRes(#SADOCreateError) else
OleCheck(Status);
end;
By somehow (because of TComponentFactory maybe?) CoCreateInstance identifies that TWorker is in the same context than TServerConn2 and don't raise errors?

Either or both of the following might apply:
On a thread not initialized with COM all existing interface pointers keep working until you make a COM API call or otherwise require COM marshalling which then fails detecting an uninitialized thread. That is, your "didn't brought me any trouble" might actually be too early to say.
If any thread in the process calls Co­Initialize­[Ex] with the COINIT_MULTI­THREADED flag, then that not only initializes the current thread as a member of the multi-threaded apartment, but it also says, "Any thread which has never called Co­Initialize­[Ex] is also part of the multi-threaded apartment." - so called impicit MTA thing

The TADOConnection used to connect to database are currently being created in the COM Thread context (TThread.Create constructor). Although, TADOConnection.Open and TADOQuery.Create/.Open are both being performed inside TThread.Execute .
That will not work, for 2 reasons:
TWorker.Create() and TWorker.Execute() will run in different thread contexts. Create() will run in the context of the thread that is calling TServerConn2.CheckException() (which will have already called CoInitialize/Ex() on itself beforehand), but Execute() will run in the context of the TThread thread instead. ADO is apartment threaded, which means its COM interfaces cannot be used across thread/apartment boundaries unless you marshal them, either via the IGlobalInterfaceTable interface or the CoMarshalInterThreadInterfaceInStream() and CoGetInterfaceAndReleaseStream() functions.
even if you did marshal the ADO interfaces, TWorker.Execute() must call CoInitialize/Ex() on itself. EVERY individual thread must initialize COM to establish its threading model before then accessing any COM interfaces. The threading model dictates how COM accesses interfaces (direct or through proxies), whether message queues are used, etc.
So the simple solution to your problem is to NOT create and use the ADO components across thread boundaries at all. Move your TADOConnection into Execute() instead:
constructor TWorker.Create(Owner: TServerConn2);
begin
inherited Create(False);
FreeOnTerminate := True;
FOwner := Owner;
end;
destructor TWorker.Destroy;
begin
FOwner.Ok := True;
inherited;
end;
procedure TWorker.Execute;
var
DB: TADOConnection;
Qry: TADOQuery;
begin
CoInitialize;
try
DB := TADOConnection.Create(nil);
try
DB.LoginPrompt := False;
DB.ConnectionString := FOwner.Str;
DB.Open(FOwner.User, FOwner.Pswd);
Qry := TADOQuery.Create(nil);
try
Qry.Connection := DB;
Qry.LockType := ltReadOnly;
Qry.SQL.Text := 'SELECT TOP 1 * FROM MyTable';
Qry.Open;
finally
Qry.Free;
end;
finally
DB.Free;
end;
finally
CoUninitialize;
end;
end;

When you create an apartment thread using TComponentFactory it calls CoInitialize and CoUnInitialize for you - it's right in the VCL source (System.Win.VCLCom.pas):
procedure TApartmentThread.Execute;
var
msg: TMsg;
Unk: IUnknown;
begin
try
CoInitialize(nil); // *** HERE
try
FCreateResult := FFactory.CreateInstanceLic(FUnkOuter, nil, FIID, '', Unk);
FUnkOuter := nil;
FFactory := nil;
if FCreateResult = S_OK then
CoMarshalInterThreadInterfaceInStream(FIID, Unk, IStream(FStream));
ReleaseSemaphore(FSemaphore, 1, nil);
if FCreateResult = S_OK then
while GetMessage(msg, 0, 0, 0) do
begin
DispatchMessage(msg);
Unk._AddRef;
if Unk._Release = 1 then break;
end;
finally
Unk := nil;
CoUninitialize; // ** AND HERE
end;
except
{ No exceptions should go unhandled }
end;
end;

Related

How to use smart pointer on default constructor

So, once again I am learning new things and I came across Smart Pointers. I had code
procedure TForm3.BitBtn1Click(Sender: TObject);
var
_StringList: ISmartPointer<TStringList>;
begin
_StringList := TSmartPointer<TStringList>.Create(TStringList.Create);
end;
As you see variable declaration is kinda odd, and simplification is needed. I came across another solution
procedure TForm3.btnDelphiClick(Sender: TObject);
var
_StringList: TStringList;
begin
_StringList := SmartGuard.SmartGuard<TStringList>(TStringList.Create(False));
end;
Sadly, it does not work with parameterless constructor
procedure TForm3.btnDelphiClick(Sender: TObject);
var
_StringList: TStringList;
begin
_StringList := SmartGuard.SmartGuard<TStringList>(TStringList.Create);
end;
[dcc32 Error] Main.pas(47): E2089 Invalid typecast
Am I out of luck here?
P.S. I know some of you would argue I should stick to try..finally block, but this is out of curiosity.
unit SmartGuard;
interface
type
IGuard = interface
['{CE522D5D-41DE-4C6F-BC84-912C2AEF66B3}']
end;
TGuard = class(TInterfacedObject, IGuard)
private
FObject: TObject;
public
constructor Create(AObject: TObject);
destructor Destroy; override;
end;
SmartGuard<T: class> = record
private
FGuard: IGuard;
FGuardedObject: T;
public
class operator Implicit(GuardedObject: T): SmartGuard<T>;
class operator Implicit(Guard: SmartGuard<T>): T;
end;
implementation
uses
{Delphi}
System.SysUtils
{Project}
;
constructor TGuard.Create(AObject: TObject);
begin
FObject := AObject;
end;
destructor TGuard.Destroy;
begin
FObject.Free;
inherited;
end;
{ SmartGuard }
class operator SmartGuard<T>.Implicit(GuardedObject: T): SmartGuard<T>;
begin
Result.FGuard := TGuard.Create(GuardedObject);
Result.FGuardedObject := GuardedObject;
end;
class operator SmartGuard<T>.Implicit(Guard: SmartGuard<T>): T;
begin
Result := Guard.FGuardedObject;
end;
end.
I would love to find a solution that would not require additional "method" calling as in here https://github.com/marcocantu/DelphiSessions/blob/master/DelphiLanguageCodeRage2018/02_SmartPointers/SmartPointerClass.pas e.g. _StringList.Value.Add('foo'); and "special" brackets e.g. _StringList := TSmartPointer<TStringList>.Create(TStringList.Create)();
The compiler needs help disambiguating
TStringList.Create
The compiler doesn't know whether this is a reference to a method, or a call to the method.
Disambiguate by adding parens to indicate that it is a call.
_StringList := SmartGuard.SmartGuard<TStringList>(TStringList.Create());

Stop method after certain time in Delphi Datasnap Server Application

I've build a datasnap server application for handling data between a windows application and mobile apps.
One method can take a while, and I want to be able to stop it after a certain time(Timeout).
How can I achieve this?
The code below shows one way to provide a server method with timeout behaviour.
The task which may take too long is executed in a secondary thread which is
started in the server method. This method uses a TSimpleEvent object (see the online help) to enable the
secondary thread to signal back to the server method's thread that it has completed. The value (in milliseconds) you specify in the call to Event.WaitFor defines how long to wait before the call times out.
If the call to WaitFor on the SimpleEvent times out, you can take whatever action you
like to notify the server's client. If the call to WaitFor returns wsSignaled, that means that the DBThread must have called SetEvent on the Event object before the period specified when calling WaitFor expired.
Btw, this example was written for D7, so might require minor adaptation for
Seattle. Also it uses a TForm descendant as the "server", but should work equally well in a DataSnap server method, since the principle is the same.
It doesn't address the issue of how exactly to stop whatever task you kick off in the secondary thread, because whether that is possible and how to do it if it is depends on exactly what the task is. Because of that, and the fact that you probably wouldn't want to delay the server method by waiting for the DBThread to complete, it does not attempt to free the DBThread, though in the real world that should of course be done.
type
TServer = class;
TDBThread = class(TThread)
private
FServer: TServer;
FEvent: TSimpleEvent;
FCancelled : Boolean;
function GetCancelled: Boolean;
procedure SetCancelled(const Value: Boolean);
public
procedure Execute; override;
constructor Create(AServer : TServer);
property Server : TServer read FServer;
property Event : TSimpleEvent read FEvent;
property Cancelled : Boolean read GetCancelled write SetCancelled;
end;
TServer = class(TForm)
// ignore the fact that in this case, TServer is a descendant of TForm
Button1: TButton;
procedure Button1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
protected
CS : TCriticalSection;
Event : TSimpleEvent;
public
procedure DoServerMethod;
end;
[...]
{ TDBThread }
constructor TDBThread.Create(AServer: TServer);
begin
inherited Create(True); // create suspended
FreeOnTerminate := False;
FServer := AServer;
FEvent := FServer.Event;
end;
procedure TDBThread.Execute;
var
StartTime : Cardinal;
begin
Cancelled := False;
// Following is for illustration ONLY, to simulate a process which takes time.
// Do not call Sleep() in a loop in a real thread
StartTime := GetTickCount;
repeat
Sleep(100);
until GetTickCount - StartTime > 5000;
if not Cancelled then begin
{ TODO : Transfer result back to server thread }
Event.SetEvent;
end;
end;
function TDBThread.GetCancelled: Boolean;
begin
FServer.CS.Enter;
try
Result := FCancelled;
finally
FServer.CS.Leave;
end;
end;
procedure TDBThread.SetCancelled(const Value: Boolean);
begin
FServer.CS.Enter;
try
FCancelled := Value;
finally
FServer.CS.Leave;
end;
end;
procedure TServer.DoServerMethod;
var
DBThread : TDBThread;
WaitResult : TWaitResult;
begin
DBThread := TDBThread.Create(Self);
DBThread.Resume;
WaitResult := Event.WaitFor(1000);
case WaitResult of
wrSignaled : begin
// the DBThread completed
ShowMessage('DBThread completed');
end;
wrTimeOut : begin
// the DBThread time out
DBThread.Cancelled := True;
ShowMessage('DBThread timed out');
// Maybe use PostThreadMessage here to tell the DBThread to abort (if possible)
// whatever task it is doing that has taken too long.
end;
end; {case}
{ TODO : Terminate and dispose of the DBThread }
end;
procedure TServer.FormCreate(Sender: TObject);
begin
CS := TCriticalSection.Create;
Event := TSimpleEvent.Create;
end;
procedure TServer.Button1Click(Sender: TObject);
begin
DoServerMethod;
end;

Notification when a program is loaded [duplicate]

I need to recognize and fire an event when a file is going to be executed or run by an application. I know I can do it by hooking windows procedures, but I don't know what procedure or event of windows fires.
For example, when an autorun file going to execute, my application should recognize it, Like an antivirus application.
I'm not sure that hooking is useful for my purpose, if solution isn't hooking, please give me a true solution.
try using the PsSetCreateProcessNotifyRoutine, this function adds a driver-supplied callback routine to, or removes it from, a list of routines to be called whenever a process is created or deleted.
you can find a very nice sample int this link written in c++
Detecting Windows NT/2K process execution
UPDATE
Another option is use the WMI events, check the Win32_Process class, the ExecNotificationQuery method and the SWbemEventSource.NextEvent function.
Check this sample tested in delphi 7 and Windows 7, you must run this application from outside of the Delphi IDE or disable the exception notification for the EOleException exception (check this link), to avoid the EOleException wich is intercepted by the IDE.
program GetWMI_InstanceCreationEvent;
{$APPTYPE CONSOLE}
uses
SysUtils
,Windows
,ComObj
,ActiveX
,Variants;
Function KeyPressed:boolean; //detect if an key is pressed
var
NumEvents : DWORD;
ir : _INPUT_RECORD;
bufcount : DWORD;
StdIn : THandle;
begin
Result:=false;
StdIn := GetStdHandle(STD_INPUT_HANDLE);
NumEvents:=0;
GetNumberOfConsoleInputEvents(StdIn,NumEvents);
if NumEvents<> 0 then
begin
PeekConsoleInput(StdIn,ir,1,bufcount);
if bufcount <> 0 then
begin
if ir.EventType = KEY_EVENT then
begin
if ir.Event.KeyEvent.bKeyDown then
result:=true
else
FlushConsoleInputBuffer(StdIn);
end
else
FlushConsoleInputBuffer(StdIn);
end;
end;
end;
function VarStrNUll(VarStr:OleVariant):string;//dummy function to handle null variants
begin
Result:='';
if not VarIsNull(VarStr) then
Result:=VarToStr(VarStr);
end;
function GetWMIObject(const objectName: String): IDispatch; //create a wmi object instance
var
chEaten: Integer;
BindCtx: IBindCtx;
Moniker: IMoniker;
begin
OleCheck(CreateBindCtx(0, bindCtx));
OleCheck(MkParseDisplayName(BindCtx, StringToOleStr(objectName), chEaten, Moniker));
OleCheck(Moniker.BindToObject(BindCtx, nil, IDispatch, Result));
end;
Procedure GetWin32_InstanceCreationEvent;
var
objWMIService : OLEVariant;
colMonitoredProcesses : OLEVariant;
objLatestProcess : OLEVariant;
begin
objWMIService := GetWMIObject('winmgmts:\\localhost\root\cimv2');
colMonitoredProcesses := objWMIService.ExecNotificationQuery('Select * From __InstanceCreationEvent Within 1 Where TargetInstance ISA ''Win32_Process'''); //Get the event listener
while not KeyPressed do
begin
try
objLatestProcess := colMonitoredProcesses.NextEvent(100);//set the max time to wait (ms)
except
on E:EOleException do
if EOleException(E).ErrorCode=HRESULT($80043001) then //Check for the timeout error wbemErrTimedOut 0x80043001
objLatestProcess:=Null
else
raise;
end;
if not VarIsNull(objLatestProcess) then
begin
Writeln('Process Started '+VarStrNUll(objLatestProcess.TargetInstance.Name));
Writeln('CommandLine '+VarStrNUll(objLatestProcess.TargetInstance.CommandLine));
Writeln('PID '+VarStrNUll(objLatestProcess.TargetInstance.ProcessID));
end;
end;
end;
begin
try
CoInitialize(nil);
try
Writeln('Press Any key to exit');
GetWin32_InstanceCreationEvent;
finally
CoUninitialize;
end;
except
on E:Exception do
Begin
Writeln(E.Classname, ': ', E.Message);
Readln;
End;
end;
end.

Delphi calling shgetfileinfo from a thread fails

function GetFileIcon(const filename:string): HICON;
var
shfi: TShFileInfo;
begin
try
FillChar(shfi, SizeOf(TShFileInfo), 0);
ShGetFileInfo(PChar(filename), 0, shfi, SizeOf(TShFileInfo), SHGFI_ICON or SHGFI_LARGEICON);
Result := shfi.hIcon;
except
Result := 0;
end;
end;
Using delphi xe2, on win 7 64bits, this function will often return 0 when called inside a Tthread, but is always working fine when called from main thread. It looks like a shell initialization problem, because after a while it will work in the Thread as well.
I found a similar question in stack overflow (Calling SHGetFileInfo in thread to avoid UI freeze) but it is for c++ language so I did not sort it out.
Update: It seems ShGetFileInfo is not threadsafe. When there are multiple threads calling it simultaneously, it fails. See David
Hefferman's answer below. Also using CoInitializeEx instead of Coinitialize does not help with multiple threads. You have to serilize access using a TCriticalSection.
From the documentation:
You must initialize Component Object Model (COM) with CoInitialize or OleInitialize prior to calling SHGetFileInfo.
In a GUI app, the COM is initialized in the main thread. But from other threads that does not happen automatically. You will need to do it explicitly.
Beyond that you are not handling errors correctly. Remember that Windows API functions do not raise exceptions. So your exception handler is pointless and should be removed. Instead you need to check the return value of your call to SHGetFileInfo, as described in the documentation.
Beyond that your code works, as this program demonstrates:
{$APPTYPE CONSOLE}
uses
Classes, Windows, ActiveX, ShellAPI;
var
hThread: THandle;
ThreadId: Cardinal;
function ThreadFunc(Parameter: Pointer): Integer;
var
shfi: TSHFileInfo;
begin
CoInitialize(nil);
Try
if ShGetFileInfo('C:\windows\explorer.exe', 0, shfi, SizeOf(shfi), SHGFI_ICON or SHGFI_LARGEICON)=0 then
begin
Writeln('ShGetFileInfo Failed');
Result := 1;
exit;
end;
Writeln(shfi.hIcon);
Finally
CoUninitialize;
End;
Result := 0;
end;
begin
hThread := BeginThread(nil, 0, ThreadFunc, nil, 0, ThreadId);
WaitForSingleObject(hThread, INFINITE);
CloseHandle(hThread);
Readln;
end.
I expect that any failure you observe is actually related to the particular file that you are trying to inspect.
Update: It seems ShGetFileInfo is not threadsafe. When there are multiple threads calling it simultaneously, it fails. I believe that you will need to serialize the calls to ShGetFileInfo with a lock. For instance, TCriticalSection.
The following program, based on the SSCCE you provided in the comments, demonstrates this:
{$APPTYPE CONSOLE}
uses
SysUtils,
Classes,
SyncObjs,
Windows,
ActiveX,
ShellAPI;
var
hThreads: TWOHandleArray;
ThreadId: Cardinal;
Lock: TCriticalSection;
function ThreadFunc(Parameter: Pointer): Integer;
var
shfi: TSHFileInfo;
randomnumber: integer;
fname: string;
begin
CoInitialize(nil);
Try
fname := 'c:\desktop\file'+IntToStr(Integer(Parameter))+'.exe';
Lock.Acquire;
try
if ShGetFileInfo(pchar(fname), 0, shfi, SizeOf(shfi), SHGFI_ICON or SHGFI_LARGEICON)=0 then
begin
Writeln('ShGetFileInfo Failed');
Result := 1;
exit;
end;
Writeln(shfi.hIcon);
finally
Lock.Release;
end;
Finally
CoUninitialize;
End;
Result := 0;
end;
var
i: integer;
begin
Lock := TCriticalSection.Create;
for i := 0 to 9 do
hThreads[i] := BeginThread(nil, 0, ThreadFunc, Pointer(i), 0, ThreadId);
WaitForMultipleObjects(10, #hThreads,true, INFINITE);
Readln;
end.
Remove the critical section, and the calls to ShGetFileInfo succeed, but return 0 for the icon handle. With the critical section, valid icon handles are returned.

Can overriding the CreateParams procedure allow me to still have full access to the WS_SYSMENU?

Complete source code can be found here:
http://www.eyeClaxton.com/download/delphi/SkinProject.zip
I'm trying to create a skinned form with no "Caption or Borders", but still leaving me with the full access to System Menu (I.E: Move, Minimize, Maximize, Restore and Size). I can achieve all of the menu items by overriding the CreateParams procedure by using WS_SYSMENU, WS_MAXIMIZEBOX, WS_MINIMIZEBOX. Using the WS_SIZEBOX gives me access to the menu "Size" command but paints a border I do not want. I have included a complete (Delphi 7) example in the link above. If more information is needed, please feel free to ask.
procedure TMainFrm.CreateParams(var Params: TCreateParams);
begin
FormStyle := fsNormal;
try
if (BorderIcons <> []) then BorderIcons := [];
if (BorderStyle <> bsNone) then BorderStyle := bsNone;
inherited CreateParams(Params);
Params.ExStyle := (Params.ExStyle and (not WS_EX_WINDOWEDGE)
and (not WS_EX_STATICEDGE) and (not WS_EX_DLGMODALFRAME) and (not WS_EX_CLIENTEDGE));
Params.Style := (Params.Style and (not WS_CAPTION) and (not DS_MODALFRAME)
and (not WS_DLGFRAME) and (not WS_THICKFRAME));
Params.Style := (Params.Style or WS_SYSMENU or WS_MAXIMIZEBOX or WS_MINIMIZEBOX or WS_SIZEBOX);
finally
Position := poScreenCenter;
end;
end;
SOLUTION:
unit WndProcUnit;
interface
uses
Windows, Messages, Classes, Controls, Forms, SysUtils;
type
EWndProc = class(Exception);
TWndProcMessages = class(TComponent)
private
{ Private declarations }
FOwnerWndProc: TFarProc;
FNewWndProc: TFarProc;
protected
{ Protected declarations }
procedure WndProc(var theMessage: TMessage); virtual;
public
{ Public declarations }
constructor Create(theOwner: TComponent); override;
destructor Destroy(); override;
procedure DefaultHandler(var theMessage); override;
end;
TWndProc = class(TWndProcMessages)
private
{ Private declarations }
protected
{ Protected declarations }
procedure Loaded(); override;
public
{ Public declarations }
constructor Create(theOwner: TComponent); override;
destructor Destroy(); override;
published
{ Published declarations }
end;
implementation
{ TWndProcMessages }
constructor TWndProcMessages.Create(theOwner: TComponent);
var
X, I: Integer;
begin
inherited Create(theOwner);
if (not (Owner is TForm)) then
raise EWndProc.Create('TWndProc parent must be a form!');
I := 0;
for X := 0 to (Owner.ComponentCount - 1) do
begin
if (Owner.Components[X] is TWndProc) then Inc(I);
if (I > 1) then Break;
end;
if (I > 1) then
begin
raise EWndProc.Create('The form already contains a TWndProc!');
end
else begin
FOwnerWndProc := TFarProc(GetWindowLong((Owner as TForm).Handle, GWL_WNDPROC));
FNewWndProc := Classes.MakeObjectInstance(WndProc);
if (not (csDesigning in ComponentState)) then
SetWindowLong((Owner as TForm).Handle, GWL_WNDPROC, LongInt(FNewWndProc));
end;
end;
destructor TWndProcMessages.Destroy();
begin
if Assigned(FNewWndProc) then
try
Classes.FreeObjectInstance(FNewWndProc);
finally
if (Pointer(FNewWndProc) <> nil) then Pointer(FNewWndProc) := nil;
end;
if Assigned(FOwnerWndProc) then Pointer(FOwnerWndProc) := nil;
inherited Destroy();
end;
procedure TWndProcMessages.DefaultHandler(var theMessage);
begin
if ((Owner as TForm).Handle <> 0) then
begin
case TMessage(theMessage).Msg of
WM_DESTROY:
SetWindowLong((Owner as TForm).Handle, GWL_WNDPROC, LongInt(FOwnerWndProc));
WM_INITMENU:
EnableMenuItem(TMessage(theMessage).WParam, SC_SIZE, MF_BYCOMMAND or MF_ENABLED);
else
with TMessage(theMessage) do
Result := CallWindowProc(FOwnerWndProc, (Owner as TForm).Handle, Msg, WParam, LParam);
end;
end
else
inherited DefaultHandler(theMessage);
end;
procedure TWndProcMessages.WndProc(var theMessage: TMessage);
begin
Dispatch(theMessage);
end;
{ TWndProc }
constructor TWndProc.Create(theOwner: TComponent);
begin
inherited Create(theOwner);
end;
destructor TWndProc.Destroy();
begin
inherited Destroy();
end;
procedure TWndProc.Loaded();
begin
inherited Loaded();
if (not (csDesigning in ComponentState)) then
GetSystemMenu((Owner as TForm).Handle, False);
end;
end.
Complete "updated" source code can be found here:
http://www.eyeClaxton.com/download/delphi/SkinProject.zip
Instead of having a border-less form and faking borders and caption all in the client area, the correct way to do this would be to handle WM_NCPAINT and draw your caption and border in the non-client area. Then, you wouldn't have to use an undocumented message to show the system menu on a caption-less window, or try to have the 'size' system menu item enabled on a window without a sizing border.
Anyway, if you want a quick workaround, enable the item yourself:
type
TMainFrm = class(TForm)
[...]
procedure FormCreate(Sender: TObject);
private
procedure WmInitMenuPopup(var Msg: TWMInitMenuPopup); message WM_INITMENUPOPUP;
[...]
procedure TMainFrm.FormCreate(Sender: TObject);
begin
GetSystemMenu(Handle, False); // force a copy of the system menu
[...]
end;
procedure TMainFrm.WmInitMenuPopup(var Msg: TWMInitMenuPopup);
begin
inherited;
if Msg.SystemMenu then
EnableMenuItem(Msg.MenuPopup, SC_SIZE, MF_BYCOMMAND or MF_ENABLED);
end;
PS:
In the code sample in the question, you're excluding WS_THICKFRAME, but including WS_SIZEBOX. They're, in fact, the same flag.
You've got a bit of a weird try-finally in your CreateParams. Form positioning have got nothing to do with the preceding code, you can put the 'Position := ' statement just before or after setting 'FormStyle' and drop the try-finally.

Resources