source: cprs/branches/tmg-cprs/TMG_Extra/tntUniCode/Source/TntForms.pas

Last change on this file was 672, checked in by Kevin Toppenberg, 9 years ago

Adding source to tntControls for compilation

File size: 26.6 KB
Line 
1
2{*****************************************************************************}
3{                                                                             }
4{    Tnt Delphi Unicode Controls                                              }
5{      http://www.tntware.com/delphicontrols/unicode/                         }
6{        Version: 2.3.0                                                       }
7{                                                                             }
8{    Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com)       }
9{                                                                             }
10{*****************************************************************************}
11
12unit TntForms;
13
14{$INCLUDE TntCompilers.inc}
15
16interface
17
18uses
19  Classes, Windows, Messages, Controls, Forms, TntControls;
20
21type
22{TNT-WARN TScrollBox}
23  TTntScrollBox = class(TScrollBox{TNT-ALLOW TScrollBox})
24  private
25    FWMSizeCallCount: Integer;
26    function IsHintStored: Boolean;
27    function GetHint: WideString;
28    procedure SetHint(const Value: WideString);
29    procedure WMSize(var Message: TWMSize); message WM_SIZE;
30  protected
31    procedure CreateWindowHandle(const Params: TCreateParams); override;
32    procedure DefineProperties(Filer: TFiler); override;
33    function GetActionLinkClass: TControlActionLinkClass; override;
34    procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override;
35  published
36    property Hint: WideString read GetHint write SetHint stored IsHintStored;
37  end;
38
39{TNT-WARN TCustomFrame}
40  TTntCustomFrame = class(TCustomFrame{TNT-ALLOW TCustomFrame})
41  private
42    function IsHintStored: Boolean;
43    function GetHint: WideString;
44    procedure SetHint(const Value: WideString);
45  protected
46    procedure CreateWindowHandle(const Params: TCreateParams); override;
47    procedure DefineProperties(Filer: TFiler); override;
48    function GetActionLinkClass: TControlActionLinkClass; override;
49    procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override;
50  published
51    property Hint: WideString read GetHint write SetHint stored IsHintStored;
52  end;
53
54{TNT-WARN TFrame}
55  TTntFrame = class(TTntCustomFrame)
56  published
57    property Align;
58    property Anchors;
59    property AutoScroll;
60    property AutoSize;
61    property BiDiMode;
62    property Constraints;
63    property DockSite;
64    property DragCursor;
65    property DragKind;
66    property DragMode;
67    property Enabled;
68    property Color nodefault;
69    property Ctl3D;
70    property Font;
71    {$IFDEF COMPILER_10_UP}
72    property Padding;
73    {$ENDIF}
74    {$IFDEF COMPILER_7_UP}
75    property ParentBackground default True;
76    {$ENDIF}
77    property ParentBiDiMode;
78    property ParentColor;
79    property ParentCtl3D;
80    property ParentFont;
81    property ParentShowHint;
82    property PopupMenu;
83    property ShowHint;
84    property TabOrder;
85    property TabStop;
86    property Visible;
87    {$IFDEF COMPILER_9_UP}
88    property OnAlignInsertBefore;
89    property OnAlignPosition;
90    {$ENDIF}
91    property OnCanResize;
92    property OnClick;
93    property OnConstrainedResize;
94    property OnContextPopup;
95    property OnDblClick;
96    property OnDockDrop;
97    property OnDockOver;
98    property OnDragDrop;
99    property OnDragOver;
100    property OnEndDock;
101    property OnEndDrag;
102    property OnEnter;
103    property OnExit;
104    property OnGetSiteInfo;
105    {$IFDEF COMPILER_9_UP}
106    property OnMouseActivate;
107    {$ENDIF}
108    property OnMouseDown;
109    {$IFDEF COMPILER_10_UP}
110    property OnMouseEnter;
111    property OnMouseLeave;
112    {$ENDIF}
113    property OnMouseMove;
114    property OnMouseUp;
115    property OnMouseWheel;
116    property OnMouseWheelDown;
117    property OnMouseWheelUp;
118    property OnResize;
119    property OnStartDock;
120    property OnStartDrag;
121    property OnUnDock;
122  end;
123
124{TNT-WARN TForm}
125  TTntForm = class(TForm{TNT-ALLOW TForm})
126  private
127    function GetCaption: TWideCaption;
128    procedure SetCaption(const Value: TWideCaption);
129    function GetHint: WideString;
130    procedure SetHint(const Value: WideString);
131    function IsCaptionStored: Boolean;
132    function IsHintStored: Boolean;
133    procedure WMMenuSelect(var Message: TWMMenuSelect); message WM_MENUSELECT;
134    procedure CMBiDiModeChanged(var Message: TMessage); message CM_BIDIMODECHANGED;
135    procedure WMWindowPosChanging(var Message: TMessage); message WM_WINDOWPOSCHANGING;
136  protected
137    procedure UpdateActions; override;
138    procedure CreateWindowHandle(const Params: TCreateParams); override;
139    procedure DestroyWindowHandle; override;
140    procedure DefineProperties(Filer: TFiler); override;
141    function GetActionLinkClass: TControlActionLinkClass; override;
142    procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override;
143    function CreateDockManager: IDockManager; override;
144  public
145    constructor Create(AOwner: TComponent); override;
146    procedure DefaultHandler(var Message); override;
147  published
148    property Caption: TWideCaption read GetCaption write SetCaption stored IsCaptionStored;
149    property Hint: WideString read GetHint write SetHint stored IsHintStored;
150  end;
151
152  TTntApplication = class(TComponent)
153  private
154    FMainFormChecked: Boolean;
155    FHint: WideString;
156    FTntAppIdleEventControl: TControl;
157    FSettingChangeTime: Cardinal;
158    FTitle: WideString;
159    function GetHint: WideString;
160    procedure SetAnsiAppHint(const Value: AnsiString);
161    procedure SetHint(const Value: WideString);
162    function GetExeName: WideString;
163    function IsDlgMsg(var Msg: TMsg): Boolean;
164    procedure DoIdle;
165    function GetTitle: WideString;
166    procedure SetTitle(const Value: WideString);
167    procedure SetAnsiApplicationTitle(const Value: AnsiString);
168    function ApplicationMouseControlHint: WideString;
169  protected
170    function WndProc(var Message: TMessage): Boolean;
171    function ProcessMessage(var Msg: TMsg): Boolean;
172  public
173    constructor Create(AOwner: TComponent); override;
174    destructor Destroy; override;
175    property Hint: WideString read GetHint write SetHint;
176    property ExeName: WideString read GetExeName;
177    property SettingChangeTime: Cardinal read FSettingChangeTime;
178    property Title: WideString read GetTitle write SetTitle;
179  end;
180
181{TNT-WARN IsAccel}
182function IsWideCharAccel(CharCode: Word; const Caption: WideString): Boolean;
183
184{TNT-WARN PeekMessage}
185{TNT-WARN PeekMessageA}
186{TNT-WARN PeekMessageW}
187procedure EnableManualPeekMessageWithRemove;
188procedure DisableManualPeekMessageWithRemove;
189
190type
191  TFormProc = procedure (Form: TForm{TNT-ALLOW TForm});
192
193var
194  TntApplication: TTntApplication;
195
196procedure InitTntEnvironment;
197 
198implementation
199
200uses
201  SysUtils, Consts, RTLConsts, Menus, FlatSB, StdActns,
202  Graphics, TntSystem, TntSysUtils, TntMenus, TntActnList, TntStdActns, TntClasses;
203
204function IsWideCharAccel(CharCode: Word; const Caption: WideString): Boolean;
205var
206  W: WideChar;
207begin
208  W := KeyUnicode(CharCode);
209  Result := WideSameText(W, WideGetHotKey(Caption));
210end;
211
212{ TTntScrollBox }
213
214procedure TTntScrollBox.CreateWindowHandle(const Params: TCreateParams);
215begin
216  CreateUnicodeHandle(Self, Params, '');
217end;
218
219procedure TTntScrollBox.DefineProperties(Filer: TFiler);
220begin
221  inherited;
222  TntPersistent_AfterInherited_DefineProperties(Filer, Self);
223end;
224
225function TTntScrollBox.IsHintStored: Boolean;
226begin
227  Result := TntControl_IsHintStored(Self);
228end;
229
230function TTntScrollBox.GetHint: WideString;
231begin
232  Result := TntControl_GetHint(Self);
233end;
234
235procedure TTntScrollBox.SetHint(const Value: WideString);
236begin
237  TntControl_SetHint(Self, Value);
238end;
239
240procedure TTntScrollBox.ActionChange(Sender: TObject; CheckDefaults: Boolean);
241begin
242  TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults);
243  inherited;
244end;
245
246function TTntScrollBox.GetActionLinkClass: TControlActionLinkClass;
247begin
248  Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass);
249end;
250
251procedure TTntScrollBox.WMSize(var Message: TWMSize);
252begin
253  Inc(FWMSizeCallCount);
254  try
255    if FWMSizeCallCount < 32 then { Infinite recursion was encountered on Win 9x. }
256      inherited;
257  finally
258    Dec(FWMSizeCallCount);
259  end;
260end;
261
262{ TTntCustomFrame }
263
264procedure TTntCustomFrame.CreateWindowHandle(const Params: TCreateParams);
265begin
266  CreateUnicodeHandle(Self, Params, '');
267end;
268
269procedure TTntCustomFrame.DefineProperties(Filer: TFiler);
270begin
271  inherited;
272  TntPersistent_AfterInherited_DefineProperties(Filer, Self);
273end;
274
275function TTntCustomFrame.IsHintStored: Boolean;
276begin
277  Result := TntControl_IsHintStored(Self);
278end;
279
280function TTntCustomFrame.GetHint: WideString;
281begin
282  Result := TntControl_GetHint(Self);
283end;
284
285procedure TTntCustomFrame.SetHint(const Value: WideString);
286begin
287  TntControl_SetHint(Self, Value);
288end;
289
290procedure TTntCustomFrame.ActionChange(Sender: TObject; CheckDefaults: Boolean);
291begin
292  TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults);
293  inherited;
294end;
295
296function TTntCustomFrame.GetActionLinkClass: TControlActionLinkClass;
297begin
298  Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass);
299end;
300
301{ TTntForm }
302
303constructor TTntForm.Create(AOwner: TComponent);
304begin
305  // standard construction technique (look at TForm.Create)
306  GlobalNameSpace.BeginWrite;
307  try
308    CreateNew(AOwner);
309    if (ClassType <> TTntForm) and not (csDesigning in ComponentState) then
310    begin
311      Include(FFormState, fsCreating);
312      try
313        if not InitInheritedComponent(Self, TTntForm) then
314          raise EResNotFound.CreateFmt(SResNotFound, [ClassName]);
315      finally
316        Exclude(FFormState, fsCreating);
317      end;
318      if OldCreateOrder then DoCreate;
319    end;
320  finally
321    GlobalNameSpace.EndWrite;
322  end;
323end;
324
325procedure TTntForm.CreateWindowHandle(const Params: TCreateParams);
326var
327  NewParams: TCreateParams;
328  WideWinClassName: WideString;
329begin
330  if (not Win32PlatformIsUnicode) then
331    inherited
332  else if (FormStyle = fsMDIChild) and not (csDesigning in ComponentState) then
333  begin
334    if (Application.MainForm = nil) or
335      (Application.MainForm.ClientHandle = 0) then
336        raise EInvalidOperation.Create(SNoMDIForm);
337    RegisterUnicodeClass(Params, WideWinClassName);
338    DefWndProc := @DefMDIChildProcW;
339    WindowHandle := CreateMDIWindowW(PWideChar(WideWinClassName),
340      nil, Params.style, Params.X, Params.Y, Params.Width, Params.Height,
341        Application.MainForm.ClientHandle, hInstance, Longint(Params.Param));
342    if WindowHandle = 0 then
343      RaiseLastOSError;
344    SubClassUnicodeControl(Self, Params.Caption);
345    Include(FFormState, fsCreatedMDIChild);
346  end else
347  begin
348    NewParams := Params;
349    NewParams.ExStyle := NewParams.ExStyle and not WS_EX_LAYERED;
350    CreateUnicodeHandle(Self, NewParams, '');
351    Exclude(FFormState, fsCreatedMDIChild);
352  end;
353  if AlphaBlend then begin
354    // toggle AlphaBlend to force update
355    AlphaBlend := False;
356    AlphaBlend := True;
357  end else if TransparentColor then begin
358    // toggle TransparentColor to force update
359    TransparentColor := False;
360    TransparentColor := True;
361  end;
362end;
363
364procedure TTntForm.DestroyWindowHandle;
365begin
366  if Win32PlatformIsUnicode then
367    UninitializeFlatSB(Handle); { Bug in VCL: Without this there might be a resource leak. }
368  inherited;
369end;
370
371procedure TTntForm.DefineProperties(Filer: TFiler);
372begin
373  inherited;
374  TntPersistent_AfterInherited_DefineProperties(Filer, Self);
375end;
376
377procedure TTntForm.DefaultHandler(var Message);
378begin
379  if (ClientHandle <> 0)
380  and (Win32PlatformIsUnicode) then begin
381    with TMessage(Message) do begin
382      if (Msg = WM_SIZE) then
383        Result := DefWindowProcW(Handle, Msg, wParam, lParam)
384      else
385        Result := DefFrameProcW(Handle, ClientHandle, Msg, wParam, lParam);
386      if (Msg = WM_DESTROY) then
387         Perform(TNT_WM_DESTROY, 0, 0); { This ensures that the control is Unsubclassed. }
388    end;
389  end else
390    inherited DefaultHandler(Message);
391end;
392
393function TTntForm.IsCaptionStored: Boolean;
394begin
395  Result := TntControl_IsCaptionStored(Self);
396end;
397
398function TTntForm.GetCaption: TWideCaption;
399begin
400  Result := TntControl_GetText(Self)
401end;
402
403procedure TTntForm.SetCaption(const Value: TWideCaption);
404begin
405  TntControl_SetText(Self, Value)
406end;
407
408function TTntForm.IsHintStored: Boolean;
409begin
410  Result := TntControl_IsHintStored(Self);
411end;
412
413function TTntForm.GetHint: WideString;
414begin
415  Result := TntControl_GetHint(Self)
416end;
417
418procedure TTntForm.SetHint(const Value: WideString);
419begin
420  TntControl_SetHint(Self, Value);
421end;
422
423procedure TTntForm.ActionChange(Sender: TObject; CheckDefaults: Boolean);
424begin
425  TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults);
426  inherited;
427end;
428
429function TTntForm.GetActionLinkClass: TControlActionLinkClass;
430begin
431  Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass);
432end;
433
434procedure TTntForm.WMMenuSelect(var Message: TWMMenuSelect);
435var
436  MenuItem: TMenuItem{TNT-ALLOW TMenuItem};
437  ID: Integer;
438  FindKind: TFindItemKind;
439begin
440  if Menu <> nil then
441    with Message do
442    begin
443      MenuItem := nil;
444      if (MenuFlag <> $FFFF) or (IDItem <> 0) then
445      begin
446        FindKind := fkCommand;
447        ID := IDItem;
448        if MenuFlag and MF_POPUP <> 0 then
449        begin
450          FindKind := fkHandle;
451          ID := Integer(GetSubMenu(Menu, ID));
452        end;
453        MenuItem := Self.Menu.FindItem(ID, FindKind);
454      end;
455      if MenuItem <> nil then
456        TntApplication.Hint := WideGetLongHint(WideGetMenuItemHint(MenuItem))
457      else
458        TntApplication.Hint := '';
459    end;
460end;
461
462procedure TTntForm.UpdateActions;
463begin
464  inherited;
465  TntApplication.DoIdle;
466end;
467
468procedure TTntForm.CMBiDiModeChanged(var Message: TMessage);
469var
470  Loop: Integer;
471begin
472  inherited;
473  for Loop := 0 to ComponentCount - 1 do
474    if Components[Loop] is TMenu then
475      FixMenuBiDiProblem(TMenu(Components[Loop]));
476end;
477
478procedure TTntForm.WMWindowPosChanging(var Message: TMessage);
479begin
480  inherited;
481  // This message *sometimes* means that the Menu.BiDiMode changed.
482  FixMenuBiDiProblem(Menu);
483end;
484
485function TTntForm.CreateDockManager: IDockManager;
486begin
487  if (DockManager = nil) and DockSite and UseDockManager then
488    HandleNeeded; // force TNT subclassing to occur first
489  Result := inherited CreateDockManager;
490end;
491
492{ TTntApplication }
493
494constructor TTntApplication.Create(AOwner: TComponent);
495begin
496  inherited;
497  Application.HookMainWindow(WndProc);
498  FSettingChangeTime := GetTickCount;
499  TntSysUtils._SettingChangeTime := GetTickCount;
500end;
501
502destructor TTntApplication.Destroy;
503begin
504  FreeAndNil(FTntAppIdleEventControl);
505  Application.UnhookMainWindow(WndProc);
506  inherited;
507end;
508
509function TTntApplication.GetHint: WideString;
510begin
511  // check to see if the hint has already been set on application.idle
512  if Application.Hint = AnsiString(ApplicationMouseControlHint) then
513    FHint := ApplicationMouseControlHint;
514  // get the synced string
515  Result := GetSyncedWideString(FHint, Application.Hint)
516end;
517
518procedure TTntApplication.SetAnsiAppHint(const Value: AnsiString);
519begin
520  Application.Hint := Value;
521end;
522
523procedure TTntApplication.SetHint(const Value: WideString);
524begin
525  SetSyncedWideString(Value, FHint, Application.Hint, SetAnsiAppHint);
526end;
527
528function TTntApplication.GetExeName: WideString;
529begin
530  Result := WideParamStr(0);
531end;
532
533function TTntApplication.GetTitle: WideString;
534begin
535  if (Application.Handle <> 0) and Win32PlatformIsUnicode then begin
536    SetLength(Result, DefWindowProcW(Application.Handle, WM_GETTEXTLENGTH, 0, 0) + 1);
537    DefWindowProcW(Application.Handle, WM_GETTEXT, Length(Result), Integer(PWideChar(Result)));
538    SetLength(Result, Length(Result) - 1);
539  end else
540    Result := GetSyncedWideString(FTitle, Application.Title);
541end;
542
543procedure TTntApplication.SetAnsiApplicationTitle(const Value: AnsiString);
544begin
545  Application.Title := Value;
546end;
547
548procedure TTntApplication.SetTitle(const Value: WideString);
549begin
550  if (Application.Handle <> 0) and Win32PlatformIsUnicode then begin
551    if (GetTitle <> Value) or (FTitle <> '') then begin
552      DefWindowProcW(Application.Handle, WM_SETTEXT, 0, lParam(PWideChar(Value)));
553      FTitle := '';
554    end
555  end else
556    SetSyncedWideString(Value, FTitle, Application.Title, SetAnsiApplicationTitle);
557end;
558
559{$IFDEF COMPILER_6} // verified against VCL source in Delphi 6 and BCB 6
560type
561  THackApplication = class(TComponent)
562  protected
563    FxxxxxxxxxHandle: HWnd;
564    FxxxxxxxxxBiDiMode: TBiDiMode;
565    FxxxxxxxxxBiDiKeyboard: AnsiString;
566    FxxxxxxxxxNonBiDiKeyboard: AnsiString;
567    FxxxxxxxxxObjectInstance: Pointer;
568    FxxxxxxxxxMainForm: TForm{TNT-ALLOW TForm};
569    FMouseControl: TControl;
570  end;
571{$ENDIF}
572{$IFDEF DELPHI_7} // verified against VCL source in Delphi 7
573type
574  THackApplication = class(TComponent)
575  protected
576    FxxxxxxxxxHandle: HWnd;
577    FxxxxxxxxxBiDiMode: TBiDiMode;
578    FxxxxxxxxxBiDiKeyboard: AnsiString;
579    FxxxxxxxxxNonBiDiKeyboard: AnsiString;
580    FxxxxxxxxxObjectInstance: Pointer;
581    FxxxxxxxxxMainForm: TForm{TNT-ALLOW TForm};
582    FMouseControl: TControl;
583  end;
584{$ENDIF}
585{$IFDEF DELPHI_9} // verified against VCL source in Delphi 9
586type
587  THackApplication = class(TComponent)
588  protected
589    FxxxxxxxxxHandle: HWnd;
590    FxxxxxxxxxBiDiMode: TBiDiMode;
591    FxxxxxxxxxBiDiKeyboard: AnsiString;
592    FxxxxxxxxxNonBiDiKeyboard: AnsiString;
593    FxxxxxxxxxObjectInstance: Pointer;
594    FxxxxxxxxxMainForm: TForm{TNT-ALLOW TForm};
595    FMouseControl: TControl;
596  end;
597{$ENDIF}
598{$IFDEF DELPHI_10} // verified against VCL source in Delphi 10
599type
600  THackApplication = class(TComponent)
601  protected
602    FxxxxxxxxxHandle: HWnd;
603    FxxxxxxxxxBiDiMode: TBiDiMode;
604    FxxxxxxxxxBiDiKeyboard: AnsiString;
605    FxxxxxxxxxNonBiDiKeyboard: AnsiString;
606    FxxxxxxxxxObjectInstance: Pointer;
607    FxxxxxxxxxMainForm: TForm{TNT-ALLOW TForm};
608    FMouseControl: TControl;
609  end;
610{$ENDIF}
611
612function TTntApplication.ApplicationMouseControlHint: WideString;
613var
614  MouseControl: TControl;
615begin
616  MouseControl := THackApplication(Application).FMouseControl;
617  Result := WideGetLongHint(WideGetHint(MouseControl));
618end;
619
620procedure TTntApplication.DoIdle;
621begin
622  // update TntApplication.Hint only when Ansi encodings are the same... (otherwise there are problems with action menus)
623  if Application.Hint = AnsiString(ApplicationMouseControlHint) then
624    Hint := ApplicationMouseControlHint;
625end;
626
627function TTntApplication.IsDlgMsg(var Msg: TMsg): Boolean;
628begin
629  Result := False;
630  if (Application.DialogHandle <> 0) then begin
631    if IsWindowUnicode(Application.DialogHandle) then
632      Result := IsDialogMessageW(Application.DialogHandle, Msg)
633    else
634      Result := IsDialogMessageA(Application.DialogHandle, Msg);
635  end;
636end;
637
638type
639  TTntAppIdleEventControl = class(TControl)
640  protected
641    procedure OnIdle(Sender: TObject);
642  public
643    constructor Create(AOwner: TComponent); override;
644    destructor Destroy; override;
645  end;
646
647constructor TTntAppIdleEventControl.Create(AOwner: TComponent);
648begin
649  inherited;
650  ParentFont := False; { This allows Parent (Application) to be in another module. }
651  Parent := Application.MainForm;
652  Visible := True;
653  Action := TTntAction.Create(Self);
654  Action.OnExecute := OnIdle;
655  Action.OnUpdate := OnIdle;
656  TntApplication.FTntAppIdleEventControl := Self;
657end;
658
659destructor TTntAppIdleEventControl.Destroy;
660begin
661  if TntApplication <> nil then
662    TntApplication.FTntAppIdleEventControl := nil;
663  inherited;
664end;
665
666procedure TTntAppIdleEventControl.OnIdle(Sender: TObject);
667begin
668  TntApplication.DoIdle;
669end;
670
671function TTntApplication.ProcessMessage(var Msg: TMsg): Boolean;
672var
673  Handled: Boolean;
674begin
675  Result := False;
676  // Check Main Form
677  if (not FMainFormChecked) and (Application.MainForm <> nil) then begin
678    if not (Application.MainForm is TTntForm) then begin
679      // This control will help ensure that DoIdle is called
680      TTntAppIdleEventControl.Create(Application.MainForm);
681    end;
682    FMainFormChecked := True;
683  end;
684  // Check for Unicode char messages
685  if (Msg.message = WM_CHAR)
686  and (Msg.wParam > Integer(High(AnsiChar)))
687  and IsWindowUnicode(Msg.hwnd)
688  and ((Application.DialogHandle = 0) or IsWindowUnicode(Application.DialogHandle))
689  then begin
690    Result := True;
691    // more than 8-bit WM_CHAR destined for Unicode window
692    Handled := False;
693    if Assigned(Application.OnMessage) then
694      Application.OnMessage(Msg, Handled);
695    Application.CancelHint;
696    // dispatch msg if not a dialog message
697    if (not Handled) and (not IsDlgMsg(Msg)) then
698      DispatchMessageW(Msg);
699  end;
700end;
701
702function TTntApplication.WndProc(var Message: TMessage): Boolean;
703var
704  BasicAction: TBasicAction;
705begin
706  Result := False; { not handled }
707  if (Message.Msg = WM_SETTINGCHANGE) then begin
708    FSettingChangeTime := GetTickCount;
709    TntSysUtils._SettingChangeTime := FSettingChangeTime;
710  end;
711  if (Message.Msg = WM_CREATE)
712  and (FTitle <> '') then begin
713    SetTitle(FTitle);
714    FTitle := '';
715  end;
716  if (Message.Msg = CM_ACTIONEXECUTE) then begin
717    BasicAction := TBasicAction(Message.LParam);
718    if (BasicAction.ClassType = THintAction{TNT-ALLOW THintAction})
719    and (THintAction{TNT-ALLOW THintAction}(BasicAction).Hint = AnsiString(Hint))
720    then begin
721      Result := True;
722      Message.Result := 1;
723      with TTntHintAction.Create(Self) do
724      begin
725        Hint := Self.Hint;
726        try
727          Execute;
728        finally
729          Free;
730        end;
731      end;
732    end;
733  end;
734end;
735
736//===========================================================================
737//   The NT GetMessage Hook is needed to support entering Unicode
738//     characters directly from the keyboard (bypassing the IME).
739//   Special thanks go to Francisco Leong for developing this solution.
740//
741//  Example:
742//    1. Install "Turkic" language support.
743//    2. Add "Azeri (Latin)" as an input locale.
744//    3. In an EDIT, enter Shift+I.  (You should see a capital "I" with dot.)
745//    4. In an EDIT, enter single quote (US Keyboard).  (You should see an upturned "e".)
746//
747var
748  ManualPeekMessageWithRemove: Integer = 0;
749
750procedure EnableManualPeekMessageWithRemove;
751begin
752  Inc(ManualPeekMessageWithRemove);
753end;
754
755procedure DisableManualPeekMessageWithRemove;
756begin
757  if (ManualPeekMessageWithRemove > 0) then
758    Dec(ManualPeekMessageWithRemove);
759end;
760
761var
762  NTGetMessageHook: HHOOK;
763
764function GetMessageForNT(Code: Integer; wParam: Integer; lParam: Integer): LRESULT; stdcall;
765var
766  ThisMsg: PMSG;
767begin
768  if (Code >= 0)
769  and (wParam = PM_REMOVE)
770  and (ManualPeekMessageWithRemove = 0) then
771  begin
772    ThisMsg := PMSG(lParam);
773    if (TntApplication <> nil)
774    and TntApplication.ProcessMessage(ThisMsg^) then
775      ThisMsg.message := WM_NULL; { clear for further processing }
776  end;
777  Result := CallNextHookEx(NTGetMessageHook, Code, wParam, lParam);
778end;
779
780procedure CreateGetMessageHookForNT;
781begin
782  Assert(Win32Platform = VER_PLATFORM_WIN32_NT);
783  NTGetMessageHook := SetWindowsHookExW(WH_GETMESSAGE, GetMessageForNT, 0, GetCurrentThreadID);
784  if NTGetMessageHook = 0 then
785    RaiseLastOSError;
786end;
787
788//---------------------------------------------------------------------------------------------
789//                                 Tnt Environment Setup
790//---------------------------------------------------------------------------------------------
791
792procedure InitTntEnvironment;
793
794    function GetDefaultFont: WideString;
795
796        function RunningUnderIDE: Boolean;
797        begin
798          Result := ModuleIsPackage and
799            (    WideSameText(WideExtractFileName(WideGetModuleFileName(0)), 'bds.exe')
800              or WideSameText(WideExtractFileName(WideGetModuleFileName(0)), 'delphi32.exe')
801              or WideSameText(WideExtractFileName(WideGetModuleFileName(0)), 'bcb.exe'));
802        end;
803
804        function GetProfileStr(const Section, Key, Default: AnsiString; MaxLen: Integer): AnsiString;
805        var
806          Len: Integer;
807        begin
808          SetLength(Result, MaxLen + 1);
809          Len := GetProfileString(PAnsiChar(Section), PAnsiChar(Key), PAnsiChar(Default),
810            PAnsiChar(Result), Length(Result));
811          SetLength(Result, Len);
812        end;
813
814        procedure SetProfileStr(const Section, Key, Value: AnsiString);
815        var
816          DummyResult: Cardinal;
817        begin
818          try
819            Win32Check(WriteProfileString(PAnsiChar(Section), PAnsiChar(Key), PAnsiChar(Value)));
820            if Win32Platform = VER_PLATFORM_WIN32_WINDOWS then
821              WriteProfileString(nil, nil, nil); {this flushes the WIN.INI cache}
822            SendMessageTimeout(HWND_BROADCAST, WM_SETTINGCHANGE, 0, Integer(PAnsiChar(Section)),
823              SMTO_NORMAL, 250, DummyResult);
824          except
825            on E: Exception do begin
826              E.Message := 'Couldn''t create font substitutes.' + CRLF + E.Message;
827              Application.HandleException(nil);
828            end;
829          end;
830        end;
831
832    var
833      ShellDlgFontName_1: WideString;
834      ShellDlgFontName_2: WideString;
835    begin
836      ShellDlgFontName_1 := GetProfileStr('FontSubstitutes', 'MS Shell Dlg', '', LF_FACESIZE);
837      if ShellDlgFontName_1 = '' then begin
838        ShellDlgFontName_1 := 'MS Sans Serif';
839        SetProfileStr('FontSubstitutes', 'MS Shell Dlg', ShellDlgFontName_1);
840      end;
841      ShellDlgFontName_2 := GetProfileStr('FontSubstitutes', 'MS Shell Dlg 2', '', LF_FACESIZE);
842      if ShellDlgFontName_2 = '' then begin
843        if Screen.Fonts.IndexOf('Tahoma') <> -1 then
844          ShellDlgFontName_2 := 'Tahoma'
845        else
846          ShellDlgFontName_2 := ShellDlgFontName_1;
847        SetProfileStr('FontSubstitutes', 'MS Shell Dlg 2', ShellDlgFontName_2);
848      end;
849      if RunningUnderIDE then begin
850        Result := 'MS Shell Dlg 2' {Delphi is running}
851      end else
852        Result := ShellDlgFontName_2;
853    end;
854
855begin
856  // Tnt Environment Setup
857  InstallTntSystemUpdates;
858  DefFontData.Name := GetDefaultFont;
859  Forms.HintWindowClass := TntControls.TTntHintWindow;
860end;
861
862initialization
863  TntApplication := TTntApplication.Create(nil);
864  if Win32Platform = VER_PLATFORM_WIN32_NT then
865    CreateGetMessageHookForNT;
866
867finalization
868  if NTGetMessageHook <> 0 then begin
869    UnhookWindowsHookEx(NTGetMessageHook) // no Win32Check, fails in too many cases, and doesn't matter
870  end;
871  FreeAndNil(TntApplication);
872
873end.
Note: See TracBrowser for help on using the repository browser.