Procedure vertical_text(input_string: string;memo:TMemo );
var
i: integer;
caract: char;
begin
if input_string = '' then
Exit;
for i := 1 to Length(input_string) + 1 do
Begin
caract := input_string[i];
memo.Lines.Add(caract) ;//:= memo.Text + + #$A#$d;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
vertical_text(Edit1.Text, Memo1);
end;
uses
{...} Grids;
type
TForm1 = class(TForm)
StringGrid1: TStringGrid;
procedure StringGrid1DrawCell(Sender: TObject; ACol, ARow: Integer;
Rect: TRect; State: TGridDrawState);
end;
{...}
implementation
{...}
// Display text vertically in StringGrid cells
// Vertikale Textausgabe in den Zellen eines StringGrid
procedure StringGridRotateTextOut(Grid: TStringGrid; ARow, ACol: Integer; Rect: TRect;
Schriftart: string; Size: Integer; Color: TColor; Alignment: TAlignment);
var
lf: TLogFont;
tf: TFont;
begin
// if the font is to big, resize it
// wenn Schrift zu groß dann anpassen
if (Size Grid.ColWidths[ACol] div 2) then
Size := Grid.ColWidths[ACol] div 2;
with Grid.Canvas do
begin
// Replace the font
// Font setzen
Font.Name := Schriftart;
Font.Size := Size;
Font.Color := Color;
tf := TFont.Create;
try
tf.Assign(Font);
GetObject(tf.Handle, SizeOf(lf), @lf);
lf.lfEscapement := 900;
lf.lfOrientation := 0;
tf.Handle := CreateFontIndirect(lf);
Font.Assign(tf);
finally
tf.Free;
end;
// fill the rectangle
// Rechteck füllen
FillRect(Rect);
// Align text and write it
// Text nach Ausrichtung ausgeben
if Alignment = taLeftJustify then
TextRect(Rect, Rect.Left + 2,Rect.Bottom - 2,Grid.Cells[ACol, ARow]);
if Alignment = taCenter then
TextRect(Rect, Rect.Left + Grid.ColWidths[ACol] div 2 - Size +
Size div 3,Rect.Bottom - 2,Grid.Cells[ACol, ARow]);
if Alignment = taRightJustify then
TextRect(Rect, Rect.Right - Size - Size div 2 - 2,Rect.Bottom -
2,Grid.Cells[ACol, ARow]);
end;
end;
// 2. Alternative: Display text vertically in StringGrid cells
// 2. Variante: Vertikale Textausgabe in den Zellen eines StringGrid
procedure StringGridRotateTextOut2(Grid:TStringGrid;ARow,ACol:Integer;Rect:TRect;
Schriftart:String;Size:Integer;Color:TColor;Alignment:TAlignment);
var
NewFont, OldFont : Integer;
FontStyle, FontItalic, FontUnderline, FontStrikeout: Integer;
begin
// if the font is to big, resize it
// wenn Schrift zu groß dann anpassen
If (Size Grid.ColWidths[ACol] DIV 2) Then
Size := Grid.ColWidths[ACol] DIV 2;
with Grid.Canvas do
begin
// Set font
// Font setzen
If (fsBold IN Font.Style) Then
FontStyle := FW_BOLD
Else
FontStyle := FW_NORMAL;
If (fsItalic IN Font.Style) Then
FontItalic := 1
Else
FontItalic := 0;
If (fsUnderline IN Font.Style) Then
FontUnderline := 1
Else
FontUnderline := 0;
If (fsStrikeOut IN Font.Style) Then
FontStrikeout:=1
Else
FontStrikeout:=0;
Font.Color := Color;
NewFont := CreateFont(Size, 0, 900, 0, FontStyle, FontItalic,
FontUnderline, FontStrikeout, DEFAULT_CHARSET,
OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS, DEFAULT_QUALITY,
DEFAULT_PITCH, PChar(Schriftart));
OldFont := SelectObject(Handle, NewFont);
// fill the rectangle
// Rechteck füllen
FillRect(Rect);
// Write text depending on the alignment
// Text nach Ausrichtung ausgeben
If Alignment = taLeftJustify Then
TextRect(Rect,Rect.Left+2,Rect.Bottom-2,Grid.Cells[ACol,ARow]);
If Alignment = taCenter Then
TextRect(Rect,Rect.Left+Grid.ColWidths[ACol] DIV 2 - Size + Size DIV 3,
Rect.Bottom-2,Grid.Cells[ACol,ARow]);
If Alignment = taRightJustify Then
TextRect(Rect,Rect.Right-Size - Size DIV 2 - 2,Rect.Bottom-2,Grid.Cells[ACol,ARow]);
// Recreate reference to the old font
// Referenz auf alten Font wiederherstellen
SelectObject(Handle, OldFont);
// Recreate reference to the new font
// Referenz auf neuen Font löschen
DeleteObject(NewFont);
end;
end;
// Call the method in OnDrawCell
// Methode im OnDrawCell aufrufen
procedure TForm1.StringGrid1DrawCell(Sender: TObject; ACol,
ARow: Integer; Rect: TRect; State: TGridDrawState);
begin
// In the second column: Rotate Text by 90° and left align the text
// Text um 90°gedreht ausgeben, linksbündig in der zweiten Spalte
if ACol = 1 then
StringGridRotateTextOut(StringGrid1, ARow, ACol, Rect, 'ARIAL',
12,clRed, taLeftJustify);
// In the third column: Center the text
// Ausgabe zentriert in der dritten Spalte
if ACol = 2 then
StringGridRotateTextOut(StringGrid1, ARow, ACol, Rect, 'ARIAL', 12, clBlue, taCenter);
// In all other columns third row: right align the text
// Ausgabe rechtsbündig in den restlichen Spalten
if ACol 2 then
StringGridRotateTextOut(StringGrid1, ARow, ACol, Rect, 'ARIAL', 12,clGreen,
taRightJustify);
end;
end.
كود :
procedure VerticalTypewriter(text: string; image: TImage; delay: integer);
var
x, y, i: integer;
begin
image.Canvas.Refresh;
application.ProcessMessages;
y := 1;
for i := 1 to length(text) do
begin
application.ProcessMessages;
y := y + image.Canvas.TextHeight(text[i]);
x := image.width div 2 - (image.Canvas.TextWidth(text[i]) div 2);
image.Canvas.TextOut(x, y, text[i]);
sleep(delay);
end;
end;
// Horizontal Typewriter ( , , , )
procedure HorizontalTypewriter(text: string; image: TImage;
delay, space: integer);
var
x, y, i: integer;
begin
image.Canvas.Refresh;
application.ProcessMessages;
x := 1;
for i := 1 to length(text) do
begin
application.ProcessMessages;
y := image.Picture.Height div 2 - (image.Canvas.TextHeight(text[i]) div 2);
x := x + image.Canvas.TextWidth(text[i]) + space;
image.Canvas.TextOut(x, y, text[i]);
sleep(delay);
end;
end;
// Sample calls:
procedure TForm1.Button1Click(Sender: TObject);
begin
//
VerticalTypewriter('HELLO BIG-X', Image1, 100);
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
//
HorizontalTypewriter('Hello Big-X', Image2, 100, 1);
end;
procedure TForm1.Edit1Change(Sender: TObject);
begin
HorizontalTypewriter(Edit1.text, Image2, 100, 1);
VerticalTypewriter(Edit1.text, Image1, 100);
end;
![[صورة: tip506.png]](http://www.swissdelphicenter.ch/screenshots/tip506.png)