| Новости | Поиск | FAQ | Статьи | Книги | Новости VCL | | Форумы ЧАТ | Орешник | KOL и MCK |
Форумы -» Основная («Начинающим»)/ Базы / WinAPI / Компоненты / Сети / Media / Игры / Corba и COM / KOL / FreePascal / .Net / Прочее / RSDN.ORG

	« предыдущая ветвь | форум | следующая ветвь »

Как вывести текст в центре Canvas по вертикали и горизонтали? [D7, WinXP]

452 ©   (2008-01-12 16:14:00) 

Как вывести текст в центре Canvas по вертикали и горизонтали?
С помощью функции DrawText()
uses
MyIni;
var
 FrmMain: TFrmMain;
 miy1,mix1,miy2,mix2,mzx,mzy,mrx,mry:integer;
 down:boolean;
implementation

procedure TFrmMain.FormCreate(Sender: TObject);
begin
try
mix1:=ReadIniDataInt('Option','PTX1');
mix2:=ReadIniDataInt('Option','PTX2');
miy1:=ReadIniDataInt('Option','PTY1');
miy2:=ReadIniDataInt('Option','PTY2');
mzx:=ReadIniDataInt('Option','PZX');
mzy:=ReadIniDataInt('Option','PZY');
mrx:=ReadIniDataInt('Option','PRX');
mry:=ReadIniDataInt('Option','PRY');
except
end;
end;

procedure TFrmMain.CalcuateTextPosition(const Caption: string; var TRC: TRect;BiDiFlags: Integer);
var
TB: TRect;
TS, TP: TPoint;
begin
with Canvas do
begin
  TB := Rect(0, 0, TRC.Right + TRC.Left, TRC.Top + TRC.Bottom);
  DrawText(Handle, PChar(Caption), Length(Caption), TB, DT_CALCRECT or
    BiDiFlags);
  TS := Point(TB.Right - TB.Left, TB.Bottom - TB.Top);
  TP.X := ((TRC.Right - TRC.Left) - TS.X + 1) div 2;
  TP.Y := ((TRC.Bottom - TRC.Top) - TS.Y + 1) div 2;
  OffsetRect(TB, TP.X + TRC.Left, TP.Y + TRC.Top);
  TRC := TB;
end;
end;

procedure TFrmMain.BtnPaintClick(Sender: TObject);
Const
StrSample='Тестове повідомленняВаша може бути тут.';//+#13+'А тут наша :)'+#13+'Розробка програмного забезпечення'+#13+'---------'+#13+'Домашній телефон: +380687093270'+#13+'Запитувати Ігоря';
var
str:string;
R: TRect;
BiDiFlags: Longint;
Bitmap:TBitmap;
begin
try
Bitmap:=TBitmap.Create;
Bitmap.LoadFromFile('Fon.BMP');
str:='Інформація';
////////////////////////
//miy1    (Bitmap.Height div 2)
R := Rect(mix1,miy1,mix2,miy2);//700,480);
Bitmap.Canvas.Brush.Style:=bsClear;
Bitmap.Canvas.Font.Name := 'Arial';
Bitmap.Canvas.Font.Size:=20;
Bitmap.Canvas.Pen.Width:=4;
Bitmap.Canvas.Rectangle(R.Left - 2, R.Top - 2, R.Right + 2, R.Bottom + 2);
Bitmap.Canvas.Font.Color:=clblack;
//uFormat dt_WordBreak or
//R := ClientRect;
//DrawText(Bitmap.Canvas.Handle, PChar(StrSample), Length(StrSample), R,DT_CENTER or DT_VCENTER or BiDiFlags);
DrawText(Bitmap.Canvas.Handle,PChar(StrSample),-1,R, DT_WORDBREAK or DT_CENTER or DT_VCENTER);
Image.Canvas.StretchDraw(Rect(0,0,Image.Width,Image.Height),Bitmap);
Bitmap.Free;
finally
end;
end;

procedure TFrmMain.Button1Click(Sender: TObject);
var
TB: TRect;
TS, TP: TPoint;
Caption: string;
BiDiFlags: Integer;
TRC: TRect;
Bitmap:TBitmap;
bmp: TBitmap;
begin
Bitmap:=TBitmap.Create;
bmp := TBitmap.Create;
Bitmap.LoadFromFile('Fon.BMP');
Caption:='Тестове повідомлення'+#13+'Ваша може бути тут.'+#13+'А тут наша :)'+#13+'Розробка програмного забезпечення'+#13+'---------'+#13+'Домашній телефон: +380687093270'+#13+'Запитувати Ігоря';
Bitmap.Canvas.Brush.Style:=bsClear;
Bitmap.Canvas.Font.Name := 'Arial';
Bitmap.Canvas.Font.Size:=20;
Bitmap.Canvas.Pen.Width:=4;
Bitmap.Canvas.Font.Color:=clblack;
  TRC:=Bitmap.Canvas.ClipRect;
  TB := Rect(0, 0, TRC.Right + TRC.Left, TRC.Top + TRC.Bottom);
  DrawText(bmp.Handle, PChar(Caption), Length(Caption), TB, DT_CALCRECT or BiDiFlags);
  Image.Canvas.StretchDraw(Rect(0,0,Image.Width,Image.Height),bmp);
  TS := Point(TB.Right - TB.Left, TB.Bottom - TB.Top);
  TP.X := ((TRC.Right - TRC.Left) - TS.X + 1) div 2;
  TP.Y := ((TRC.Bottom - TRC.Top) - TS.Y + 1) div 2;
OffsetRect(TB,TP.X,TP.Y+TRC.Top);
Bitmap.Canvas.Rectangle(TB.Left - 2, TB.Top - 2, TB.Right + 2, TB.Bottom + 2);
//DrawText(Bitmap.Canvas.Handle, PChar(Caption),Length(Caption), TB,DT_CENTER or DT_VCENTER or DT_NOCLIP);
//Image.Canvas.StretchDraw(Rect(0,0,Image.Width,Image.Height),Bitmap);
Bitmap.Free;
bmp.Free;
end;   //   DT_CALCRECT)
procedure TFrmMain.Button2Click(Sender: TObject);
var
Bitmap,bm:TBitmap;
TB: TRect;
Vans:String;
i:integer;
begin
Vans:='Test TestTestTest'+#13+'TestTestTestTestTestTest';
Bitmap:=TBitmap.Create;
//bm:=TBitmap.Create;
Bitmap.LoadFromFile('Fon.BMP');
//bm.LoadFromFile('Fon.BMP');
Bitmap.Canvas.Brush.Style:=bsClear;
Bitmap.Canvas.Font.Name := 'Arial';
Bitmap.Canvas.Font.Size:=20;
Bitmap.Canvas.Pen.Width:=4;
Bitmap.Canvas.Font.Color:=clblack;
//bm.Canvas.Font:=Bitmap.Canvas.Font;
TB:=Rect(14,122,701,483);
//i:=DrawText(bm.Canvas.Handle, PChar(Vans),Length(Vans), TB,DT_CENTER or DT_WORDBREAK);
//TB.Top:=i;
//Caption:=IntToStr(i);
DrawText(Bitmap.Canvas.Handle, PChar(Vans),Length(Vans), TB,DT_CENTER or DT_WORDBREAK);
Bitmap.Canvas.Rectangle(TB.Left - 2, TB.Top - 2, TB.Right + 2, TB.Bottom + 2);
Image.Canvas.StretchDraw(Rect(0,0,Image.Width,Image.Height),Bitmap);
Bitmap.Free;
//bm.Free;
end;
end.

---

452   (2008-02-09 00:59:00) [1]

Pleas return v icq
Ты {RASkov} куда пропал с аськи

---

452   (2008-01-21 13:42:00) [2]

Ты кполучил письмо?
И ты когда в аське бываешь.

---

{RASkov}   (2008-01-17 18:56:00) [3]

есть

---

{RASkov}   (2008-01-17 18:56:00) [4]

:) не туда нажал )
469970186

---

452   (2008-01-17 18:10:00) [5]

А у тебя есть ICQ

---

{RASkov}   (2008-01-15 21:07:00) [6]

> [8] 452 ©   (15.01.08 19:17)

Ну попробуй :)

---

452   (2008-01-15 19:17:00) [7]

{RASkov} как с тобой связаться есть деловое предложение.

---

452   (2008-01-13 13:18:00) [8]

Первый ответ от

> {RASkov} ©   (12.01.08 18:21) [4]
>
> > [3] 452   (12.01.08 16:43)
>
> Два варианта, ...думаю разберешься с комментариями

просмотрел работает а второй к сожалению не могу так как я на нете в знакомого а у нево Delphi нет. на первый взгляд должно работать.

http://ifolder.ru/4924581Здесь выложил видео файл который делает моя программа.
Нужно сделать такую функцию чтобы текст который не влазит в прямоугольник программа видела какой текст не поместился и выносила ево на новий Canvas вроде сообщения №2 (90% всех сообщений помещаются на экран а 10 имеют больше текста который уместить никак не получается для этово нужно текст переносить дальше)
Заранее спасибо.

---

{RASkov}   (2008-01-12 19:18:00) [9]

> [5] 452   (12.01.08 18:47)
> В моей программе это нужно для тово чтобы текс который
> не помещается переносить на новое полотно.

Вот глянь, может чего и найдешь для себя:

DFM:
object Form1: TForm1
 Left = 197
 Top = 110
 Width = 856
 Height = 478
 Caption = 'Form1'
 Color = clBtnFace
 Font.Charset = DEFAULT_CHARSET
 Font.Color = clWindowText
 Font.Height = -11
 Font.Name = 'MS Sans Serif'
 Font.Style = []
 OldCreateOrder = False
 PixelsPerInch = 96
 TextHeight = 13
 object Button1: TButton
   Left = 84
   Top = 4
   Width = 75
   Height = 25
   Caption = 'DrawText'
   TabOrder = 0
   OnClick = Button1Click
 end
 object Button2: TButton
   Left = 4
   Top = 4
   Width = 75
   Height = 25
   Caption = 'PageText'
   TabOrder = 1
   OnClick = Button2Click
 end
 object Edit2: TLabeledEdit
   Left = 488
   Top = 6
   Width = 53
   Height = 21
   EditLabel.Width = 86
   EditLabel.Height = 13
   EditLabel.Caption = 'Количество раз: '
   LabelPosition = lpLeft
   TabOrder = 3
   Text = '10'
 end
 object LabeledEdit1: TLabeledEdit
   Left = 656
   Top = 6
   Width = 53
   Height = 21
   EditLabel.Width = 87
   EditLabel.Height = 13
   EditLabel.Caption = 'Размер шрифта: '
   LabelPosition = lpLeft
   TabOrder = 4
   Text = '8'
 end
 object CheckBox1: TCheckBox
   Left = 164
   Top = 8
   Width = 17
   Height = 17
   TabOrder = 5
 end
 object Edit1: TLabeledEdit
   Left = 216
   Top = 6
   Width = 177
   Height = 21
   EditLabel.Width = 33
   EditLabel.Height = 13
   EditLabel.Caption = 'Текст:'
   LabelPosition = lpLeft
   TabOrder = 2
   Text = 'Длинная строка из кучи слов '
 end
end
PAS:
unit Unit1;
interface
uses
 Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
 StdCtrls, ExtCtrls, Buttons, Dialogs;

type
 TForm1 = class(TForm)
   Button1: TButton;
   Button2: TButton;
   Edit1: TLabeledEdit;
   Edit2: TLabeledEdit;
   LabeledEdit1: TLabeledEdit;
   CheckBox1: TCheckBox;
   procedure Button1Click(Sender: TObject);
   procedure Button2Click(Sender: TObject);
 private
   { Private declarations }
 public
   { Public declarations }
 end;

var
 Form1: TForm1;

implementation

{$R *.dfm}

function GetLongStr(const FNoSpace: Boolean=False): String;
var N: Integer; S: String;
begin
 S:=Form1.Edit1.Text;
 if FNoSpace then for N := Length(S) downto 1 do if S[N]=' ' then Delete(S, N, 1);
 for N:= 1 to StrToIntDef(Form1.Edit2.Text, 10) do Result:=Result+IntToStr(N)+S;
end;

function DivStr(var S: String; R: TRect): String;
var Flags: LongInt;
begin
 Flags:=DT_WORDBREAK or DT_MODIFYSTRING or DT_EDITCONTROL or DT_END_ELLIPSIS;
 InflateRect(R, -4, -4);
 Result:=Copy(S, 1, Length(S));
 DrawTextEx(Form1.Canvas.Handle, PChar(S), -1, R, Flags, nil);
 S:=StrPas(PChar(S));
 if Length(Result)>=(Length(S)+3) then Delete(Result, 1, Length(S)-3) else Result:='';
end;

function DivStrEx(var S: String; R: TRect; const FNoDraw: Boolean=True): String;
var Flags: LongInt;
begin
 Flags:=DT_MODIFYSTRING or DT_EDITCONTROL or DT_WORD_ELLIPSIS;
 if FNoDraw then Flags:=DT_CALCRECT or Flags;
 InflateRect(R, -4, -4);
 Result:=Copy(S, 1, Length(S));
 DrawText(Form1.Canvas.Handle, PChar(Result), -1, R, Flags);
 Result:=StrPas(PChar(Result));
 while Result[Length(Result)]='.' do Delete(Result, Length(Result), 1);
 if Length(S)>=(Length(Result)) then Delete(S, 1, Length(Result)) else S:='';
end;

procedure TForm1.Button1Click(Sender: TObject);
var PS: PChar; N: Integer; R: Trect;
begin
 PS:=PChar(GetLongStr(CheckBox1.Checked));
 Canvas.Pen.Width:=2;
 R:=Canvas.ClipRect; Canvas.Brush.Style:=bsSolid; Canvas.Brush.Color:=Color;
 Canvas.FillRect(R); Repaint; Canvas.Font.Size:=StrToIntDef(LabeledEdit1.Text, 8);
 Canvas.Brush.Style:=bsClear; Canvas.Pen.Color:=clBlue; Canvas.Rectangle(R);
 INC(R.Left, 4); INC(R.Top, 35);
 N:=DrawText(Canvas.Handle, PS, -1, R, DT_CALCRECT or DT_WORDBREAK);
 Canvas.Pen.Color:=clRed; Canvas.Rectangle(R);
 DrawText(Canvas.Handle, PS, -1, R, DT_WORDBREAK);
 R:=Canvas.ClipRect; INC(R.Top, N+65); INC(R.Left, 4); DEC(R.Right, 4); DEC(R.Bottom, 4);
 Canvas.Pen.Color:=clGreen; Canvas.Rectangle(R);
 DrawText(Canvas.Handle, PS, -1, R, DT_WORDBREAK or DT_CENTER);
end;

procedure TForm1.Button2Click(Sender: TObject);
procedure ModifRect(var R: TRect);
var W, H: Integer;
begin
  W:=R.Right-R.Left; H:=R.Bottom-R.Top;
  if (R.Right+W>ClientWidth-10) then begin
   INC(R.Top, H+10);
   R.Bottom:=R.Top+H;
   R.Left:=10;
   R.Right:=130;
  end else begin
   INC(R.Left, W+10);
   R.Right:=R.Left+W;
  end;
end;
var PS: String; R: TRect; N: Integer;
begin
 PS:=GetLongStr(CheckBox1.Checked); N:=0; Canvas.Pen.Width:=1;
 R:=Rect(10, 35, 130, 230);
 Canvas.Brush.Style:=bsSolid; Canvas.Brush.Color:=Color; Canvas.FillRect(Canvas.ClipRect);
 Repaint; Canvas.Font.Size:=StrToIntDef(LabeledEdit1.Text, 8);
 repeat
  Canvas.Brush.Style:=bsSolid; Canvas.Brush.Color:=clGray;
  Canvas.Pen.Color:=clGray;
  Canvas.Rectangle(R.Left+4, R.Top+4, R.Right+4, R.Bottom+4);
  Canvas.Brush.Style:=bsSolid; Canvas.Brush.Color:=clWhite;
  Canvas.Pen.Color:=clBlack;
  Canvas.Rectangle(R);
  Canvas.Brush.Style:=bsClear;
  PS:=DivStr(PS, R);
  ModifRect(R);
  INC(N);
 until PS='';
 Caption:='Страниц: '+IntToStr(N);
end;

end.

---

452   (2008-01-12 18:47:00) [10]

Щас буду пробовать.
А как сделать реакцию вроде DT_WORDBREAK (это срабатывает когда текст не помещается по горизонтали). А нужна реакция когда текст не помещается по вертикали в заданную область. В моей программе это нужно для тово чтобы текс который не помещается переносить на новое полотно.

---

{RASkov}   (2008-01-12 18:21:00) [11]

> [3] 452   (12.01.08 16:43)

Два варианта, ...думаю разберешься с комментариями

procedure MyDrawText(DC: HDC; AR: TRect; {AWidth: Integer;} AStr: String);
var R: TRect; WR, WAR, HR, HAR: Integer;
begin
 R:=AR;
 //R.Right:=R.Left+AWidth;
 DrawText(DC, PChar(AStr), -1, R, DT_CALCRECT or DT_WORDBREAK or DT_CENTER);
 WAR:=AR.Right-AR.Left;
 WR:=R.Right-R.Left;
 HAR:=AR.Bottom-AR.Top;
 HR:=R.Bottom-R.Top;
 R.Left:=AR.Left+((WAR-WR) div 2);
 R.Right:=R.Left+WR;
 R.Top:=AR.Top+((HAR-HR) div 2);
 R.Bottom:=R.Top+HR;
 DrawText(DC, PChar(AStr), -1, R, DT_WORDBREAK or DT_CENTER);
end;

procedure TForm1.Button1Click(Sender: TObject);
const Txt = 'I?aiu aeeiiu oaeno iiiaino?i?iue oaeie aio aeeiiue oaeno io?ii aey auaiaa oaenoa uaeieaieeuiaai uaau?aau? uaa?ua';
begin
 MyDrawText(Canvas.Handle, Canvas.ClipRect{, 100}, Txt);
end;

---

452   (2008-01-12 16:43:00) [12]

Кстати опция DT_VCenter работает с выводом текста по вертикали если мы выводим только одну строку а мне нужно выводить многострочный текст (multi line text )

---

452   (2008-01-12 16:38:00) [13]

Нет нужно просто вывести текст по горизонтали и вертикали в заданном прямоугольнике на определенном канвасе.
У меня не получается.

---

antonn   (2008-01-12 16:23:00) [14]

а что не получается?

---

Наверх