WideMemo.pas

   1 unit WideMemo;
   2
   3 interface
   4
   5 uses
   6     Messages, Windows, Controls, StdCtrls, SysUtils, Classes, Types;
   7
   8 type
   9     TWideMemo = class;
  10
  11     TWideMemo = class(TMemo)
  12 private
  13     function GetWideText: WideString;
  14     function GetEncodeText: AnsiString;
  15     procedure SetEncodeText(SrcText: AnsiString);
  16     function SetClipboard(SrcText: WideString): Boolean;
  17     function GetClipboard(IsClear: Boolean): WideString;
  18 protected
  19     procedure CreateWindowHandle(const Params: TCreateParams); override;
  20 public
  21     constructor Create(AOwner: TComponent); override;
  22     procedure Free;
  23     procedure InsertText(InsText: WideString);
  24     procedure QuotePaste(QuoteStr: AnsiString);
  25     property EncodeText: AnsiString read GetEncodeText write SetEncodeText;
  26 end;
  27
  28
  29 implementation
  30
  31 constructor TWideMemo.Create(AOwner: TComponent);
  32 begin
  33     inherited Create(AOwner);
  34 end;
  35
  36 procedure TWideMemo.Free;
  37 begin
  38     inherited Free;
  39 end;
  40
  41 procedure TWideMemo.CreateWindowHandle(const Params: TCreateParams);
  42 var
  43     ClassName: WideString;
  44 begin
  45     with Params do
  46     begin
  47         ClassName := WideString(WinClassName);
  48         WindowHandle := CreateWindowExW(ExStyle, PWideChar(ClassName), '', Style,
  49                                         X, Y, Width, Height, WndParent, 0,
  50                                         HInstance, Param);
  51         SendMessage(WindowHandle, WM_SETTEXT, 0, Longint(Caption));
  52     end;
  53 end;
  54
  55 function TWideMemo.GetWideText: WideString;
  56 var
  57 //    Len: Integer;
  58 //    LenUC: Integer;
  59 //    BufUC: PWideChar;
  60 //    BufUCSize: Integer;
  61     PosS: LongWord;
  62     PosE: LongWord;
  63 begin
  64 //    Len := GetWindowTextLengthW(Handle);
  65 //    Len := Perform(WM_GETTEXTLENGTH, 0, 0);
  66 //    LenUC := Len + 1;
  67 //    BufUCSize := LenUC * SizeOf(WideChar);
  68 //    BufUC := AllocMem(BufUCSize);
  69 //    ZeroMemory(BufUC, BufUCSize);
  70 //    GetWindowTextW(Handle, BufUC, LenUC);
  71 //    SendMessageW(Handle, WM_GETTEXT, WPARAM(LenUC), LPARAM(BufUC));
  72 //    Result := WideString(BufUC);
  73 //    FreeMem(BufUC);
  74
  75         SendMessage(Handle, EM_GETSEL, WPARAM(@PosS), LPARAM(@PosE));
  76         SendMessage(Handle, EM_SETSEL, 0, GetWindowTextLengthW(Handle));
  77         SendMessage(Handle, WM_COPY, 0, 0);
  78         SendMessage(Handle, EM_SETSEL, WPARAM(PosS), LPARAM(PosE));
  79
  80     Result := GetClipboard(True);
  81 end;
  82
  83 function TWideMemo.GetEncodeText: AnsiString;
  84 const
  85     _WC_NO_BEST_FIT_CHARS = $400;
  86 var
  87     Len: Integer;
  88     LenUC: Integer;
  89     BufUC: PWideChar;
  90     BufSJ: array[0..16] of AnsiChar;
  91     UseDefChar: LongBool;
  92     Cnt: Integer;
  93     TextSJ: AnsiString;
  94     TextUC: WideString;
  95 begin
  96     TextUC := GetWideText;
  97     BufUC := PWideChar(TextUC);
  98     Len := Length(TextUC);
  99     LenUC := Len + 1;
 100
 101     WideCharToMultiByte(CP_ACP, _WC_NO_BEST_FIT_CHARS, BufUC, LenUC, nil, 0, nil, @UseDefChar);
 102     if (UseDefChar = False) then begin
 103         Result := AnsiString(BufUC);
 104     end else begin
 105         for Cnt := 0 to Len - 1 do
 106         begin
 107             ZeroMemory(@BufSJ, 16);
 108             WideCharToMultiByte(CP_ACP, _WC_NO_BEST_FIT_CHARS, @BufUC[Cnt], 1, BufSJ, 16, nil, @UseDefChar);
 109             if (UseDefChar = False) then begin
 110                 TextSJ := TextSJ + AnsiString(BufSJ);
 111             end else begin
 112                 TextSJ := TextSJ + Format('&#%d;', [Ord(BufUC[Cnt])]);
 113             end;
 114         end;
 115         Result := TextSJ;
 116     end;
 117 end;
 118
 119 procedure TWideMemo.SetEncodeText(SrcText: AnsiString);
 120 var
 121     CodePos: Integer;
 122     TextSJ: AnsiString;
 123     TextUC: WideString;
 124     CodeSJ: AnsiString;
 125     CodeVal: Integer;
 126 begin
 127     TextSJ := SrcText;
 128     while Length(TextSJ) > 0 do begin
 129         CodePos := AnsiPos('&#', TextSJ);
 130         if (CodePos < 1) then begin
 131             TextUC := TextUC + WideString(TextSJ);
 132             Break;
 133         end;
 134         if (CodePos > 1) then begin
 135             TextUC := TextUC + WideString(Copy(TextSJ, 1, CodePos - 1));
 136             Delete(TextSJ, 1, CodePos - 1);
 137         end;
 138         CodePos := AnsiPos(';', TextSJ);
 139         if (CodePos < 1) then begin
 140             TextUC := TextUC + WideString(TextSJ);
 141             Break;
 142         end;
 143         CodeSJ := Copy(TextSJ, 3, CodePos - 3);
 144         CodeVal := StrToIntDef(CodeSJ, 0);
 145         if ((CodeVal < 1) or (CodeVal > $FFFF)) then begin
 146             TextUC := TextUC + WideString(Copy(TextSJ, 1, CodePos));
 147         end else begin
 148             TextUC := TextUC + WideString(WideChar(CodeVal));
 149         end;
 150         Delete(TextSJ, 1, CodePos);
 151     end;
 152
 153     SetWindowTextW(Handle, PWideChar(TextUC));
 154 end;
 155
 156 function TWideMemo.SetClipboard(SrcText: WideString): Boolean;
 157 var
 158     LenUC: Integer;
 159     BufUC: PWideChar;
 160     BufUCSize: Integer;
 161     MemHandle: HGLOBAL;
 162     CopySize: Integer;
 163 begin
 164     LenUC := Length(SrcText);
 165     CopySize := LenUC * SizeOf(WideChar);
 166     BufUCSize := (LenUC + 1) * SizeOf(WideChar);
 167     MemHandle := GlobalAlloc(GMEM_DDESHARE or GMEM_MOVEABLE, BufUCSize);
 168     BufUC := GlobalLock(MemHandle);
 169     ZeroMemory(BufUC, BufUCSize);
 170     CopyMemory(BufUC, PWideChar(SrcText), CopySize);
 171     GlobalUnlock(MemHandle);
 172
 173     if (OpenClipboard(Handle) = True) then begin
 174         EmptyClipboard;
 175         SetClipboardData(CF_UNICODETEXT, MemHandle);
 176         CloseClipboard;
 177         Result := True;
 178     end else begin
 179         GlobalFree(MemHandle);
 180         Result := False;
 181     end;
 182 end;
 183
 184 function TWideMemo.GetClipboard(IsClear: Boolean): WideString;
 185 var
 186     TextGet: WideString;
 187     MemHandle: HGLOBAL;
 188     TextP: PWideChar;
 189 begin
 190     if (OpenClipboard(Handle) = True) then begin
 191         MemHandle := GetClipboardData(CF_UNICODETEXT);
 192         if (MemHandle <> 0) then begin
 193             TextP := PWideChar(GlobalLock(MemHandle));
 194             if not (TextP = nil) then begin
 195                 TextGet := WideString(TextP);
 196                 GlobalUnlock(MemHandle);
 197             end;
 198         end;
 199         if (IsClear = True) then
 200             EmptyClipboard;
 201         CloseClipboard;
 202     end;
 203     Result := TextGet;
 204 end;
 205
 206 procedure TWideMemo.InsertText(InsText: WideString);
 207 var
 208 //    SelS: LongWord;
 209 //    SelE: LongWord;
 210 //    FullText: WideString;
 211 //    AftCurPos: LongInt;
 212     TextOrg: WideString;
 213 begin
 214 (*
 215     FullText := GetWideText;
 216
 217     SelS := 0;
 218     SelE := 0;
 219     SendMessageW(Handle, EM_GETSEL, WPARAM(@SelS), LPARAM(@SelE));
 220
 221     if (SelS <> SelE) then
 222         Delete(FullText, SelS + 1, SelE - SelS);
 223     Insert(InsText, FullText, SelS + 1);
 224
 225     SetWindowTextW(Handle, PWideChar(FullText));
 226
 227     AftCurPos := LongInt(SelS) + Length(InsText);
 228
 229     SendMessageW(Handle, EM_SETSEL, AftCurPos, AftCurPos);
 230 *)
 231
 232     TextOrg := GetClipboard(False);
 233
 234     if (SetClipboard(InsText) = True) then begin
 235
 236         SendMessageW(Handle, WM_PASTE, 0, 0);
 237
 238         SetClipboard(TextOrg);
 239     end;
 240
 241     Change;
 242 end;
 243
 244 procedure TWideMemo.QuotePaste(QuoteStr: AnsiString);
 245 var
 246     TextDst: WideString;
 247     TextSrc: WideString;
 248     QuoteUC: WideString;
 249     RetChar: WideString;
 250     Ret: Integer;
 251 begin
 252     TextSrc := GetClipboard(False);
 253     QuoteUC := QuoteStr;
 254     RetChar := AnsiString(#13#10);
 255
 256     while (Length(TextSrc) > 0) do begin
 257         Ret := Pos(RetChar, TextSrc);
 258         if (Ret < 1) then begin // \89ü\8ds\82È\82µ
 259             TextDst := TextDst + QuoteUC + TextSrc;
 260             Break;
 261         end;
 262
 263         // \89ü\8ds\82Ü\82Å\82Ì1\8ds
 264         TextDst := TextDst + QuoteUC + Copy(TextSrc, 1, Ret + 1);
 265         Delete(TextSrc, 1, Ret + 1);
 266     end;
 267
 268     if (Length(TextDst) > 0) then
 269         InsertText(TextDst);
 270 end;
 271
 272 end.