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;

Code:

memo1.Perform(WM_VScroll, SB_LINEDOWN,0);

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;

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;

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('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;

  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;