{ -----------------------------------

2003/04/27
    WinXP環境で誤動作していたので修正
    CharFormatの初期化するように
      FillChar(CFmt, SizeOf(TCharFormat), 0);
    の行を追加した。
//----------------------------------- }
unit SCFREdString;

interface

uses
  Windows,
  Messages,
  SysUtils,
  Graphics,
  ComCtrls,
  RichEdit;

procedure SetCharFormatRichEdString( RichEdit: TCustomRichEdit;
 const SearchStr: String; IgnoreCase: Boolean;
 StrColor: TColor; StrFStyle: TFontStyles);
//IgnoreCase = trueなら大文字小文字区別『する！』

implementation

(*-----------------------------------
procedure SetCharFormatRichEdString( RichEdit: TCustomRichEdit;
 const SearchStr: String; IgnoreCase: Boolean;
 StrColor: TColor; StrFStyle: TFontStyles);

    function GetTopIndex: Integer;
    begin        //画面表示されている一番上のIndex
      Result := RichEdit.Perform(EM_GETFIRSTVISIBLELINE, 0, 0);
    end;
    

    procedure SetTopIndex(const Value: Integer);
    var          //差を求めてスクロール
      LineCount: Integer;
    begin
      LineCount :=  Value - GetTopIndex; //差を求めてスクロール
      RichEdit.Perform(EM_LINESCROLL,0,LineCount);
    end;


var
  mask: Longint;
  CFmt: TCharFormat;
  Str: String;
  PTop, PPos, PEnd, PSearch: PChar;
  CR: TCharRange;
  PreTopIndex, PreSelStart: Integer;
begin
  PreTopIndex := GetTopIndex;
  PreSelStart := RichEdit.SelStart;

  RichEdit.Lines.BeginUpdate;
  mask := SendMessage(RichEdit.Handle, EM_GETEVENTMASK, 0, 0);
  SendMessage(RichEdit.Handle, EM_SETEVENTMASK, 0, 0);

  with RichEdit do
  try
    SelStart := length(Text);
    Perform(EM_SCROLLCARET, 0, 0);

//−−−−−−−−−−−
      CFmt.cbSize := sizeof(CFmt);

      if ( StrColor <> 0 ) then
      begin
        CFmt.dwMask := CFM_COLOR;
        CFmt.crTextColor := ColorToRGB(StrColor);
      end;

      if ( fsBold in StrFStyle ) then
      begin
        CFmt.dwMask := CFmt.dwMask or CFM_BOLD;
        CFmt.dwEffects := CFmt.dwEffects or CFE_BOLD;
      end;
      if ( fsItalic in StrFStyle ) then
      begin
        CFmt.dwMask := CFmt.dwMask or CFM_ITALIC;
        CFmt.dwEffects := CFmt.dwEffects or CFE_ITALIC;
      end;
      if ( fsUnderline in StrFStyle ) then
      begin
        CFmt.dwMask := CFmt.dwMask or CFM_UNDERLINE;
        CFmt.dwEffects := CFmt.dwEffects or CFE_UNDERLINE;
      end;
      if ( fsStrikeOut in StrFStyle ) then
      begin
        CFmt.dwMask := CFmt.dwMask or CFM_STRIKEOUT;
        CFmt.dwEffects := CFmt.dwEffects or CFE_STRIKEOUT;
      end;

//−−−−−−−−−−−

    Str := RichEdit.Text;
    if IgnoreCase then    //大文字小文字区別する
      PTop := PChar(Str)
    else                  //大文字小文字区別無し｜すべて大文字に変換
      PTop := PChar(AnsiUpperCase(Str));
    PPos := PTop;

    if IgnoreCase then            //大文字小文字区別する
      PSearch := PChar(SearchStr)
    else                          //大文字小文字区別無し｜すべて大文字に変換
      PSearch := PChar(AnsiUpperCase(SearchStr));

    while (AnsiStrPos(PPos, PSearch) <> nil) do
    begin
      PPos := AnsiStrPos( PPos, PSearch ) ;
      PEnd := PPos + ( Length(SearchStr) );

      CR.cpMin := PPos - PTop;
      CR.cpMax := PEnd - PTop;
      Perform(EM_EXSETSEL, 0, lParam(@CR));
      Perform(EM_SETCHARFORMAT, 1, lParam(@CFmt));//書式決定
      PPos := PEnd;
    end;

  finally
    SendMessage(Handle, EM_SETEVENTMASK, 0, mask);
    SetTopIndex(PreTopIndex);
    SelStart := PreSelStart;
    Lines.EndUpdate;
  end;
end;
//-----------------------------------*)

procedure SetCharFormatRichEdString( RichEdit: TCustomRichEdit;
 const SearchStr: String; IgnoreCase: Boolean;
 StrColor: TColor; StrFStyle: TFontStyles);

    function GetTopIndex: Integer;
    begin        //画面表示されている一番上のIndex
      Result := RichEdit.Perform(EM_GETFIRSTVISIBLELINE, 0, 0);
    end;

    procedure SetTopIndex(const Value: Integer);
    var          //差を求めてスクロール
      LineCount: Integer;
    begin
      LineCount :=  Value - GetTopIndex; //差を求めてスクロール
      RichEdit.Perform(EM_LINESCROLL,0,LineCount);
    end;


var
  mask: Longint;
  CFmt: TCharFormat;
  Str: String;
  PTop, PPos, PEnd, PSearch: PChar;
  CR: TCharRange;
  PreTopIndex, PreSelStart: Integer;
begin
  PreTopIndex := GetTopIndex;
  PreSelStart := RichEdit.SelStart;

  RichEdit.Lines.BeginUpdate;
  mask := SendMessage(RichEdit.Handle, EM_GETEVENTMASK, 0, 0);
  SendMessage(RichEdit.Handle, EM_SETEVENTMASK, 0, 0);

  with RichEdit do
  try
    SelStart := length(Text);
    Perform(EM_SCROLLCARET, 0, 0);

//−−−−−−−−−−−
      FillChar(CFmt, SizeOf(TCharFormat), 0);
      CFmt.cbSize := sizeof(TCharFormat);

      if ( StrColor <> clWindowText ) then
      begin
        CFmt.dwMask := CFM_COLOR;
        CFmt.crTextColor := ColorToRGB(StrColor);
        CFmt.dwEffects := CFmt.dwEffects or (not CFE_AUTOCOLOR)
      end else
      begin
        CFmt.dwEffects := CFmt.dwEffects or CFE_AUTOCOLOR;
      end;

      if ( fsBold in StrFStyle ) then
      begin
        CFmt.dwMask := CFmt.dwMask or CFM_BOLD;
        CFmt.dwEffects := CFmt.dwEffects or CFE_BOLD;
      end;

      if ( fsItalic in StrFStyle ) then
      begin
        CFmt.dwMask := CFmt.dwMask or CFM_ITALIC;
        CFmt.dwEffects := CFmt.dwEffects or CFE_ITALIC;
      end;
      if ( fsUnderline in StrFStyle ) then
      begin
        CFmt.dwMask := CFmt.dwMask or CFM_UNDERLINE;
        CFmt.dwEffects := CFmt.dwEffects or CFE_UNDERLINE;
      end;
      if ( fsStrikeOut in StrFStyle ) then
      begin
        CFmt.dwMask := CFmt.dwMask or CFM_STRIKEOUT;
        CFmt.dwEffects := CFmt.dwEffects or CFE_STRIKEOUT;
      end;

//−−−−−−−−−−−

    Str := RichEdit.Text;
    if IgnoreCase then    //大文字小文字区別する
    begin
      PTop := PChar(Str);
      PSearch := PChar(SearchStr);
    end else
    begin                  //大文字小文字区別無し｜すべて大文字に変換
      PTop := PChar(AnsiUpperCase(Str));
      PSearch := PChar(AnsiUpperCase(SearchStr));
    end;
    PPos := PTop;

    while (AnsiStrPos(PPos, PSearch) <> nil) do
    begin
      PPos := AnsiStrPos( PPos, PSearch ) ;
      PEnd := PPos + ( Length(SearchStr) );

      CR.cpMin := PPos - PTop;
      CR.cpMax := PEnd - PTop;
      Perform(EM_EXSETSEL, 0, lParam(@CR));
      Perform(EM_SETCHARFORMAT, SCF_SELECTION, lParam(@CFmt));//書式決定
//      SendMessage(RichEdit.Handle, EM_SETCHARFORMAT, SCF_SELECTION, lParam(@CFmt));
      PPos := PEnd;
    end;

  finally
    SendMessage(Handle, EM_SETEVENTMASK, 0, mask);
    SetTopIndex(PreTopIndex);
    SelStart := PreSelStart;
    Lines.EndUpdate;
  end;
end;


end.