Как сделать поле 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

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

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

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

Новые блоги и статьи Все статьи Все блоги /
Отчёт о спецтехнике находящейся в ремонте Maks 20.04.2026 Отчёт из решения ниже размещен в конфигурации КА2. Задача: отобразить спецтехнику, которая на данный момент находится в ремонте. Есть нетиповой документ "Заявка на ремонт спецтехники" который. . .	Памятка для бота и "визитка" для читателей "Semantic Universe Layer (Слой семантической вселенной)" Hrethgir 19.04.2026 Сгенерировано для краткого описания по случаю сборки и компиляции скелета серверного приложения. И пусть после этого скажут, что статьи сгенерированные AI - туфта и не интересно. И это не реклама -. . .	Запрет удаления строк ТЧ документа при определенном условии Maks 19.04.2026 Алгоритм из решения ниже реализован на примере нетипового документа "Аккумуляторы", разработанного в конфигурации КА2. У данного документа есть ТЧ, в которой в зависимости от прав доступа. . .	Модель заражения группы наркоманов alhaos 17.04.2026 Условия задачи сформулированы тут Суть: - Группа наркоманов из 10 человек. - Только один инфицирован ВИЧ. - Колются одной иглой. - Колются раз в день. - Колются последовательно через. . .
Мысли в слух. Про "навсегда". kumehtar 16.04.2026 Подумалось тут, что наверное очень глупо использовать во всяких своих установках понятие "навсегда". Это очень сильное понятие, и я только начинаю понимать край его смысла, не смотря на то что давно. . .	My Business CRM MaGz GoLd 16.04.2026 Всем привет, недавно возникла потребность создать CRM, для личных нужд. Собственно программа предоставляет из себя базу данных клиентов, в которой можно фиксировать звонки, стадии сделки, а также. . .	Знаешь почему 90% людей редко бывают счастливыми? kumehtar 14.04.2026 Потому что они ждут. Ждут выходных, ждут отпуска, ждут удачного момента. . . а удачный момент так и не приходит.	Фиксация колонок в отчете СКД Maks 14.04.2026 Фиксация колонок в СКД отчета типа Таблица. Задача: зафиксировать три левых колонки в отчете. Процедура ПриКомпоновкеРезультата(ДокументРезультат, ДанныеРасшифровки, СтандартнаяОбработка) / / . . .

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

Решение

Решение

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

	Как сделать поле Memo растягивающимся? 26.11.2012, 12:52. Показов 4596. Ответов 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 Супер-модератор 33421 / 21527 / 8240 Регистрация: 22.10.2011 Сообщений: 36,935 Записей в блоге: 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