frxunicodectrls.pas

这个是功能强大的报表软件

function FindOrCreateWinControlTrap(Control: TWinControl): TWinControlTrap;
var
  i: integer;
begin
  // find or create trap object
  Result := nil;
  for i := PendingRecreateWndTrapList.Count - 1 downto 0 do begin
    if TWinControlTrap(PendingRecreateWndTrapList[i]).FControl = Control then begin
      Result := TWinControlTrap(PendingRecreateWndTrapList[i]);
      PendingRecreateWndTrapList.Delete(i);
      break; { found it }
    end;
  end;
  if Result = nil then
    Result := TWinControlTrap.Create(Control);
end;

{$IFDEF Delphi12}
procedure SubClassUnicodeControl(Control: TWinControl; Params_Caption: PWideChar; IDEWindow: Boolean = False);
{$ELSE}
procedure SubClassUnicodeControl(Control: TWinControl; Params_Caption: PAnsiChar; IDEWindow: Boolean = False);
{$ENDIF}
var
  WinControlTrap: TWinControlTrap;
begin
  if not IsWindowUnicode(Control.Handle) then
    raise Exception.Create('Internal Error: SubClassUnicodeControl.Control is not Unicode.');

  WinControlTrap := FindOrCreateWinControlTrap(Control);
  WinControlTrap.SubClassControl(Params_Caption);
  WinControlTrap.IDEWindow := IDEWindow;
end;


//----------------------------------------------- CREATE/DESTROY UNICODE HANDLE

var
  WindowAtom: TAtom;
  ControlAtom: TAtom;
  WindowAtomString: String;
  ControlAtomString: String;

type
  TWndProc = function(HWindow: HWnd; Message, WParam, LParam: Longint): Longint; stdcall;

function InitWndProcW(HWindow: HWnd; Message, WParam, LParam: Longint): Longint; stdcall;

    function GetObjectInstance(Control: TWinControl): Pointer;
    var
      WinControlTrap: TWinControlTrap;
    begin
      WinControlTrap := FindOrCreateWinControlTrap(Control);
      PendingRecreateWndTrapList.Add(WinControlTrap);
      Result := WinControlTrap.WinControl_ObjectInstance;
    end;

var
  ObjectInstance: Pointer;
begin
  TAccessWinControl(CreationControl).WindowHandle := HWindow;
  ObjectInstance := GetObjectInstance(CreationControl);
  {Controls.InitWndProc converts control to ANSI here by calling SetWindowLongA()!}
  SetWindowLongW(HWindow, GWL_WNDPROC, Integer(ObjectInstance));
  if  (GetWindowLongW(HWindow, GWL_STYLE) and WS_CHILD <> 0)
  and (GetWindowLongW(HWindow, GWL_ID) = 0) then
    SetWindowLongW(HWindow, GWL_ID, Integer(HWindow));
  SetProp(HWindow, MakeIntAtom(ControlAtom), THandle(CreationControl));
  SetProp(HWindow, MakeIntAtom(WindowAtom), THandle(CreationControl));
  CreationControl := nil;
  Result := TWndProc(ObjectInstance)(HWindow, Message, WParam, lParam);
end;

procedure RegisterUnicodeClass(Params: TCreateParams; out WideWinClassName: WideString; IDEWindow: Boolean = False);
var
  TempClass: TWndClassW;
  WideClass: TWndClassW;
  ClassRegistered: Boolean;
  InitialProc: TFNWndProc;
begin
  if IDEWindow then
    InitialProc := @InitWndProc
  else
    InitialProc := @InitWndProcW;

  with Params do begin
    WideWinClassName := WinClassName + UNICODE_CLASS_EXT;
    ClassRegistered := GetClassInfoW(hInstance, PWideChar(WideWinClassName), TempClass);
    if (not ClassRegistered) or (TempClass.lpfnWndProc <> InitialProc)
    then begin
      if ClassRegistered then Win32Check(Windows.UnregisterClassW(PWideChar(WideWinClassName), hInstance));
      // Prepare a TWndClassW record
      WideClass := TWndClassW(WindowClass);
      WideClass.hInstance := hInstance;
      WideClass.lpfnWndProc := InitialProc;
      WideClass.lpszMenuName := PWideChar(WideString(WindowClass.lpszMenuName));
      WideClass.lpszClassName := PWideChar(WideWinClassName);

      // Register the UNICODE class
      RegisterClassW(WideClass);
    end;
  end;
end;

procedure CreateUnicodeHandle(Control: TWinControl; const Params: TCreateParams;
                                        const SubClass: WideString; IDEWindow: Boolean = False);
var
  TempSubClass: TWndClassW;
  WideWinClassName: WideString;
  Handle: THandle;
begin
  if (not Win32PlatformIsUnicode) then begin
    with Params do
      TAccessWinControl(Control).WindowHandle := CreateWindowEx(ExStyle, WinClassName,
        Caption, Style, X, Y, Width, Height, WndParent, 0, WindowClass.hInstance, Param);
  end else begin
    // SubClass the unicode version of this control by getting the correct DefWndProc
    if (SubClass <> '')
    and GetClassInfoW(Params.WindowClass.hInstance, PWideChar(SubClass), TempSubClass) then
      TAccessWinControl(Control).DefWndProc := TempSubClass.lpfnWndProc
    else
      TAccessWinControl(Control).DefWndProc := @DefWindowProcW;

    // make sure Unicode window class is registered
    RegisterUnicodeClass(Params, WideWinClassName, IDEWindow);

    // Create UNICODE window handle
    UnicodeCreationControl := Control;
    try
      with Params do
        Handle := CreateWindowExW(ExStyle, PWideChar(WideWinClassName), nil,
          Style, X, Y, Width, Height, WndParent, 0, hInstance, Param);
      TAccessWinControl(Control).WindowHandle := Handle;
      if IDEWindow then
        SetWindowLongW(Handle, GWL_WNDPROC, GetWindowLong(Handle, GWL_WNDPROC));
    finally
      UnicodeCreationControl := nil;
    end;

    SubClassUnicodeControl(Control, Params.Caption, IDEWindow);
  end;
end;


//----------------------------------------------- GET/SET WINDOW TEXT

function WideGetWindowText(Control: TWinControl): WideString;
begin
  if (not Control.HandleAllocated)
  or (not IsWindowUnicode(Control.Handle)) then begin
    // NO HANDLE -OR- NOT UNICODE
    result := TAccessWinControl(Control).Text;
  end else begin
    // UNICODE & HANDLE
    SetLength(Result, GetWindowTextLengthW(Control.Handle) + 1);
    GetWindowTextW(Control.Handle, PWideChar(Result), Length(Result));
    SetLength(Result, Length(Result) - 1);
  end;
end;

procedure WideSetWindowText(Control: TWinControl; const Text: WideString);
begin
  if (not Control.HandleAllocated)
  or (not IsWindowUnicode(Control.Handle)) then begin
    // NO HANDLE -OR- NOT UNICODE
    TAccessWinControl(Control).Text := Text;
  end else if WideGetWindowText(Control) <> Text then begin
    // UNICODE & HANDLE
    SetWindowTextW(Control.Handle, PWideChar(Text));
    Control.Perform(CM_TEXTCHANGED, 0, 0);
  end;
end;



{ TUnicodeEdit }

procedure TUnicodeEdit.CreateWindowHandle(const Params: TCreateParams);
begin
  CreateUnicodeHandle(Self, Params, 'EDIT');
end;

function TUnicodeEdit.GetSelText: WideString;
begin
  Result := Copy(GetText, SelStart + 1, SelLength);
end;

function TUnicodeEdit.GetText: WideString;
begin
  Result := WideGetWindowText(Self);
end;

procedure TUnicodeEdit.SetSelText(const Value: WideString);
begin
  SendMessageW(Handle, EM_REPLACESEL, 0, Longint(PWideChar(Value)));
end;

procedure TUnicodeEdit.SetText(const Value: WideString);
begin
  WideSetWindowText(Self, Value);
end;


{ TUnicodeMemo }

procedure TUnicodeMemo.CreateWindowHandle(const Params: TCreateParams);
begin
  CreateUnicodeHandle(Self, Params, 'EDIT');
end;

function TUnicodeMemo.GetSelText: WideString;
begin
  Result := Copy(GetText, SelStart + 1, SelLength);
end;

function TUnicodeMemo.GetText: WideString;
begin
  Result := WideGetWindowText(Self);
end;

procedure TUnicodeMemo.SetSelText(const Value: WideString);
begin
  SendMessageW(Handle, EM_REPLACESEL, 0, Longint(PWideChar(Value)));
end;

procedure TUnicodeMemo.SetText(const Value: WideString);
begin
  WideSetWindowText(Self, Value);
end;


procedure InitControls;
var
  Controls_HInstance: Cardinal;
begin
  Controls_HInstance := FindClassHInstance(TWinControl);
  WindowAtomString := Format('Delphi%.8X',[GetCurrentProcessID]);
  ControlAtomString := Format('ControlOfs%.8X%.8X', [Controls_HInstance, GetCurrentThreadID]);
{$IFDEF Delphi12}
  WindowAtom := (GlobalAddAtom(PWideChar(WindowAtomString)));
  ControlAtom := (GlobalAddAtom(PWideChar(ControlAtomString)));
{$ELSE}
  WindowAtom := (GlobalAddAtom(PAnsiChar(WindowAtomString)));
  ControlAtom := (GlobalAddAtom(PAnsiChar(ControlAtomString)));
{$ENDIF}

end;


//===========================================================================
//  GetMessage Hook is needed to support entering Unicode
{$IFDEF HOOK_WNDPROC_FOR_UNICODE}
var
  _GetMessageHook: HHOOK;

function _IsDlgMsg(var Msg: TMsg): Boolean;
begin
  Result := False;
  if (Application.DialogHandle <> 0) then begin
    if IsWindowUnicode(Application.DialogHandle) then
      Result := IsDialogMessageW(Application.DialogHandle, Msg)
    else
      Result := IsDialogMessageA(Application.DialogHandle, Msg);
  end;
end;

function _GetMessage(Code: Integer; wParam: Integer; lParam: Integer): LRESULT; stdcall;
var
  Msg: PMsg;
  Handled: Boolean;
begin
  if (Code >= 0) and (wParam = PM_REMOVE) then
  begin
    Msg := PMsg(lParam);
    if (Application <> nil) and IsWindowUnicode(Msg.hwnd) and (Msg.message = WM_CHAR)
    and (Msg.wParam > Integer(High(AnsiChar))) then
    begin
      Handled := False;
      if Assigned(Application.OnMessage) then
        Application.OnMessage(Msg^, Handled);

      if (not Handled) and (not _IsDlgMsg(Msg^)) then
      begin
        DispatchMessageW(Msg^);
        Msg.message := WM_NULL;
      end;
    end;
  end;
  Result := CallNextHookEx(_GetMessageHook, Code, wParam, lParam);
end;

procedure _CreateGetMessageHook;
var
  LastError: Integer;
begin
  Assert(Win32Platform = VER_PLATFORM_WIN32_NT);
  _GetMessageHook := SetWindowsHookExW(WH_GETMESSAGE, _GetMessage, 0, GetCurrentThreadID);
  if _GetMessageHook = 0 then
  begin
    LastError := GetLastError;
    raise Exception.Create(SysErrorMessage(LastError));
  end;
end;
{$ENDIF}

{ TUnicodeRxRichEdit }

{$IFDEF Delphi12}
{$ELSE}
procedure TRxUnicodeRichEdit.CreateWindowHandle(
  const Params: TCreateParams);
var
 Bounds: TRect;
begin
  if Win32PlatformIsUnicode and (RichEditVersion >= 2) then
  begin
    Bounds := BoundsRect;
    CreateUnicodeHandle(Self, Params, RICHEDIT_CLASSW);
    if HandleAllocated then BoundsRect := Bounds;
  end
  else
    inherited
end;
{$ENDIF}
initialization
  Win32PlatformIsUnicode := (Win32Platform = VER_PLATFORM_WIN32_NT);
  Win32PlatformIsXP := ((Win32MajorVersion = 5) and (Win32MinorVersion >= 1))
                    or  (Win32MajorVersion > 5);
  {$IFDEF HOOK_WNDPROC_FOR_UNICODE}
  if Win32PlatformIsUnicode then
    _CreateGetMessageHook;
  {$ENDIF}
  PendingRecreateWndTrapList := TList.Create;
  InitControls;

finalization
  {$IFDEF HOOK_WNDPROC_FOR_UNICODE}
  if _GetMessageHook <> 0 then
    UnhookWindowsHookEx(_GetMessageHook);
  {$ENDIF}
  GlobalDeleteAtom(ControlAtom);
  GlobalDeleteAtom(WindowAtom);
  PendingRecreateWndTrapList.Free;
  PendingRecreateWndTrapList := nil;
  Finalized := True;

end.


//