tntjvexcontrols.pas

TntExUpdate 是 流行的 TntUnicodeControls控件的扩展包.包括很难找到的 TntJVCL 也在里面. TntSysUtils2.pas/TntSysUtilsEx.pa

  Result := 0;
  if dcWantAllKeys in Value then
    Result := Result or DLGC_WANTALLKEYS;
  if dcWantArrows in Value then
    Result := Result or DLGC_WANTARROWS;
  if dcWantTab in Value then
    Result := Result or DLGC_WANTTAB;
  if dcWantChars in Value then
    Result := Result or DLGC_WANTCHARS;
  if dcButton in Value then
    Result := Result or DLGC_BUTTON;
  if dcHasSetSel in Value then
    Result := Result or DLGC_HASSETSEL;
end;

procedure GetHintColor(var HintInfo: THintInfo; AControl: TControl; HintColor: TColor);
var
  AHintInfo: THintInfo;
begin
  case HintColor of
    clNone:
      HintInfo.HintColor := Application.HintColor;
    clDefault:
      begin
        if Assigned(AControl) and Assigned(AControl.Parent) then
        begin
          AHintInfo := HintInfo;
          {$IFNDEF CLR}
          {$IFDEF VCL}
          AControl.Parent.Perform(CM_HINTSHOW, 0, Integer(@AHintInfo));
          {$ENDIF VCL}
          {$IFDEF VisualCLX}
          Perform(AControl.Parent, CM_HINTSHOW, 0, Integer(@AHintInfo));
          {$ENDIF VisualCLX}
          {$ELSE}
          AControl.Parent.Perform(CM_HINTSHOW, 0, AHintInfo);
          {$ENDIF !CLR}
          HintInfo.HintColor := AHintInfo.HintColor;
        end;
      end;
  else
    HintInfo.HintColor := HintColor;
  end;
end;

function DispatchIsDesignMsg(Control: TControl; var Msg: TMessage): Boolean;
var
  Form: TCustomForm;
begin
  Result := False;
  case Msg.Msg of
    WM_SETFOCUS, WM_KILLFOCUS, WM_NCHITTEST,
    WM_MOUSEFIRST..WM_MOUSELAST,
    WM_KEYFIRST..WM_KEYLAST,
    WM_CANCELMODE:
      Exit; // These messages are handled in TWinControl.WndProc before IsDesignMsg() is called
  end;
  if (Control <> nil) and (csDesigning in Control.ComponentState) then
  begin
    Form := GetParentForm(Control);
    if (Form <> nil) and (Form.Designer <> nil) and
       Form.Designer.IsDesignMsg(Control, Msg) then
      Result := True;
  end;
end;

{$IFDEF VisualCLX}
function Perform(AControl: TControl; Msg: Integer; WParam, LParam: Integer): Integer;
var
  PerformMsg, Mesg: TMessage;
begin
  if AControl.GetInterfaceEntry(IJvExControl) <> nil then
  begin
    Mesg.Msg := Msg;
    Mesg.WParam := WParam;
    Mesg.LParam := LParam;
    Mesg.Result := 0;

    PerformMsg.Msg := CM_PERFORM;
    PerformMsg.WParam := 0;
    PerformMsg.LParam := @Mesg;
    PerformMsg.Result := 0;
    AControl.Dispatch(PerformMsg);
  end;
end;
{$ENDIF VisualCLX}

{$IFDEF COMPILER5}

{ Delphi 5's SetAutoSize is private and not virtual. This code installs a
  JUMP-Hook into SetAutoSize that jumps to our function. }
var
  AutoSizeOffset: Cardinal;
  TControl_SetAutoSize: Pointer;

type
  PBoolean = ^Boolean;
  TControlAccessProtected = class(TControl)
  published
    property AutoSize;
  end;

procedure OrgSetAutoSize(AControl: TControl; Value: Boolean);
asm
        DD    0, 0, 0, 0  // 16 Bytes
end;

procedure TOpenControl_SetAutoSize(AControl: TControl; Value: Boolean);
begin
  // same as OrgSetAutoSize(AControl, Value); but secure
  with TControlAccessProtected(AControl) do
    if AutoSize <> Value then
    begin
      PBoolean(Cardinal(AControl) + AutoSizeOffset)^ := Value;
      if Value then
        AdjustSize;
    end;
end;

procedure SetAutoSizeHook(AControl: TControl; Value: Boolean);
var
  Msg: TMessage;
begin
  if AControl.GetInterfaceEntry(IJvExControl) <> nil then
  begin
    Msg.Msg := CM_SETAUTOSIZE;
    Msg.WParam := Ord(Value);
    AControl.Dispatch(Msg);
  end
  else
    TOpenControl_SetAutoSize(AControl, Value);
end;

procedure InitHookVars;
var
  Info: PPropInfo;
begin
  Info := GetPropInfo(TControlAccessProtected, 'AutoSize');
  AutoSizeOffset := Integer(Info.GetProc) and $00FFFFFF;
  TControl_SetAutoSize := Info.SetProc;
end;

{$ENDIF COMPILER5}

//=== { TJvHotTrackOptions } ======================================

constructor TJvHotTrackOptions.Create;
begin
  inherited Create;
  FEnabled := False;
  FFrameVisible := False;
  FColor := $00D2BDB6;
  FFrameColor := $006A240A;
end;

procedure TJvHotTrackOptions.Assign(Source: TPersistent);
begin
  if Source is TJvHotTrackOptions then
  begin
    BeginUpdate;
    try
      Enabled := TJvHotTrackOptions(Source).Enabled;
      Color := TJvHotTrackOptions(Source).Color;
      FrameVisible := TJvHotTrackOptions(Source).FrameVisible;
      FrameColor := TJvHotTrackOptions(Source).FrameColor;
    finally
      EndUpdate;
    end;
  end
  else
    inherited Assign(Source);
end;

procedure TJvHotTrackOptions.SetColor(Value: TColor);
begin
  if FColor <> Value then
  begin
    Changing;
    ChangingProperty('Color');
    FColor := Value;
    ChangedProperty('Color');
    Changed;
  end;
end;

procedure TJvHotTrackOptions.SetEnabled(Value: Boolean);
begin
  if FEnabled <> Value then
  begin
    Changing;
    ChangingProperty('Enabled');
    FEnabled := Value;
    ChangedProperty('Enabled');
    Changed;
  end;
end;

procedure TJvHotTrackOptions.SetFrameVisible(Value: Boolean);
begin
  if FFrameVisible <> Value then
  begin
    Changing;
    ChangingProperty('FrameVisible');
    FFrameVisible := Value;
    ChangedProperty('FrameVisible');
    Changed;
  end;
end;

procedure TJvHotTrackOptions.SetFrameColor(Value: TColor);
begin
  if FFrameColor <> Value then
  begin
    Changing;
    ChangingProperty('FrameColor');
    FFrameColor := Value;
    ChangedProperty('FrameColor');
    Changed;
  end;
end;
***)

//============================================================================

constructor TJvExControl0.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FHintColor := clDefault;
end;

function TJvExControl0.BaseWndProc(Msg: Integer; WParam: Integer = 0; LParam: Integer = 0): Integer;
var
  Mesg: TMessage;
begin
  Mesg := CreateWMMessage(Msg, WParam, LParam);
  inherited WndProc(Mesg);
  Result := Mesg.Result;
end;

function TJvExControl0.BaseWndProc(Msg: Integer; WParam: Integer; LParam: TControl): Integer;
var
  Mesg: TMessage;
begin
  Mesg := CreateWMMessage(Msg, WParam, LParam);
  inherited WndProc(Mesg);
  Result := Mesg.Result;
end;

function TJvExControl0.BaseWndProcEx(Msg: Integer; WParam: Integer; var LParam): Integer;
var
  Mesg: TStructPtrMessage;
begin
  Mesg := TStructPtrMessage.Create(Msg, WParam, LParam);
  try
    inherited WndProc(Mesg.Msg);
  finally
    Result := Mesg.Msg.Result;
    Mesg.Free;
  end;
end;

procedure TJvExControl0.VisibleChanged;
begin
  BaseWndProc(CM_VISIBLECHANGED);
end;

procedure TJvExControl0.EnabledChanged;
begin
  BaseWndProc(CM_ENABLEDCHANGED);
end;

procedure TJvExControl0.TextChanged;
begin
  BaseWndProc(CM_TEXTCHANGED);
end;

procedure TJvExControl0.FontChanged;
begin
  BaseWndProc(CM_FONTCHANGED);
end;

procedure TJvExControl0.ColorChanged;
begin
  BaseWndProc(CM_COLORCHANGED);
end;

procedure TJvExControl0.ParentFontChanged;
begin
  BaseWndProc(CM_PARENTFONTCHANGED);
end;

procedure TJvExControl0.ParentColorChanged;
begin
  BaseWndProc(CM_PARENTCOLORCHANGED);
  if Assigned(OnParentColorChange) then
    OnParentColorChange(Self);
end;

procedure TJvExControl0.ParentShowHintChanged;
begin
  BaseWndProc(CM_PARENTSHOWHINTCHANGED);
end;

function TJvExControl0.WantKey(Key: Integer; Shift: TShiftState; const KeyText: WideString): Boolean;
begin
  Result := BaseWndProc(CM_DIALOGCHAR, Word(Key), ShiftStateToKeyData(Shift)) <> 0;
end;

function TJvExControl0.HitTest(X, Y: Integer): Boolean;
begin
  Result := BaseWndProc(CM_HITTEST, 0, SmallPointToLong(PointToSmallPoint(Point(X, Y)))) <> 0;
end;

function TJvExControl0.HintShow(var HintInfo: THintInfo): Boolean;
begin
  GetHintColor(HintInfo, Self, FHintColor);
  Result := BaseWndProcEx(CM_HINTSHOW, 0, HintInfo) <> 0;
end;

procedure TJvExControl0.MouseEnter(AControl: TControl);
begin
  FMouseOver := True;
  {$IFDEF VCL}
  if Assigned(FOnMouseEnter) then
    FOnMouseEnter(Self);
  {$ENDIF VCL}
  BaseWndProc(CM_MOUSEENTER, 0, AControl);
end;

procedure TJvExControl0.MouseLeave(AControl: TControl);
begin
  FMouseOver := False;
  BaseWndProc(CM_MOUSELEAVE, 0, AControl);
  {$IFDEF VCL}
  if Assigned(FOnMouseLeave) then
    FOnMouseLeave(Self);
  {$ENDIF VCL}
end;

{$IFNDEF CLR}
procedure TJvExControl0.FocusChanged(AControl: TWinControl);
begin
  BaseWndProc(CM_FOCUSCHANGED, 0, AControl);
end;
{$ENDIF !CLR}

{$IFDEF COMPILER5}
{$IFNDEF HASAUTOSIZE}

procedure TJvExControl0.CMSetAutoSize(var Msg: TMessage);
begin
  SetAutoSize(Msg.WParam <> 0);
end;

procedure TJvExControl0.SetAutoSize(Value: Boolean);
begin
  TOpenControl_SetAutoSize(Self, Value);
end;

{$ENDIF !HASAUTOSIZE}
{$ENDIF COMPILER5}

procedure TJvExControl0.WndProc(var Msg: TMessage);
{$IFDEF CLR}
var
  AHintInfo: THintInfo;
{$ENDIF CLR}
begin
  if not DispatchIsDesignMsg(Self, Msg) then
  case Msg.Msg of
    CM_DENYSUBCLASSING:
      {$IFNDEF CLR}
      Msg.Result := Ord(GetInterfaceEntry(IJvDenySubClassing) <> nil);
      {$ELSE}
      Msg.Result := Integer(Supports(Self, IJvDenySubClassing));
      {$ENDIF !CLR}
    CM_DIALOGCHAR:
      with TCMDialogChar{$IFDEF CLR}.Create{$ENDIF}(Msg) do
        Result := Ord(WantKey(CharCode, KeyDataToShiftState(KeyData), WideChar(CharCode)));
    CM_HINTSHOW:
      {$IFNDEF CLR}
      with TCMHintShow(Msg) do
        Result := Integer(HintShow(HintInfo^));
      {$ELSE}
      with TCMHintShow.Create(Msg) do
      begin
        AHintInfo := HintInfo;
        Result := Integer(HintShow(AHintInfo));
        HintInfo := AHintInfo;
      end;
      {$ENDIF !CLR}
    CM_HITTEST:
      with TCMHitTest{$IFDEF CLR}.Create{$ENDIF}(Msg) do
        Result := Integer(HitTest(XPos, YPos));
    CM_MOUSEENTER:
      MouseEnter({$IFDEF CLR}nil{$ELSE}TControl(Msg.LParam){$ENDIF});
    CM_MOUSELEAVE:
      MouseLeave({$IFDEF CLR}nil{$ELSE}TControl(Msg.LParam){$ENDIF});
    CM_VISIBLECHANGED:
      VisibleChanged;
    CM_ENABLEDCHANGED:
      EnabledChanged;
    CM_TEXTCHANGED:
      TextChanged;
    CM_FONTCHANGED:
      FontChanged;
    CM_COLORCHANGED:
      ColorChanged;
    {$IFNDEF CLR}
    CM_FOCUSCHANGED:
      FocusChanged(TWinControl(Msg.LParam));
    {$ENDIF !CLR}
    CM_PARENTFONTCHANGED:
      ParentFontChanged;
    CM_PARENTCOLORCHANGED:
      ParentColorChanged;