// Falls man auf
einer Zeichenfläche (TCanvas)
einen längeren Text
type
TForm1 = class(TForm)
Button1: TButton;
Button2: TButton;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
private
{ Private-Deklarationen }
public
{ Public-Deklarationen }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
type
T3Char = array [0 .. 2] of Char;
var
afz: T3Char = (#132, #147, #148);
Ausnahmen, BreakText: TStringList;
const
vok = ['a', 'e', 'i', 'o', 'u', 'y', 'ä', 'ö', 'ü', '-'];
procedure Vorbereitung(aTxt: String; Cnv: TCanvas; Breite: Word;
Silbentrennung, Ueberhang, Erweitert: Boolean);
var
p, m: PChar;
wdt, akt, mnz, p13, leer: Integer;
s, s2: String;
procedure Ersatz;
var
i: Integer;
begin
for i := 0 to 2 do
aTxt := StringReplace(aTxt, afz[i], '"', [rfReplaceall]);
end;
function dritte(i: Integer; const ss: string): Boolean;
var
x: Integer;
begin
for x := i - 1 downto 1 do
if charinset(ss[i], vok) then
begin
result := true;
exit;
end;
result := false;
end;
function finden(const lg, ss: string): Integer;
var
w, i, j: Integer;
begin
result := 0;
i := 1;
j := 0;
for w := 1 to length(lg) do
begin
if lg[w] = ss[w + j] then
inc(i)
else if ss[w + j] = '-' then
begin
inc(i, 2);
inc(j);
end;
end;
for w := i downto 2 do
if ss[w] = '-' then
begin
result := w;
break;
end;
end;
function Suche(const ss: string): Integer;
var
w: Integer;
begin
result := -1;
if Ausnahmen.Count = 0 then
exit;
w := 0;
repeat
if AnsiCompareText(Ausnahmen[w], ss) = 0 then
begin
result := w;
break;
end;
inc(w, 2);
until w >= Ausnahmen.Count;
end;
function SuchTeil(ss: string): Integer;
var
w: Integer;
begin
result := -1;
if (Ausnahmen.Count = 0) or not Erweitert then
exit;
w := 0;
repeat
if AnsiPos(AnsiUppercase(Ausnahmen[w]), AnsiUppercase(ss)) = 1 then
begin
result := w;
break;
end;
inc(w, 2);
until w >= Ausnahmen.Count;
end;
function trennen: Boolean;
var
x, y, st, z, i, a, b, dopp: Integer;
c: array [1 .. 6] of Char;
rest, anf: string;
procedure stelle;
var
k: Integer;
begin
for k := 3 to 6 do
begin
dec(b);
if b >= 1 then
c[k] := aTxt[b]
else
c[k] := #0;
end;
end;
begin
result := false;
for x := length(aTxt) downto 2 do
begin
y := 1;
b := x - 1;
c[1] := aTxt[pred(x)];
c[2] := aTxt[x];
stelle;
dopp := ord(c[1] = c[2]); // z.B. Trau-ung
if (not charinset(c[1], vok) or (dopp = 1)) and (charinset(c[2], vok)) or
(charinset(c[4], vok) and charinset(c[1], vok) and charinset(c[3],
vok)) then
begin
for z := x - 2 downto 1 do // zweiter Vokal?
if charinset(aTxt[z], vok) then
begin
if c[1] = 'h' then
begin // CH und SCH nicht trennen
inc(y, ord(UpperCase(copy(aTxt, x - 2, 1)) = 'C'));
inc(y, ord(UpperCase(copy(aTxt, x - 3, 1)) = 'S'));
end
else // "ck" nicht trennen
inc(y, ord((c[1] = 'k') and (aTxt[x - 2] = 'c')));
rest := copy(aTxt, b + 1, 3);
if (c[6] > #0) and (rest = 'sch') then
begin
if not charinset(c[6], vok) // Hubsch-rauber --> Hub-schrauber
or dritte(b, aTxt) // Wäschesch-leuder --> Wäsche-schleuder
then
inc(y, 3);
end;
rest := copy(aTxt, x - y, maxint);
anf := copy(aTxt, 1, x - succ(y));
if (wdt + Cnv.TextWidth(anf) + mnz <= Breite) and
(copy(aTxt, x - succ(y), 1) <> '/') then // nicht an "/"
begin // wenn's passt
i := 0;
a := Suche(aTxt);
if a < 0 then
a := SuchTeil(aTxt);
if a >= 0 then
begin
i := finden(anf, Ausnahmen[a + 1]);
if i > 0 then
begin
s2 := StringReplace(copy(Ausnahmen[a + 1], 1, i - 1), '-',
'', [rfReplaceall]) + '-';
if charinset(aTxt[1], ['A' .. 'Z']) then
s2[1] := upcase(s2[1]);
aTxt := copy(aTxt, length(s2), maxint);
end;
end;
if i = 0 then
begin
if (c[3] = 's') and ((c[1] = 't') or (c[1] = 'p'))
and not charinset(c[4], vok) and not charinset(c[5], vok)
then
begin // Holzs-tiel --> Holz-stiel
rest := ansilastchar(anf) + rest;
inc(y);
end;
s2 := copy(aTxt, 1, x - succ(y) + dopp);
if ansilastchar(s2) = #39 then // z.B. Bismark'sche
delete(s2, length(s2), 1);
if (s2 <> '') and (ansilastchar(s2) <> #13) and
(ansilastchar(s2) <> #10) then
if ansilastchar(s2) <> '-' then
s2 := s2 + '-';
aTxt := copy(rest, 1 + dopp, maxint);
end;
result := true;
exit;
end;
end;
end;
end;
end;
begin
BreakText.Clear;
Ersatz; // Anfürungszeichen anpassen für bestimmte Schriftarten
p := PChar(AdjustLineBreaks(aTxt));
mnz := Cnv.TextWidth('-') * ord(Ueberhang);
leer := Cnv.TextWidth(#32);
s := '';
repeat
m := p;
while not charinset(p^, [#0, #32]) do
inc(p);
SetString(aTxt, m, p - m);
if aTxt <> '' then
begin
akt := Cnv.TextWidth(aTxt);
wdt := Cnv.TextWidth(s);
s2 := '';
if wdt + akt > Breite then
begin
if Silbentrennung then
if trennen then
s := s + s2;
p13 := pos(#13, s);
if p13 > 0 then
begin
if p13 > 1 then
aTxt := copy(s, p13 + 1, maxint);
s := copy(s, 1, p13 - 1);
BreakText.Add(s);
s := '';
p := m - length(aTxt) - 1 + length(s2);
if p^ = #13 then
inc(p);
continue;
end;
BreakText.Add(s);
s := trim(aTxt) + #32;
continue;
end;
s := s + aTxt;
if Cnv.TextWidth(s) + leer <= Breite then
s := s + #32;
end;
while p^ = #32 do
inc(p);
if p^ = #0 then
begin
BreakText.Add(s);
break;
end;
until false;
end;
procedure Anzeige(Cnv: TCanvas; x, y: Integer);
var
i, d: Integer;
begin
if BreakText.Count = 0 then
exit;
Cnv.Brush.Style := bsclear;
d := Cnv.TextHeight(BreakText[0]);
for i := 0 to BreakText.Count - 1 do
Cnv.TextOut(x, y + i * d, BreakText[i]);
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
BreakText := TStringList.Create;
Ausnahmen := TStringList.Create;
Ausnahmen.Add('aufgrund');
Ausnahmen.Add('auf-grund');
Ausnahmen.Add('Prophet');
Ausnahmen.Add('Pro-phet');
Ausnahmen.Add('katholisch');
Ausnahmen.Add('ka-tho-lisch');
Ausnahmen.Add('beinhalten');
Ausnahmen.Add('be-inhal-ten');
{ nicht be-in-hal-ten, da bei der Trennung
zwischen n und h "bein-halten" entsteht }
Ausnahmen.Add('Analphabet');
Ausnahmen.Add('An-alpha-bet');
{ nicht An-al-pha-bet, da bei der Trennung
zwischen l und p "Anal-phabet" entsteht }
Ausnahmen.Add('Cashewnuss');
Ausnahmen.Add('Ca-shew-nuss');
Ausnahmen.Add('Cashewnüsse');
Ausnahmen.Add('Ca-shew-nüs-se');
Ausnahmen.Add('Baumstamm');
Ausnahmen.Add('Baum-stamm');
// usw.
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
Ausnahmen.Free;
BreakText.Free;
end;
// --------------------------------------------------------------------
// Beispiel 1
// mittels Textauszug aus dem Buch "Ein paar Kurze"
const
txt = 'Seine Darstellung des Weihnachtsmannes bescherte ihm neben Beifall ' +
'auch noch einen zusätzlichen Effekt: Ab diesem Zeitpunkt nannten ihn ' +
'alle beharrlich "Santa Klaus". Später wurde dann der zweite Teil ' +
'dieser Bezeichnung weggelassen, da die Menschen aufgrund ihrer ' +
'angeborenen Faulheit alles unbedingt abkürzen müssen. Fortan hörte ' +
'also Klaus Wegener mit einem gewissen Stolz auf den Namen "Santa". ' +
'Und das sollte so bis an sein Lebensende bleiben.' + #13 +
'Santa konnte in fast allen Schulfächern eine Eins auf dem Zeugnis ' +
'vorweisen. Besonders hatten es ihm die Naturwissenschaften angetan. ' +
'Chemie und Physik liebte er mehr als alles andere auf der Welt. Dabei ' +
'war er absolut kein Streber. Zensuren interessierten ihn genauso viel, ' +
'als würde in Mexiko ein grün lackiertes Fahrrad umfallen. Ihm ging es ' +
'nur um das Lernen an sich. Sein Gehirn schien exklusiv in diese Welt ' +
'gekommen zu sein, um wie ein Schwamm Wissen aufzusaugen.';
procedure TForm1.Button1Click(Sender: TObject);
var
breit, rand: Integer;
begin
breit := 273;
rand := 20;
Canvas.Font.Size := 12;
Canvas.Font.Name := 'Arial';
Vorbereitung(txt, Canvas, breit, false, false, false);
Anzeige(Canvas, rand, rand);
Vorbereitung(txt, Canvas, breit, true, false, true);
Anzeige(Canvas, breit + rand * 2, rand);
end;
// --------------------------------------------------------------------
// Beispiel 2
// Text aus Textdatei laden
procedure TForm1.Button2Click(Sender: TObject);
var
fs: TFileStream;
ss: TStringStream;
begin
ss := TStringStream.Create;
fs := TFileStream.Create('Test.txt', fmOpenRead);
fs.Position := 0;
ss.CopyFrom(fs, 0);
fs.Free;
Vorbereitung(ss.DataString, Canvas, 450, true, true, true);
ss.Free;
Canvas.Brush.Color := clBtnFace;
Canvas.FillRect(Canvas.ClipRect);
Anzeige(Canvas, 10, 10);
end;
|
||||||
