Help - usar help chm nos programas em delphi

Top Previous Next

{

Exemplo completo para chamar um HTMLHelp (.chm) a partir da aplicação Delphi

Permite o uso de F1 para um componente visual, uso de biHelp do form e chamada

direta através da função "AbrirHelpContext"

Importante: Não coloque o nome do arquivo de help no Project/Options/HelpFile, nem no Application.HelpFile,

pois ao pressionar F1 a aplicação tentará carregar o Htmlhelp (.CHM) que estiver lá,

gerando uma exception pois o formato CHM não é suportado pelo Delphi .

Para testar: crie um help com 3 tópicos com Context ID 10, 20 e 30

-----------------------------------------------------------------------------------------------------------}

unit Unit1;

interface

uses Forms, Classes, Controls, StdCtrls, HookHelp, Windows;

type

TForm1 = class(TForm)

HelpBtn: TButton;

Button3: TButton;

Button4: TButton;

Button5: TButton;

procedure FormCreate(Sender: TObject);

private

function OnHelp_HelpHook(Command: Word; Data: Longint; var CallHelp: Boolean): Boolean;

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);

begin

HelpCHM_Arquivo := 'C:\temp\Teste.chm';

Application.OnHelp := OnHelp_HelpHook;

end;

function TForm1.OnHelp_HelpHook(Command : Word; Data : Longint; Var CallHelp : Boolean) : Boolean;

begin

Result := AbrirHelpContext(Data);

end;

end.

// ----------------------------------- form1.dfm -----------------------------------------------

object Form1: TForm1

Left = 330

Top = 260

BorderIcons = [biSystemMenu, biHelp]

Caption = 'Form1 - Cxt=1000'

ClientHeight = 340

ClientWidth = 592

Color = clBtnFace

Constraints.MinHeight = 367

Constraints.MinWidth = 600

Font.Charset = DEFAULT_CHARSET

Font.Color = clWindowText

Font.Height = -11

Font.Name = 'MS Sans Serif'

Font.Style = []

OldCreateOrder = True

Position = poScreenCenter

OnCreate = FormCreate

PixelsPerInch = 96

TextHeight = 13

object HelpBtn: TButton

Left = 224

Top = 108

Width = 129

Height = 25

HelpContext = 10

Caption = '10'

TabOrder = 0

end

object Button3: TButton

Left = 224

Top = 140

Width = 129

Height = 25

HelpContext = 20

Caption = '20'

TabOrder = 1

end

object Button4: TButton

Left = 224

Top = 172

Width = 129

Height = 25

HelpContext = 30

Caption = '30'

TabOrder = 2

end

object Button5: TButton

Left = 224

Top = 203

Width = 129

Height = 25

Caption = 'Help do Form'

TabOrder = 3

end

// ==============================================================================================

// Esta unit abaixo deve ser adicionada ao Path do Project Options. Ela é quem hackeia o OnHelp

// do form para apontar para a OCX que redireciona o help para o CHM. Para mais detalhes:

// http://Helpware.net

unit HookHelp;

interface

uses Classes, Types, Windows, Dialogs;

var

HelpCHM_Arquivo: string;

HtmlHelpA : function(hwndCaller: HWND; pszFile: PAnsiChar; uCommand: UInt; dwData: DWORD): HWND; stdcall;

function AbrirHelpContext(const IDContext: Cardinal): Boolean;

implementation

uses HelpIntfs, WinHelpViewer, SysUtils, Forms, Controls, Registry;

var

HHCtrlHandle: THandle = 0;

ViewerName : string = 'D6OnHelpFix';

HtmlHelpW : function(hwndCaller: HWND; pszFile: PWideChar; uCommand: UInt; dwData: DWORD): HWND; stdcall;

HtmlHelp : function(hwndCaller: HWND; pszFile: PChar ; uCommand: UInt; dwData: DWORD): HWND; stdcall;

const

hhctrlLib = 'hhctrl.ocx';

HH_DISPLAY_TOPIC = $0000;

HH_HELP_CONTEXT = $000F;

HH_CLOSE_ALL = $0012;

type

THTMLHelpViewer = class(TInterfacedObject, ICustomHelpViewer, IExtendedHelpViewer{, ISpecialWinHelpViewer})

private

FViewerID: Integer;

public

FHelpManager: IHelpManager;

constructor Create;

destructor Destroy; override;

function HelpFile(const Name: String) : String;

procedure InternalShutDown;

procedure HelpCommand_HELP_SETPOPUP_POS;

{ ICustomHelpViewer }

function GetViewerName : String;

procedure NotifyID(const ViewerID: Integer);

procedure SoftShutDown;

procedure ShutDown;

function UnderstandsKeyword(const HelpString: String): Integer;

function GetHelpStrings(const HelpString: String): TStringList;

function CanShowTableOfContents: Boolean;

procedure ShowTableOfContents;

procedure ShowHelp(const HelpString: String);

{ IExtendedHelpViewer }

function UnderstandsTopic(const Topic: String): Boolean;

procedure DisplayTopic(const Topic: String);

function UnderstandsContext(const ContextID: Integer;

const HelpFileName: String): Boolean;

procedure DisplayHelpByContext(const ContextID: Integer;

const HelpFileName: String);

property ViewerID : Integer read FViewerID;

property HelpManager : IHelpManager read FHelpManager write FHelpManager;

end;

{ global instance of THTMLHelpViewer which HelpIntfs can talk to. }

var

HelpViewer : THTMLHelpViewer;

{----------------------------------------------------------------------------}

{ THelpSelector }

{----------------------------------------------------------------------------}

{ IHelpSelector. IHelpSelector is used by the HelpSystem to ask the

application to decide which keyword, out of multiple matches returned

by multiple different Help Viewers, it wishes to support. If an application

wishes to support this, it passes an IHelpSelector interface into

IHelpSystem.AssignHelpSelector. }

type

THelpSelector = class (TInterfacedObject, IHelpSelector)

public

function SelectKeyword(Keywords: TStrings) : Integer;

function TableOfContents(Contents: TStrings): Integer;

end;

var

HelpSelector : IHelpSelector;

const hhPathRegKey = 'CLSID\{adb880a6-d8ff-11cf-9377-00aa003b7a11}\InprocServer32';

function GetPathToHHCtrlOCX: string;

var

Reg: TRegistry;

begin

result := ''; //default return

Reg := TRegistry.Create;

Reg.RootKey := HKEY_CLASSES_ROOT;

if reg.OpenKeyReadOnly(hhPathRegKey) then //safer call under NT

begin

result := Reg.ReadString(''); //default value

Reg.CloseKey;

if (result <> '') and (not FileExists(result)) then //final check - file must exist

result := '';

end;

Reg.Free;

end;

procedure LoadHtmlHelp;

var

OcxPath: string;

begin

if HHCtrlHandle = 0 then

begin

OcxPath := GetPathToHHCtrlOCX;

if (OcxPath <> '') and FileExists(OcxPath) then

begin

HHCtrlHandle := LoadLibrary(PChar(OcxPath));

if HHCtrlHandle <> 0 then

begin

@HtmlHelpA := GetProcAddress(HHCtrlHandle, 'HtmlHelpA');

@HtmlHelpW := GetProcAddress(HHCtrlHandle, 'HtmlHelpW');

@HtmlHelp := GetProcAddress(HHCtrlHandle, 'HtmlHelpA');

end;

if HHCtrlHandle = 0 then

begin

ShowMessage('HTML Help não está instalado neste PC');

Halt;

end;

procedure UnloadHtmlHelp;

begin

if HHCtrlHandle <> 0 then

begin

FreeLibrary(HHCtrlHandle);

HHCtrlHandle := 0;

end;

{Note: Never called - Since we are the only Keyword player in town}

function THelpSelector.SelectKeyword(Keywords: TStrings) : Integer;

begin

Result := 0; //return index of first item in supplied keyword list

end;

{Returning our name poistion in the provided list will ensure that we are used to display the TOC}

function THelpSelector.TableOfContents(Contents: TStrings): Integer;

var I: Integer;

begin

Result := 0;

for I := 0 to Contents.count-1 do

if Contents[I] = ViewerName then //Found ourselves in the list

Result := I;

end;

{----------------------------------------------------------------------------}

{ TWinHelpTester }

{----------------------------------------------------------------------------}

{ Look though the standard viewer code, WinHelpViewer.pas which this

module is based on. Typically viewer 1 is first cab off the rank and

wants to handle the help call. Except... there is this global thing

"WinHelpTester" which if implemented can override the decisions made

in Viewer 1. That's what this section is. We implement WinHelpTester

and can manipulate the decisions made by Viewer 1. Viewer 2 now gets

a chance to handle all help calls.

}

type

TWinHelpTester = class (TInterfacedObject, IWinHelpTester)

public

function CanShowALink(const ALink, FileName: string): Boolean;

function CanShowTopic(const Topic, FileName: string): Boolean;

function CanShowContext(const Context: Integer; const FileName: string): Boolean;

function GetHelpStrings(const ALink: string): TStringList;

function GetHelpPath: string;

function GetDefaultHelpFile: string;

end;

function TWinHelpTester.CanShowALink(const ALink, FileName: string): Boolean;

begin

Result := FALSE;

end;

function TWinHelpTester.CanShowTopic(const Topic, FileName: string):

Boolean;

begin

Result := False;

end;

function TWinHelpTester.CanShowContext(const Context: Integer; const FileName: string): Boolean;

begin

Result := False;

end;

function TWinHelpTester.GetHelpStrings(const ALink: string): TStringList;

begin

Result := TStringList.Create;

end;

{Used by HelpeViewer 1 for Linux - ignored for now}

function TWinHelpTester.GetHelpPath: string;

begin

Result := '';

end;

{This will do for now - Not too important if using OnHelp}

function TWinHelpTester.GetDefaultHelpFile: string;

begin

Result := '';

if Assigned(HelpViewer) then

Result := HelpViewer.HelpFile('');

end;

{----------------------------------------------------------------------------}

{ THTMLHelpViewer }

{----------------------------------------------------------------------------}

constructor THTMLHelpViewer.Create;

begin

inherited Create;

end;

destructor THTMLHelpViewer.Destroy;

begin

inherited Destroy;

end;

function THTMLHelpViewer.HelpFile(const Name: String): String;

var

FileName : String;

begin

if (Name = '') and Assigned(FHelpManager) then

FileName := HelpManager.GetHelpFile

else

FileName := Name;

Result := FileName;

end;

{ InternalShut Down is called from unit finalization if the unit is exiting

and the Help Manager needs to be informed. }

procedure THTMLHelpViewer.InternalShutDown;

begin

SoftShutDown;

if Assigned(FHelpManager) then

begin

HelpManager.Release(ViewerID);

if Assigned(FHelpManager) then HelpManager := nil;

end;

{ Send the HELP_SETPOPUP_POS command

just before a Context help call. }

procedure THTMLHelpViewer.HelpCommand_HELP_SETPOPUP_POS;

var

Control: TWinControl;

Pt: TSmallPoint;

function ControlHasHelp(const Control: TWinControl) : Boolean;

begin

Result := false;

if (Control.HelpType = htContext) and (Control.HelpContext <> 0)

then Result := true

else if (Control.HelpType = htKeyword) and (Control.HelpKeyword <> '') then

Result := true;

end;

begin

{This is not the best - since F1 press could have come from a memu -- no way of telling}

Control := Screen.ActiveControl;

while (Control <> nil) and ( not ControlHasHelp(Control)) do

Control := Control.Parent;

if Control <> nil then begin

Pt := PointToSmallPoint(Control.ClientToScreen(Point(0, 0)));

Application.HelpCommand(HELP_SETPOPUP_POS, Longint(Pt));

end;

{----------------------------------------------------------------------------}

{ THTMLHelpViewer - ICustomHelpViewer }

{----------------------------------------------------------------------------}

function THTMLHelpViewer.GetViewerName : String;

begin

Result := ViewerName;

end;

{ UnderstandsKeyword is a querying function that the Help Manager calls to

determine if the Viewer provide helps on a particular keyword string. }

function THTMLHelpViewer.UnderstandsKeyword(const HelpString: String): Integer;

begin

Result := 1;

end;

{ GetHelpStrings is used by the Help Manager to display a list of keyword

matches from which an application's user can select one. It assumes

that the String List is properly allocated, so this function should

never return nil. }

function THTMLHelpViewer.GetHelpStrings(const HelpString: String): TStringList;

begin

Result := TStringList.Create;

Result.Add(GetViewerName + ': ' + HelpString);

end;

{ CanShowTableOfContents is a querying function that the Help Manager

calls to determine if the Viewer supports tables of contents. WinHelp

and HyperHelp both do. }

function THTMLHelpViewer.CanShowTableOfContents : Boolean;

begin

Result := true;

end;

{ ShowTableOfContents is a command function that the Help Manager uses

to direct the Viewer to display a table of contents. It is never

called without being preceded by a call to CanShowTableOfContents. }

procedure THTMLHelpViewer.ShowTableOfContents;

begin

{ The Fix!! - data ignored we set to zero}

Application.HelpCommand(HELP_CONTENTS, 0);

end;

{ ShowHelp is the function that the Help Manager calls to request that

a Help Viewer display help for a given keyword. }

procedure THTMLHelpViewer.ShowHelp(const HelpString: String);

var

HelpCommand: array[0..255] of Char;

begin

StrLFmt(HelpCommand, SizeOf(HelpCommand) -1, '%s', [HelpString]);

{ The Fix!! }

Self.HelpCommand_HELP_SETPOPUP_POS;

Application.HelpCommand(HELP_KEY, Longint(@HelpCommand));

end;

{ NotifyID is called by the Help Manager after a successful registration

to provide the Help Viewer with a cookie which uniquely identifies the

Viewer to the Manager, and can be used in communications between the two. }

procedure THTMLHelpViewer.NotifyID(const ViewerID: Integer);

begin

FViewerID := ViewerID;

end;

{ SoftShutDown is called by the help manager to ask the viewer to

terminate any externally spawned subsystem without shutting itself down. }

procedure THTMLHelpViewer.SoftShutDown;

begin

{ The Fix!! }

{rob: Commented this out - caused an error on a user in Win98}

//Application.HelpCommand(HELP_QUIT, 0);

end;

procedure THTMLHelpViewer.ShutDown;

begin

SoftShutDown;

if Assigned(FHelpManager) then HelpManager := nil;

end;

{----------------------------------------------------------------------------}

{ THTMLHelpViewer --- IExtendedHelpViewer }

{----------------------------------------------------------------------------}

{ UnderstandsTopic is called by the Help Manager to ask if the Viewer

is capable of displaying a topic-based help query for a given topic. }

function THTMLHelpViewer.UnderstandsTopic(const Topic: String): Boolean;

begin

Result := true;

end;

{ DisplayTopic is called by the Help Manager if a Help Viewer claims

in its response to UnderstandsTopic to be able to provide Topic-based

help for a particular keyword. }

procedure THTMLHelpViewer.DisplayTopic(const Topic: String);

var

HelpCommand: array[0..255] of Char;

begin

StrLFmt(HelpCommand, SizeOf(HelpCommand) -1, '%s', [Topic + 'zzz']);

{ The Fix!! }

Self.HelpCommand_HELP_SETPOPUP_POS;

Application.HelpCommand(HELP_KEY, Longint(@HelpCommand));

end;

{ UnderstandsContext is a querying function called by the Help Manager

to determine if an Extended Help Viewer is capable of providing

help for a particular context-ID. }

function THTMLHelpViewer.UnderstandsContext(const ContextID: Integer;

const HelpFileName: String): Boolean;

begin

Result := true;

end;

{ DisplayHelpByContext is used by the Help Manager to request that a

Help Viewer display help for a particular Context-ID. }

procedure THTMLHelpViewer.DisplayHelpByContext(const ContextID: Integer; const HelpFileName: String);

var SaveWinHelpTester: IWinHelpTester;

begin

{ The Fix!! }

Self.HelpCommand_HELP_SETPOPUP_POS;

{ 9-Jan-2003: Stop recursion by saving state}

SaveWinHelpTester := WinHelpViewer.WinHelpTester;

WinHelpViewer.WinHelpTester := nil;

Application.HelpCommand(HELP_CONTEXT, ContextID);

WinHelpViewer.WinHelpTester := SaveWinHelpTester;

end;

{ Uses this function to enable or disable WinHelpViewer.WinHelpTester.

WinHelpTester is enabled when you use this module (viewer 2). It

is used to stop Viewer 1 being favoured by the HelpManager.

If you need to call a WinHelp function (viewer 1 needed) then

you would need to disable winhelptester for that call.

See Delphi source WinHelpViewer.pas for where WinHelpTester is used.

Note: WinHelpTester is set to Nil by WinHelpViewer cleanup

}

procedure WinHelpTester_Enable(aEnable: Boolean);

begin

{Enable WinHelpTester - ie. Make HelpManager use this viewer}

if aEnable then begin

if not Assigned(WinHelpViewer.WinHelpTester) then

WinHelpViewer.WinHelpTester := TWinHelpTester.Create;

end

{Disable WinHelpTester - ie. Make HelpManager use WinHelpViewer again}

else begin

if Assigned(WinHelpViewer.WinHelpTester) then

WinHelpViewer.WinHelpTester := Nil;

end;

function AbrirHelpContext(const IDContext: Cardinal): Boolean;

begin

HtmlHelpA(Screen.ActiveForm.Handle, PChar(HelpCHM_Arquivo), $F, IDContext);

Result := True;

end;

initialization

WinHelpTester_Enable(true);

HelpSelector := THelpSelector.Create; //set to Nil by HelpIntfs cleanup

HelpViewer := THTMLHelpViewer.Create;

Application.HelpSystem.AssignHelpSelector(HelpSelector);

HelpIntfs.RegisterViewer(HelpViewer {ICustomHelpViewer}, HelpViewer.FHelpManager {IHelpManager});

LoadHtmlHelp;

finalization

UnloadHtmlHelp;

HelpSelector._Release; //RWC_RELEASE

if Assigned(HelpViewer.FHelpManager) then

HelpViewer.InternalShutDown;

end.