source: cprs/branches/tmg-cprs/TntWare/Delphi Unicode Controls/Source/TntForms.pas@ 457

Last change on this file since 457 was 453, checked in by Kevin Toppenberg, 16 years ago

Initial upload of TMG-CPRS 1.0.26.69

File size: 26.6 KB
RevLine 
[453]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.