chemtext: Initial commit

git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@5958 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
wp_xxyyzz 2017-06-25 15:56:27 +00:00
parent 146b28a4cc
commit 8094316fc5
12 changed files with 1157 additions and 0 deletions

View File

@ -0,0 +1,81 @@
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<ProjectOptions>
<Version Value="10"/>
<PathDelim Value="\"/>
<General>
<SessionStorage Value="InProjectDir"/>
<MainUnit Value="0"/>
<Title Value="chem"/>
<ResourceType Value="res"/>
<UseXPManifest Value="True"/>
<Icon Value="0"/>
</General>
<BuildModes Count="1">
<Item1 Name="Default" Default="True"/>
</BuildModes>
<PublishOptions>
<Version Value="2"/>
</PublishOptions>
<RunParams>
<local>
<FormatVersion Value="1"/>
</local>
</RunParams>
<RequiredPackages Count="2">
<Item1>
<PackageName Value="laz_chemtext"/>
</Item1>
<Item2>
<PackageName Value="LCL"/>
</Item2>
</RequiredPackages>
<Units Count="2">
<Unit0>
<Filename Value="chem.lpr"/>
<IsPartOfProject Value="True"/>
</Unit0>
<Unit1>
<Filename Value="testchem.pas"/>
<IsPartOfProject Value="True"/>
<ComponentName Value="Form1"/>
<HasResources Value="True"/>
<ResourceBaseClass Value="Form"/>
</Unit1>
</Units>
</ProjectOptions>
<CompilerOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<Target>
<Filename Value="chem"/>
</Target>
<SearchPaths>
<IncludeFiles Value="$(ProjOutDir)"/>
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
</SearchPaths>
<Linking>
<Debugging>
<UseExternalDbgSyms Value="True"/>
</Debugging>
<Options>
<Win32>
<GraphicApplication Value="True"/>
</Win32>
</Options>
</Linking>
</CompilerOptions>
<Debugging>
<Exceptions Count="3">
<Item1>
<Name Value="EAbort"/>
</Item1>
<Item2>
<Name Value="ECodetoolError"/>
</Item2>
<Item3>
<Name Value="EFOpenError"/>
</Item3>
</Exceptions>
</Debugging>
</CONFIG>

View File

@ -0,0 +1,17 @@
program chem;
{$mode objfpc}{$H+}
uses
Interfaces, // this includes the LCL widgetset
Forms, testchem;
{$R *.RES}
begin
RequireDerivedFormResource := True;
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.Run;
end.

View File

@ -0,0 +1,139 @@
object Form1: TForm1
Left = 200
Height = 280
Top = 108
Width = 399
Caption = 'ChemLabel Demo'
ClientHeight = 280
ClientWidth = 399
Font.Color = clWindowText
Font.Height = -16
Font.Name = 'Arial'
Position = poScreenCenter
LCLVersion = '1.9.0.0'
object Panel1: TPanel
Left = 16
Height = 137
Top = 8
Width = 361
BevelOuter = bvNone
BorderStyle = bsSingle
ClientHeight = 133
ClientWidth = 357
Color = clWhite
Font.Color = clWindowText
Font.Height = -16
Font.Name = 'Arial'
ParentColor = False
ParentFont = False
TabOrder = 1
object ChemLabel1: TChemLabel
AnchorSideLeft.Control = Spacer
AnchorSideLeft.Side = asrBottom
Left = 187
Height = 23
Top = 40
Width = 60
Caption = 'C3H7OH'
ParentColor = False
end
object ChemLabel2: TChemLabel
AnchorSideLeft.Control = Spacer
AnchorSideLeft.Side = asrBottom
Left = 187
Height = 23
Top = 68
Width = 121
Arrow = caUTF8Single
Caption = '2H2 + O2 -> H2O'
ParentColor = False
end
object ChemLabel3: TChemLabel
AnchorSideLeft.Control = Panel1
AnchorSideLeft.Side = asrCenter
Left = 110
Height = 19
Top = 8
Width = 136
Caption = 'Using ChemLabel'
Font.Color = clNavy
Font.Height = -16
Font.Name = 'Arial'
Font.Style = [fsBold]
ParentColor = False
ParentFont = False
end
object ChemLabel5: TChemLabel
AnchorSideLeft.Control = Spacer
AnchorSideLeft.Side = asrBottom
Left = 187
Height = 23
Top = 96
Width = 141
Arrow = caUTF8Single
Caption = 'H2+ + H2 --> H3+ + H'
ParentColor = False
end
object Spacer: TBevel
AnchorSideLeft.Control = Panel1
AnchorSideLeft.Side = asrCenter
Left = 170
Height = 136
Top = 0
Width = 17
Shape = bsSpacer
end
object Label1: TLabel
AnchorSideRight.Control = Spacer
Left = 103
Height = 18
Top = 40
Width = 67
Anchors = [akTop, akRight]
Caption = 'Propanol:'
ParentColor = False
end
object Label2: TLabel
AnchorSideRight.Control = Spacer
Left = 40
Height = 18
Top = 68
Width = 130
Anchors = [akTop, akRight]
Caption = 'Chemical reaction:'
ParentColor = False
end
object Label3: TLabel
AnchorSideRight.Control = Spacer
Left = 19
Height = 18
Top = 96
Width = 151
Anchors = [akTop, akRight]
Caption = 'Ion-molecule reaction:'
ParentColor = False
end
end
object Edit1: TEdit
Left = 32
Height = 26
Top = 168
Width = 329
OnChange = Edit1Change
TabOrder = 0
Text = '(CH3)3COH'
end
object ChemLabel4: TChemLabel
Left = 32
Height = 36
Top = 208
Width = 131
Arrow = caUTF8Single
Caption = '(CH3)3COH'
Font.Color = clWindowText
Font.Height = -27
Font.Name = 'Times New Roman'
ParentColor = False
ParentFont = False
end
end

View File

@ -0,0 +1,44 @@
unit testchem;
interface
uses
SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ExtCtrls, chemtext;
type
{ TForm1 }
TForm1 = class(TForm)
Spacer: TBevel;
ChemLabel1: TChemLabel;
ChemLabel2: TChemLabel;
ChemLabel3: TChemLabel;
ChemLabel5: TChemLabel;
Edit1: TEdit;
ChemLabel4: TChemLabel;
Label1: TLabel;
Label2: TLabel;
Label3: TLabel;
Panel1: TPanel;
procedure Edit1Change(Sender: TObject);
private
public
end;
var
Form1: TForm1;
implementation
{$R *.lfm}
procedure TForm1.Edit1Change(Sender: TObject);
begin
ChemLabel4.Caption := Edit1.Text;
end;
end.

View File

@ -0,0 +1,80 @@
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<ProjectOptions>
<Version Value="10"/>
<PathDelim Value="\"/>
<General>
<SessionStorage Value="InProjectDir"/>
<MainUnit Value="0"/>
<Title Value="project1"/>
<ResourceType Value="res"/>
<UseXPManifest Value="True"/>
<Icon Value="0"/>
</General>
<BuildModes Count="1">
<Item1 Name="Default" Default="True"/>
</BuildModes>
<PublishOptions>
<Version Value="2"/>
</PublishOptions>
<RunParams>
<local>
<FormatVersion Value="1"/>
</local>
</RunParams>
<RequiredPackages Count="2">
<Item1>
<PackageName Value="laz_chemtext"/>
</Item1>
<Item2>
<PackageName Value="LCL"/>
</Item2>
</RequiredPackages>
<Units Count="2">
<Unit0>
<Filename Value="project1.lpr"/>
<IsPartOfProject Value="True"/>
</Unit0>
<Unit1>
<Filename Value="unit1.pas"/>
<IsPartOfProject Value="True"/>
<ComponentName Value="Form1"/>
<HasResources Value="True"/>
<ResourceBaseClass Value="Form"/>
<UnitName Value="Unit1"/>
</Unit1>
</Units>
</ProjectOptions>
<CompilerOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<Target>
<Filename Value="project1"/>
</Target>
<SearchPaths>
<IncludeFiles Value="$(ProjOutDir)"/>
<OtherUnitFiles Value="..\source"/>
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
</SearchPaths>
<Linking>
<Options>
<Win32>
<GraphicApplication Value="True"/>
</Win32>
</Options>
</Linking>
</CompilerOptions>
<Debugging>
<Exceptions Count="3">
<Item1>
<Name Value="EAbort"/>
</Item1>
<Item2>
<Name Value="ECodetoolError"/>
</Item2>
<Item3>
<Name Value="EFOpenError"/>
</Item3>
</Exceptions>
</Debugging>
</CONFIG>

View File

@ -0,0 +1,21 @@
program project1;
{$mode objfpc}{$H+}
uses
{$IFDEF UNIX}{$IFDEF UseCThreads}
cthreads,
{$ENDIF}{$ENDIF}
Interfaces, // this includes the LCL widgetset
Forms, Unit1
{ you can add units after this };
{$R *.res}
begin
RequireDerivedFormResource := True;
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.Run;
end.

View File

@ -0,0 +1,169 @@
object Form1: TForm1
Left = 280
Height = 418
Top = 130
Width = 435
Caption = 'Form1'
ClientHeight = 418
ClientWidth = 435
OnCreate = FormCreate
LCLVersion = '1.9.0.0'
object RadioGroup1: TRadioGroup
Left = 13
Height = 330
Top = 74
Width = 195
Anchors = [akTop, akLeft, akBottom]
AutoFill = True
Caption = 'Formula'
ChildSizing.LeftRightSpacing = 6
ChildSizing.EnlargeHorizontal = crsHomogenousChildResize
ChildSizing.EnlargeVertical = crsHomogenousChildResize
ChildSizing.ShrinkHorizontal = crsScaleChilds
ChildSizing.ShrinkVertical = crsScaleChilds
ChildSizing.Layout = cclLeftToRightThenTopToBottom
ChildSizing.ControlsPerLine = 1
ClientHeight = 310
ClientWidth = 191
ItemIndex = 0
Items.Strings = (
'H'
'H+'
'2H+'
'O--'
'H2O'
'C3H7OH'
'(CH3)3COH'
'2H+ + O--'
'H + Cl -> HCl'
'H + Cl --> HCl'
'2 H+ + O-- <-> H2O'
'2 H+ + O-- <--> H2O'
'H2O <- 2H + O'
'H2O <-- 2H + O'
)
OnClick = RadioGroup1Click
TabOrder = 0
end
object CbDefaultFontSize: TCheckBox
Left = 335
Height = 19
Top = 354
Width = 83
Caption = 'Default font'
Checked = True
OnChange = CbDefaultFontSizeChange
State = cbChecked
TabOrder = 1
end
object RadioGroup2: TRadioGroup
Left = 224
Height = 142
Top = 74
Width = 185
AutoFill = True
Caption = 'Arrow'
ChildSizing.LeftRightSpacing = 6
ChildSizing.EnlargeHorizontal = crsHomogenousChildResize
ChildSizing.EnlargeVertical = crsHomogenousChildResize
ChildSizing.ShrinkHorizontal = crsScaleChilds
ChildSizing.ShrinkVertical = crsScaleChilds
ChildSizing.Layout = cclLeftToRightThenTopToBottom
ChildSizing.ControlsPerLine = 1
ClientHeight = 122
ClientWidth = 181
ItemIndex = 0
Items.Strings = (
'ASCII single'
'ASCII double'
'UTF8 '
'UTF8 single'
'UTF8 double'
'UTF8 half'
)
OnClick = RadioGroup2Click
TabOrder = 2
end
object RadioGroup3: TRadioGroup
Left = 224
Height = 43
Top = 232
Width = 185
AutoFill = True
Caption = 'Alignment'
ChildSizing.LeftRightSpacing = 6
ChildSizing.EnlargeHorizontal = crsHomogenousChildResize
ChildSizing.EnlargeVertical = crsHomogenousChildResize
ChildSizing.ShrinkHorizontal = crsScaleChilds
ChildSizing.ShrinkVertical = crsScaleChilds
ChildSizing.Layout = cclLeftToRightThenTopToBottom
ChildSizing.ControlsPerLine = 3
ClientHeight = 23
ClientWidth = 181
Columns = 3
ItemIndex = 0
Items.Strings = (
'left'
'center'
'right'
)
OnClick = RadioGroup3Click
TabOrder = 3
end
object CheckBox2: TCheckBox
Left = 335
Height = 19
Top = 330
Width = 65
Caption = 'Autosize'
OnChange = CheckBox2Change
TabOrder = 4
end
object RadioGroup4: TRadioGroup
Left = 224
Height = 88
Top = 298
Width = 97
AutoFill = True
Caption = 'Layout'
ChildSizing.LeftRightSpacing = 6
ChildSizing.EnlargeHorizontal = crsHomogenousChildResize
ChildSizing.EnlargeVertical = crsHomogenousChildResize
ChildSizing.ShrinkHorizontal = crsScaleChilds
ChildSizing.ShrinkVertical = crsScaleChilds
ChildSizing.Layout = cclLeftToRightThenTopToBottom
ChildSizing.ControlsPerLine = 1
ClientHeight = 68
ClientWidth = 93
ItemIndex = 0
Items.Strings = (
'tlTop'
'tlCenter'
'tlBottom'
)
OnClick = RadioGroup4Click
TabOrder = 5
end
object CheckBox3: TCheckBox
Left = 335
Height = 19
Top = 306
Width = 62
Caption = 'Enabled'
Checked = True
OnChange = CheckBox3Change
State = cbChecked
TabOrder = 6
end
object SpinEdit1: TSpinEdit
Left = 352
Height = 23
Top = 381
Width = 50
Alignment = taRightJustify
OnChange = SpinEdit1Change
TabOrder = 7
Value = 20
Visible = False
end
end

View File

@ -0,0 +1,124 @@
unit Unit1;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls,
ExtCtrls, Spin, ChemText;
type
{ TForm1 }
TForm1 = class(TForm)
CbDefaultFontSize: TCheckBox;
CheckBox2: TCheckBox;
CheckBox3: TCheckBox;
RadioGroup1: TRadioGroup;
RadioGroup2: TRadioGroup;
RadioGroup3: TRadioGroup;
RadioGroup4: TRadioGroup;
SpinEdit1: TSpinEdit;
procedure CbDefaultFontSizeChange(Sender: TObject);
procedure CheckBox2Change(Sender: TObject);
procedure CheckBox3Change(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure RadioGroup1Click(Sender: TObject);
procedure RadioGroup2Click(Sender: TObject);
procedure RadioGroup3Click(Sender: TObject);
procedure RadioGroup4Click(Sender: TObject);
procedure SpinEdit1Change(Sender: TObject);
private
ChemLabel: TChemLabel;
public
end;
var
Form1: TForm1;
implementation
{$R *.lfm}
{ TForm1 }
procedure TForm1.CbDefaultFontSizeChange(Sender: TObject);
begin
if CbDefaultFontSize.Checked then
Chemlabel.Font.Size := 0
else
ChemLabel.Font.Size := SpinEdit1.Value;
SpinEdit1.Visible := not CbDefaultFontSize.Checked;
end;
procedure TForm1.CheckBox2Change(Sender: TObject);
begin
ChemLabel.AutoSize := Checkbox2.Checked;
if not ChemLabel.AutoSize then begin
ChemLabel.Width := Width - 2*ChemLabel.Left;
ChemLabel.Height := Radiogroup1.Top - 8 - 8;
end;
end;
procedure TForm1.CheckBox3Change(Sender: TObject);
begin
ChemLabel.Enabled := Checkbox3.Checked;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
ChemLabel := TChemLabel.Create(self);
ChemLabel.Parent := self;
ChemLabel.Left := 8;
ChemLabel.Top := 8;
ChemLabel.AutoSize := false;
Chemlabel.Height := 50;
ChemLabel.Width := ClientWidth - 2*Chemlabel.Left;
// ChemLabel.Anchors := [akLeft, akRight, akTop];
ChemLabel.Color := clWindow;
RadioGroup1Click(nil);
RadioGroup2Click(nil);
end;
procedure TForm1.RadioGroup1Click(Sender: TObject);
begin
Chemlabel.Caption := RadioGroup1.Items[Radiogroup1.ItemIndex];
end;
procedure TForm1.RadioGroup2Click(Sender: TObject);
begin
ChemLabel.Arrow := TChemArrow(RadioGroup2.ItemIndex);
end;
procedure TForm1.RadioGroup3Click(Sender: TObject);
begin
case Radiogroup3.ItemIndex of
0: ChemLabel.Alignment := taLeftJustify;
1: ChemLabel.Alignment := taCenter;
2: Chemlabel.Alignment := taRightJustify;
end;
end;
procedure TForm1.RadioGroup4Click(Sender: TObject);
begin
case Radiogroup4.ItemIndex of
0: ChemLabel.Layout := tlTop;
1: Chemlabel.Layout := tlCenter;
2: Chemlabel.Layout := tlBottom;
end;
end;
procedure TForm1.SpinEdit1Change(Sender: TObject);
begin
if not CbDefaultFontSize.Checked then
Chemlabel.Font.Size := SpinEdit1.Value;
ChemLabel.Invalidate;
end;
end.

View File

@ -0,0 +1,40 @@
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<Package Version="4">
<PathDelim Value="\"/>
<Name Value="laz_chemtext"/>
<Type Value="RunAndDesignTime"/>
<CompilerOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<SearchPaths>
<OtherUnitFiles Value="source"/>
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)\"/>
</SearchPaths>
</CompilerOptions>
<Description Value="A label showing chemical formulas with sub- and superscripts and reaction arrows."/>
<License Value="LGPL with linking exception (like Lazarus)"/>
<Version Minor="1"/>
<Files Count="1">
<Item1>
<Filename Value="source\chemtext.pas"/>
<HasRegisterProc Value="True"/>
<UnitName Value="chemtext"/>
</Item1>
</Files>
<RequiredPkgs Count="2">
<Item1>
<PackageName Value="LCL"/>
</Item1>
<Item2>
<PackageName Value="FCL"/>
</Item2>
</RequiredPkgs>
<UsageOptions>
<UnitPath Value="$(PkgOutDir)"/>
</UsageOptions>
<PublishOptions>
<Version Value="2"/>
</PublishOptions>
</Package>
</CONFIG>

View File

@ -0,0 +1,22 @@
{ This file was automatically created by Lazarus. Do not edit!
This source is only used to compile and install the package.
}
unit laz_chemtext;
{$warn 5023 off : no warning about unused units}
interface
uses
chemtext, LazarusPackageIntf;
implementation
procedure Register;
begin
RegisterUnit('chemtext', @chemtext.Register);
end;
initialization
RegisterPackage('laz_chemtext', @Register);
end.

View File

@ -0,0 +1,420 @@
(*******************************************************************************
chemtext.pas
Motivated by chemtxt written by Patrick Spanel (Patrik.Spanel@jh-inst.cas.cz)
Download his version from
http://torry.net/vcl/science/packs/ChemText12.zip
or
http://delphi.icm.edu.pl/ftp/d10free/chemtxt.zip
Adapted to Lazarus and extended by Werner Pamler
License:
LGPL with linking exception (like Lazarus)
See the file COPYING.modifiedLGPL.txt, included in the Lazarus distribution,
for details about the license.
*******************************************************************************)
unit chemtext;
interface
uses
LclIntf, LCLType, Types, SysUtils, Classes, Graphics, StdCtrls;
type
TChemArrow = (
caASCIISingle, caASCIIDouble, caUTF8, caUTF8Single, caUTF8Double, caUTF8Half
);
TChemLabel = class(TCustomLabel)
private
FArrow: TChemArrow;
procedure SetArrow(const AValue: TChemArrow);
protected
procedure CalculatePreferredSize(var PreferredWidth, PreferredHeight: integer;
{%H-}WithThemeSpace: Boolean); override;
procedure CalculateSize(out NeededWidth, NeededHeight: Integer);
procedure DoMeasureTextPosition(var TextTop: integer;
var TextLeft: integer); override;
public
constructor Create(AOwner: TComponent); override;
procedure Paint; override;
published
property Arrow: TChemArrow read FArrow write SetArrow default caASCIISingle;
property Align;
property Alignment;
property Anchors;
property AutoSize;
// property BidiMode;
property BorderSpacing;
property Caption;
property Color;
property Constraints;
property DragCursor;
property DragKind;
property DragMode;
property Enabled;
property FocusControl;
property Font;
property Layout;
// property ParentBidiMode;
property ParentColor;
property ParentFont;
property ParentShowHint;
property PopupMenu;
// property ShowAccelChar;
property ShowHint;
property Transparent;
property Visible;
// property WordWrap;
property OnChangeBounds;
property OnClick;
property OnContextPopup;
property OnDblClick;
property OnDragDrop;
property OnDragOver;
property OnEndDrag;
property OnMouseDown;
property OnMouseEnter;
property OnMouseLeave;
property OnMouseMove;
property OnMouseUp;
property OnMouseWheel;
property OnMouseWheelDown;
property OnMouseWheelUp;
property OnResize;
property OnStartDrag;
// property OptimalFill;
end;
{ The following rotuines can be used in an event handler, for example in
OnDrawDataCell of DBGrid:
procedure TForm1.DBGrid1DrawDataCell(Sender: TObject;
const Rect: TRect; Field: TField; State:
TGridDrawState);
begin
if Assigned(Field) then
ChemTextOut((Sender as TDBGrid).Canvas, Rect, Rect.Left,
Rect.Top, Field.DisplayText);
end;
}
function ChemTextOut(ACanvas: TCanvas; X, Y: integer;
const AText:String; Arrow: TChemArrow = caAsciiSingle; Measure: Boolean = false): TSize;
function ChemTextHeight(ACanvas: TCanvas; const AText: String;
Arrow: TChemArrow = caAsciiSingle): Integer;
function ChemTextWidth(ACanvas: TCanvas; const AText: String;
Arrow: TChemArrow = caAsciiSingle): Integer;
function ChemTextExtent(ACanvas: TCanvas; const AText: String;
Arrow: TChemArrow = caAsciiSingle): TSize;
procedure Register;
implementation
{$R chemtext.res}
uses
Themes, Math;
type
TArrowDir = (adLeft, adRight, adBoth);
const
SUBFONT_SIZE_MULTIPLIER = 75;
SUBFONT_OFFSET_MULTIPLIER = 50;
SUBFONT_DIVISOR = 100;
ARROW_LINE: array[boolean] of char = ('-', '=');
function ChemTextHeight(ACanvas: TCanvas; const AText: String;
Arrow: TChemArrow = caAsciiSingle): Integer;
var
ex: TSize;
begin
ex := ChemTextExtent(ACanvas, AText, Arrow);
Result := ex.CY;
end;
function ChemTextWidth(ACanvas: TCanvas; const AText: String;
Arrow: TChemArrow = caAsciiSingle): Integer;
var
ex: TSize;
begin
ex := ChemTextExtent(ACanvas, AText, Arrow);
Result := ex.CX;
end;
function ChemTextExtent(ACanvas: TCanvas; const AText: String;
Arrow: TChemArrow = caAsciiSingle): TSize;
begin
Result := ChemTextOut(ACanvas, 0, 0, AText, Arrow, true);
end;
function ChemTextOut(ACanvas: TCanvas; X, Y:integer; const AText: String;
Arrow: TChemArrow = caAsciiSingle; Measure: Boolean = false): TSize;
var
lTextHeight: Integer;
procedure DrawSub(var x: Integer; y: Integer; const s: String);
var
h: Integer;
yoff: Integer;
begin
h := ACanvas.Font.Height;
try
ACanvas.Font.Height := MulDiv(h, SUBFONT_SIZE_MULTIPLIER, SUBFONT_DIVISOR);
yoff := abs(MulDiv(h, SUBFONT_OFFSET_MULTIPLIER, SUBFONT_DIVISOR));
if not Measure then
ACanvas.TextOut(x, y + yoff, s);
x := x + ACanvas.TextWidth(s);
lTextHeight := Max(lTextHeight, yoff + ACanvas.TextHeight('0'));
finally
ACanvas.Font.Height := h;
end;
end;
procedure DrawSup(var x: Integer; y: Integer; const s: String);
var
h: Integer;
begin
h := ACanvas.Font.Height;
try
ACanvas.Font.Height := MulDiv(h, SUBFONT_SIZE_MULTIPLIER, SUBFONT_DIVISOR);
if not Measure then
ACanvas.TextOut(x, y - 1, s);
inc(x, ACanvas.TextWidth(s));
finally
ACanvas.Font.Height := h;
end;
end;
procedure DrawNormal(var x: Integer; y: Integer; const s: String);
begin
if not Measure then
ACanvas.TextOut(x, y, s);
inc(x, ACanvas.TextWidth(s));
end;
procedure DrawArrow(var x: Integer; y: Integer; ADir: TArrowDir;
ALen: Integer);
const
ARROWS: array[TChemArrow, TArrowDir] of string = (
('<%s', '%s>', '<%s>'), // caAsciiSingle
('<%s', '%s>', '<%s>'), // caAsciiDouble
(#$E2#$86#$90, #$E2#$86#$92, #$E2#$87#$8C), // caUTF8
(#$E2#$86#$90, #$E2#$86#$92, #$E2#$86#$94), // caUTF8Single
(#$E2#$87#$90, #$E2#$87#$92, #$E2#$87#$94), // caUTF8Double
(#$E2#$86#$BD, #$E2#$87#$80, #$E2#$87#$8C) // caUTF8Half
);
var
i: Integer;
s: String;
begin
if Arrow in [caASCIISingle, caASCIIDouble] then
begin
SetLength(s, ALen);
for i:=1 to ALen do s[i] := ARROW_LINE[Arrow=caAsciiDouble];
s := Format(ARROWS[Arrow, ADir], [s]);
end else
s := ARROWS[Arrow, ADir];
if not Measure then
ACanvas.TextOut(x, y, s);
inc(x, ACanvas.TextWidth(s));
end;
var
x0: Integer;
i, j: integer;
s: string;
subNos: boolean; // "subscript numbers"
begin
Result := Size(0, 0);
if AText = '' then
exit;
with ACanvas do begin
if Font.Size = 0 then
Font.Size := GetFontData(Font.Reference.Handle).Height;
lTextHeight := TextHeight('Tg');
x0 := X;
subNos := false;
i := 1;
while i <= Length(AText) do begin
case AText[i] of
'0'..'9':
begin
s := AText[i];
j := i+1;
while (j <= Length(AText)) and (AText[j] in ['0'..'9']) do
inc(j);
s := Copy(AText, i, j-i);
if subNos then
DrawSub(X, Y, s)
else
DrawNormal(X, Y, s);
i := j-1;
subNos := false;
end;
'<':
begin
j := i+1;
while (j <= Length(AText)) and (AText[j] in ['-', '=']) do
inc(j);
if (AText[j] = '>') then
DrawArrow(X, Y, adBoth, j-i-1)
else begin
DrawArrow(X, Y, adLeft, j-i-1);
dec(j);
end;
i := j;
subNos := false;
end;
'+':
begin
if (i > 1) and (AText[i-1] in ['A'..'Z','a'..'z','0'..'9','+',')']) then
DrawSup(X, Y, '+')
else
DrawNormal(X, Y, '+');
subNos := false;
end;
'-':
begin
j := i+1;
while (j <= Length(AText)) and (AText[j] = '-') do inc(j);
if (j <= Length(AText)) and (AText[j] = '>') then // Arrow
begin
DrawArrow(X, y, adRight, j-i);
i := j;
end else // superscript -
DrawSup(X, Y, '-');
subNos := false;
end;
else
begin
j := i+1;
while (j <= Length(AText)) and not (AText[j] in ['0'..'9', '+', '-', '<']) do
inc(j);
s := Copy(AText, i, j-i);
DrawNormal(X, Y, s);
i := j-1;
subNos := AText[i] in ['A'..'Z', 'a'..'z', ')'];
// In these cases a subsequent number will be subscripted.
end;
end;
inc(i);
end;
end;
Result.CX := X - x0;
Result.CY := lTextHeight;
end;
{ TChemText }
constructor TChemLabel.Create(AOwner: TComponent);
begin
inherited;
end;
procedure TChemLabel.CalculatePreferredSize(
var PreferredWidth, PreferredHeight: integer; WithThemeSpace: Boolean);
begin
CalculateSize(PreferredWidth, PreferredHeight);
end;
procedure TChemlabel.CalculateSize(out NeededWidth, NeededHeight: Integer);
var
ex: TSize;
begin
Canvas.Font := Font;
ex := ChemTextExtent(Canvas, Caption, FArrow);
NeededWidth := ex.CX;
NeededHeight := ex.CY;
end;
procedure TChemLabel.DoMeasureTextPosition(var TextTop: integer;
var TextLeft: integer);
var
lTextHeight: integer;
lTextWidth: integer;
begin
TextLeft := 0;
TextTop := 0;
if (Alignment <> taLeftJustify) or (Layout <> tlTop) then begin
CalculateSize(lTextWidth, lTextHeight);
case Alignment of
taCenter : TextLeft := (Width - lTextWidth) div 2;
taRightJustify : TextLeft := Width - lTextWidth;
end;
case Layout of
tlCenter : TextTop := (Height - lTextHeight) div 2;
tlBottom : TextTop := Height - lTextHeight;
end;
end;
end;
procedure TChemLabel.Paint;
var
textTop: Integer = 0;
textLeft: Integer = 0;
oldFontColor: TColor;
labelText: String;
begin
if not Transparent then
begin
Canvas.Brush.Color := Self.Color;
Canvas.Brush.Style := bsSolid;
Canvas.FillRect(ClientRect);
end;
Canvas.Brush.Style := bsClear;
Canvas.Font := Font;
labelText := Caption;
DoMeasureTextPosition(textTop, textLeft);
oldFontColor := Font.Color;
if not IsEnabled then
if ThemeServices.ThemesEnabled then
Canvas.Font.Color := clGrayText
else
begin
Canvas.Font.Color := clBtnHighlight;
ChemTextOut(Canvas, textLeft + 1, textTop + 1, labelText, FArrow);
Canvas.Font.Color := clBtnShadow;
end;
ChemTextOut(Canvas, textLeft, textTop, labelText, FArrow);
Canvas.Font.Color := oldFontColor;
end;
procedure TChemLabel.SetArrow(const AValue: TChemArrow);
begin
if AValue = FArrow then
exit;
FArrow := AValue;
Invalidate;
end;
procedure Register;
begin
RegisterComponents('Misc', [TChemlabel]);
end;
end.

Binary file not shown.