Как сделать поле Memo растягивающимся?

@A_R_S · Регистрация: 01.04.2009

Студворк — интернет-сервис помощи студентам

Как сделать поле MEMO растягивающимся, например форма ввода на сайте которую можно потянуть и расширить?.

@volvo · 26.11.2012, 13:50

Первоначальный набросок (можно улучшать, скажем, в OnPaint нарисовать в правом нижнем углу такой же треугольник, чтобы показать, что размер можно менять. На данный момент пользователь узнает об этом только когда подведет мышу к правому нижнему углу, и курсор поменяется):

Delphi
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
// Перед классом формы (воздействует на все TMemo на данной форме)
type
  TMemo = class(StdCtrls.TMemo)
  private
    MouseButtonDown, Sizing: Boolean;
    StartPosition, MousePosition: TPoint;
    MemoRect: TRect;
 
  public
     constructor Create(AOwner: TComponent); override;
 
  protected
    procedure MouseMove(Shift: TShiftState; X: Integer; Y: Integer); override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X: Integer;
      Y: Integer); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X: Integer;
      Y: Integer); override;
  end;
 
  TForm1 = class(TForm) // Это твоя форма
  // ...
 
// Реализация методов (добавляешь в секции Implementation своего модуля)
{ TMemo }
constructor TMemo.Create(AOwner: TComponent);
begin
  inherited;
  Sizing := False;
end;
 
procedure TMemo.MouseDown(Button: TMouseButton; Shift: TShiftState; X,
  Y: Integer);
begin
  inherited;
  if Button = mbLeft then
  begin
    StartPosition := Point(X, Y);
    MemoRect := BoundsRect;
    MouseButtonDown := True;
  end;
end;
 
procedure TMemo.MouseMove(Shift: TShiftState; X, Y: Integer);
var
  XOffset, YOffset: integer;
  P: TPoint;
  InnerRect: TRect;
begin
  inherited;
  InnerRect := Bounds(Width - 10, Height - 10, Width, Height);
  MousePosition := Point(X, Y);
 
  if (PtInRect(InnerRect, MousePosition)) or Sizing then
  begin
    Cursor := crSizeNWSE;
    if MouseButtonDown then
    begin
      Sizing := True;
      XOffset := MousePosition.x - StartPosition.x;
      YOffset := MousePosition.y - StartPosition.y;
      StartPosition := MousePosition;
      Inc(MemoRect.Right, XOffset);
      Inc(MemoRect.Bottom, YOffset);
      BoundsRect := MemoRect;
    end;
  end
  else
   Cursor := crDefault;
end;
 
procedure TMemo.MouseUp(Button: TMouseButton; Shift: TShiftState; X,
  Y: Integer);
var
 XOffset, YOffset: integer;
begin
  inherited;
  MouseButtonDown := False;
  Sizing := False;
end;

Всё, больше ничего делать не надо, запускай программу и смотри...

@FIL · 27.11.2012, 13:35

Убрал мерцание при изменении размеров:

Delphi
1
2
3
4
5
6
constructor TMemo.Create(AOwner: TComponent);
begin
  inherited;
  Sizing := False;
  DoubleBuffered := true;
end;

А вот с рисованием проблемы. У Мемо в событиях нет OnPaint. Попробовал сделать через перехват WM_PAINT:

Delphi
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
procedure TMemo.WMPaint(var Message: TWMPaint);
var
  DC: HDC;
  PS: TPaintStruct;
  Canvas: TCanvas;
begin
  DC := Message.DC;
  if DC = 0 then DC := BeginPaint(Handle, PS);
  Canvas := TCanvas.Create;
  Canvas.Handle := DC;
  Canvas.Rectangle(Width-10,Height-10,Width-5,Height-5);
  Canvas.Free;
 
  inherited;
 
 end;

но при растягивании Мемо получается бяка (см. рис.). Как это сделать правильно?

@volvo · 27.11.2012, 14:02

Пардон, а где EndPaint?

А вообще, всё делается проще:

Delphi
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
type
  TMemo = class(StdCtrls.TMemo)
  private
    MouseButtonDown, Sizing: Boolean;
    StartPosition, MousePosition: TPoint;
    MemoRect: TRect;
 
    FCanvas : TCanvas; // <--- Раз
    procedure WMPaint(var Message: TWMPaint); message WM_PAINT; // <--- Два
 
  public
     constructor Create(AOwner: TComponent); override;
     destructor Destroy; override; // <--- Три
 
  protected
    // тут без изменений
  end;

, и реализации:

Delphi
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
constructor TMemo.Create(AOwner: TComponent);
begin
  inherited;
  Sizing := False;
  DoubleBuffered := true;
 
  FCanvas := TControlCanvas.Create;
  TControlCanvas(FCanvas).Control := Self; // Это чтоб потом не мучиться
end;
 
destructor TMemo.Destroy;
begin
  FreeAndNil(FCanvas); // Удаляем канву
  inherited;
end;
 
procedure TMemo.WMPaint(var Message: TWMPaint);
begin
   inherited;
   FCanvas.Rectangle(Width-10,Height-10,Width-5,Height-5); // Вот и выгода...
end;

@FIL · 27.11.2012, 20:28

Нарисовал значок:

Delphi
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
procedure TMemo.WMPaint(var Message: TWMPaint);
begin
  inherited;
  FCanvas.Pixels[Width-7, Height-7]   := clGrayText; // 109
  FCanvas.Pixels[Width-10, Height-7]  := clGrayText;
  FCanvas.Pixels[Width-13, Height-7]  := clGrayText;
  FCanvas.Pixels[Width-10, Height-10] := clGrayText;
  FCanvas.Pixels[Width-7, Height-10]  := clGrayText;
  FCanvas.Pixels[Width-7, Height-13]  := clGrayText;
 
  FCanvas.Pixels[Width-7, Height-8]   := clBtnShadow; // 160
  FCanvas.Pixels[Width-10, Height-8]  := clBtnShadow;
  FCanvas.Pixels[Width-13, Height-8]  := clBtnShadow;
  FCanvas.Pixels[Width-10, Height-11] := clBtnShadow;
  FCanvas.Pixels[Width-7, Height-11]  := clBtnShadow;
  FCanvas.Pixels[Width-7, Height-14]  := clBtnShadow;
 
  FCanvas.Pixels[Width-8, Height-7]   := clActiveBorder; // 180
  FCanvas.Pixels[Width-11, Height-7]  := clActiveBorder;
  FCanvas.Pixels[Width-14, Height-7]  := clActiveBorder;
  FCanvas.Pixels[Width-11, Height-10] := clActiveBorder;
  FCanvas.Pixels[Width-8, Height-10]  := clActiveBorder;
  FCanvas.Pixels[Width-8, Height-13]  := clActiveBorder;
 
  FCanvas.Pixels[Width-8, Height-8]   := clBtnFace; // 240
  FCanvas.Pixels[Width-11, Height-8]  := clBtnFace;
  FCanvas.Pixels[Width-14, Height-8]  := clBtnFace;
  FCanvas.Pixels[Width-11, Height-11] := clBtnFace;
  FCanvas.Pixels[Width-8, Height-11]  := clBtnFace;
  FCanvas.Pixels[Width-8, Height-14]  := clBtnFace;
 
 end;

но тут возникла другая проблема:
текст в нижней строке Мемо затирает его (значок).
Нашел способ как сделать отступ сверху или слева:

Delphi
1
2
3
4
5
6
7
8
9
var
  Rect: TRect;
begin
  // Îòñòóï ñëåâà
  SendMessage(Memo1.Handle, EM_GETRECT, 0, LongInt(@Rect));
  Rect.Left := 10;
  SendMessage(Memo1.Handle, EM_SETRECT, 0, LongInt(@Rect));
  Memo1.Refresh;
end;

но отступ снизу так сделать не получается.
Подскажите как это исправить.

@volvo · 27.11.2012, 21:17

Можно, только делать это надо будет в двух местах: при создании контрола и при каждом изменении размера. Для этого придется переопределить еще и Resize:

Delphi
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
  private
    // Бла-бла-бла ...
    procedure NewRect; // <--- Вспомогательный
 
  protected
    procedure Resize; override; // Вот этот метод вызывается при каждом изменении размера
 
 
procedure TMemo.NewRect;
var
  Rect: TRect;
begin
  // Отступ снизу
  Perform(EM_GETRECT, 0, LongInt(@Rect));
  Dec(Rect.Bottom, 10);
  Perform(EM_SETRECT, 0, LongInt(@Rect));
end;
 
procedure TMemo.Resize;
begin
  inherited;
  NewRect; // Изменяем Rect
end;

, и из конструктора тоже вызвать NewRect, чтобы работало еще до первого изменения размера пользователем.

@FIL · 27.11.2012, 22:29

UI, в конструкторе NewRect не срабатывает (по крайней мере в Д7), я и раньше пробовал там отступ назначать. Есть процедуры, которые выполняются после конструктора (единоразово)?
А по Resize работает даже без Dec(Rect.Bottom, 10);. Текст становится всегда выше уровня значка.

@volvo · 27.11.2012, 22:32

Сообщение от gorfil

Есть процедуры, которые выполняются после конструктора (единоразово)?

Конечно: AfterConstruction, например.

@FIL · 27.11.2012, 22:46

Так тоже не срабатывает.

Delphi
1
2
3
4
5
procedure TMemo.AfterConstruction;
begin
  inherited;
  NewRect;
end;

27.11.2012, 23:18

Для отрисовки GRIP-а можно поиграться с функцией DrawFrameControl

Delphi
1
  DrawFrameControl(Memo1.Canvas.Handle, Rect(0, 0, W, H), DFC_SCROLL, DFCS_SCROLLSIZEGRIP);

@volvo · 28.11.2012, 01:20

Сообщение от gorfil

Так тоже не срабатывает.

Очень странно. Я надеюсь, метод описан там, где он должен быть, в секции public, и с директивой override?

Собственно, непонятно другое. Почему NewRect не отрабатывает при вызове из конструктора? Это ж обычный метод, даже не виртуальный, обязан работать... Если даже это не работает в Д7, что там вообще тогда работает?

Сообщение от gorfil

А по Resize работает даже без Dec(Rect.Bottom, 10);. Текст становится всегда выше уровня значка.

И это непонятно. Неправильная это работа, я не заказывал без уменьшения Rect.Bottom. Без уменьшения должна переустанавливаться та же структура (тот же размер), который был прочитан, то есть, изменяться ничего не должно. Почему изменяется? Что-то бардак какой-то...

@FIL · 28.11.2012, 10:48

Сообщение от UI

Очень странно. Я надеюсь, метод описан там, где он должен быть, в секции public, и с директивой override?

Delphi
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
  public
     constructor Create(AOwner: TComponent); override;
     destructor Destroy; override;
     procedure AfterConstruction; override;
 
//...
 
constructor TMemo.Create(AOwner: TComponent);
begin
  inherited;
  Sizing := False;
  DoubleBuffered := true;
  FCanvas := TControlCanvas.Create;
  TControlCanvas(FCanvas).Control := Self;
  NewRect;
end;
 
procedure TMemo.AfterConstruction;
begin
  inherited;
  NewRect;
end;
 
procedure TMemo.NewRect;
var
  Rect: TRect;
begin
  Perform(EM_GETRECT, 0, LongInt(@Rect));
  Dec(Rect.Bottom, 10);
  Perform(EM_SETRECT, 0, LongInt(@Rect));
end;

Вероятно после конструктора выполняются процедуры, которые сбрасывают отступы.
Например, при изменении размера сбрасываются отступы (не прописанные в Resize), хотя вызов самой Resize отступы не меняет.

А какая процедура выполняется перед самым появлением компонента? Show? Activate?

@volvo · 28.11.2012, 11:16

Ну, не знаю... Попробуй еще вот этот способ, если уж и это не отработает на вашей Семерке - то выбросьте ее в конце концов, что ж тогда с ней делать, если она простейшего не позволяет? Что тогда говорить о более сложных случаях? Или так и будем писать однообразные сортировки да программы для прохождения тестов всю жизнь?

@FIL · 28.11.2012, 12:21

Сообщение от UI

Попробуй еще вот этот способ

Да, этот способ сработал.
Получилось так:

Кликните здесь для просмотра всего текста

Delphi
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
//...
 
type
  TMemo = class(StdCtrls.TMemo)
  private
    MouseButtonDown, Sizing, FResetRect : Boolean;
    StartPosition, MousePosition: TPoint;
    MemoRect: TRect;
    FCanvas : TCanvas;
    procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
 
  public
     constructor Create(AOwner: TComponent); override;
     destructor Destroy; override;
  protected
    procedure MouseMove(Shift: TShiftState; X: Integer; Y: Integer); override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X: Integer;
      Y: Integer); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X: Integer;
      Y: Integer); override;
    procedure Resize; override;
  end;
 
//...
 
constructor TMemo.Create(AOwner: TComponent);
begin
  inherited;
  Sizing := False;
  DoubleBuffered := true;
  FCanvas := TControlCanvas.Create;
  TControlCanvas(FCanvas).Control := Self;
  FResetRect := true;
end;
 
destructor TMemo.Destroy;
begin
  FreeAndNil(FCanvas);
  inherited;
end;
 
procedure TMemo.WMPaint(var Message: TWMPaint);
var
  Rect: TRect;
begin
  if FResetRect then
  begin
    Perform(EM_GETRECT, 0, LongInt(@Rect));
//    Dec(Rect.Bottom, 10);
    Perform(EM_SETRECT, 0, LongInt(@Rect));
    FResetRect := false;
  end;
 
  inherited;
 
  FCanvas.Pixels[Width-7, Height-7]   := clGrayText; // 109
  FCanvas.Pixels[Width-10, Height-7]  := clGrayText;
  FCanvas.Pixels[Width-13, Height-7]  := clGrayText;
  FCanvas.Pixels[Width-10, Height-10] := clGrayText;
  FCanvas.Pixels[Width-7, Height-10]  := clGrayText;
  FCanvas.Pixels[Width-7, Height-13]  := clGrayText;
 
  FCanvas.Pixels[Width-7, Height-8]   := clBtnShadow; // 160
  FCanvas.Pixels[Width-10, Height-8]  := clBtnShadow;
  FCanvas.Pixels[Width-13, Height-8]  := clBtnShadow;
  FCanvas.Pixels[Width-10, Height-11] := clBtnShadow;
  FCanvas.Pixels[Width-7, Height-11]  := clBtnShadow;
  FCanvas.Pixels[Width-7, Height-14]  := clBtnShadow;
 
  FCanvas.Pixels[Width-8, Height-7]   := clActiveBorder; // 180
  FCanvas.Pixels[Width-11, Height-7]  := clActiveBorder;
  FCanvas.Pixels[Width-14, Height-7]  := clActiveBorder;
  FCanvas.Pixels[Width-11, Height-10] := clActiveBorder;
  FCanvas.Pixels[Width-8, Height-10]  := clActiveBorder;
  FCanvas.Pixels[Width-8, Height-13]  := clActiveBorder;
 
  FCanvas.Pixels[Width-8, Height-8]   := clBtnFace; // 240
  FCanvas.Pixels[Width-11, Height-8]  := clBtnFace;
  FCanvas.Pixels[Width-14, Height-8]  := clBtnFace;
  FCanvas.Pixels[Width-11, Height-11] := clBtnFace;
  FCanvas.Pixels[Width-8, Height-11]  := clBtnFace;
  FCanvas.Pixels[Width-8, Height-14]  := clBtnFace;
 end;
 
procedure TMemo.Resize;
begin
  inherited;
  FResetRect := true;
end;
 
procedure TMemo.MouseDown(Button: TMouseButton; Shift: TShiftState; X,
  Y: Integer);
begin
  inherited;
  if Button = mbLeft then
  begin
    StartPosition := Point(X, Y);
    MemoRect := BoundsRect;
    MouseButtonDown := True;
  end;
end;
 
procedure TMemo.MouseMove(Shift: TShiftState; X, Y: Integer);
var
  XOffset, YOffset: integer;
  InnerRect: TRect;
begin
  inherited;
  InnerRect := Bounds(Width - 10, Height - 10, Width, Height);
  MousePosition := Point(X, Y);
 
  if (PtInRect(InnerRect, MousePosition)) or Sizing then
  begin
    Cursor := crSizeNWSE;
    if MouseButtonDown then
    begin
      Sizing := True;
      XOffset := MousePosition.X - StartPosition.X;
      YOffset := MousePosition.Y - StartPosition.Y;
      StartPosition := MousePosition;
      Inc(MemoRect.Right, XOffset);
      Inc(MemoRect.Bottom, YOffset);
      BoundsRect := MemoRect;
    end;
  end
  else
   Cursor := crDefault;
end;
 
procedure TMemo.MouseUp(Button: TMouseButton; Shift: TShiftState; X,
  Y: Integer);
begin
  inherited;
  MouseButtonDown := False;
  Sizing := False;
end;
 
//...

@MorpheyZ · 21.05.2016, 09:54

Delphi
1
TMemo = class(StdCtrls.TMemo)

в Delphi XE4 эта строчка выдает ошибку, а так же ругается на обе "perform: и все ширины и высоты в процедуре: "TMemo.WMPaint"

@BOGG ART · 21.05.2016, 17:50

Может потому что StdCtrls был типа "переименован" в фигню вроде "Vcl.StdCtrls".

Добавлено через 2 часа 55 минут
На мой взгляд отодвигать края - это не айс. Кстати если ScrollBars<>ssNone - нифига не работает. С:
Поковыряю как будет время, может улучшу.

@MorpheyZ · 22.05.2016, 11:17

Ну может быть. Если написать так:

Delphi
1
TMemo = class(TMemo)

прописав в Uses "Vcl.StdCtrls", то этой ошибки нет, но все остальные остались.
Жаль, что ни разу не был предоставлен полный код, посмотреть бы что там в Uses, и прочее, всё же раздел "для начинающих")

@BOGG ART · 22.05.2016, 19:41

Сообщение от MorpheyZ

Если написать так:

Дак как раз нельзя так писать. "Я" не может быть потомком "Я". Потому и надо в скобках полный путь писать до настоящего компонента.

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

Новые блоги и статьи Все статьи Все блоги /
Новый ноутбук volvo 07.12.2025 Всем привет. По скидке в "черную пятницу" взял себе новый ноутбук Lenovo ThinkBook 16 G7 на Амазоне: Ryzen 5 7533HS 64 Gb DDR5 1Tb NVMe 16" Full HD Display Win11 Pro	Музыка, написанная Искусственным Интеллектом volvo 04.12.2025 Всем привет. Некоторое время назад меня заинтересовало, что уже умеет ИИ в плане написания музыки для песен, и, собственно, исполнения этих самых песен. Стихов у нас много, уже вышли 4 книги, еще 3. . .	От async/await к виртуальным потокам в Python IndentationError 23.11.2025 Армин Ронахер поставил под сомнение async/ await. Создатель Flask заявляет: цветные функции - провал, виртуальные потоки - решение. Не threading-динозавры, а новое поколение лёгких потоков. Откат?. . .	Поиск "дружественных имён" СОМ портов Argus19 22.11.2025 Поиск "дружественных имён" СОМ портов На странице: https:/ / norseev. ru/ 2018/ 01/ 04/ comportlist_windows/ нашёл схожую тему. Там приведён код на С++, который показывает только имена СОМ портов, типа,. . .	Сколько Государство потратило денег на меня, обеспечивая инсулином. Programma_Boinc 20.11.2025 Сколько Государство потратило денег на меня, обеспечивая инсулином. Вот решила сделать интересный приблизительный подсчет, сколько государство потратило на меня денег на покупку инсулинов. . . .
Ломающие изменения в C#.NStar Alpha Etyuhibosecyu 20.11.2025 Уже можно не только тестировать, но и пользоваться C#. NStar - писать оконные приложения, содержащие надписи, кнопки, текстовые поля и даже изображения, например, моя игра "Три в ряд" написана на этом. . .	Мысли в слух kumehtar 18.11.2025 Кстати, совсем недавно имел разговор на тему медитаций с людьми. И обнаружил, что они вообще не понимают что такое медитация и зачем она нужна. Самые базовые вещи. Для них это - когда просто люди. . .	Создание Single Page Application на фреймах krapotkin 16.11.2025 Статья исключительно для начинающих. Подходы оригинальностью не блещут. В век Веб все очень привыкли к дизайну Single-Page-Application . Быстренько разберем подход "на фреймах". Мы делаем одну. . .	Фото: Daniel Greenwood kumehtar 13.11.2025	Расскажи мне о Мире, бродяга kumehtar 12.11.2025 — Расскажи мне о Мире, бродяга, Ты же видел моря и метели. Как сменялись короны и стяги, Как эпохи стрелою летели. - Этот мир — это крылья и горы, Снег и пламя, любовь и тревоги, И бескрайние. . .

Как сделать поле Memo растягивающимся?

Решение

Решение

@A_R_S МИР ВАШЕМУ ДОМУ!!! 57 / 58 / 7 Регистрация: 01.04.2009 Сообщений: 890 Записей в блоге: 1

	Как сделать поле Memo растягивающимся? 26.11.2012, 12:52. Показов 4480. Ответов 17 Метки нет (Все метки) Как сделать поле MEMO растягивающимся, например форма ввода на сайте которую можно потянуть и расширить?. Изображения 0

@FIL Модератор 3492 / 2614 / 742 Регистрация: 19.09.2012 Сообщений: 7,977
	27.11.2012, 22:29
	UI, в конструкторе NewRect не срабатывает (по крайней мере в Д7), я и раньше пробовал там отступ назначать. Есть процедуры, которые выполняются после конструктора (единоразово)? А по Resize работает даже без Dec(Rect.Bottom, 10);. Текст становится всегда выше уровня значка. 1

@volvo Супер-модератор 33194 / 21480 / 8231 Регистрация: 22.10.2011 Сообщений: 36,848 Записей в блоге: 12
	28.11.2012, 11:16
	Ну, не знаю... Попробуй еще вот этот способ, если уж и это не отработает на вашей Семерке - то выбросьте ее в конце концов, что ж тогда с ней делать, если она простейшего не позволяет? Что тогда говорить о более сложных случаях? Или так и будем писать однообразные сортировки да программы для прохождения тестов всю жизнь? 1

@BOGG ART 592 / 459 / 147 Регистрация: 09.12.2013 Сообщений: 2,385 Записей в блоге: 2
	21.05.2016, 17:50
	Может потому что StdCtrls был типа "переименован" в фигню вроде "Vcl.StdCtrls". Добавлено через 2 часа 55 минут На мой взгляд отодвигать края - это не айс. Кстати если ScrollBars<>ssNone - нифига не работает. С: Поковыряю как будет время, может улучшу. 0