unit ChatEdit;
interface
uses
Winapi.Windows,
Winapi.Messages, System.SysUtils, System.Variants,
System.Classes,
Vcl.Graphics,
Vcl.StdCtrls,
Winapi.CommCtrl,
Vcl.Controls,
Vcl.Forms,
Vcl.Dialogs, Contnrs,
Vcl.Themes,
Vcl.OleCtrls,
Vcl.Menus,
Vcl.ExtCtrls, mmSystem;
type
TMyAlign = (myleft, mycenter, myright);
TBBCode = (BBcolor, BBsize, BBfont, BBb, BBi, BBright, BBcenter, BBbutton,
BBimg, BBcolorEnd, BBsizeEnd, BBfontEnd, BBbEnd, BBiEnd, BBrightEnd,
BBcenterEnd, BBbuttonEnd, BBimgEnd, sLinebreak);
TBBCodes =
class(TObject)
from, end_id: Integer;
Typ: TBBCode;
Value:
string;
end;
TEvents =
array of TBBCodes;
TChatEdit =
class(TCustomControl)
private
FFont: TFont;
FLines: TStringList;
Special_Objects: TObjectList;
FScrollbar: TScrollBar;
current_Height: Integer;
procedure setLines(Value: TStringList);
procedure setFont(Value: TFont);
procedure setScrollbar(Value: TScrollBar);
procedure onScrollbarChange(Sender: TObject);
function giveNextChars(Text:
String; id: Integer; id_to: Integer):
String;
function findUntil(Input:
String; id: Integer; Find:
String): Integer;
function explode(Input:
String; Splitter:
String): TStringList;
function StrtoCol(Text:
String): TColor;
function getTextWidth(Text:
string): Integer;
function searchforBBCodes(Text:
String): TEvents;
function createTBBCodes(from: Integer; end_id: Integer; Typ: TBBCode;
Value:
String): TBBCodes;
{ Private-Deklarationen }
protected
procedure Paint;
override;
{ Protected-Deklarationen }
public
constructor Create(AOwner: TComponent);
override;
destructor Destroy;
override;
procedure Clear;
procedure AddLine(Text:
String);
function Count: Integer;
{ Public-Deklarationen }
published
property OnClick;
property OnContextPopup;
property OnDblClick;
property OnDragDrop;
property OnDragOver;
property OnEndDock;
property OnEndDrag;
property OnEnter;
property OnExit;
property OnGesture;
property OnKeyDown;
property OnKeyPress;
property OnKeyUp;
property OnMouseActivate;
property OnMouseDown;
property OnMouseEnter;
property OnMouseLeave;
property OnMouseMove;
property OnMouseUp;
property Font: TFont
read FFont
write setFont;
property Lines: TStringList
read FLines
write setLines;
property Scrollbar: TScrollBar
read FScrollbar
write setScrollbar;
property Anchors;
property Align;
property Color;
property Constraints;
property Ctl3D;
property PopupMenu;
{ Published-Deklarationen }
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('
Chat', [TChatEdit]);
end;
function CaseStringOf(
const Value:
string;
const Args:
array of string)
: Integer;
begin
for Result := 0
to High(Args)
do
if Args[Result] = Value
then
Exit;
Result := -1;
end;
constructor TChatEdit.Create(AOwner: TComponent);
var
Pfad:
String;
begin
inherited Create(AOwner);
FLines := TStringList.Create;
FFont := TFont.Create;
Special_Objects := TObjectList.Create;
Pfad := ExtractFilePath(ParamStr(0));
FScrollbar := TScrollBar.Create(Self);
FScrollbar.Parent := Self;
FScrollbar.Kind := sbVertical;
FScrollbar.PageSize := FScrollbar.Max;
FScrollbar.Top := 1;
FScrollbar.OnChange := onScrollbarChange;
FLines.Add(Self.GetNamePath);
end;
function TChatEdit.createTBBCodes(from: Integer; end_id: Integer; Typ: TBBCode;
Value:
String): TBBCodes;
begin
Result := TBBCodes.Create;
Result.from := from;
Result.end_id := end_id;
Result.Typ := Typ;
Result.Value := Value;
end;
function TChatEdit.searchforBBCodes(Text:
String): TEvents;
var
zahl, search_begin, search_end, this_height: Integer;
gesamt:
String;
BB: TStringList;
Events: TObjectList;
begin
Events := TObjectList.Create;
zahl := 1;
// Intialisierung
this_height := 0;
while zahl < Length(Text)
do
begin
if Text[zahl] = '
&'
then
begin
search_begin := zahl;
search_end := findUntil(Text, zahl, '
');
gesamt := lowercase(giveNextChars(Text, zahl, search_end));
search_end := search_end + 2;
Events.Add(createTBBCodes(zahl, search_end, sLinebreak, '
'));
zahl := search_begin + Length(gesamt);
end;
if Text[zahl] = '
['
then
begin
search_begin := zahl;
zahl := zahl + 1;
if Text[zahl] <> '
/'
then
begin
// Bei Öffnung
search_end := findUntil(Text, zahl, '
]');
gesamt := lowercase(giveNextChars(Text, zahl, search_end));
BB := explode(gesamt, '
=');
search_end := search_end + 2;
case CaseStringOf(BB[0], ['
color', '
size', '
font', '
b', '
i', '
right',
'
center', '
button', '
img'])
of
0:
begin
if BB.Count = 2
then
Events.Add(createTBBCodes(search_begin, search_end,
BBcolor, BB[1]));
end;
1:
begin
if BB.Count = 2
then
Events.Add(createTBBCodes(search_begin, search_end,
BBsize, BB[1]));
if this_height < Canvas.TextHeight('
h')
then
this_height := Canvas.TextHeight('
h');
end;
2:
begin
if (BB.Count = 2)
and (Screen.Fonts.IndexOf(BB[1]) <> -1)
then
Events.Add(createTBBCodes(search_begin, search_end,
BBfont, BB[1]));
end;
3:
begin
Events.Add(createTBBCodes(search_begin, search_end, BBb, '
'));
end;
4:
begin
Events.Add(createTBBCodes(search_begin, search_end, BBi, '
'));
end;
5:
begin
Events.Add(createTBBCodes(search_begin, search_end, BBright, '
'));
end;
6:
begin
Events.Add(createTBBCodes(search_begin, search_end,
BBcenter, '
'));
end;
end;
end
else
begin
// Bei Schließung
search_end := findUntil(Text, zahl, '
]') - 1;
gesamt := lowercase(giveNextChars(Text, zahl + 1, search_end));
search_end := search_end + 3;
case CaseStringOf(gesamt, ['
color', '
size', '
font', '
b', '
i', '
right',
'
center', '
button', '
img'])
of
0:
Events.Add(createTBBCodes(search_begin, search_end,
BBcolorEnd, '
'));
1:
Events.Add(createTBBCodes(search_begin, search_end, BBsizeEnd, '
'));
2:
Events.Add(createTBBCodes(search_begin, search_end, BBfontEnd, '
'));
3:
Events.Add(createTBBCodes(search_begin, search_end, BBbEnd, '
'));
4:
Events.Add(createTBBCodes(search_begin, search_end, BBiEnd, '
'));
5:
Events.Add(createTBBCodes(search_begin, search_end,
BBrightEnd, '
'));
6:
Events.Add(createTBBCodes(search_begin, search_end,
BBcenterEnd, '
'));
end;
gesamt := '
/' + gesamt;
end;
zahl := search_begin + 1 + Length(gesamt);
gesamt := '
';
end;
zahl := zahl + 1;
end;
SetLength(Result, Events.Count);
for zahl := 0
to Events.Count - 1
do
begin
Result[zahl] := TBBCodes(Events[zahl]);
end;
end;
function TChatEdit.StrtoCol(Text:
string): TColor;
begin
case CaseStringOf(Text, ['
red', '
yellow', '
green', '
blue', '
white', '
black',
'
brown', '
silver'])
of
0:
Result := clRed;
1:
Result := clYellow;
2:
Result := clGreen;
3:
Result := clHotLight;
4:
Result := clWhite;
5:
Result := clBlack;
6:
Result := clOlive;
7:
Result := clSilver;
else
Result := clBlack;
end;
end;
function TChatEdit.findUntil(Input:
string; id: Integer; Find:
string): Integer;
var
anfang: Integer;
begin
anfang := id;
Result := -1;
while Length(Input) >= id
do
begin
if Find = Input[id]
then
begin
Result := (id - 1) - anfang;
break;
end;
id := id + 1;
end;
end;
function TChatEdit.explode(Input:
string; Splitter:
string): TStringList;
var
zahl, last_Split: Integer;
begin
zahl := 1;
last_Split := 1;
Result := TStringList.Create;
while zahl < Length(Input)
do
begin
if Input[zahl] = Splitter
then
begin
if zahl + 1 < Length(Input)
then
begin
Result.Add(giveNextChars(Input, last_Split, zahl - 2));
last_Split := zahl;
end;
end;
zahl := zahl + 1;
end;
if (last_Split < zahl)
and (Result.Count > 0)
then
Result.Add(giveNextChars(Input, last_Split + 1, (zahl) - (last_Split + 1)));
if Result.Count = 0
then
Result.Add(Input);
end;
function TChatEdit.giveNextChars(Text:
String; id: Integer;
id_to: Integer):
String;
var
gesamt: Integer;
begin
Result := '
';
gesamt := id + id_to;
for id := id
to gesamt
do
Result := Result + Text[id];
end;
procedure TChatEdit.onScrollbarChange(Sender: TObject);
begin
Paint;
end;
destructor TChatEdit.Destroy;
begin
FFont.Destroy;
Special_Objects.Free;
FLines.Free;
FScrollbar.Free;
inherited Destroy;
end;
procedure TChatEdit.setFont(Value: TFont);
begin
FFont.Assign(Value);
Canvas.Font.Assign(Value);
Paint;
end;
procedure TChatEdit.setLines(Value: TStringList);
begin
FLines.Assign(Value);
Paint;
end;
procedure TChatEdit.setScrollbar(Value: TScrollBar);
begin
FScrollbar.Assign(Value);
Paint;
end;
function TChatEdit.getTextWidth(Text:
string): Integer;
var
zahl, active_Event_Index: Integer;
Events: TEvents;
begin
Events := searchforBBCodes(Text);
active_Event_Index := 0;
Result := 0;
zahl := 1;
if Length(Events) < 0
then
while zahl < Length(Text)
do
begin
if Events[active_Event_Index].from = zahl
then
begin
if Events[active_Event_Index].Typ = sLinebreak
then
break;
if (Events[active_Event_Index].Typ = BBfont)
and
(Screen.Fonts.IndexOf(Events[active_Event_Index].Value) <> -1)
then
Canvas.Font.
Name := Events[active_Event_Index].Value;
if Events[active_Event_Index].Typ = BBfontEnd
then
Canvas.Font.
Name := FFont.
Name;
if Events[active_Event_Index].Typ = BBsize
then
Canvas.Font.Size := StrtoInt(Events[active_Event_Index].Value);
if Events[active_Event_Index].Typ = BBsizeEnd
then
Canvas.Font.Size := FFont.Size;
if active_Event_Index < Length(Events) - 1
then
active_Event_Index := active_Event_Index + 1;
zahl := zahl + Events[active_Event_Index].end_id;
end;
Result := Result + Canvas.TextWidth(Text[zahl]);
zahl := zahl + 1;
end
else
Result := Canvas.TextWidth(Text);
end;
procedure TChatEdit.Paint;
var
zahl, i, current_width, this_height, this_width, Event_index: Integer;
MyAlgin: TMyAlign;
Events: TEvents;
Linebreak: Boolean;
begin
inherited;
MyAlgin := myleft;
Linebreak := false;
this_height := 0;
// Scrollbar
FScrollbar.left := Self.Width - FScrollbar.Width;
FScrollbar.height := Self.height - 2;
// Rahmen zeichnen
Canvas.Brush.Color := clWhite;
Canvas.Rectangle(0, 0, Self.Width - (FScrollbar.Width + 1), Self.height);
// Für Text zeichnen vorbereiten
Canvas.Brush.Style := bsClear;
Canvas.Font := FFont;
// Setzen der Zähler werte
current_Height := 0;
current_width := 2;
// Render
for zahl := 0
to FLines.Count - 1
do
begin
// Setzen des Zählers auf 1 da der String erst beim zweitem Anfängt
i := 1;
Event_index := 0;
// Nach BBCodes suchen
Events := searchforBBCodes(FLines[zahl]);
// Überprüfung der Ziffern
while i < Length(FLines[zahl])
do
begin
if i = Events[Event_index].from
then
begin
case Events[Event_index].Typ
of
BBcolor:
Canvas.Font.Color := StrtoCol(Events[Event_index].Value);
BBsize:
if Events[Event_index].Value <> '
'
then
Canvas.Font.Size := StrtoInt(Events[Event_index].Value);
BBfont:
if Screen.Fonts.IndexOf(Events[Event_index].Value) <> -1
then
Canvas.Font.
Name := FFont.
Name;
BBb:
Canvas.Font.Style := Canvas.Font.Style + [fsBold];
BBi:
Canvas.Font.Style := Canvas.Font.Style + [fsItalic];
BBright:
MyAlgin := myright;
BBcenter:
MyAlgin := mycenter;
BBbutton:
;
BBimg:
;
BBcolorEnd:
Canvas.Font.Color := FFont.Color;
BBsizeEnd:
Canvas.Font.Size := FFont.Size;
BBfontEnd:
Canvas.Font.
Name := FFont.
Name;
BBbEnd:
Canvas.Font.Style := Canvas.Font.Style - [fsBold];
BBiEnd:
Canvas.Font.Style := Canvas.Font.Style - [fsItalic];
BBrightEnd:
begin
MyAlgin := myleft;
current_width := 2;
end;
BBcenterEnd:
begin
MyAlgin := myleft;
current_width := 2;
end;
BBbuttonEnd:
;
BBimgEnd:
;
sLinebreak:
begin
Linebreak := true;
end;
end;
i := i + Events[Event_index].end_id;
if Event_index < Length(Events) - 1
then
Event_index := Event_index + 1;
end;
// algin
case MyAlgin
of
mycenter:
begin
this_width := getTextWidth(giveNextChars(FLines[zahl], i + 1,
Length(FLines[zahl])));
current_width := (Self.Width - FScrollbar.Width + 1)
div 2 -
this_width
div 2;
end;
myright:
begin
this_width := getTextWidth(giveNextChars(FLines[zahl], i + 1,
Length(FLines[zahl]) - i));
current_width := (Self.Width - (FScrollbar.Width + 1)) - this_width;
end;
end;
if this_height < Canvas.TextHeight('
H')
then
this_height := Canvas.TextHeight('
H');
if Linebreak
then
begin
current_width := 2;
current_Height := current_Height + this_height;
this_height := Canvas.TextHeight('
H');
Linebreak := false;
end;
// TextZeichnen
if FLines[zahl][i] <> '
]'
then
begin
Canvas.TextOut(current_width, (current_Height - FScrollbar.Position) +
this_height - (Canvas.TextHeight('
h') + 2), FLines[zahl][i]);
current_width := current_width + Canvas.TextWidth(FLines[zahl][i]);
end;
i := i + 1;
end;
// Zurücksetzung
Canvas.Font.Color := FFont.Color;
Canvas.Font.Size := FFont.Size;
Canvas.Font.
Name := FFont.
Name;
Canvas.Font.Style := Canvas.Font.Style - [fsBold];
Canvas.Font.Style := Canvas.Font.Style - [fsItalic];
MyAlgin := myleft;
current_width := 2;
current_Height := current_Height + this_height;
end;
Canvas.Font.Color := FFont.Color;
Canvas.Font.
Name := FFont.
Name;
Canvas.Font.Style := FFont.Style;
Canvas.Font.Size := FFont.Size;
if Self.height < current_Height
then
begin
FScrollbar.Enabled := true;
FScrollbar.Max := current_Height;
FScrollbar.PageSize := Self.height;
end
else
begin
FScrollbar.Enabled := false;
end;
end;
function TChatEdit.Count: Integer;
begin
Result := FLines.Count;
end;
procedure TChatEdit.Clear;
begin
FLines.Clear;
end;
procedure TChatEdit.AddLine(Text:
string);
begin
if FLines[0] = '
'
then
FLines[0] := Text
else
FLines.Add(Text);
Paint;
if Self.height < current_Height
then
FScrollbar.Position := FScrollbar.Max - FScrollbar.PageSize;
Paint;
end;
end.