paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-09-08 13:19:07 +02:00
Code Issues Packages Projects Releases Wiki Activity

chmhelp: added menu item to open all chm files, patch #23411

Browse Source 
git-svn-id: trunk@40589 -
This commit is contained in:
mattias 2013-03-19 09:05:51 +00:00
parent aa66a6499f
commit f3776676a3
5 changed files with 188 additions and 67 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitattributes vendored
View File

@ -614,6 +614,7 @@ components/chmhelp/packages/idehelp/chmlangref.pas svneol=native#text/plain
components/chmhelp/packages/idehelp/chmlcl.pas svneol=native#text/plain
components/chmhelp/packages/idehelp/chmprog.pas svneol=native#text/plain
components/chmhelp/packages/idehelp/lazchmhelp.pas svneol=native#text/plain
components/chmhelp/packages/idehelp/lazchmhelpregister.pas svneol=native#text/plain
components/codetools/Makefile.compiled svneol=native#text/plain
components/codetools/basiccodetools.pas svneol=native#text/pascal
components/codetools/cachecodetools.pas svneol=native#text/plain

10
components/chmhelp/packages/idehelp/chmhelppkg.lpk
View File

@ -23,7 +23,7 @@
<Description Value="IDE package to use chm help files in the IDE via the lhelp viewer."/>
<License Value="GPL 2"/>
<Version Minor="2"/>
<Files Count="4">
<Files Count="5">
<Item1>
<Filename Value="lazchmhelp.pas"/>
<HasRegisterProc Value="True"/>
@ -41,6 +41,11 @@
<Filename Value="chmprog.pas"/>
<UnitName Value="ChmProg"/>
</Item4>
<Item5>
<Filename Value="lazchmhelpregister.pas"/>
<HasRegisterProc Value="True"/>
<UnitName Value="LazCHMHelpRegister"/>
</Item5>
</Files>
<Type Value="DesignTime"/>
<RequiredPkgs Count="4">
@ -65,5 +70,8 @@
<Version Value="2"/>
<IgnoreBinaries Value="False"/>
</PublishOptions>
<CustomOptions Items="ExternHelp" Version="2">
<_ExternHelp Items="Count"/>
</CustomOptions>
</Package>
</CONFIG>

14
components/chmhelp/packages/idehelp/chmhelppkg.pas
View File

@ -2,20 +2,22 @@
This source is only used to compile and install the package.
}
unit ChmHelpPkg;
unit ChmHelpPkg;
interface
uses
LazChmHelp, ChmLangRef, ChmLcl, ChmProg, LazarusPackageIntf;
LazChmHelp, ChmLangRef, ChmLcl, ChmProg, LazCHMHelpRegister,
LazarusPackageIntf;
implementation
procedure Register;
procedure Register;
begin
RegisterUnit('LazChmHelp', @LazChmHelp.Register);
end;
RegisterUnit('LazChmHelp', @LazChmHelp.Register);
RegisterUnit('LazCHMHelpRegister', @LazCHMHelpRegister.Register);
end;
initialization
RegisterPackage('ChmHelpPkg', @Register);
RegisterPackage('ChmHelpPkg', @Register);
end.

144
components/chmhelp/packages/idehelp/lazchmhelp.pas
View File

@ -40,6 +40,8 @@ type
function DBFindViewer({%H-}HelpDB: THelpDatabase; {%H-}const MimeType: string;
var {%H-}ErrMsg: string; out Viewer: THelpViewer): TShowHelpResult;
function GetHelpLabel: String;
// Shows all chm files in the given search path. Requires help viewer to be running already
procedure OpenAllCHMsInSearchPath(const SearchPath: String);
procedure SetChmsFilePath(const AValue: String);
procedure SetHelpEXE(AValue: String);
protected
@ -54,6 +56,9 @@ type
function SupportsTableOfContents: boolean; override;
procedure ShowTableOfContents({%H-}Node: THelpNode); override;
function SupportsMimeType(const AMimeType: string): boolean; override;
// Shows all chm help files. Opens lhelp if necessary. Used by menu commands.
procedure ShowAllHelp(Sender: TObject);
// Shows help for the indicated node or an error message if it cannot. Opens lhelp if necessary
function ShowNode(Node: THelpNode; var ErrMsg: string): TShowHelpResult; override;
//procedure Hide; virtual;
procedure Assign(Source: TPersistent); override;
@ -68,13 +73,27 @@ type
property HelpFilesPath: String read fCHMSearchPath write SetChmsFilePath; // directories separated with semicolon, with macros, see GetHelpFilesPath
property HelpExeParams: String read fHelpExeParams write fHelpExeParams;
end;
procedure Register;
implementation
uses Process, MacroIntf, InterfaceBase, Forms, Dialogs, HelpFPDoc, IDEMsgIntf;
procedure Register;
var
ChmHelp: TChmHelpViewer;
begin
ChmHelp := TChmHelpViewer.Create(nil);
HelpViewers.RegisterViewer(ChmHelp);
RegisterLangRefHelpDatabase;
LangRefHelpDatabase.OnFindViewer := @ChmHelp.DBFindViewer;
RegisterLclHelpDatabase;
LCLHelpDatabase.OnFindViewer := @ChmHelp.DBFindViewer;
RegisterFPCDirectivesHelpDatabase;
FPCDirectivesHelpDatabase.OnFindViewer := @ChmHelp.DBFindViewer;
end;
{ TChmHelpViewer }
@ -93,6 +112,57 @@ begin
Result := fHelpLabel;
end;
procedure TChmHelpViewer.OpenAllCHMsInSearchPath(const SearchPath: String);
var
SearchPathList: TStringlist; //SearchPath as a stringlist
CHMFiles: TStringList;
i: integer;
DirCounter: integer;
begin
{ Alternative:
Open registered chm help files (no online html help etc)
Using SupportsMimetype would seem to be the solution here.
This does mean that all classes providing chm file support add
AddSupportedMimeType('application/x-chm');
in their constructors as they normally inherit
text/html from their HTML help parents.
Also, this will not work for other .chm files in the relevant directories.
this still does not open all help files such as rtl.chm
for i := 0 to HelpDatabases.Count-1 do begin
if HelpDatabases[i].SupportsMimeType('application/x-chm') then begin
HelpDatabases[i].ShowTableOfContents;
Sleep(200); //give viewer chance to open file. todo: better way of doing this?
Application.ProcessMessages;
end;
end;
}
// Just open all CHM files in all directories+subdirs in ;-delimited searchpath:
SearchPathList:=TStringList.Create;
CHMFiles:=TStringList.Create;
try
CHMFiles.Sorted:=true;
CHMFiles.Duplicates:=dupIgnore;
SearchPathList.Delimiter:=';';
SearchPathList.StrictDelimiter:=false;
SearchPathList.DelimitedText:=SearchPath;
for DirCounter := 0 to SearchPathList.Count-1 do begin
// Note: FindAllFiles has a SearchPath parameter that is a *single* directory,
CHMFiles.AddStrings(FindAllFiles(SearchPathList[DirCounter], '', true));
end;
for i := 0 to CHMFiles.Count-1 do begin
if UpperCase(ExtractFileExt(CHMFiles[i]))='.CHM' then begin
fHelpConnection.OpenURL(CHMFiles[i], '/index.html');
Sleep(200); //give viewer chance to open file. todo: better way of doing this?
Application.ProcessMessages;
end;
end;
finally
CHMFiles.Free;
SearchPathList.Free;
end;
end;
procedure TChmHelpViewer.SetChmsFilePath(const AValue: String);
var
p: String;
@ -338,17 +408,25 @@ begin
Result := inherited;
end;
procedure TChmHelpViewer.ShowAllHelp(Sender: TObject);
var
SearchPath: String; //; delimited list of directories
begin
SearchPath := GetHelpFilesPath;
// Start up server if needed
if not(fHelpConnection.ServerRunning) then
fHelpConnection.StartHelpServer(HelpLabel, GetHelpExe);
// Open all chm files after it has started
OpenAllCHMsInSearchPath(SearchPath);
end;
function TChmHelpViewer.ShowNode(Node: THelpNode; var ErrMsg: string
): TShowHelpResult;
var
DirCounter: integer;
i: integer;
FileName: String;
CHMFiles: TStringList;
Url: String;
Res: TLHelpResponse;
SearchPath: String; //; delimited list of directories
SearchPathList: tstringlist; //SearchPath as a stringlist
Proc: TProcessUTF8;
FoundFileName: String;
LHelpPath: String;
@ -393,47 +471,7 @@ begin
// If the server is not already running, open all chm files after it has started
// This will allow cross-chm (LCL, FCL etc) searching and browsing in lhelp.
if not(WasRunning) then begin
// Open registered chm help files (no online html help etc)
// Using SupportsMimetype would seem to be the solution here.
// This does mean that all classes providing chm file support add
// AddSupportedMimeType('application/x-chm');
// in their constructors as they normally inherit
// text/html from their HTML help parents.
// Also, this will not work for other .chm files in the relevant directories.
// this still does not open all help files such as rtl.chm
{
for i := 0 to HelpDatabases.Count-1 do begin
if HelpDatabases[i].SupportsMimeType('application/x-chm') then begin
HelpDatabases[i].ShowTableOfContents;
Sleep(200); //give viewer chance to open file. todo: better way of doing this?
Application.ProcessMessages;
end;
end;
}
// Just open all CHM files in all directories+subdirs in ;-delimited searchpath:
SearchPathList:=TStringList.Create;
CHMFiles:=TStringList.Create;
try
CHMFiles.Sorted:=true;
CHMFiles.Duplicates:=dupIgnore;
SearchPathList.Delimiter:=';';
SearchPathList.StrictDelimiter:=false;
SearchPathList.DelimitedText:=SearchPath;
for DirCounter := 0 to SearchPathList.Count-1 do begin
// Note: FindAllFiles has a SearchPath parameter that is a *single* directory,
CHMFiles.AddStrings(FindAllFiles(SearchPathList[DirCounter],'',true));
end;
for i := 0 to CHMFiles.Count-1 do begin
if UpperCase(ExtractFileExt(CHMFiles[i]))='.CHM' then begin
fHelpConnection.OpenURL(CHMFiles[i], '/index.html');
Sleep(200); //give viewer chance to open file. todo: better way of doing this?
Application.ProcessMessages;
end;
end;
finally
CHMFiles.Free;
SearchPathList.Free;
end;
OpenAllCHMsInSearchPath(SearchPath);
end;
Res := fHelpConnection.OpenURL(FileName, Url);
end else begin
@ -525,20 +563,6 @@ begin
Result := 'CHM Help Viewer';
end;
procedure Register;
var
ChmHelp: TChmHelpViewer;
begin
ChmHelp := TChmHelpViewer.Create(nil);
HelpViewers.RegisterViewer(ChmHelp);
RegisterLangRefHelpDatabase;
LangRefHelpDatabase.OnFindViewer := @ChmHelp.DBFindViewer;
RegisterLclHelpDatabase;
LCLHelpDatabase.OnFindViewer := @ChmHelp.DBFindViewer;
RegisterFPCDirectivesHelpDatabase;
FPCDirectivesHelpDatabase.OnFindViewer := @ChmHelp.DBFindViewer;
end;
initialization
RegisterPropertyEditor(TypeInfo(AnsiString),
TChmHelpViewer,'HelpEXE',TFileNamePropertyEditor);

86
components/chmhelp/packages/idehelp/lazchmhelpregister.pas Normal file
View File

@ -0,0 +1,86 @@
unit LazCHMHelpRegister;
{$mode objfpc}{$H+}
{ Registers Lazarus CHM Help menu shortcuts into the IDE }
{ This source is free software; you can redistribute it and/or modify it under
the terms of the GNU General Public License as published by the Free
Software Foundation; either version 2 of the License, or (at your option)
any later version.
This code is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
details.
A copy of the GNU General Public License is available on the World Wide Web
at <http://www.gnu.org/copyleft/gpl.html>. You can also obtain it by writing
to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,
MA 02111-1307, USA.
}
interface
uses
{ rtl }
SysUtils, Classes,
{ lcl }
LCLType, FileUtil, LResources,
PropEdits, Controls;
procedure Register;
implementation
uses
{ lazarus }
LazIDEIntf, MenuIntf, IdeCommands,
{ local }
LazCHMHelp, InterfaceBase, IDEMsgIntf;
const
//HELP_MENU_NAME = 'chpOfflineHelp';
HELP_CURRENT_NAME = 'chpHelp';
HELP_CATEGORY_IDECMD_NAME = 'chpFormat';
resourcestring
//HELP_MENU = '&Help';
HELP_CURRENT_MENU = '&Help';
HELP_CURRENT_IDECMD = 'Show help';
HELP_CATEGORY_IDECMD = 'CHM Help';
var
IDECHMHelp: TChmHelpViewer;
procedure Register;
var
Cat: TIDECommandCategory;
{
Key: TIDEShortCut;
}
CmdHelpCommand: TIDECommand;
begin
// We can't put this in an initialization section because IDEChmHelp requires
// some IDE features, which are only available in "Register".
IDECHMHelp := TChmHelpViewer.Create(nil);
Cat := IDECommandList.CreateCategory(nil, HELP_CATEGORY_IDECMD_NAME,
HELP_CATEGORY_IDECMD, IDECmdScopeSrcEditOnly);
{
// Assign F1 key
Key := IDEShortCut(VK_F1, [], VK_UNKNOWN, []);
CmdHelpCommand := RegisterIDECommand(Cat, HELP_CURRENT_NAME, HELP_CURRENT_IDECMD, Key,
@IDECHMHelp.ShowAllHelp);
}
CmdHelpCommand := RegisterIDECommand(Cat, HELP_CURRENT_NAME, HELP_CURRENT_IDECMD,
@IDECHMHelp.ShowAllHelp);
RegisterIDEMenuCommand(mnuHelp, HELP_CURRENT_NAME, HELP_CURRENT_MENU,
@IDECHMHelp.ShowAllHelp, nil, CmdHelpCommand);
end;
finalization
FreeAndNil(IDECHMHelp);
end.