Игорь Шевченко ©   (21.05.10 23:16) [20]

копирование произоводится корректно, как при Ctrl+C, Ctrl+Ins там и при вызове из локального меню

procedure TForm1.FormCreate(Sender: TObject);
begin
FOldMemoWndProc := Memo1.WindowProc;
Memo1.WindowProc := MemoWndProc;
FOldEditWndProc := Edit1.WindowProc;
Edit1.WindowProc := EditWndProc;
Memo1.Lines.Text := 'Это русский текст';
end;

procedure TForm1.MemoWndProc(var Message: TMessage);
var
LKL: array [0..1023] of char;
begin
if Message.Msg = WM_COPY then
begin
  GetKeyboardLayoutName(LKL);
  LoadKeyboardLayout('00000419',KLF_ACTIVATE);
end;
FOldMemoWndProc(Message);
if Message.Msg = WM_COPY then
  LoadKeyboardLayout(LKL,KLF_ACTIVATE);
end;

procedure SendKeyboardLayout(Wnd, Msg:int; lParam:int=0; wParam:int=0);
var a:HKL; s:string;
begin
 SetLength(s,8);
 Win32Check(GetKeyboardLayoutName(ptr(s)));
 if s='00000409' then
 begin
   a:=ActivateKeyboardLayout(
        LoadKeyBoardLayout(ptr(intToHex(GetUserDefaultLangID,8)),0),0);
   if a=0 then RaiseLastOSError;
   SendMessage(Wnd, Msg, lParam, wParam);
   if ActivateKeyboardLayout(a,0)=0 then RaiseLastOSError;
 end else
   SendMessage(Wnd, Msg, lParam, wParam);
end;

procedure TForm1.Copy1Click(Sender: TObject);
begin
 SendKeyboardLayout(GetFocus, WM_COPY);
end;

procedure TForm1.Cut1Click(Sender: TObject);
begin
 SendKeyboardLayout(GetFocus, WM_CUT);
end;

procedure TForm1.Paste1Click(Sender: TObject);
begin
 SendMessage(GetFocus, WM_PASTE, 0, 0);
end;

procedure TForm1.Paste1Click(Sender: TObject);
begin
SendMessage(GetFocus, WM_PASTE, 0, 0);
end;

var cl: string;
...

procedure ClipboardCopy(const Text: String);
var
Len, wLen: Integer;
hClip: THandle;
pwStr: PWideChar;
begin
with Clipboard do
begin
  Open;
  try
    if (Win32Platform = VER_PLATFORM_WIN32_NT) then
    begin
      Len := Length(Text) + 1;
      wLen := Len shl 1;
      hClip := GlobalAlloc(GMEM_MOVEABLE, wLen);
      try
        pwStr := PWideChar(GlobalLock(hClip));
        MultiByteToWideChar(CP_ACP, MB_PRECOMPOSED, PChar(Text), Len, pwStr, wLen);
        GlobalUnlock(hClip);
        SetAsHandle(CF_UNICODETEXT, hClip);
      except
        GlobalFree(hClip);
        raise;
      end;
    end else
      SetTextBuf(PChar(Text));
  finally
    Close;
  end;
end;
end;

procedure ClipboardPaste(var Text: String);
var
Len, wLen: Integer;
hClip: THandle;
pwStr: PWideChar;
begin
Text := '';
with Clipboard do
try
  Open;
  if HasFormat(CF_TEXT) or HasFormat(CF_UNICODETEXT) then
  begin
    if (Win32Platform = VER_PLATFORM_WIN32_NT) then
    begin
      hClip := GetAsHandle(CF_UNICODETEXT);
      wlen := GlobalSize(hClip);
      pwStr := GlobalLock(hClip);
      try
        Len := (wLen div 2) - 1;
        SetLength(Text, Len);
        WideCharToMultiByte(CP_ACP, 0, pwStr, wlen, PChar(Text), Len, nil, nil);
      finally
        GlobalUnlock(hClip);
      end;
    end else
    begin
      hClip := GetAsHandle(CF_TEXT);
      Len := GlobalSize(hClip);
      SetLength(Text, Len);
      SetLength(Text, GetTextBuf(PChar(Text), Len));
    end;
  end;
finally
  Close;
end;
end;

function NewMemoProc(wnd:HWND; uMsg:UINT;
                    wParam:WPARAM; lParam:LPARAM):integer; stdcall;
begin
 case uMsg of
 WM_COPY:
   begin
     uMsg:=0;
     ClipboardCopy(cl);
   end;
 WM_CUT:
   begin
     SendMessage(wnd,EM_REPLACESEL,1,cardinal(pchar('')));
     uMsg:=0;
     ClipboardCopy(cl);
   end;
 WM_PASTE:
   begin
     uMsg:=0;
     ClipboardPaste(cl);
   end;
 end;
 Result:= CallWindowProc(Pointer(GetWindowLong(wnd,GWL_USERDATA)),
                                          wnd,uMsg,wParam,lParam);
end;

form1.create
procedure CreateOwnClipboard;
var i: integer;
   h: hwnd;
   c: TComboBoxInfo;
begin
with form1 do
for i :=0 to componentCount - 1 do
begin
  if Components[i] is TEdit then
  begin
    h:= TEdit(Components[i]).Handle;
    SetWindowLong(h,GWL_USERDATA,SetWindowLong(h, GWL_WNDPROC, LPARAM(@NewMemoProc)))
  end;
  if Components[i] is TMemo then
  begin
    h:= TMemo(Components[i]).Handle;
    SetWindowLong(h,GWL_USERDATA,SetWindowLong(h, GWL_WNDPROC, LPARAM(@NewMemoProc)))
  end;
  if Components[i] is TComboBox then
  begin
    c.cbSize:= SizeOf(TCOMBOBOXINFO);
    GetComboBoxInfo(TComboBox(Components[i]).Handle,c);
    h:= c.hwndItem;
    SetWindowLong(h,GWL_USERDATA,SetWindowLong(h, GWL_WNDPROC, LPARAM(@NewMemoProc)))
  end;
end;
end;

MemoKeyDown
begin
 with TFlat(Sender) do
 begin
   if not ReadOnly then
   if ((Key = ord('V'))  and (ssCtrl  in Shift)) or
      ((Key = VK_INSERT) and (ssShift in Shift)) then
   begin
     SelText:=cl;
   end;
   if ((Key = ord('C'))   and (ssCtrl  in Shift)) or
      ((Key = VK_INSERT)  and (ssCtrl  in Shift)) or
      ((Key = ord('X'))   and (ssCtrl  in Shift)) or
      ((Key = VK_DELETE)  and (ssShift in Shift)) then
      cl:= SelText;
 end;
end;

так же по аналогии с EditOnKeyDown и ComboboxOnKeyDown