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

 

 

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;

  

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

 

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

Code:

memo1.Perform(WM_VScroll, SB_LINEDOWN,0);

 

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

 

 

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;

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;

end;

 


 

Code:

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

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

 

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

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

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

Вот и все...

 

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

Автор:       Mirag, Этот адрес электронной почты защищён от спам-ботов. У вас должен быть включен JavaScript для просмотра., Mirag

Copyright:   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;

   end;

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;

end;

 

procedure TForm1.FormCreate(Sender: TObject);

begin

 

end;

 

end.

 

 

 

 


 

Code:

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

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

 

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

Автор:       Fenik, Этот адрес электронной почты защищён от спам-ботов. У вас должен быть включен JavaScript для просмотра., Новоуральск

Copyright:   Автор: Федоровских Николай

 

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

 

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;

   end;

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

   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;

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;

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;

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.

 

 

 

 

 

 

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;

 

  

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;

 

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('http://', Memo1.Lines.Strings[i]) > 0 then

    begin

      s := '';

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

 

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

      und bei Erfolg ab der gefundenen Position ausgelesen, bis ein

      Leerzeichen auftritt...}

 

      for p := Pos('http://', 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;

  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;

 

Автор: Hog

 

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

 

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

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

Автор: Xavier Pacheco

 

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