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

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

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;

http://delphiworld.narod.ru/ DelphiWorld 6.0

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

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;

http://delphiworld.narod.ru/ DelphiWorld 6.0

{ **** UBPFD *********** by delphibase.endimus.com ****
>> Поиск и замена текста в поле МЕМО программно
На форму бросьте кнопку и поле МЕМО
напишите в МЕМО(в первой строке) текст и поставьте C:\, нажмите кнопку,
при этом C:\ замениться на D:\ без потери форматирования
Вот и все...
Зависимости: Смотрите uses
Автор: Mirag, <a href="mailto:wwwMirage@yandex.ru">wwwMirage@yandex.ru</a>, Mirag
Copyright: Mirag
Дата: 15 ноября 2002 г.
***************************************************** }

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.

{ **** UBPFD *********** by delphibase.endimus.com ****
>> Поиск строки в редакторе Memo
Зависимости: Windows, Classes, StdCtrls
Автор: Fenik, <a href="mailto:chook_nu@uraltc.ru">chook_nu@uraltc.ru</a>, Новоуральск
Copyright: Автор: Федоровских Николай
Дата: 26 июня 2002 г.
***************************************************** }

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'у)." Так как тескт "авторский" (более того, здесь также присутствует наследование), помещаю его здесь в том виде, в котором он был прислан, т.е. без перевода. В случае каких-либо вопросов и недоразумений обращайтесь по вышеуказанносу адресу электронной почты.

{ПРИМЕР :

[...]

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 FindWordStart(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 FindWordStart(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.

http://delphiworld.narod.ru/
DelphiWorld 6.0

Отправить комментарий

Проверка
Антиспам проверка
Image CAPTCHA
...