paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-04-05 14:57:57 +02:00
Code Issues Packages Projects Releases Wiki Activity

added package components/turbopower_ipro/design/turbopoweriprodsgn.lpk

Browse Source 
git-svn-id: trunk@13530 -
This commit is contained in:
mattias 2007-12-29 20:58:16 +00:00
parent 26aebf8d14
commit 5987e7d9cb
5 changed files with 235 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
.gitattributes vendored
View File

@ -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

164
components/turbopower_ipro/design/ipidehtmlcontrol.pas Normal file
View File

@ -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.

45
components/turbopower_ipro/design/turbopoweriprodsgn.lpk Normal file
View File

@ -0,0 +1,45 @@
<?xml version="1.0"?>
<CONFIG>
<Package Version="3">
<Name Value="TurboPowerIProDsgn"/>
<CompilerOptions>
<Version Value="5"/>
<SearchPaths>
<UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)/"/>
</SearchPaths>
<CodeGeneration>
<Generate Value="Faster"/>
</CodeGeneration>
<Other>
<CompilerPath Value="$(CompPath)"/>
</Other>
</CompilerOptions>
<Files Count="1">
<Item1>
<Filename Value="ipidehtmlcontrol.pas"/>
<HasRegisterProc Value="True"/>
<UnitName Value="IPIDEHTMLControl"/>
</Item1>
</Files>
<Type Value="RunAndDesignTime"/>
<RequiredPkgs Count="3">
<Item1>
<PackageName Value="TurboPowerIPro"/>
</Item1>
<Item2>
<PackageName Value="IDEIntf"/>
</Item2>
<Item3>
<PackageName Value="FCL"/>
<MinVersion Major="1" Valid="True"/>
</Item3>
</RequiredPkgs>
<UsageOptions>
<UnitPath Value="$(PkgOutDir)"/>
</UsageOptions>
<PublishOptions>
<Version Value="2"/>
<IgnoreBinaries Value="False"/>
</PublishOptions>
</Package>
</CONFIG>

21
components/turbopower_ipro/design/turbopoweriprodsgn.pas Normal file
View File

@ -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.

1
packager/globallinks/turbopoweriprodsgn-0.lpl Normal file
View File

@ -0,0 +1 @@
$(LazarusDir)/components/turbopower_ipro/design/turbopoweriprodsgn.lpk