jvcllaz: Add TJvMarkupViewer and TJvMarkupLabel. Add designtime package for JvCmp (JvSpellChecker).

git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@6254 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
wp_xxyyzz
2018-03-18 17:49:53 +00:00
parent 45b89294c8
commit 2c7564c314
18 changed files with 1609 additions and 14 deletions

View File

@ -0,0 +1,2 @@
tjvspellchecker.bmp
tjventerastab.bmp

View File

@ -0,0 +1 @@
lazres ../../../resource/jvcmpreg.res @images.txt

Binary file not shown.

After

Width:  |  Height:  |  Size: 1.6 KiB

View File

@ -0,0 +1,31 @@
unit JvCmpReg;
{$mode objfpc}{$H+}
interface
uses
SysUtils;
procedure Register;
implementation
{$R ../../resource/jvcmpreg.res}
uses
Classes, PropEdits,
JvDsgnConsts,
// JvEnterTab,
JvSpellChecker;
procedure Register;
begin
RegisterComponents(RsPaletteJvcl, [
// TJvEnterAsTab,
TJvSpellChecker
]);
end;
end.

View File

@ -9,8 +9,5 @@ tjvsimbutton.bmp
tjvsimreverse.bmp
tjvsimlight.bmp
tjvlogic.bmp
tjvcsvbase.bmp
tjvcsvcheckbox.bmp
tjvcsvcombobox.bmp
tjvcsvedit.bmp
tjvcsvnavigator.bmp
tjvmarkupviewer.bmp
tjvmarkuplabel.bmp

View File

@ -17,6 +17,7 @@ uses
Classes, JvDsgnConsts,
JvYearGrid,
//JvCSVData, JvCSVBaseControls, //JvCsvBaseEditor,
JvMarkupViewer, JvMarkupLabel,
JvSimScope, JvSimIndicator, JvSimPID, JvSimPIDLinker, JvSimLogic;
procedure Register;
@ -30,6 +31,12 @@ begin
TJvSimScope, TJvSimIndicator, TJvSimPID,
TJvSimPIDLinker, TJvSimConnector, TJvLogic, TJvSimButton, TJvSimLight,
TJvSimLogicBox, TJvSimReverse]);
// Markup components
RegisterComponents(RsPaletteJvcl, [
TJvMarkupViewer, TJvMarkupLabel
]);
(*
// CSV Components
RegisterComponents('Data Access', [TJvCSVDataset]);

View File

@ -1,7 +1,7 @@
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<ProjectGroup FileVersion="1">
<Targets Count="21">
<Targets Count="22">
<Target0 FileName="JvCoreLazR.lpk"/>
<Target1 FileName="JvCoreLazD.lpk"/>
<Target2 FileName="JvCtrlsLazR.lpk"/>
@ -21,8 +21,9 @@
<Target16 FileName="jvcustomlazr.lpk"/>
<Target17 FileName="jvcustomlazd.lpk"/>
<Target18 FileName="jvcmpr.lpk"/>
<Target19 FileName="jvjanslazr.lpk"/>
<Target20 FileName="jvjanslazd.lpk"/>
<Target19 FileName="jvcmpd.lpk"/>
<Target20 FileName="jvjanslazr.lpk"/>
<Target21 FileName="jvjanslazd.lpk"/>
</Targets>
</ProjectGroup>
</CONFIG>

View File

@ -0,0 +1,49 @@
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<Package Version="4">
<PathDelim Value="\"/>
<Name Value="jvcmpd"/>
<Type Value="RunAndDesignTime"/>
<Author Value="Various authors - see header of each unit for original author."/>
<CompilerOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<SearchPaths>
<OtherUnitFiles Value="..\design\JvCmp"/>
<UnitOutputDirectory Value="..\lib\$(TargetCPU)-$(TargetOS)\design\JvCmp"/>
</SearchPaths>
</CompilerOptions>
<Description Value="Custom controls of the JVCL library (https://sourceforge.net/projects/jvcl/) (runtime code):
- Spellchecker component
- EnterAsTab component"/>
<License Value="The JVCL is released in accordance with the MPL 1.1 license. To get your own copy or read it, go to http://www.mozilla.org/MPL/MPL-1.1.html. "/>
<Version Major="1" Release="4"/>
<Files Count="1">
<Item1>
<Filename Value="..\design\JvCmp\jvcmpreg.pas"/>
<HasRegisterProc Value="True"/>
<UnitName Value="JvCmpReg"/>
</Item1>
</Files>
<RequiredPkgs Count="4">
<Item1>
<PackageName Value="JvCoreLazD"/>
</Item1>
<Item2>
<PackageName Value="IDEIntf"/>
</Item2>
<Item3>
<PackageName Value="JvCmpR"/>
</Item3>
<Item4>
<PackageName Value="FCL"/>
</Item4>
</RequiredPkgs>
<UsageOptions>
<UnitPath Value="$(PkgOutDir)"/>
</UsageOptions>
<PublishOptions>
<Version Value="2"/>
</PublishOptions>
</Package>
</CONFIG>

View File

@ -9,7 +9,6 @@
<Version Value="11"/>
<PathDelim Value="\"/>
<SearchPaths>
<IncludeFiles Value="..\run\JvJans"/>
<OtherUnitFiles Value="..\design\JvJans"/>
<UnitOutputDirectory Value="..\lib\$(TargetCPU)-$(TargetOS)\design\JvJans"/>
</SearchPaths>

View File

@ -17,7 +17,7 @@
- Simulation components"/>
<License Value="The JVCL is released in accordance with the MPL 1.1 license. To get your own copy or read it, go to http://www.mozilla.org/MPL/MPL-1.1.html. "/>
<Version Major="1" Release="4"/>
<Files Count="7">
<Files Count="10">
<Item1>
<Filename Value="..\run\JvJans\JvYearGrid.pas"/>
<UnitName Value="JvYearGrid"/>
@ -46,6 +46,18 @@
<Filename Value="..\run\JvJans\JvSimScope.pas"/>
<UnitName Value="JvSimScope"/>
</Item7>
<Item8>
<Filename Value="..\run\JvJans\JvMarkupCommon.pas"/>
<UnitName Value="JvMarkupCommon"/>
</Item8>
<Item9>
<Filename Value="..\run\JvJans\JvMarkupViewer.pas"/>
<UnitName Value="JvMarkupViewer"/>
</Item9>
<Item10>
<Filename Value="..\run\JvJans\JvMarkupLabel.pas"/>
<UnitName Value="JvMarkupLabel"/>
</Item10>
</Files>
<RequiredPkgs Count="2">
<Item1>

Binary file not shown.

View File

@ -30,8 +30,6 @@ unit JvHint;
{$mode objfpc}{$H+}
//{.$I jvcl.inc}
interface
uses

View File

@ -11,7 +11,7 @@ the specific language governing rights and limitations under the License.
The Original Code is: JvDBSearchEdit.pas, released on 2004-02-28.
The Initial Developer of the Original Code is Lionel Reynaud
Portions created by Sbastien Buysse are Copyright (C) 2004 Lionel Reynaud.
Portions created by Sébastien Buysse are Copyright (C) 2004 Lionel Reynaud.
All Rights Reserved.
Contributor(s):

View File

@ -1,4 +1,4 @@
{-----------------------------------------------------------------------------
{-----------------------------------------------------------------------------
The contents of this file are subject to the Mozilla Public License
Version 1.1 (the "License"); you may not use this file except in compliance
with the License. You may obtain a copy of the License at

View File

@ -0,0 +1,236 @@
{-----------------------------------------------------------------------------
The contents of this file are subject to the Mozilla Public License
Version 1.1 (the "License"); you may not use this file except in compliance
with the License. You may obtain a copy of the License at
http://www.mozilla.org/MPL/MPL-1.1.html
Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for
the specific language governing rights and limitations under the License.
The Original Code is: JvMarkupCommon.PAS, released on 2002-06-15.
The Initial Developer of the Original Code is Jan Verhoeven [jan1 dott verhoeven att wxs dott nl]
Portions created by Jan Verhoeven are Copyright (C) 2002 Jan Verhoeven.
All Rights Reserved.
Contributor(s): Robert Love [rlove att slcdug dott org].
You may retrieve the latest version of this file at the Project JEDI's JVCL home page,
located at http://jvcl.delphi-jedi.org
Known Issues:
* Classes extracted from JvMarkupLabel and JvMarkupViewer (duplicates)
-----------------------------------------------------------------------------}
// $Id$
unit JvMarkupCommon;
{$mode objfpc}{$H+}
interface
uses
Controls, Graphics, SysUtils, Classes;
type
TJvHTMLElement = class(TObject)
private
FFontSize: Integer;
FText: string;
FFontName: string;
FFontStyle: TFontStyles;
FFontColor: TColor;
FAscent: Integer;
FHeight: Integer;
FWidth: Integer;
FSolText: string;
FEolText: string;
FBreakLine: Boolean;
procedure SetFontName(const Value: string);
procedure SetFontSize(const Value: Integer);
procedure SetFontStyle(const Value: TFontStyles);
procedure SetText(const Value: string);
procedure SetFontColor(const Value: TColor);
procedure SetAscent(const Value: Integer);
procedure SetHeight(const Value: Integer);
procedure SetWidth(const Value: Integer);
procedure SetEolText(const Value: string);
procedure SetSolText(const Value: string);
procedure SetBreakLine(const Value: Boolean);
public
procedure Breakup(ACanvas: TCanvas; Available: Integer);
property Text: string read FText write SetText;
property SolText: string read FSolText write SetSolText;
property EolText: string read FEolText write SetEolText;
property FontName: string read FFontName write SetFontName;
property FontSize: Integer read FFontSize write SetFontSize;
property FontStyle: TFontStyles read FFontStyle write SetFontStyle;
property FontColor: TColor read FFontColor write SetFontColor;
property Height: Integer read FHeight write SetHeight;
property Width: Integer read FWidth write SetWidth;
property Ascent: Integer read FAscent write SetAscent;
property BreakLine: Boolean read FBreakLine write SetBreakLine;
end;
TJvHTMLElementStack = class(TList)
public
destructor Destroy; override;
procedure Clear; override;
// will free ALL elements in the stack
procedure Push(Element: TJvHTMLElement);
function Pop: TJvHTMLElement;
// calling routine is responsible for freeing the element.
function Peek: TJvHTMLElement;
// calling routine must NOT free the element
end;
{$IFDEF UNITVERSIONING}
const
UnitVersioning: TUnitVersionInfo = (
RCSfile: '$URL$';
Revision: '$Revision$';
Date: '$Date$';
LogPath: 'JVCL\run'
);
{$ENDIF UNITVERSIONING}
implementation
//=== { TJvHTMLElement } =====================================================
procedure TJvHTMLElement.Breakup(ACanvas: TCanvas; Available: Integer);
var
S: string;
I, W: Integer;
begin
ACanvas.Font.Name := FontName;
ACanvas.Font.Size := FontSize;
ACanvas.Font.Style := FontStyle;
ACanvas.Font.Color := FontColor;
if SolText = '' then
S := Text
else
S := EolText;
if ACanvas.TextWidth(S) <= Available then
begin
SolText := S;
EolText := '';
Exit;
end;
for I := Length(S) downto 1 do
begin
if S[I] = ' ' then
begin
W := ACanvas.TextWidth(Copy(S, 1, I));
if W <= Available then
begin
SolText := Copy(S, 1, I);
EolText := Copy(S, I + 1, Length(S));
Break;
end;
end;
end;
end;
procedure TJvHTMLElement.SetAscent(const Value: Integer);
begin
FAscent := Value;
end;
procedure TJvHTMLElement.SetBreakLine(const Value: Boolean);
begin
FBreakLine := Value;
end;
procedure TJvHTMLElement.SetEolText(const Value: string);
begin
FEolText := Value;
end;
procedure TJvHTMLElement.SetFontColor(const Value: TColor);
begin
FFontColor := Value;
end;
procedure TJvHTMLElement.SetFontName(const Value: string);
begin
FFontName := Value;
end;
procedure TJvHTMLElement.SetFontSize(const Value: Integer);
begin
FFontSize := Value;
end;
procedure TJvHTMLElement.SetFontStyle(const Value: TFontStyles);
begin
FFontStyle := Value;
end;
procedure TJvHTMLElement.SetHeight(const Value: Integer);
begin
FHeight := Value;
end;
procedure TJvHTMLElement.SetSolText(const Value: string);
begin
FSolText := Value;
end;
procedure TJvHTMLElement.SetText(const Value: string);
begin
FText := Value;
end;
procedure TJvHTMLElement.SetWidth(const Value: Integer);
begin
FWidth := Value;
end;
//=== { TJvHTMLElementStack } ================================================
destructor TJvHTMLElementStack.Destroy;
begin
Clear;
inherited Destroy;
end;
procedure TJvHTMLElementStack.Clear;
var
I: Integer;
begin
for I := Count - 1 downto 0 do
TJvHTMLElement(Items[I]).Free;
inherited Clear;
end;
function TJvHTMLElementStack.Peek: TJvHTMLElement;
begin
if Count = 0 then
Result := nil
else
Result := TJvHTMLElement(Items[Count - 1]);
end;
function TJvHTMLElementStack.Pop: TJvHTMLElement;
begin
if Count = 0 then
Result := nil
else
begin
Result := TJvHTMLElement(Items[Count - 1]);
Delete(Count - 1);
end;
end;
procedure TJvHTMLElementStack.Push(Element: TJvHTMLElement);
begin
Add(Element);
end;
end.

View File

@ -0,0 +1,644 @@
{-----------------------------------------------------------------------------
The contents of this file are subject to the Mozilla Public License
Version 1.1 (the "License"); you may not use this file except in compliance
with the License. You may obtain a copy of the License at
http://www.mozilla.org/MPL/MPL-1.1.html
Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for
the specific language governing rights and limitations under the License.
The Original Code is: JvMarkupLabel.PAS, released on 2002-06-15.
The Initial Developer of the Original Code is Jan Verhoeven [jan1 dott verhoeven att wxs dott nl]
Portions created by Jan Verhoeven are Copyright (C) 2002 Jan Verhoeven.
All Rights Reserved.
Contributor(s):
Robert Love [rlove att slcdug dott org].
Lionel Reynaud
You may retrieve the latest version of this file at the Project JEDI's JVCL home page,
located at http://jvcl.delphi-jedi.org
Known Issues:
-----------------------------------------------------------------------------}
// $Id$
unit JvMarkupLabel;
{$mode objfpc}{$H+}
interface
uses
//Messages,
Graphics, Controls,
SysUtils, Classes,
JvMarkupCommon;
type
TJvMarkupLabel = class(TGraphicControl) //TJvPubGraphicControl)
private
FElementStack: TJvHTMLElementStack;
FTagStack: TJvHTMLElementStack;
FMarginLeft: Integer;
FMarginRight: Integer;
FMarginTop: Integer;
FAlignment: TAlignment;
FText: TCaption;
procedure Refresh;
procedure ParseHTML(S: string);
procedure RenderHTML;
procedure HTMLClearBreaks;
procedure HTMLElementDimensions;
procedure SetMarginLeft(const Value: Integer);
procedure SetMarginRight(const Value: Integer);
procedure SetMarginTop(const Value: Integer);
procedure SetAlignment(const Value: TAlignment);
// procedure DoReadBackColor(Reader: TReader);
protected
// procedure FontChanged; override;
procedure SetText(const Value: TCaption);
procedure SetAutoSize(Value: Boolean); override;
// procedure DefineProperties(Filer: TFiler); override;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure Paint; override;
published
property Height default 100;
property Width default 200;
property MarginLeft: Integer read FMarginLeft write SetMarginLeft default 5;
property MarginRight: Integer read FMarginRight write SetMarginRight default 5;
property MarginTop: Integer read FMarginTop write SetMarginTop default 5;
property Alignment: TAlignment read FAlignment write SetAlignment default taLeftJustify;
property Text: TCaption read FText write SetText;
property AutoSize;
property Align;
property Font;
property Anchors;
property BorderSpacing;
property Constraints;
property Enabled;
property Color default clBtnFace; // Duplicates BackColor
property ParentColor default True;
property ParentFont;
property ParentShowHint;
property PopupMenu;
property ShowHint;
property Visible;
property OnClick;
property OnContextPopup;
property OnDblClick;
property OnDragDrop;
property OnDragOver;
property OnEndDrag;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
property OnMouseEnter;
property OnMouseLeave;
property OnStartDrag;
end;
implementation
uses
Themes,
JvJCLUtils, JvConsts;
constructor TJvMarkupLabel.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
//IncludeThemeStyle(Self, [csParentBackground]);
FElementStack := TJvHTMLElementStack.Create;
FTagStack := TJvHTMLElementStack.Create;
FAlignment := taLeftJustify;
Width := 200;
Height := 100;
FMarginLeft := 5;
FMarginRight := 5;
FMarginTop := 5;
Color := clBtnFace;
ParentColor := True;
end;
destructor TJvMarkupLabel.Destroy;
begin
FElementStack.Free;
FTagStack.Free;
inherited Destroy;
end;
procedure TJvMarkupLabel.HTMLClearBreaks;
var
I, C: Integer;
El: TJvHTMLElement;
begin
C := FElementStack.Count;
if C = 0 then
Exit;
for I := 0 to C - 1 do
begin
El := TJvHTMLElement(FElementStack.Items[I]);
El.SolText := '';
El.EolText := '';
end;
end;
procedure TJvMarkupLabel.HTMLElementDimensions;
var
I, C: Integer;
El: TJvHTMLElement;
H, A, W: Integer;
tm: TLCLTextMetric;
//m: TTextMetric;
S: string;
begin
C := FElementStack.Count;
if C = 0 then
Exit;
for I := 0 to C - 1 do
begin
El := TJvHTMLElement(FElementStack.Items[I]);
S := El.Text;
Canvas.Font.Name := El.FontName;
Canvas.Font.Size := El.FontSize;
Canvas.Font.Style := El.FontStyle;
Canvas.Font.Color := El.FontColor;
Canvas.GetTextMetrics(tm);
// GetTextMetrics(Canvas.Handle, Tm);
H := tm.Height;
A := tm.Ascender;
W := Canvas.TextWidth(S);
El.Height := H;
El.Ascent := A;
El.Width := W;
end;
end;
procedure TJvMarkupLabel.Refresh;
begin
ParseHTML(FText);
HTMLElementDimensions;
Invalidate;
end;
procedure TJvMarkupLabel.Paint;
begin
RenderHTML;
end;
{
procedure TJvMarkupLabel.FontChanged;
begin
inherited FontChanged;
Refresh;
end;
}
procedure TJvMarkupLabel.ParseHTML(S: string);
var
P: Integer;
SE, ST: string;
lText: string;
lStyle: TFontStyles;
lName: string;
lSize: Integer;
lBreakLine: Boolean;
AColor, lColor: TColor;
Element: TJvHTMLElement;
function HTMLStringToColor(V: string; var Col: TColor): Boolean;
var
VV: string;
begin
Result := False;
if Length(V) < 2 then
Exit;
if not CharInSet(V[1], ['#', '$']) then
begin
// allow the use of both "clBlack" and "Black"
if Pos('cl', AnsiLowerCase(V)) = 1 then
VV := V
else
VV := 'cl' + V;
try
Col := StringToColor(VV);
Result := True;
except
Result := False;
end;
end
else
// this is either #FFFFFF or $FFFFFF - we treat them the same
begin
try
VV := '$' + Copy(V, 6, 2) + Copy(V, 4, 2) + Copy(V, 2, 2);
Col := StringToColor(VV);
Result := True;
except
Result := False;
end
end;
end;
procedure PushTag;
begin
Element := TJvHTMLElement.Create;
Element.FontName := lName;
Element.FontSize := lSize;
Element.FontStyle := lStyle;
Element.FontColor := lColor;
FTagStack.Push(Element);
end;
procedure PopTag;
begin
Element := FTagStack.Pop;
if Element <> nil then
begin
lName := Element.FontName;
lSize := Element.FontSize;
lStyle := Element.FontStyle;
lColor := Element.FontColor;
Element.Free;
end;
end;
procedure PushElement;
begin
Element := TJvHTMLElement.Create;
Element.Text := lText;
Element.FontName := lName;
Element.FontSize := lSize;
Element.FontStyle := lStyle;
Element.FontColor := lColor;
Element.BreakLine := lBreakLine;
lBreakLine := False;
FElementStack.Push(Element);
end;
procedure ParseTag(SS: string);
var
PP: Integer;
ATag, APar, AVal: string;
HaveParams: Boolean;
begin
SS := Trim(SS);
HaveParams := False;
PP := Pos(' ', SS);
if PP = 0 then
ATag := SS // tag only
else
begin // tag + attributes
ATag := Copy(SS, 1, PP - 1);
SS := Trim(Copy(SS, PP + 1, Length(SS)));
HaveParams := True;
end;
// handle ATag
ATag := LowerCase(ATag);
if ATag = 'br' then
lBreakLine := True
else
if ATag = 'b' then
begin // bold
PushTag;
lStyle := lStyle + [fsBold];
end
else
if ATag = '/b' then
begin // cancel bold
lStyle := lStyle - [fsBold];
PopTag;
end
else
if ATag = 'i' then
begin // italic
PushTag;
lStyle := lStyle + [fsItalic];
end
else
if ATag = '/i' then
begin // cancel italic
lStyle := lStyle - [fsItalic];
PopTag;
end
else
if ATag = 'u' then
begin // underline
PushTag;
lStyle := lStyle + [fsUnderline];
end
else
if ATag = '/u' then
begin // cancel underline
lStyle := lStyle - [fsUnderline];
PopTag;
end
else
if ATag = 'font' then
PushTag
else
if ATag = '/font' then
PopTag;
if HaveParams then
begin
repeat
PP := Pos('="', SS);
if PP > 0 then
begin
APar := LowerCase(Trim(Copy(SS, 1, PP - 1)));
Delete(SS, 1, PP + 1);
PP := Pos('"', SS);
if PP > 0 then
begin
AVal := Copy(SS, 1, PP - 1);
Delete(SS, 1, PP);
if APar = 'face' then
lName := AVal
else
if APar = 'size' then
try
lSize := StrToInt(AVal);
except
end
else
if APar = 'color' then
try
if HTMLStringToColor(AVal, AColor) then
lColor := AColor;
except
end;
end;
end;
until PP = 0;
end;
end;
begin
FElementStack.Clear;
FTagStack.Clear;
lStyle := Font.Style;
lName := Font.Name;
lSize := Font.Size;
lColor := Font.Color;
lBreakLine := False;
repeat
P := Pos('<', S);
if P = 0 then
begin
lText := S;
PushElement;
end
else
begin
if P > 1 then
begin
SE := Copy(S, 1, P - 1);
lText := SE;
PushElement;
Delete(S, 1, P - 1);
end;
P := Pos('>', S);
if P > 0 then
begin
ST := Copy(S, 2, P - 2);
Delete(S, 1, P);
ParseTag(ST);
end;
end;
until P = 0;
end;
procedure TJvMarkupLabel.RenderHTML;
var
R: TRect;
I, C, X, Y: Integer;
ATotalWidth, AClientWidth, ATextWidth, BaseLine: Integer;
iSol, iEol, PendingCount, MaxHeight, MaxAscent: Integer;
El: TJvHTMLElement;
Eol: Boolean;
PendingBreak: Boolean;
lSolText: string;
MaxWidth: Integer;
procedure SetFont(EE: TJvHTMLElement);
begin
with Canvas do
begin
Font.Name := EE.FontName;
Font.Size := EE.FontSize;
Font.Style := EE.FontStyle;
Font.Color := EE.FontColor;
end;
end;
procedure RenderString(EE: TJvHTMLElement; Test: Boolean);
var
SS: string;
WW: Integer;
begin
SetFont(EE);
if EE.SolText <> '' then
begin
SS := TrimLeft(EE.SolText);
WW := Canvas.TextWidth(SS);
if not Test then
Canvas.TextOut(X, Y + BaseLine - EE.Ascent, SS);
X := X + WW;
end;
end;
begin
iEol := 0; // Not Needed but removes warning.
R := ClientRect;
Canvas.Brush.Color := Color;
Canvas.FillRect(R);
//DrawThemedBackground(Self, Canvas, R);
C := FElementStack.Count;
if C = 0 then
Exit;
HTMLClearBreaks;
if AutoSize then
AClientWidth := 10000
else
AClientWidth := ClientWidth - MarginLeft - MarginRight;
Canvas.Brush.Style := bsClear;
Y := MarginTop;
iSol := 0;
PendingBreak := False;
PendingCount := -1;
MaxWidth := 0;
repeat
I := iSol;
ATotalWidth := AClientWidth;
ATextWidth := 0;
MaxHeight := 0;
MaxAscent := 0;
Eol := False;
repeat // scan line
El := TJvHTMLElement(FElementStack.Items[I]);
if El.BreakLine then
begin
if not PendingBreak and (PendingCount <> I) then
begin
PendingBreak := True;
PendingCount := I;
iEol := I;
Break;
end
else
PendingBreak := False;
end;
if El.Height > MaxHeight then
MaxHeight := El.Height;
if El.Ascent > MaxAscent then
MaxAscent := El.Ascent;
if El.Text <> '' then
begin
lSolText := El.SolText;
// (Lionel) If Breakup can do something, I increase a bit the space until
// it can do the break ...
repeat
El.Breakup(Canvas, ATotalWidth);
Inc(ATotalWidth, 5);
until lSolText <> El.SolText;
end;
if El.SolText <> '' then
begin
ATotalWidth := ATotalWidth - Canvas.TextWidth(El.SolText) - 5;
ATextWidth := ATextWidth + Canvas.TextWidth(El.SolText);
if El.EolText = '' then
begin
if I >= C - 1 then
begin
Eol := True;
iEol := I;
end
else
Inc(I);
end
else
begin
Eol := True;
iEol := I;
end;
end
else
begin // Eol
Eol := True;
iEol := I;
end;
until Eol;
// render line
BaseLine := MaxAscent;
if AutoSize then
begin
X := MarginLeft;
if (ATextWidth + MarginLeft + MarginRight) > MaxWidth then
MaxWidth := (ATextWidth + MarginLeft + MarginRight);
end
else
case Alignment of
taLeftJustify:
X := MarginLeft;
taRightJustify:
X := Width - MarginRight - ATextWidth;
taCenter:
X := MarginLeft + (Width - MarginLeft - MarginRight - ATextWidth) div 2;
end;
for I := iSol to iEol do
begin
El := TJvHTMLElement(FElementStack.Items[I]);
RenderString(El, False);
end;
Y := Y + MaxHeight;
iSol := iEol;
until (iEol >= C - 1) and (El.EolText = '');
if AutoSize then
begin
Width := MaxWidth;
Height := Y + 5;
end;
end;
procedure TJvMarkupLabel.SetAlignment(const Value: TAlignment);
begin
if Value <> FAlignment then
begin
FAlignment := Value;
Invalidate;
end;
end;
procedure TJvMarkupLabel.SetAutoSize(Value: Boolean);
begin
inherited SetAutoSize(Value);
Invalidate;
end;
procedure TJvMarkupLabel.SetMarginLeft(const Value: Integer);
begin
FMarginLeft := Value;
Invalidate;
end;
procedure TJvMarkupLabel.SetMarginRight(const Value: Integer);
begin
FMarginRight := Value;
Invalidate;
end;
procedure TJvMarkupLabel.SetMarginTop(const Value: Integer);
begin
FMarginTop := Value;
Invalidate;
end;
procedure TJvMarkupLabel.SetText(const Value: TCaption);
var
S: string;
begin
if Value = FText then
Exit;
S := Value;
S := StringReplace(S, SLineBreak, ' ', [rfReplaceAll]);
S := TrimRight(S);
FText := S;
Refresh;
end;
{function TJvMarkupLabel.GetBackColor: TColor;
begin
Result := Color;
end;
procedure TJvMarkupLabel.SetBackColor(const Value: TColor);
begin
Color := Value;
end;}
{
procedure TJvMarkupLabel.DoReadBackColor(Reader: TReader);
begin
if Reader.NextValue = vaIdent then
Color := StringToColor(Reader.ReadIdent)
else
Color := Reader.ReadInteger;
end;
procedure TJvMarkupLabel.DefineProperties(Filer: TFiler);
begin
inherited DefineProperties(Filer);
Filer.DefineProperty('BackColor', @DoReadBackColor, nil, False);
end;
}
end.

View File

@ -0,0 +1,618 @@
{-----------------------------------------------------------------------------
The contents of this file are subject to the Mozilla Public License
Version 1.1 (the "License"); you may not use this file except in compliance
with the License. You may obtain a copy of the License at
http://www.mozilla.org/MPL/MPL-1.1.html
Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for
the specific language governing rights and limitations under the License.
The Original Code is: JvMarkupViewer.PAS, released on 2002-06-15.
The Initial Developer of the Original Code is Jan Verhoeven [jan1 dott verhoeven att wxs dott nl]
Portions created by Jan Verhoeven are Copyright (C) 2002 Jan Verhoeven.
All Rights Reserved.
Contributor(s): Robert Love [rlove att slcdug dott org].
You may retrieve the latest version of this file at the Project JEDI's JVCL home page,
located at http://jvcl.delphi-jedi.org
Known Issues:
-----------------------------------------------------------------------------}
// $Id$
unit JvMarkupViewer;
{$mode objfpc}{$H+}
interface
uses
SysUtils, Classes,
Messages, Graphics, Forms, Controls, StdCtrls,
JvMarkupCommon;
type
TJvMarkupViewer = class(TCustomControl)
private
FScrollBar: TScrollBar;
FBmp: TBitmap;
FrameTop: Integer;
FrameBottom: Integer;
PageBottom: Integer;
FElementStack: TJvHTMLElementStack;
FTagStack: TJvHTMLElementStack;
FBackColor: TColor;
FMarginLeft: Integer;
FMarginRight: Integer;
FMarginTop: Integer;
FText: TCaption;
function GetText: TCaption;
procedure SetText(const Value: TCaption);
procedure ParseHTML(s: string);
procedure RenderHTML;
procedure HTMLClearBreaks;
procedure HTMLElementDimensions;
procedure SetBackColor(const Value: TColor);
procedure SetMarginLeft(const Value: Integer);
procedure SetMarginRight(const Value: Integer);
procedure SetMarginTop(const Value: Integer);
procedure ScrollViewer(Sender: TObject);
protected
procedure CreateWnd; override;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure Paint; override;
published
property Width default 300;
property Height default 275;
property Text: TCaption read GetText write SetText;
property BackColor: TColor read FBackColor write SetBackColor default clWhite;
property MarginLeft: Integer read FMarginLeft write SetMarginLeft default 5;
property MarginRight: Integer read FMarginRight write SetMarginRight default 5;
property MarginTop: Integer read FMarginTop write SetMarginTop default 5;
property Align;
property BorderSpacing;
property BorderStyle;
property BorderWidth;
property Constraints;
property Font;
property ParentFont;
property PopupMenu;
property Visible;
property OnClick;
property OnMouseDown;
property OnMouseEnter;
property OnMouseLeave;
property OnMouseMove;
property OnMouseUp;
property OnMouseWheel;
property OnMouseWheelDown;
property OnMouseWheelUp;
property OnResize;
end;
implementation
uses
JvConsts, Themes;
constructor TJvMarkupViewer.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
//IncludeThemeStyle(Self, [csParentBackground]);
FElementStack := TJvHTMLElementStack.Create;
FTagStack := TJvHTMLElementStack.Create;
Width := 300;
Height := 275;
FMarginLeft := 5;
FMarginRight := 5;
FMarginTop := 5;
FBackColor := clWhite;
end;
destructor TJvMarkupViewer.Destroy;
begin
FElementStack.Free;
FTagStack.Free;
FBmp.Free;
FScrollBar.Free;
inherited Destroy;
end;
procedure TJvMarkupViewer.HTMLClearBreaks;
var
I, C: Integer;
Element: TJvHTMLElement;
begin
C := FElementStack.Count;
if C = 0 then
Exit;
for I := 0 to C - 1 do
begin
Element := TJvHTMLElement(FElementStack.Items[I]);
Element.SolText := '';
Element.EolText := '';
end;
end;
procedure TJvMarkupViewer.HTMLElementDimensions;
var
I, C: Integer;
Element: TJvHTMLElement;
h, a, w: Integer;
tm: TLCLTextMetric;
// tm: TEXTMETRIC;
s: string;
begin
C := FElementStack.Count;
if C = 0 then
Exit;
for I := 0 to C - 1 do
begin
Element := TJvHTMLElement(FElementStack.Items[I]);
s := Element.Text;
Canvas.Font.Name := Element.FontName;
Canvas.Font.Size := Element.FontSize;
Canvas.Font.Style := Element.FontStyle;
Canvas.Font.Color := Element.FontColor;
Canvas.GetTextMetrics(tm);
// GetTextMetrics(Canvas.Handle, tm);
h := tm.Height;
a := tm.Ascender;
w := Canvas.TextWidth(s);
Element.Height := h;
Element.Ascent := a;
Element.Width := w;
end;
end;
procedure TJvMarkupViewer.CreateWnd;
begin
inherited CreateWnd;
FScrollBar := TScrollBar.Create(Self);
FScrollBar.Kind := sbVertical;
FScrollBar.Parent := Self;
FScrollBar.Align := alRight;
FScrollBar.Min := 0;
FScrollBar.Max := 0;
FScrollBar.OnChange := @ScrollViewer;
FrameTop := 0;
FrameBottom := ClientHeight;
FBmp := TBitmap.Create;
FBmp.Width := ClientWidth - FScrollBar.Width;
FBmp.Height := ClientHeight;
end;
procedure TJvMarkupViewer.Paint;
var
sm: Integer;
w, h: Integer;
begin
w := ClientWidth - FScrollBar.Width;
h := ClientHeight;
FBmp.Width := w;
FBmp.Height := h;
RenderHTML;
Canvas.Draw(0, 0, FBmp);
FScrollBar.Min := 0;
sm := PageBottom - ClientHeight;
if sm > 0 then
FScrollBar.Max := sm
else
FScrollBar.Max := 0;
FScrollBar.Position := 0;
FScrollBar.LargeChange := Trunc(0.8 * ClientHeight);
end;
procedure TJvMarkupViewer.ParseHTML(s: string);
var
p: Integer;
se, st: string;
LText: string;
FStyle: TFontStyles;
FName: string;
FSize: Integer;
LBreakLine: Boolean;
AColor, FColor: TColor;
Element: TJvHTMLElement;
function HTMLStringToColor(v: string; var col: TColor): Boolean;
var
vv: string;
begin
if Copy(v, 1, 1) <> '#' then
begin
vv := 'cl' + v;
try
col := StringToColor(vv);
Result := True;
except
Result := False;
end;
end
else
begin
try
vv := '$' + Copy(v, 6, 2) + Copy(v, 4, 2) + Copy(v, 2, 2);
col := StringToColor(vv);
Result := True;
except
Result := False;
end
end
end;
procedure PushTag;
begin
Element := TJvHTMLElement.Create;
Element.FontName := FName;
Element.FontSize := FSize;
Element.FontStyle := FStyle;
Element.FontColor := FColor;
FTagStack.Push(Element);
end;
procedure PopTag;
begin
Element := FTagStack.Pop;
if Element <> nil then
begin
FName := Element.FontName;
FSize := Element.FontSize;
FStyle := Element.FontStyle;
FColor := Element.FontColor;
Element.Free;
end;
end;
procedure PushElement;
begin
Element := TJvHTMLElement.Create;
Element.Text := LText;
Element.FontName := FName;
Element.FontSize := FSize;
Element.FontStyle := FStyle;
Element.FontColor := FColor;
Element.BreakLine := LBreakLine;
LBreakLine := False;
FElementStack.Push(Element);
end;
procedure ParseTag(SS: string);
var
PP: Integer;
LTag, LPar, LVal: string;
HavePar: Boolean;
begin
SS := Trim(SS);
HavePar := False;
PP := Pos(' ', SS);
if PP = 0 then
LTag := SS // tag only
else
begin // tag + attributes
LTag := Copy(SS, 1, PP - 1);
SS := Trim(Copy(SS, PP + 1, Length(SS)));
HavePar := True;
end;
// handle LTag
LTag := LowerCase(LTag);
if LTag = 'br' then
LBreakLine := True
else
if LTag = 'b' then
begin // bold
PushTag;
FStyle := FStyle + [fsBold];
end
else
if LTag = '/b' then
begin // cancel bold
FStyle := FStyle - [fsBold];
PopTag;
end
else
if LTag = 'i' then
begin // italic
PushTag;
FStyle := FStyle + [fsItalic];
end
else
if LTag = '/i' then
begin // cancel italic
FStyle := FStyle - [fsItalic];
PopTag;
end
else
if LTag = 'u' then
begin // underline
PushTag;
FStyle := FStyle + [fsUnderline];
end
else
if LTag = '/u' then
begin // cancel underline
FStyle := FStyle - [fsUnderline];
PopTag;
end
else
if LTag = 'font' then
PushTag
else
if LTag = '/font' then
PopTag;
if HavePar then
begin
repeat
PP := Pos('="', SS);
if PP > 0 then
begin
LPar := LowerCase(Trim(Copy(SS, 1, PP - 1)));
Delete(SS, 1, PP + 1);
PP := Pos('"', SS);
if PP > 0 then
begin
LVal := Copy(SS, 1, PP - 1);
Delete(SS, 1, PP);
if LPar = 'face' then
FName := LVal
else
if LPar = 'size' then
try
FSize := StrToInt(LVal);
except
end
else
if LPar = 'color' then
try
if HTMLStringToColor(LVal, AColor) then
FColor := AColor;
except
end
end;
end;
until PP = 0;
end;
end;
begin
FElementStack.Clear;
FTagStack.Clear;
FStyle := Font.Style;
FName := Font.Name;
FSize := Font.Size;
FColor := Font.Color;
LBreakLine := False;
repeat
p := Pos('<', s);
if p = 0 then
begin
LText := s;
PushElement;
end
else
begin
if p > 1 then
begin
se := Copy(s, 1, p - 1);
LText := se;
PushElement;
Delete(s, 1, p - 1);
end;
p := Pos('>', s);
if p > 0 then
begin
st := Copy(s, 2, p - 2);
Delete(s, 1, p);
ParseTag(st);
end;
end;
until p = 0;
end;
procedure TJvMarkupViewer.RenderHTML;
var
R: TRect;
X, Y, xav, clw: Integer;
BaseLine: Integer;
I, C: Integer;
el: TJvHTMLElement;
eol: Boolean;
ml: Integer; // margin left
isol, ieol: Integer;
MaxHeight, MaxAscent: Integer;
PendingBreak: Boolean;
procedure SetFont(AElem: TJvHTMLElement);
begin
with FBmp.Canvas do
begin
if SameText(AElem.FontName, 'default') then
Font.Name := Screen.MenuFont.Name else
Font.Name := AElem.FontName;
if AElem.FontSize = 0 then
Font.Size := 10 else
Font.Size := AElem.FontSize;
Font.Style := AElem.FontStyle;
Font.Color := AElem.FontColor;
end;
end;
procedure RenderString(ee: TJvHTMLElement);
var
SS: string;
w: Integer;
begin
SetFont(ee);
if ee.SolText <> '' then
begin
SS := ee.SolText;
w := FBmp.Canvas.TextWidth(SS);
FBmp.Canvas.TextOut(X, Y + BaseLine - ee.Ascent - FrameTop, SS);
X := X + w;
end;
end;
begin
ieol := 0; // Not needed but removed Warning
R := Rect(0, 0, FBmp.Width, FBmp.Height);
FBmp.Canvas.Brush.Style := bsSolid;
FBmp.Canvas.Brush.Color := FBackColor;
FBmp.Canvas.FillRect(R);
FBmp.Canvas.Font.Assign(Font);
C := FElementStack.Count;
if C = 0 then
Exit;
HTMLClearBreaks;
clw := FBmp.Width - FMarginRight;
ml := MarginLeft;
FBmp.Canvas.Brush.Style := bsClear;
Y := FMarginTop;
isol := 0;
PendingBreak := False;
repeat
I := isol;
xav := clw;
MaxHeight := 0;
MaxAscent := 0;
eol := False;
repeat // scan line
el := TJvHTMLElement(FElementStack.Items[I]);
if el.BreakLine then
begin
if not PendingBreak then
begin
eol := True;
ieol := I - 1;
// break;
end;
PendingBreak := not PendingBreak;
end;
if not PendingBreak then
begin
if el.Height > MaxHeight then
MaxHeight := el.Height;
if el.Ascent > MaxAscent then
MaxAscent := el.Ascent;
el.Breakup(FBmp.Canvas, xav);
if el.SolText <> '' then
begin
xav := xav - FBmp.Canvas.TextWidth(el.SolText);
if el.EolText = '' then
begin
if I >= C - 1 then
begin
eol := True;
ieol := I;
end
else
Inc(I);
end
else
begin
eol := True;
ieol := I;
end;
end
else
begin
eol := True;
ieol := I;
end;
end;
until eol;
// render line, only when in visible frame
X := ml;
BaseLine := MaxAscent;
if (Y + MaxHeight >= FrameTop) and (Y <= FrameBottom) then
for I := isol to ieol do
begin
el := TJvHTMLElement(FElementStack.Items[I]);
RenderString(el);
end;
Y := Y + MaxHeight;
if not PendingBreak then
isol := ieol
else
isol := ieol + 1;
until (ieol >= C - 1) and (el.EolText = '');
// clxfix: set transparency after bitmap has be drawn
FBmp.TransparentColor := Color;
FBmp.Transparent := True;
PageBottom := Y;
end;
procedure TJvMarkupViewer.ScrollViewer(Sender: TObject);
begin
FrameTop := FScrollBar.Position;
FrameBottom := FrameTop + ClientHeight - 1;
RenderHTML;
Canvas.Draw(0, 0, FBmp);
end;
procedure TJvMarkupViewer.SetBackColor(const Value: TColor);
begin
if Value <> FBackColor then
begin
FBackColor := Value;
Invalidate;
end;
end;
procedure TJvMarkupViewer.SetMarginLeft(const Value: Integer);
begin
if Value <> FMarginLeft then
begin
FMarginLeft := Value;
Invalidate;
end;
end;
procedure TJvMarkupViewer.SetMarginRight(const Value: Integer);
begin
if Value <> FMarginRight then
begin
FMarginRight := Value;
Invalidate;
end;
end;
procedure TJvMarkupViewer.SetMarginTop(const Value: Integer);
begin
if Value <> FMarginTop then
begin
FMarginTop := Value;
Invalidate;
end;
end;
function TJvMarkupViewer.GetText: TCaption;
begin
Result := FText;
end;
procedure TJvMarkupViewer.SetText(const Value: TCaption);
var
S: string;
begin
if Value = FText then
Exit;
S := Value;
S := StringReplace(S, sLineBreak, ' ', [rfReplaceAll]);
S := TrimRight(S);
ParseHTML(S);
HTMLElementDimensions;
FText := S;
Invalidate;
end;
end.