unit FormUtils;
interface

uses
	Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
	StdCtrls, AppEvnts;

type
	TExForm = class(TForm)
		procedure WMSysCommand(var aMsg: TWMSysCommand); message WM_SYSCOMMAND;
		procedure WMHelp(var aMsg: TWMHelp); message WM_HELP;
		procedure WMSetCursor(var aMsg: TWMSetCursor); message WM_SETCURSOR;
	end;

	TNonModalForm = class(TExForm)
	private
		FCreationWndParent: HWND;
	protected
		procedure CreateParams(var Params: TCreateParams); override;
	public
		constructor CreateWithParent(aWndParent: HWND);
	end;


	THelpCtxForm = class(TForm)
		Label1: TLabel;
		Label2: TLabel;
    Label3: TLabel;
    HelpCtx: TEdit;
    Ok: TButton;
    Cancel: TButton;
    FormName: TEdit;
    ItemName: TEdit;
	private
		{ Private declarations }
	public
		{ Public declarations }
	end;

	TWhatsThis = class
	private
		FTracking: Boolean;
    FApplicationEvents: TApplicationEvents;
    
		procedure OnMessage(var aMsg: TMSG; var aHandled: Boolean);
		procedure SetTracking(aValue: Boolean);
		function FindForm(aComponent: TComponent): TCustomForm;
		function CanProcessForm(aForm: TCustomForm): Boolean;
		procedure GetNames(aComponent: TComponent; aHitTest: Integer; out s1, s2: String);

		function SubstCtx(const aSection, aKey, aCtx: String): String;
		function GetComponentCtx(aComponent: TComponent; aHitTest: Integer): String;
		procedure HelpOnContext(aPt: TPoint; const aSection, aKey, aCtx: String);
		procedure HelpOnComponent(aPt: TPoint; aHitTest: Integer; aComponent: TComponent);
		procedure HelpOnPos(aPt: TPoint; aHitTest: Integer);
		procedure HelpOnMenu(aWnd: HWND; aCommand: Integer);
		procedure Options;

	public
		Profile: String;
		DesignMode: Boolean;
		ModalForm: TCustomForm;

		constructor Create;
		destructor Destroy; override;

		function WMSetCursor(aForm: TCustomForm; var aMsg: TWMSetCursor): Boolean;
		function WMHelp(aForm: TCustomForm; var aMsg: TWMHelp): Boolean;
		procedure ShowHelp(const aCtx: String);
		property Tracking: Boolean read FTracking write SetTracking;
	end;

var
	MainFormHandle: HWND = 0;
	WhatsThis: TWhatsThis = nil;

implementation

{$R *.DFM}

uses
	TypInfo, Menus, WhatsThisOptions, HtmlHelps;

constructor TNonModalForm.CreateWithParent(aWndParent: HWND);
begin
	FCreationWndParent := aWndParent;
	Create(nil);
end;

procedure TNonModalForm.CreateParams(var Params: TCreateParams);
begin
	inherited CreateParams(Params);
	if FCreationWndParent <> 0 then
		Params.WndParent := FCreationWndParent
	else if MainFormHandle <> 0 then
		Params.WndParent := MainFormHandle
	else if Assigned(Application.MainForm) then
		Params.WndParent := Application.MainForm.Handle;
end;

procedure TExForm.WMSetCursor(var aMsg: TWMSetCursor);
begin
	if not WhatsThis.WMSetCursor(Self, aMsg) then
		inherited;
end;

procedure TExForm.WMHelp(var aMsg: TWMHelp);
begin
	aMsg.Result := 0;
end;

procedure TExForm.WMSysCommand(var aMsg: TWMSysCommand);
begin
	if aMsg.CmdType = SC_CONTEXTHELP then begin
		aMsg.Result := 0;
		WhatsThis.Tracking := True;
		WhatsThis.ModalForm := Self;
	end
	else
		inherited;
end;

//****************************************************************************
//	TWhatsThis
//

constructor TWhatsThis.Create;
begin
	inherited Create;
	Profile := ChangeFileExt(ParamStr(0), '.INI');
  FApplicationEvents := TApplicationEvents.Create(nil);
  FApplicationEvents.OnMessage := OnMessage;
end;

destructor TWhatsThis.Destroy;
begin
  FApplicationEvents.Free;
	inherited Destroy;
end;

procedure TWhatsThis.SetTracking(aValue: Boolean);
var
	aMouse: TPoint;
	aWnd: HWND;
	aHitTest: Integer;
begin
	if aValue <> FTracking then begin
		if aValue then begin
			FTracking := True;
		end
		else begin
			FTracking := False;
			GetCursorPos(aMouse);
			aWnd := WindowFromPoint(aMouse);
			if aWnd <> 0 then begin
				aHitTest := SendMessage(aWnd, WM_NCHITTEST, 0, MakeLParam(aMouse.X, aMouse.Y));
				SendMessage(aWnd, WM_SETCURSOR, aWnd, MakeLParam(aHitTest, WM_MOUSEMOVE));
			end
			else
				Windows.SetCursor(LoadCursor(0, IDC_ARROW));
		end;
		ModalForm := nil;
	end;
end;

function TWhatsThis.FindForm(aComponent: TComponent): TCustomForm;
begin
	if aComponent is TControl then
		Result := ValidParentForm(TControl(aComponent))
	else if aComponent.Owner = nil then
		Result := Application.MainForm
	else
		Result := FindForm(aComponent.Owner);
end;

procedure TWhatsThis.GetNames(aComponent: TComponent; aHitTest: Integer; out s1, s2: String);

	function GetObjectName(anObject: TObject; anIndex: Integer): String;
	begin
		Result := anObject.ClassName;
		if (Length(Result) > 1) and (Result[1] = 'T') then
			Delete(Result, 1, 1);
		if anIndex <> -1 then
			Result := Result + IntToStr(anIndex);
	end;

	function GetComponentName(aComponent: TComponent): String;
	var
		anIndex, i: Integer;
		aControl: TControl;
	begin
		Result := aComponent.Name;
		if Result = '' then begin
			anIndex := -1;
			if aComponent is TControl then begin
				aControl := aComponent as TControl;
				if aControl.Parent <> ValidParentForm(aControl) then
					Result := GetComponentName(aControl.Parent) + '.';
				for i := 0 to aControl.Parent.ControlCount - 1 do
					if aControl.Parent.Controls[i] = aControl then begin
						anIndex := i;
						break;
					end;
			end;
			if anIndex = -1 then
				anIndex := aComponent.ComponentIndex;
			Result := Result + GetObjectName(aComponent, anIndex);
		end;
	end;

var
	aForm: TCustomForm;
	aClient,
	aScroll: Boolean;
begin
	aClient := aHitTest = HTCLIENT;
	aScroll := (aHitTest = HTHSCROLL) or (aHitTest = HTVSCROLL);
	aForm := FindForm(aComponent);
	s1 := aForm.ClassName;
	if aForm = aComponent then
		s2 := 'Form'
	else
		s2 := GetComponentName(aComponent);
	if not (aClient or aScroll) then
		s1 := 'Forms';
	if not aClient then
		s2 := s2 + '(' + IntToStr(aHitTest) + ')';
end;

function TWhatsThis.SubstCtx(const aSection, aKey, aCtx: String): String;
var
	aBuf: array [0..256] of Char;
begin
	GetPrivateProfileString(PChar(aSection), PChar(aKey), PChar(aCtx),
		aBuf, sizeof(aBuf), PChar(Profile));
	Result := aBuf;
end;

function TWhatsThis.GetComponentCtx(aComponent: TComponent; aHitTest: Integer): String;
var
	s1, s2: String;
begin
	GetNames(aComponent, aHitTest, s1, s2);
	Result := SubstCtx(s1, s2, '');
end;

procedure TWhatsThis.HelpOnContext(aPt: TPoint; const aSection, aKey, aCtx: String);
var
	aForm: THelpCtxForm;
	aNewCtx: String;
begin
	aNewCtx := SubstCtx(aSection, aKey, aCtx);
	if DesignMode then begin
		aForm := THelpCtxForm.Create(Application);
		try
			aForm.FormName.Text := aSection;
			aForm.ItemName.Text := aKey;
			aForm.HelpCtx.Text := aNewCtx;
			if aForm.ShowModal = mrOk then
				WritePrivateProfileString(PChar(aSection), PChar(aKey), PChar(aForm.HelpCtx.Text),
					PChar(Profile));
		finally
			aForm.Free
		end;
	end
	else
		ShowHelp(aNewCtx);
end;

procedure TWhatsThis.HelpOnComponent(aPt: TPoint; aHitTest: Integer; aComponent: TComponent);
var
	s1, s2: String;
begin
	GetNames(aComponent, aHitTest, s1, s2);
	HelpOnContext(aPt, s1, s2, GetComponentCtx(aComponent, aHitTest));
end;

function TWhatsThis.CanProcessForm(aForm: TCustomForm): Boolean;
begin
	Result := (ModalForm = nil) or (ModalForm = aForm);
end;


var
	WindowAtom: TAtom;

function FindWindow(Handle: HWnd): TWinControl;
begin
	Result := nil;
	if Handle <> 0 then begin
		Result := Pointer(GetProp(Handle, MakeIntAtom(WindowAtom)));
		if Assigned(Result) and not Result.InheritsFrom(TWinControl) then
			Result := nil;
	end;
end;

function FindVCLForm(const Pos: TPoint): TCustomForm;
var
	Handle: HWND;
	aControl: TWinControl;
begin
	Handle := WindowFromPoint(Pos);
	while Handle <> 0 do begin
		aControl := FindWindow(Handle);
		if Assigned(aControl) and aControl.InheritsFrom(TCustomForm) then begin
			Result := TCustomForm(aControl);
			Exit;
		end;
		Handle := GetParent(Handle);
	end;
	Result := nil;
end;

function FindChildControl(aParent: TWinControl; const aPos: TPoint): TControl;
var
	i: Integer;
begin
	for i := aParent.ControlCount - 1 downto 0 do begin
		Result := aParent.Controls[i];
		if Result.Visible and PtInRect(Result.ClientRect, Result.ScreenToClient(aPos))
		then begin
			if Result is TWinControl then
				Result := FindChildControl(TWinControl(Result), aPos);
			Exit;
		end;
	end;
	Result := aParent;
end;

function FindVCLControl(const aPos: TPoint): TControl;
var
	aForm: TCustomForm;
begin
	aForm := FindVCLForm(aPos);
	if Assigned(aForm) then
		Result := FindChildControl(aForm, aPos)
	else
		Result := nil;
end;

procedure TWhatsThis.HelpOnPos(aPt: TPoint; aHitTest: Integer);
var
	aControl: TControl;
	aSaveModalForm: TCustomForm;
begin
	aSaveModalForm := ModalForm;
	Tracking := False;
	aControl := FindVCLControl(aPt);
	if Assigned(aControl) and CanProcessForm(FindForm(aControl)) then
		HelpOnComponent(aPt, aHitTest, aControl)
	else
		MessageBeep($FFFFFFFF);
	if DesignMode then begin
		Tracking := True;
		ModalForm := aSaveModalForm;
	end;
end;

procedure TWhatsThis.HelpOnMenu(aWnd: HWND; aCommand: Integer);
var
	aForm: TCustomForm;
	aMenuItem: TMenuItem;
	aPt: TPoint;
	aSaveModalForm: TCustomForm;
begin
	aSaveModalForm := ModalForm;
	Tracking := False;
	aForm := ValidParentForm(FindControl(aWnd));
	if Assigned(aForm) and Assigned(aForm.Menu) then begin
		aMenuItem := aForm.Menu.FindItem(aCommand, fkCommand);
		if Assigned(aMenuItem) then begin
			GetCursorPos(aPt);
			HelpOnComponent(aPt, HTCLIENT, aMenuItem);
		end
	end;
	if DesignMode then begin
		Tracking := True;
		Modalform := aSaveModalForm;
	end;
end;

procedure TWhatsThis.Options;
var
	aForm: TWhatsThisOptionsForm;
begin
	Tracking := False;
	aForm := TWhatsThisOptionsForm.Create(Application);
	try
		aForm.Profile.Text := Profile;
		aForm.DesignMode.Checked := DesignMode;
		if aForm.ShowModal = mrOk then begin
			Profile := aForm.Profile.Text;
			DesignMode := aForm.DesignMode.Checked;
		end;
	finally
		aForm.Free
	end;
	Tracking := True;
end;

procedure TWhatsThis.OnMessage(var aMsg: TMSG; var aHandled: Boolean);
begin
	aHandled := False;
	if FTracking then
		case aMsg.Message of
			WM_SYSCOMMAND:
				begin
					aHandled := True;
	//				Tracking := False;
				end;
			WM_COMMAND:
				begin
					aHandled := True;
					if (HIWORD(aMsg.wParam) = 0) and (aMsg.lParam = 0) then
						HelpOnMenu(aMsg.HWnd, LOWORD(aMsg.wParam));
				end;
			WM_KEYDOWN:
				begin
					aHandled := True;
					case aMsg.WParam of
						VK_F1: Options;
						VK_ESCAPE: Tracking := False;
					end;
				end;
			WM_LBUTTONDOWN,
			WM_RBUTTONDOWN,
			WM_MBUTTONDOWN,
			WM_LBUTTONDBLCLK,
			WM_MBUTTONDBLCLK,
			WM_RBUTTONDBLCLK:
				begin
					aHandled := True;
					HelpOnPos(aMsg.pt, HTCLIENT);
				end;
			WM_NCLBUTTONDOWN,
			WM_NCRBUTTONDOWN,
			WM_NCMBUTTONDOWN,
			WM_NCLBUTTONDBLCLK,
			WM_NCMBUTTONDBLCLK,
			WM_NCRBUTTONDBLCLK:
				begin
					if (aMsg.WParam <> HTMENU) and (aMsg.WParam <> HTSYSMENU) then begin
						aHandled := True;
						HelpOnPos(aMsg.pt, aMsg.WParam);
					end
				end;
		end
end;

function TWhatsThis.WMSetCursor(aForm: TCustomForm; var aMsg: TWMSetCursor): Boolean;
begin
	Result := Tracking and CanProcessForm(aForm);
	if Result then begin
		Windows.SetCursor(LoadCursor(0, IDC_HELP));
		aMsg.Result := 1;
	end
end;

function TWhatsThis.WMHelp(aForm: TCustomForm; var aMsg: TWMHelp): Boolean;
begin
	ShowMessage(IntToStr(aMsg.HelpInfo.iContextType));
	Result := False;
end;

procedure TWhatsThis.ShowHelp(const aCtx: String);
var
	aHelpFile: String;
	aPopup: HH_POPUP;
	e: Integer;
	s: String;
begin
	aHelpFile := ChangeFileExt(ParamStr(0), '.CHM');
	if (aCtx <> '') and (aCtx[1] = '#') then begin
		s := aCtx;
		Delete(s, 1, 1);
		aPopup.cbStruct := sizeof(aPopup);
		aPopup.hinst := 0;
		aPopup.idString := 0;
		aPopup.pszText := nil;
		aPopup.pt := Mouse.CursorPos;
		aPopup.clrForeground := COLORREF(-1);
		aPopup.clrBackground := COLORREF(-1);
		aPopup.rcMargins := Rect(-1, -1, -1, -1);
		aPopup.pszFont := nil;
		Val(s, aPopup.idString, e);
		if e > 1 then
			Delete(s, 1, e - 1);
		while (s <> '') and (s[1] = ' ') do
			Delete(s, 1, 1);
		if s <> '' then
			aHelpFile := aHelpFile + '::/' + s;
		HtmlHelp(0, PChar(aHelpFile), HH_DISPLAY_TEXT_POPUP, DWORD_PTR(@aPopup));
	end
	else begin
		if aCtx <> '' then
			aHelpFile := aHelpFile + '::/' + aCtx;
		HtmlHelp(0, PChar(aHelpFile), HH_DISPLAY_TOPIC, 0);
	end
end;

var
	AtomText: array[0..31] of Char;

initialization
	WhatsThis := TWhatsThis.Create;
	WindowAtom := GlobalAddAtom(StrFmt(AtomText, 'Delphi%.8X',
		[GetCurrentProcessID]));
finalization
	WindowAtom := GlobalDeleteAtom(WindowAtom);
	WhatsThis.Free;
	WhatsThis := nil;
end.
