diff --git a/.gitattributes b/.gitattributes index 0c43574901..b7ac614e2b 100644 --- a/.gitattributes +++ b/.gitattributes @@ -1056,6 +1056,9 @@ components/tdbf/registerdbf.pas svneol=native#text/pascal components/tdbf/tdbf.png -text svneol=unset#image/png components/turbopower_ipro/Makefile svneol=native#text/plain components/turbopower_ipro/Makefile.fpc svneol=native#text/plain +components/turbopower_ipro/design/ipidehtmlcontrol.pas svneol=native#text/plain +components/turbopower_ipro/design/turbopoweriprodsgn.lpk svneol=native#text/plain +components/turbopower_ipro/design/turbopoweriprodsgn.pas svneol=native#text/plain components/turbopower_ipro/examples/htmfileexp1.lfm svneol=native#text/plain components/turbopower_ipro/examples/htmfileexp1.lrs svneol=native#text/plain components/turbopower_ipro/examples/htmfileexp1.pas svneol=native#text/plain @@ -3363,6 +3366,7 @@ packager/globallinks/simpleideintf-0.lpl svneol=native#text/plain packager/globallinks/tachartlazaruspkg-0.lpl svneol=native#text/plain packager/globallinks/trayiconlaz-0.lpl svneol=native#text/plain packager/globallinks/turbopoweripro-1.lpl svneol=native#text/plain +packager/globallinks/turbopoweriprodsgn-0.lpl svneol=native#text/plain packager/installpkgsetdlg.lfm svneol=native#text/plain packager/installpkgsetdlg.lrs svneol=native#text/pascal packager/installpkgsetdlg.pas svneol=native#text/pascal diff --git a/components/turbopower_ipro/design/ipidehtmlcontrol.pas b/components/turbopower_ipro/design/ipidehtmlcontrol.pas new file mode 100644 index 0000000000..1691ded92b --- /dev/null +++ b/components/turbopower_ipro/design/ipidehtmlcontrol.pas @@ -0,0 +1,164 @@ +{ + ***************************************************************************** + * * + * See the file COPYING.modifiedLGPL, included in this distribution, * + * for details about the copyright. * + * * + * This program 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. * + * * + ***************************************************************************** + + Author: Mattias Gaertner + + Abstract: + Installs a HTML control in the IDE using TIpHtmlPanel. +} +unit IPIDEHTMLControl; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, LCLProc, Graphics, Controls, Dialogs, + IpHtml, IDEHelpIntf, LazHelpIntf; + +type + TSimpleIpHtml = class(TIpHtml) + public + property OnGetImageX; + end; + + { TIPLazHtmlControl } + + TIPLazHtmlControl = class(TIpHtmlPanel,TIDEHTMLControlIntf) + private + FProvider: TAbstractIDEHTMLProvider; + FURL: string; + procedure SetProvider(const AValue: TAbstractIDEHTMLProvider); + procedure HTMLGetImageX(Sender: TIpHtmlNode; const URL: string; + var Picture: TPicture); + public + function GetURL: string; + procedure SetURL(const AValue: string); + property Provider: TAbstractIDEHTMLProvider read FProvider write SetProvider; + end; + +function IPCreateLazIDEHTMLControl(Owner: TComponent; + var Provider: TAbstractIDEHTMLProvider): TControl; + +procedure Register; + +implementation + +procedure Register; +begin + CreateIDEHTMLControl:=@IPCreateLazIDEHTMLControl; +end; + +function IPCreateLazIDEHTMLControl(Owner: TComponent; + var Provider: TAbstractIDEHTMLProvider): TControl; +var + HTMLControl: TIPLazHtmlControl; +begin + HTMLControl:=TIPLazHtmlControl.Create(Owner); + Result:=HTMLControl; + if Provider=nil then + Provider:=CreateIDEHTMLProvider(Owner); + Provider.ControlIntf:=HTMLControl; + HTMLControl.Provider:=Provider; +end; + +{ TIPLazHtmlControl } + +procedure TIPLazHtmlControl.SetProvider(const AValue: TAbstractIDEHTMLProvider + ); +begin + if FProvider=AValue then exit; + FProvider:=AValue; +end; + +procedure TIPLazHtmlControl.HTMLGetImageX(Sender: TIpHtmlNode; + const URL: string; var Picture: TPicture); +var + URLType: string; + URLPath: string; + URLParams: string; + Filename: String; + Ext: String; + Stream: TStream; + NewURL: String; +begin + //DebugLn(['TIPLazHtmlControl.HTMLGetImageX URL=',URL]); + if Provider=nil then exit; + NewURL:=Provider.BuildURL(Provider.BaseURL,URL); + //DebugLn(['TIPLazHtmlControl.HTMLGetImageX NewURL=',NewURL,' Provider.BaseURL=',Provider.BaseURL,' URL=',URL]); + + Picture:=nil; + Stream:=nil; + try + try + SplitURL(NewURL,URLType,URLPath,URLParams); + if URLPath='' then + URLPath:=NewURL; + Filename:=URLPathToFilename(URLPath); + Ext:=ExtractFileExt(Filename); + //DebugLn(['TIPLazHtmlControl.HTMLGetImageX URLPath=',URLPath,' Filename=',Filename,' Ext=',Ext]); + Picture:=TPicture.Create; + // quick check if file format is supported + Picture.FindGraphicClassWithFileExt(Ext); + // get stream + Stream:=Provider.GetStream(NewURL); + // load picture + Picture.LoadFromStreamWithFileExt(Stream,Ext); + finally + if Stream<>nil then + Provider.ReleaseStream(NewURL); + end; + except + on E: Exception do begin + FreeAndNil(Picture); + DebugLn(['TIPLazHtmlControl.HTMLGetImageX ERROR: ',E.Message]); + end; + end; +end; + +function TIPLazHtmlControl.GetURL: string; +begin + Result:=FURL; +end; + +procedure TIPLazHtmlControl.SetURL(const AValue: string); +var + Stream: TStream; + NewHTML: TSimpleIpHtml; + NewURL: String; +begin + if Provider=nil then raise Exception.Create('TIPLazHtmlControl.SetURL missing Provider'); + if FURL=AValue then exit; + NewURL:=Provider.BuildURL(Provider.BaseURL,AValue); + if FURL=NewURL then exit; + FURL:=NewURL; + try + Stream:=Provider.GetStream(FURL); + try + NewHTML:=TSimpleIpHtml.Create; // Beware: Will be freed automatically + NewHTML.OnGetImageX:=@HTMLGetImageX; + NewHTML.LoadFromStream(Stream); + finally + Provider.ReleaseStream(FURL); + end; + SetHtml(NewHTML); + except + on E: Exception do begin + MessageDlg('Unable to open HTML file', + 'HTML File: '+FURL+#13 + +'Error: '+E.Message,mtError,[mbCancel],0); + end; + end; +end; + +end. + diff --git a/components/turbopower_ipro/design/turbopoweriprodsgn.lpk b/components/turbopower_ipro/design/turbopoweriprodsgn.lpk new file mode 100644 index 0000000000..481854940c --- /dev/null +++ b/components/turbopower_ipro/design/turbopoweriprodsgn.lpk @@ -0,0 +1,45 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/components/turbopower_ipro/design/turbopoweriprodsgn.pas b/components/turbopower_ipro/design/turbopoweriprodsgn.pas new file mode 100644 index 0000000000..534d8831d9 --- /dev/null +++ b/components/turbopower_ipro/design/turbopoweriprodsgn.pas @@ -0,0 +1,21 @@ +{ This file was automatically created by Lazarus. Do not edit! +This source is only used to compile and install the package. + } + +unit TurboPowerIProDsgn; + +interface + +uses + IPIDEHTMLControl, LazarusPackageIntf; + +implementation + +procedure Register; +begin + RegisterUnit('IPIDEHTMLControl', @IPIDEHTMLControl.Register); +end; + +initialization + RegisterPackage('TurboPowerIProDsgn', @Register); +end. diff --git a/packager/globallinks/turbopoweriprodsgn-0.lpl b/packager/globallinks/turbopoweriprodsgn-0.lpl new file mode 100644 index 0000000000..1ea2dcebfd --- /dev/null +++ b/packager/globallinks/turbopoweriprodsgn-0.lpl @@ -0,0 +1 @@ +$(LazarusDir)/components/turbopower_ipro/design/turbopoweriprodsgn.lpk