TMemo

Memo со свойствами Row и Col

2017-08-10T21:44:19+07:00

Наследник TMemo со свойствами row & col:

Подробнее...

Вставка текста в TMemo в текущую позицию

2017-08-10T21:50:02+07:00

Code:

SendMessage(Memo.Handle, EM_REPLACESEL, 0, PCHAR('Delphi World - это КРУТО!'));

Var TempBuf :Array [0..255] of Char;

SendMessage(Memo.Handle, EM_REPLACESEL, 0, StrPCopy(TempBuf,'Delphi World - это КРУТО!'));

Memo1.SelText := 'Delphi World!';

Выделить строку в Memo

2017-08-10T22:00:31+07:00

Code:

procedure TfrmMain.Memo1Click(Sender: TObject);

var

Line: Integer;

begin

with (Sender as TMemo) do

begin

Line := Perform(EM_LINEFROMCHAR, SelStart, 0);

SelStart := Perform(EM_LINEINDEX, Line, 0);

SelLength := Length(Lines[Line]);

end;

Дельфи компонент для подкраски синтаксиса

2017-08-10T21:55:47+07:00

Результат совместной работы Fanasist'а и меня. Это компонент для Дельфи для известного пакета SynEdit (https://synedit.sourceforge.net), позволяющий на лету создавать подкраску синтаксиса по любым правилам любых форматов (создание и загрузка в run-time, хранение шаблонов на диске). В настоящее время пакет включает в себя более 300 готовых шаблонов для наиболее распространённых форматов, но каждый может создать свой собственный шаблон (можно с помошью компонента или используя прилагающуюся утилиту). Пример использования - простенький текстовый редактор с поддержкой любых расскрасок.

Платформа: Delphi 5/6/7

Для работы необходимо установить предварительно установить пакет SynEdit (https://synedit.sourceforge.net).

Компонент свободен для распространения и поставляется с исходными кодами.

Логика работы:

Для подкраски синтаксиса необходимо предусмотреть следующие правила:

1) расскраска всего кода в промежутке от одного слова до второго - например комментарии /*...*/ или строки "...."

2) расскраска ключевых слов

Это реализовано, кроме того бывают ситуации когда промежуток должен быть расскрашен по другому с другими правилами например ASP код внутри HTML или ассемблерные вставки внутри Дельфи - это тоже реализовано тем что внутри промежутка можно использовать свои правила и промежутки. Вложенность не лимитирована.

Всем кому интересно, я создал форум для обсуждения компонента, правда сообщения писать только на английском, там уже идёт дискуссия с авторами проекта SynEdit:

Добавление строк в Memo

2017-08-10T21:50:19+07:00

Code:

Memo1.Perform( WM_SETREDRAW, 0, 0 );

// ... здесь можно добавлять строки

Memo1.Perform( WM_SETREDRAW, 1, 0 );

Memo1.Refresh;

Как вставить содержимое файла в текущую позицию TMemo?

2017-08-10T21:47:57+07:00

Для чтения файла будем использовать TMemoryStream, а затем используем метод SetSelTextBuf() из TMemo, чтобы вставить в него текст:

Подробнее...

Как загрузить юникоды в мемо?

2017-08-10T21:48:47+07:00

Code:

procedure LoadUnicodeFile(const filename: string; strings: TStrings);

procedure SwapWideChars(p: PWideChar);

begin

while p^ <> #0000 do

begin

p^ := WideChar(Swap(Word(p^)));

Inc(p);

end;

var

ms: TMemoryStream;

wc: WideChar;

pWc: PWideChar;

begin

ms := TMemoryStream.Create;

try

ms.LoadFromFile(filename);

ms.Seek(0, soFromend);

wc := #0000;

ms.Write(wc, sizeof(wc));

pWC := ms.Memory;

if pWc^ = #$FEFF then {normal byte order mark}

Inc(pWc)

else if pWc^ = #$FFFE then

begin {byte order is big-endian}

SwapWideChars(pWc);

Inc(pWc);

end

else

; {no byte order mark}

strings.Text := WideChartoString(pWc);

finally

ms.free;

end;

Использовать

LoadUnicodeFile(filename, memo1.lines);

Как использовать различные шрифты и стили в Memo-объекте?

2017-08-10T21:59:41+07:00

Просто создайте собственный TxxxMemo: наследуйтесь от стандартного TMemo и перекройте метод Paint.

Вот мой старый пример, изменяющий цвет каждой строки:

Подробнее...

Как нарисовать что-нибудь на TMemo?

2017-08-10T21:54:37+07:00

Для рисования на поверхности TMemo необходимо создать создать собственный компонент, наследованный от TMemo и переопределить в нём рисование. Примерно так:

Подробнее...

Как настроить табуляцию в компоненте TMemo?

2017-08-10T21:53:44+07:00

Пошлите в Memo сообщение EM_SETTABSTOPS

Code:

procedure TForm1.FormCreate(Sender: TObject);

var

DialogUnitsX: LongInt;

PixelsX: LongInt;

i: integer;

TabArray: array[0..4] of integer;

begin

Memo1.WantTabs := true;

DialogUnitsX := LoWord(GetDialogBaseUnits);

PixelsX := 20;

for i := 1 to 5 do

begin

TabArray[i - 1] := ((PixelsX * i) * 4) div DialogUnitsX;

end;

SendMessage(Memo1.Handle,

EM_SETTABSTOPS, 5, LongInt(@TabArray));

Memo1.Refresh;

end;

Подробнее...

Как переместить каретку TMemo в нужную строку?

2017-08-10T21:42:50+07:00

Code:

Function SetCaretPosition(memo:TMemo; x,y:integer);

{©Drkb v.3(2007): www.drkb.ru,

®Vit (Vitaly Nevzorov) - nevzorov@yahoo.com}

var i:integer;

begin

i := SendMessage(memo.Handle, EM_LINEINDEX, y, 0) + x;

SendMessage(memo1.Handle, EM_SETSEL, i, i);

end;

или

type TFake=class(TCustomMemo);

....

TFake(MyMemo).SetCaretPos()

Как перехватить Ctrl-V в компоненте TMemo?

2017-08-10T21:51:09+07:00

Следующий пример демонстрирует, как перехватить комбинацию Ctrl-V в компоненте TMemo и поместить в него свой текст вместо того, который в буфере обмена.

Подробнее...

Как получить координаты курсора в memo-поле?

2017-08-10T21:43:50+07:00

Code:

procedure CaretPos(H: THandle; var L,C : Word);

begin

L := SendMessage(H,EM_LINEFROMCHAR,-1,0);

C := LoWord(SendMessage(H,EM_GETSEL,0,0)) - SendMessage(H,EM_LINEINDEX,-1,0);

end;

procedure TForm1.Button1Click(Sender: TObject);

var

LineNum,ColNum : Word;

begin

CaretPos(Memo1.Handle,LineNum,ColNum);

Edit1.Text := IntToStr(LineNum) + ' ' + IntToStr(ColNum);

end;

Подробнее...

Как програмно прокрутить Memo?

2017-08-10T21:45:25+07:00

Этот пример прокручивает на одну строку вниз.

Code:

memo1.Perform(WM_VScroll, SB_LINEDOWN,0);

Подробнее...

Как реализовать поиск, замену

2017-08-10T21:59:15+07:00

Code:

procedure TForm1.Button1Click(Sender: TObject);

begin

if OpenDialog1.Execute then

Memo1.Lines.LoadFromFile(OpenDialog1.FileName);

end;

procedure TForm1.Button2Click(Sender: TObject);

var

find: string;

text: string;

st, len: integer;

res: integer;

begin

if Memo1.SelStart >= Length(Memo1.Text) then

Memo1.SelStart := 0;

st := Memo1.SelStart + 1;

if (Memo1.SelLength <= 0) or (not CheckBox1.Checked) then

begin

inc(st, Memo1.SelLength);

len := Length(Memo1.Text) - st;

end

else

len := Memo1.SelLength;

text := copy(Memo1.Text, st, len);

find := Edit1.Text;

res := pos(find, text);

if res = 0 then

begin

ShowMessage('Search string "' + find + '" not found');

Exit;

end;

Memo1.SelStart := res + st - 2;

Memo1.SelLength := length(find);

end;

Поиск и замена текста в TMemo

Code:

procedure TForm1.FindDialog1Find(Sender: TObject);

var

Buff, P, FT: PChar;

BuffLen: Word;

begin

with Sender as TFindDialog do

begin

GetMem(FT, Length(FindText) + 1);

StrPCopy(FT, FindText);

BuffLen := Memo1.GetTextLen + 1;

GetMem(Buff, BuffLen);

Memo1.GetTextBuf(Buff, BuffLen);

P := Buff + Memo1.SelStart + Memo1.SelLength;

P := StrPos(P, FT);

if P = nil then

MessageBeep(0)

else

begin

Memo1.SelStart := P - Buff;

Memo1.SelLength := Length(FindText);

end;

FreeMem(FT, Length(FindText) + 1);

FreeMem(Buff, BuffLen);

end;

procedure TForm1.ReplaceDialog1Replace(Sender: TObject);

begin

with Sender as TReplaceDialog do

while True do

begin

if Memo1.SelText <> FindText then

FindDialog1Find(Sender);

if Memo1.SelLength = 0 then

Break;

Memo1.SelText := ReplaceText;

if not (frReplaceAll in Options) then

Break;

end;

Code:

{ **** UBPFD *********** by delphibase.endimus.com ****

>> Поиск и замена текста в поле МЕМО программно

На форму бросьте кнопку и поле МЕМО

напишите в МЕМО(в первой строке) текст и поставьте C:\, нажмите кнопку,

при этом C:\ замениться на D:\ без потери форматирования

Вот и все...

Зависимости: Смотрите uses

Автор: Mirag, wwwMirage@yandex.ru, Mirag

***************************************************** }

unit Unit1;

interface

uses

Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,

Dialogs, StdCtrls;

type

TForm1 = class(TForm)

Button1: TButton;

Label1: TLabel;

Memo1: TMemo;

procedure Button1Click(Sender: TObject);

procedure FormCreate(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

end;

var

Form1: TForm1;

result: boolean;

implementation

{$R *.dfm}

function ReplaceSub(str, sub1, sub2: string): string;

var

aPos: Integer;

rslt: string;

begin

aPos := Pos(sub1, str);

rslt := '';

while (aPos <> 0) do

begin

rslt := rslt + Copy(str, 1, aPos - 1) + sub2;

Delete(str, 1, aPos + Length(sub1) - 1);

aPos := Pos(sub1, str);

end;

Result := rslt + str;

end;

function MatchStrings(source, pattern: string): Boolean;

var

pSource: array[0..255] of Char;

pPattern: array[0..255] of Char;

function MatchPattern(element, pattern: PChar): Boolean;

function IsPatternWild(pattern: PChar): Boolean;

var

t: Integer;

begin

Result := StrScan(pattern, '*') <> nil;

if not Result then

Result := StrScan(pattern, '?') <> nil;

end;

begin

if 0 = StrComp(pattern, '*') then

Result := True

else if (element^ = Chr(0)) and (pattern^ <> Chr(0)) then

Result := False

else if element^ = Chr(0) then

Result := True

else

begin

case pattern^ of

'*': if MatchPattern(element, @pattern[1]) then

Result := True

else

Result := MatchPattern(@element[1], pattern);

'?': Result := MatchPattern(@element[1], @pattern[1]);

else

if element^ = pattern^ then

Result := MatchPattern(@element[1], @pattern[1])

else

Result := False;

end;

begin

StrPCopy(pSource, source);

StrPCopy(pPattern, pattern);

Result := MatchPattern(pSource, pPattern);

end;

procedure TForm1.Button1Click(Sender: TObject);

var

ss: string;

begin

result := MatchStrings(memo1.Lines.Text, '*c:\*');

if result = true then

begin

messagebox(0, '', '', MB_OK);

ss := ReplaceSub(memo1.Lines.Strings[0], 'c:\', 'd:\');

memo1.Lines.Delete(0);

memo1.Lines.Insert(0, ss);

end;

procedure TForm1.FormCreate(Sender: TObject);

begin

end;

end.

Code:

{ **** UBPFD *********** by delphibase.endimus.com ****

>> Поиск строки в редакторе Memo

Зависимости: Windows, Classes, StdCtrls

Автор: Fenik, chook_nu@uraltc.ru, Новоуральск

***************************************************** }

function FindInMemo(Memo: TMemo; const FindText: string;

FindDown, MatchCase: Boolean): Boolean;

{Если строка найдена, то результат True, иначе - False;

FindText : искомая строка;

FindDown : True - поиск вниз от курсора ввода;

False - поиск вверх от курсора ввода;

MatchCase : True - с учетом регистра букв,

False - не учитывая регистр бук.

Если у Memo стоит автоперенос слов, то могут

возникнуть проблемы - текст будет найден,

но выделен не там где надо. Так что, для нормального поиска

свойство ScrollBars у Memo ставить в ssBoth (ну или ssHorizontal)}

function PosR2L(const FindStr, SrcStr: string): Integer;

{Поиск последнего вхождения подстроки FindStr в строку SrcStr}

var

ps, L: Integer;

function InvertSt(const S: string): string;

{Инверсия строки S}

var

i: Integer;

begin

L := Length(S);

SetLength(Result, L);

for i := 1 to L do

Result[i] := S[L - i + 1];

end;

begin

ps := Pos(InvertSt(FindStr), InvertSt(SrcStr));

if ps <> 0 then

Result := Length(SrcStr) - Length(FindStr) - ps + 2

else

Result := 0;

end;

function MCase(const s: string): string;

{Перевод заглавных букв в строчные;

Функция вызывается если регистр не учитывается}

var

i: Integer;

begin

Result := s;

for i := 1 to Length(s) do

begin

case s[i] of

'A'..'Z',

'А'..'Я': Result[i] := Chr(Ord(s[i]) + 32);

'Ё': Result[i] := 'ё';

'Ѓ': Result[i] := 'ѓ';

'Ґ': Result[i] := 'ґ';

'Є': Result[i] := 'є';

'Ї': Result[i] := 'ї';

'І': Result[i] := 'і';

'Ѕ': Result[i] := 'ѕ';

end;

var

Y, X, SkipChars: Integer;

FindS, SrcS: string;

P: TPoint;

begin

Result := False;

if MatchCase then

FindS := FindText

else

FindS := MCase(FindText);

P := Memo.CaretPos;

if FindDown then

{Поиск вправо и вниз от курсора ввода}

for Y := P.y to Memo.Lines.Count do

begin

if Y <> P.y then

{Если это не строка, в которой курсор вода,

то ищем во всей строке}

SrcS := Memo.Lines[Y]

else

{иначе обрезаем строку от курсора до конца}

SrcS := Copy(Memo.Lines[Y], P.x + 1,

Length(Memo.Lines[Y]) - P.x + 1);

if not MatchCase then

SrcS := MCase(SrcS);

X := Pos(FindS, SrcS);

if X <> 0 then

begin

if Y = P.y then

Inc(X, P.x);

P := Point(X, Y);

Result := True;

Break; {Выход из цикла}

end

else

{Поиск влево и вверх от курсора ввода}

for Y := P.y downto 0 do

begin

if Y <> P.y then

{Если это не строка, в которой курсор вода,

то ищем во всей строке}

SrcS := Memo.Lines[Y]

else

{иначе обрезаем строку от начала до курсора

минус выделенный текст}

SrcS := Copy(Memo.Lines[Y], 1, P.x - Memo.SelLength);

if not MatchCase then

SrcS := MCase(SrcS);

X := PosR2L(FindS, SrcS);

if X <> 0 then

begin

P := Point(X, Y);

Result := True;

Break; {Выход из цикла}

end

end;

if Result then

begin

{Если текст найден - выделяем его}

SkipChars := 0;

for y := 0 to P.Y - 1 do

Inc(SkipChars, Length(Memo.Lines[y]));

Memo.SelStart := SkipChars + (P.Y * 2) + P.X - 1;

Memo.SelLength := Length(FindText);

end;

Пример использования:

procedure TForm1.FindDialog1Find(Sender: TObject);

begin

if not FindInMemo(Memo1,

FindDialog1.FindText,

frDown in FindDialog1.Options,

frMatchCase in FindDialog1.Options) then

Application.MessageBox('Поиск результатов не дал.',

PChar(Application.Title),

MB_OK or MB_ICONINFORMATION);

end;

Пришло мне письмо от Алексея. На этот раз он прислал (цитирую): "юнит для поиска строки(текста) в TEdit, TMemo, или других компонентах (дочерних TCustomEdit'у)." Так как тескт "авторский" (более того, здесь также присутствует наследование), помещаю его здесь в том виде, в котором он был прислан, т.е. без перевода. В случае каких-либо вопросов и недоразумений обращайтесь по вышеуказанносу адресу электронной почты.

Code:

{ПРИМЕР :

[...]

implementation

uses Search;}

{$R *.DFM}

{procedure TForm1.Button1Click(Sender: TObject);

begin

SearchMemo(RichEdit1, 'Найди меня', [frDown]);

end;

В опции поиска можно подключать, отключать, комбинировать следующие

параметры:

frDown - указывает на то, что происходит поиск вниз по тексту от курсора(при

отключенном frDown'е будет происходит поиск вверх по тексту).

frMatchCase - указывает на то, что следует проводить поиск с учетом

регистра.

frWholeWord - указывает на то, что следует искать только слово целиком.

[...]

Авторские права на этот юнит пренадлежат неизвесно кому.

В каком виде этот юнит попал мне, практически в этом же

виде я отдаю его вам. Пользуйтесь и благодарите неизвесного

героя.}

unit Search;

interface

uses

WinProcs, SysUtils, StdCtrls, Dialogs;

const

{****************************************************************************

* Default word delimiters are any character except the core alphanumerics. *

****************************************************************************}

WordDelimiters: set of Char = [#0..#255] - ['a'..'z', 'A'..'Z', '1'..'9',

'0'];

{******************************************************************************

* SearchMemo scans the text of a TEdit, TMemo, or other TCustomEdit-derived *

* component for a given search string. The search starts at the current *

* caret position in the control. The Options parameter determines whether *

* the search runs forward (frDown) or backward from the caret position, *

* whether or not the text comparison is case sensitive, and whether the *

* matching string must be a whole word. If text is already selected in the *

* control, the search starts at the 'far end' of the selection (SelStart if *

* searching backwards, SelEnd if searching forwards). If a match is found, *

* the control's text selection is changed to select the found text and the *

* function returns True. If no match is found, the function returns False. *

******************************************************************************}

function SearchMemo(Memo: TCustomEdit;

const SearchString: string;

Options: TFindOptions): Boolean;

{******************************************************************************

* SearchBuf is a lower-level search routine for arbitrary text buffers. *

* Same rules as SearchMemo above. If a match is found, the function returns *

* a pointer to the start of the matching string in the buffer. If no match, *

* the function returns nil. *

******************************************************************************}

function SearchBuf(Buf: PChar; BufLen: Integer;

SelStart, SelLength: Integer;

SearchString: string;

Options: TFindOptions): PChar;

implementation

function SearchMemo(Memo: TCustomEdit;

const SearchString: string;

Options: TFindOptions): Boolean;

var

Buffer, P: PChar;

Size: Word;

begin

Result := False;

if (Length(SearchString) = 0) then

Exit;

Size := Memo.GetTextLen;

if Size = 0 then

Exit;

Buffer := StrAlloc(Size + 1);

try

Memo.GetTextBuf(Buffer, Size + 1);

P := SearchBuf(Buffer, Size, Memo.SelStart, Memo.SelLength, SearchString,

Options);

if P <> nil then

begin

Memo.SelStart := P - Buffer;

Memo.SelLength := Length(SearchString);

Result := True;

end;

finally

StrDispose(Buffer);

end;

function SearchBuf(Buf: PChar; BufLen: Integer;

SelStart, SelLength: Integer;

SearchString: string;

Options: TFindOptions): PChar;

var

SearchCount, I: Integer;

C: Char;

Direction: Shortint;

CharMap: array[Char] of Char;

function FindNextWordStart(var BufPtr: PChar): Boolean;

begin { (True XOR N) is equivalent to (not N) }

// Result := False; { (False XOR N) is equivalent to (N) }

{ When Direction is forward (1), skip non delimiters, then skip delimiters. }

{ When Direction is backward (-1), skip delims, then skip non delims }

while (SearchCount > 0) and

((Direction = 1) xor

(BufPtr^ in WordDelimiters)) do

begin

Inc(BufPtr, Direction);

Dec(SearchCount);

end;

while (SearchCount > 0) and

((Direction = -1) xor

(BufPtr^ in WordDelimiters)) do

begin

Inc(BufPtr, Direction);

Dec(SearchCount);

end;

Result := SearchCount > 0;

if Direction = -1 then

begin {back up one char, to leave ptr on first non delim}

Dec(BufPtr, Direction);

Inc(SearchCount);

end;

begin

Result := nil;

if BufLen <= 0 then

Exit;

if frDown in Options then

begin {if frDown...}

Direction := 1;

Inc(SelStart, SelLength); { start search past end of selection }

SearchCount := BufLen - SelStart - Length(SearchString);

if SearchCount < 0 then

Exit;

if Longint(SelStart) + SearchCount > BufLen then

Exit;

end {if frDown...}

else

begin {else}

Direction := -1;

Dec(SelStart, Length(SearchString));

SearchCount := SelStart;

end; {else}

if (SelStart < 0) or (SelStart > BufLen) then

Exit;

Result := @Buf[SelStart];

{ Using a Char map array is faster than calling AnsiUpper on every character }

for C := Low(CharMap) to High(CharMap) do

CharMap[C] := C;

if not (frMatchCase in Options) then

begin {if not (frMatchCase}

AnsiUpperBuff(PChar(@CharMap), sizeof(CharMap));

AnsiUpperBuff(@SearchString[1], Length(SearchString));

end; {if not (frMatchCase}

while SearchCount > 0 do

begin {while SearchCount}

if frWholeWord in Options then

begin

if not FindNextWordStart(Result) then

Break;

end;

I := 0;

while (CharMap[Result[I]] = SearchString[I + 1]) do

begin {while (CharMap...}

Inc(I);

if I >= Length(SearchString) then

begin {if I >=...}

if (not (frWholeWord in Options)) or

(SearchCount = 0) or

(Result[I] in WordDelimiters) then

Exit;

Break;

end; {if I >=...}

end; {while (CharMap...}

Inc(Result, Direction);

Dec(SearchCount);

end; {while SearchCount}

Result := nil;

end;

end.

Как сделать Memo с закруглёнными краями?

2017-08-10T21:51:32+07:00

Code:

procedure TForm1.Button1Click(Sender: TObject);

var

rgn: HRGN;

r: TRect;

begin

r := memo1.ClientRect;

rgn := CreateRoundRectRgn(r.Left, r.top, r.right, r.bottom, 20, 20);

memo1.BorderStyle := bsNone;

memo1.Perform(EM_GETRECT, 0, lparam(@r));

InflateRect(r, -5, -5);

memo1.Perform(EM_SETRECTNP, 0, lparam(@r));

SetWindowRgn(memo1.Handle, rgn, true);

end;

Как сделать окошко подсказки в редакторе как Delphi по CTRL-J

2017-08-10T22:00:10+07:00

Автор: Hog

Допустим у тебя TMemo..

1. Делаешь ListBox, заполняешь, visible := false, parent := Memo

2. У Memo в обработчике Memo.onKeyDown что-нибудь типа:

Подробнее...

Как сделать отступ в Memo?

2017-08-10T21:52:00+07:00

С помощью API-функции SendMessage можно задать поля в Memo-компоненте. Если необходимо, например, сделать отступ в 20 пикселей слева то можно это сделать следующим образом:

Подробнее...

Как создание нестандартную процедуру разбиения слов при переносах для TEdit, TMemo или TRichEdit?

2017-08-10T21:56:23+07:00

В следующем примере создается процедура разбиения слов при переносах для TMemo. Заметьте, что реализованная процедура просто всегда разрешает перенос. Для дополнительной информации см.таже документацию к сообщению EM_SETWORDBREAKPROC.

Подробнее...

Как узнать количество видимых строчек в TMemo?

2017-08-10T21:54:58+07:00

Code:

function LinesVisible(Memo: TMemo): integer;

Var

OldFont : HFont;

Hand : THandle;

TM : TTextMetric;

Rect : TRect;

tempint : integer;

begin

Hand := GetDC(Memo.Handle);

try

OldFont := SelectObject(Hand, Memo.Font.Handle);

try

GetTextMetrics(Hand, TM);

Memo.Perform(EM_GETRECT, 0, longint(@Rect));

tempint := (Rect.Bottom - Rect.Top) div

(TM.tmHeight + TM.tmExternalLeading);

finally

SelectObject(Hand, OldFont);

end;

finally

ReleaseDC(Memo.Handle, Hand);

end;

Result := tempint;

end;

Найти все ссылки в TMemo

2017-08-10T22:00:57+07:00

Code:

{

For this tip you need Memo1, ListBox1, Label1, Button1.

}

procedure TForm1.Button1Click(Sender: TObject);

var

i, p: Integer;

s: string;

begin

ListBox1.Clear;

for i := 0 to Memo1.Lines.Count - 1 do

begin

if Pos('https://', Memo1.Lines.Strings[i]) > 0 then

begin

s := '';

{If the current line contains a "https://", read on until a space is found

Die aktuelle Zeile wird nach der Zeichenfolge "https://" durchsucht

und bei Erfolg ab der gefundenen Position ausgelesen, bis ein

Leerzeichen auftritt...}

for p := Pos('https://', Memo1.Lines.Strings[i]) to

Length(Memo1.Lines.Strings[i]) do

if Memo1.Lines.Strings[i][p] <> ' ' then

s := s + Memo1.Lines.Strings[i][p]

else

break;

{Remove some characters if address doesn't end with a space

Falls die gefundene Adresse nicht mit einem Leerzeichen abschlie?t,

werden hier noch anhangende Textzeichen entfernt...}

while Pos(s[Length(s)], '..;!")]}?''>') > 0 do

Delete(s, Length(s), 1);

// Add the Address to the list...

//Gefundene Adresse in die Liste aufnehmen...

ListBox1.Items.Add(s);

end;

// Show the number of Addresses in Label1

// Die Zahl der gefundenen Adressen in Label1 anzeigen...

if ListBox1.Items.Count > 0 then

label1.Caption := IntToStr(ListBox1.Items.Count) +

' Adresse(n) gefunden.'

else

label1.Caption := 'Keine Adresse gefunden.';

end;

Обнаружение прокрутки TMemo

2017-08-10T21:45:47+07:00

Автор: Xavier Pacheco

Создайте потомок TMemo, перехватывающий сообщения WM_HSCROLL и WM_VSCROLL:

Подробнее...

Ограничение длины и количества строк компонента Memo

2017-08-10T22:01:36+07:00

Code:

unit Unit1;

interface

uses

SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,

StdCtrls, ExtCtrls, Forms;

type

TForm1 = class(TForm)

Memo1: TMemo;

procedure FormCreate(Sender: TObject);

procedure Memo1KeyPress(Sender: TObject; var Key: Char);

public

MaxCharsPerLine, MaxLines: Integer;

function MemoLine: Integer;

function LineLen(r: Integer): Integer;

function NRows: Integer;

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

function TForm1.NRows: Integer;

begin

with Memo1 do

Result := 1 + SendMessage(Handle, EM_LINEFROMCHAR, GetTextLen - 1, 0);

end;

function TForm1.LineLen(r: Integer): Integer;

var

r1, r2: Integer;

begin

with Memo1 do

begin

r1 := SendMessage(Handle, EM_LINEINDEX, r, 0);

if (r > NRows - 1) then

r2 := SendMessage(Handle, EM_LINEINDEX, r + 1, 0) - 2 {-CR/LF}

else

r2 := GetTextLen;

end;

Result := r2 - r1;

end;

function TForm1.MemoLine: Integer;

begin

with Memo1 do

Result := SendMessage(Handle, EM_LINEFROMCHAR, SelStart, 0);

end;

procedure TForm1.FormCreate(Sender: TObject);

begin

MaxCharsPerLine := 8;

MaxLines := 4;

end;

procedure TForm1.Memo1KeyPress(Sender: TObject; var Key: Char);

begin

with Memo1 do

begin

case Key of

' '..#255: if (LineLen(MemoLine) >= MaxCharsPerLine) then

Key := #0;

#10, #13: if (NRows >= MaxLines) then

Key := #0;

#8: if (SelStart = SendMessage(Handle, EM_LINEINDEX, MemoLine, 0)) then

Key := #0;

end;

end.

Code:

procedure TForm1.Memo1Change(Sender: TObject);

const

MaxLineCount = 5;

begin

if Memo1.Lines.Count > MaxLineCount then

// undo the last change

// letze Дnderung rьckgдngig machen

Memo1.Perform(EM_UNDO, 0, 0);

// The EM_EMPTYUNDOBUFFER message clears the undo flag,

// which means that you can no longer undo your last change

// to the edit control.

// Die Message EM_EMPTYUNDOBUFFER lцscht das UnDo Flag,

// damit kann die letzte Дnderung nicht Rьckgдngig gemacht werden.

Memo1.Perform(EM_EMPTYUNDOBUFFER, 0, 0);

end;

Постраничная прокрутка Memo, когда фокус находится на Edit

2017-08-10T21:46:07+07:00

Code:

procedure TForm1.Edit1KeyDown(Sender: TObject; var Key: Word;

Shift: TShiftState);

begin

if Key = VK_F8 then

SendMessage(Memo1.Handle, { HWND для Memo }

WM_VSCROLL, { сообщение Windows }

SB_PAGEDOWN, {на страницу вниз }

0) { не используется }

else if Key = VK_F7 then

SendMessage(Memo1.Handle, WM_VSCROLL, SB_PAGEUP, 0);

end;

Проверить, можно ли отменить последнее действие в TMemo

2017-08-10T22:01:53+07:00

Code:

procedure TForm1.Button1Click(Sender: TObject);

begin

if Memo1.Perform(EM_CANUNDO, 0, 0) <> 0 then

ShowMessage('Undo is possible')

else

ShowMessage('Undo is not possible');

end;

Програмная навигация в Memo

2017-08-10T21:56:55+07:00

Code:

{************************************************************

* Procedure PostKeyEx

* Parameters:

* hWindow: target window to be send the keystroke

* key : virtual keycode of the key to send. For printable

* keys this is usually the ANSI code (Ord(character))

* of the UPPERCASE character. See VkKeyScan to obtain

* the virtual key codes of other characters.

* shift : state of the modifier keys. This is a set, so you

* can set several of these keys (shift, control, alt,

* mouse buttons) in tandem. The TShiftState type is

* declared in the Classes Unit.

* specialkey: normally this should be False. Set it to True to

* specify a key on the numeric keypad, for example.

* If this parameter is true, bit 24 of the lparam for

* the posted WM_KEY* messages will be set.

* Description:

* This procedure sets up Windows key state array to correctly

* reflect the requested pattern of modifier keys and then posts

* a WM_KEYDOWN/WM_KEYUP message pair to the target window. Then

* Application.ProcessMessages is called to process the messages

* before the keyboard state is restored.

* Error Conditions:

* May fail due to lack of memory for the two key state buffers.

* Will raise an exception in this case.

* NOTE:

* Setting the keyboard state will not work across applications

* running in different memory spaces on Win32.

*Created: 02/21/96 16:39:00 by P. Below

************************************************************}

Procedure PostKeyEx( hWindow: HWnd; key: Word; Const shift: TShiftState;

specialkey: Boolean );

Type

TBuffers = Array [0..1] of TKeyboardState;

Var

pKeyBuffers : ^TBuffers;

lparam: LongInt;

Begin

(* check if the target window exists *)

If IsWindow(hWindow) Then Begin

(* set local variables to default values *)

pKeyBuffers := Nil;

lparam := MakeLong(0, MapVirtualKey(key, 0));

(* modify lparam if special key requested *)

If specialkey Then

lparam := lparam or $1000000;

(* allocate space for the key state buffers *)

New(pKeyBuffers);

try

(* Fill buffer 1 with current state so we can later restore it.

Null out buffer 0 to get a "no key pressed" state. *)

GetKeyboardState( pKeyBuffers^[1] );

FillChar(pKeyBuffers^[0], Sizeof(TKeyboardState), 0);

(* set the requested modifier keys to "down" state in the buffer *)

If ssShift In shift Then

pKeyBuffers^[0][VK_SHIFT] := $80;

If ssAlt In shift Then Begin

(* Alt needs special treatment since a bit in lparam needs also be

set *)

pKeyBuffers^[0][VK_MENU] := $80;

lparam := lparam or $20000000;

End;

If ssCtrl In shift Then

pKeyBuffers^[0][VK_CONTROL] := $80;

If ssLeft In shift Then

pKeyBuffers^[0][VK_LBUTTON] := $80;

If ssRight In shift Then

pKeyBuffers^[0][VK_RBUTTON] := $80;

If ssMiddle In shift Then

pKeyBuffers^[0][VK_MBUTTON] := $80;

(* make out new key state array the active key state map *)

SetKeyboardState( pKeyBuffers^[0] );

(* post the key messages *)

If ssAlt In Shift Then Begin

PostMessage( hWindow, WM_SYSKEYDOWN, key, lparam);

PostMessage( hWindow, WM_SYSKEYUP, key, lparam or $C0000000);

End

Else Begin

PostMessage( hWindow, WM_KEYDOWN, key, lparam);

PostMessage( hWindow, WM_KEYUP, key, lparam or $C0000000);

End;

(* process the messages *)

Application.ProcessMessages;

(* restore the old key state map *)

SetKeyboardState( pKeyBuffers^[1] );

finally

(* free the memory for the key state buffers *)

If pKeyBuffers <> Nil Then

Dispose( pKeyBuffers );

End; { If }

End;

End; { PostKeyEx }

Пример:

Code:

procedure TForm1.SpeedButton2Click(Sender: TObject);

Var

W: HWnd;

begin

W := Memo1.Handle;

PostKeyEx( W, VK_END, [ssCtrl, ssShift], False ); {select all}

PostKeyEx( W, Ord('C'), [ssCtrl], False ); {copy to clipboard}

PostKeyEx( W, Ord('C'), [ssShift], False ); {replace with C}

PostKeyEx( W, VK_RETURN, [], False ); {new line}

PostKeyEx( W, VK_END, [], False ); {goto end}

PostKeyEx( W, Ord('V'), [ssCtrl], False ); {paste from keyboard}

end;

Режим вставки и замены

2017-08-10T21:50:45+07:00

Элементы управления Windows TEdit и TMemo не имеют режима замены. Однако этот режим можно эмулировать установив свойство SelLength edit'а или memo в 1 при обработке события KeyPress. Это заставит его перезаписывать символ в текущей позиции курсора. В примере этот способ используется для TMemo. Режим вставка/замена переключается клавишей "Insert".

Подробнее...

Режим замены

2017-08-10T21:49:26+07:00

Подробнее...

Следование за мышкой в TMemo для установки позиции курсора

2017-08-10T21:44:38+07:00

Code:

procedure TForm1.Memo1MouseMove(Sender: TObject; Shift: TShiftState; X,

Y: Integer);

begin

Memo1.SelStart := LoWord(SendMessage(Memo1.Handle, EM_CHARFROMPOS, 0, MakeLParam(X, Y)));

Memo1.SelLength := 0;

end;

Событие Key Press и курсорные клавиши в TMemo

2017-08-10T22:02:34+07:00

Мне необходимо обновлять текущую строку в во время перемещения по ним с помощью курсорных клавиш.

Вам повезло. Совсем недавно мне пришлось помучиться с этой задачкой. Я переместил функции в отдельный модуль. Для тестирования кода создайте пустую форму с одним компонентом Tmemo.

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

Данный пример отображает в заголовке текущие координаты курсора (столбец, строка).

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

Сообщайте мне о любых возникающих проблемах, но я уверен что это должно работать как положено.

Подробнее...

Сортировка строк в MEMO

2017-08-10T22:02:52+07:00

Code:

procedure TForm1.Button3Click(Sender: TObject);

var

t: TStringList;

begin

// создаем

t:=TStringList.Create;

// присваиваем переменной t строки из Memo

t.AddStrings(memo1.lines);

// сортируем

t.Sort;

memo1.Clear;

// присваиваем memo уже отсортированные строки

memo1.Lines.AddStrings(t);

end;

Управление прокруткой Memo

2017-08-10T21:47:03+07:00

У меня имеется компонент TMemo, и мне необходимо автоматически "тормозить" программным способом его прокрутку при добавлении новой строки Memo.Lines.Add(Строка).

В Delphi 2.0 простая установка 'SelStart:=0' НЕ срабатывает. Это ошибка в коде VCL. Значения различных частей 'сообщения' windows, используемые для "set selection" (установления выбранной части текста) в WIN32 были изменены (это использовалось для 'автоматической' прокрутки каретки/курсора, но больше не работает).

Подробнее...