newchecklistbox.pas

源代码

var
  R: TRect;
begin
  if ItemStates[Index].SubItem <> ASubItem then
  begin
    ItemStates[Index].SubItem := ASubItem;
    R := ItemRect(Index);
    InvalidateRect(Handle, @R, False);
  end;
end;

procedure TNewCheckListBox.Toggle(Index: Integer);
begin
  case ItemStates[Index].ItemType of
    itCheck:
      case ItemStates[Index].State of
        cbUnchecked: CheckItem(Index, True);
        cbChecked: CheckItem(Index, False);
        cbGrayed:
          { First try checking, but if that doesn't work because of children
            that are disabled and unchecked, try unchecking }
          if not CheckItem(Index, True) then
            CheckItem(Index, False);
      end;
    itRadio: CheckItem(Index, True);
  end;
  if Assigned(FOnClickCheck) then
    FOnClickCheck(Self);
end;

procedure TNewCheckListBox.UpdateThreads;

  function LastImmediateChildOf(Item: Integer): Integer;
  var
    L: Integer;
  begin
    Result := -1;
    L := ItemLevel[Item] + 1;
    Inc(Item);
    while (Item < Items.Count) and (ItemLevel[Item] >= L) do
    begin
      if ItemLevel[Item] = L then
        Result := Item;
      Inc(Item);
    end;
    if Result >= 0 then
      ItemStates[Result].IsLastChild := True;
  end;
var
  I, J, LastChild, L: Integer;
begin
  for I := 0 to Items.Count - 1 do
  begin
    ItemStates[I].ThreadCache := [];
    ItemStates[I].IsLastChild := False;
  end;
  for I := 0 to Items.Count - 1 do
  begin
    LastChild := LastImmediateChildOf(I);
    L := ItemLevel[I];
    for J := I + 1 to LastChild do
      Include(ItemStates[J].ThreadCache, L);
  end;
end;

procedure TNewCheckListBox.WMGetDlgCode(var Message: TWMGetDlgCode);
begin
  inherited;
  if FWantTabs then
    Message.Result := Message.Result and not DLGC_WANTCHARS;
end;

procedure TNewCheckListBox.WMKeyDown(var Message: TWMKeyDown);
var
  GoForward, Arrows: Boolean;
  I: Integer;
  Prnt, Ctrl: TWinControl;
begin
  { If space is pressed, avoid flickering -- exit now. }
  if not FWantTabs or (Message.CharCode = VK_SPACE) then
  begin
    inherited;
    Exit;
  end;
  Arrows := True;
  case Message.CharCode of
    VK_TAB:
      begin
        GoForward := GetKeyState(VK_SHIFT) >= 0;
        Arrows := False
      end;
    VK_DOWN, VK_RIGHT: GoForward := True;
    VK_UP, VK_LEFT: GoForward := False
  else
    if FSpaceDown then EndCapture(True);
    inherited;
    Exit;
  end;
  EndCapture(not FSpaceDown);
  SendMessage(Handle, WM_CHANGEUISTATE, UIS_CLEAR or (UISF_HIDEFOCUS shl 16), 0);
  if Arrows or TabStop then
    I := FindNextItem(-2, GoForward, not Arrows)
  else
    I := -1;
  if I < 0 then
  begin
    Prnt := nil;
    if not Arrows then
      Prnt := GetParentForm(Self);
    if Prnt = nil then Prnt := Parent;
    if Prnt <> nil then
    begin
      Ctrl := TWinControlAccess(Prnt).FindNextControl(Self, GoForward, True, Arrows);
      if (Ctrl <> nil) and (Ctrl <> Self) then
      begin
        Ctrl.SetFocus;
        Exit;
      end;
    end;
    if Items.Count = 0 then
      Exit;
    if GoForward then
      I := FindNextItem(-1, True, not Arrows)
    else
      I := FindNextItem(Items.Count, False, not Arrows);
  end;
  ItemIndex := I;
  if (ItemStates[I].ItemType = itRadio) and Arrows then
    Toggle(I);
end;

procedure TNewCheckListBox.WMMouseMove(var Message: TWMMouseMove);
var
  Pos: TPoint;
  Index, NewHotIndex: Integer;
  Rect: TRect;
  Indent: Integer;
begin
  Pos := SmallPointToPoint(Message.Pos);
  Index := ItemAtPos(Pos, True);

  if FCaptureIndex >= 0 then begin
    if not FSpaceDown and (Index <> FLastMouseMoveIndex) then begin
      if (FLastMouseMoveIndex = FCaptureIndex) or (Index = FCaptureIndex) then
        InvalidateCheck(FCaptureIndex);
      FLastMouseMoveIndex := Index;
    end
  end;

  NewHotIndex := -1;
  if (Index <> -1) and CanFocusItem(Index) then
  begin
    Rect := ItemRect(Index);
    Indent := (FOffset * 2 + FCheckWidth);
    if FWantTabs or ((Pos.X >= Rect.Left + Indent * ItemLevel[Index]) and
      (Pos.X < Rect.Left + Indent * (ItemLevel[Index] + 1))) then
      NewHotIndex := Index;
  end;
  UpdateHotIndex(NewHotIndex);
end;

procedure TNewCheckListBox.WMNCHitTest(var Message: TWMNCHitTest);
var
  I: Integer;
begin
  inherited;
  if FWantTabs and not (csDesigning in ComponentState) then
  begin
    if Message.Result = HTCLIENT then
    begin
      I := ItemAtPos(ScreenToClient(SmallPointToPoint(Message.Pos)), True);
      if (I < 0) or not CanFocusItem(I) then
      begin
        UpdateHotIndex(-1);
        {$IFDEF HINTSHOWPAUSE}
        FShowHintImmediately := True;
        Application.HintMouseMessage(Self, TMessage(Message));
        {$ELSE}
        Application.HideHint;
        {$ENDIF}
        Message.Result := 12345;
        Exit;
      end;
    end;
  end;
end;

procedure TNewCheckListBox.WMThemeChanged(var Message: TMessage);
begin
  { Don't Run to Cursor into this function, it will interrupt up the theme change }
  UpdateThemeData(True, True);
  inherited;
end;

procedure TNewCheckListBox.WMUpdateUIState(var Message: TMessage);
begin
  Invalidate;
  inherited;
end;

procedure TNewCheckListBox.WMGetObject(var Message: TMessage);
begin
  if (Message.LParam = Integer(OBJID_CLIENT)) and InitializeOleAcc then begin
    if FAccObjectInstance = nil then begin
      try
        FAccObjectInstance := TAccObject.Create(Self);
      except
        inherited;
        Exit;
      end;
    end;
    Message.Result := LresultFromObjectFunc(IID_IAccessible, Message.WParam,
      TAccObject(FAccObjectInstance));
  end
  else
    inherited;
end;

{ TAccObject }

constructor TAccObject.Create(AControl: TNewCheckListBox);
begin
  inherited Create;
  if CreateStdAccessibleObjectFunc(AControl.Handle, Integer(OBJID_CLIENT),
     IID_IAccessible, Pointer(FStdAcc)) <> S_OK then begin
    { Note: The user will never actually see this message since the call to
      TAccObject.Create in TNewCheckListBox.WMGetObject is protected by a
      try..except. }
    raise Exception.Create('CreateStdAccessibleObject failed');
  end;
  FControl := AControl;
end;

destructor TAccObject.Destroy;
begin
  { If FControl is assigned, then we are being destroyed before the control --
    the usual case. Clear FControl's reference to us. }
  if Assigned(FControl) then begin
    FControl.FAccObjectInstance := nil;
    FControl := nil;
  end;
  if Assigned(FStdAcc) then
    FStdAcc.Release;
  inherited;
end;

procedure TAccObject.ControlDestroying;
begin
  { Set FControl to nil, since it's no longer valid }
  FControl := nil;
  { Take this opportunity to disconnect remote clients, i.e. don't allow them
    to call us anymore. This prevents invalid memory accesses if this unit's
    code is in a DLL, and the application subsequently unloads the DLL while
    remote clients still hold (and are using) references to this TAccObject. }
  CoDisconnectObject(Self, 0);
  { NOTE: Don't access Self in any way at this point. The CoDisconnectObject
    call likely caused all references to be relinquished and Self to be
    destroyed. }
end;

function TAccObject.QueryInterface(const iid: TIID; var obj): HRESULT;
begin
  if IsEqualIID(iid, IID_IUnknown) or
     IsEqualIID(iid, IID_IDispatch) or
     IsEqualIID(iid, IID_IAccessible) then begin
    Pointer(obj) := Self;
    AddRef;
    Result := S_OK;
  end
  else begin
    Pointer(obj) := nil;
    Result := E_NOINTERFACE;
  end;
end;

function TAccObject.AddRef: Longint;
begin
  Inc(FRefCount);
  Result := FRefCount;
end;

function TAccObject.Release: Longint;
begin
  Dec(FRefCount);
  Result := FRefCount;
  if Result = 0 then
    Destroy;
end;

function TAccObject.GetTypeInfoCount(var ctinfo: Integer): HRESULT;
begin
  Result := E_NOTIMPL;
end;

function TAccObject.GetTypeInfo(itinfo: Integer; lcid: TLCID; var tinfo: ITypeInfo): HRESULT;
begin
  Result := E_NOTIMPL;
end;

function TAccObject.GetIDsOfNames(const iid: TIID; rgszNames: POleStrList;
  cNames: Integer; lcid: TLCID; rgdispid: PDispIDList): HRESULT;
begin
  Result := E_NOTIMPL;
end;

function TAccObject.Invoke(dispIDMember: TDispID; const iid: TIID; lcid: TLCID;
  flags: Word; var dispParams: TDispParams; varResult: PVariant;
  excepInfo: PExcepInfo; argErr: PInteger): HRESULT;
begin
  Result := E_NOTIMPL;
end;

function TAccObject.accDoDefaultAction(varChild: NewOleVariant): HRESULT;
begin
  { A list box's default action is Double Click, which is useless for a
    list of check boxes. }
  Result := DISP_E_MEMBERNOTFOUND;
end;

function TAccObject.accHitTest(xLeft, yTop: Integer;
  var pvarID: NewOleVariant): HRESULT;
begin
  Result := FStdAcc.accHitTest(xLeft, yTop, pvarID);
end;

function TAccObject.accLocation(var pxLeft, pyTop, pcxWidth,
  pcyHeight: Integer; varChild: NewOleVariant): HRESULT;
begin
  Result := FStdAcc.accLocation(pxLeft, pyTop, pcxWidth, pcyHeight, varChild);
end;

function TAccObject.accNavigate(navDir: Integer; varStart: NewOleVariant;
  var pvarEnd: NewOleVariant): HRESULT;
begin
  Result := FStdAcc.accNavigate(navDir, varStart, pvarEnd);
end;

function TAccObject.accSelect(flagsSelect: Integer;
  varChild: NewOleVariant): HRESULT;
begin
  Result := FStdAcc.accSelect(flagsSelect, varChild);
end;

function TAccObject.get_accChild(varChild: NewOleVariant;
  var ppdispChild: IDispatch): HRESULT;
begin
  Result := FStdAcc.get_accChild(varChild, ppdispChild);
end;

function TAccObject.get_accChildCount(var pcountChildren: Integer): HRESULT;
begin
  Result := FStdAcc.get_accChildCount(pcountChildren);
end;

function TAccObject.get_accDefaultAction(varChild: NewOleVariant;
  var pszDefaultAction: NewWideString): HRESULT;
begin
  { A list box's default action is Double Click, which is useless for a
    list of check boxes. }
  pszDefaultAction := nil;
  Result := S_FALSE;
end;

function TAccObject.get_accDescription(varChild: NewOleVariant;
  var pszDescription: NewWideString): HRESULT;
begin
  Result := FStdAcc.get_accDescription(varChild, pszDescription);
end;

function TAccObject.get_accFocus(var pvarID: NewOleVariant): HRESULT;
begin
  Result := FStdAcc.get_accFocus(pvarID);
end;

function TAccObject.get_accHelp(varChild: NewOleVariant;
  var pszHelp: NewWideString): HRESULT;
begin
  Result := FStdAcc.get_accHelp(varChild, pszHelp);
end;

function TAccObject.get_accHelpTopic(var pszHelpFile: NewWideString;
  varChild: NewOleVariant; var pidTopic: Integer): HRESULT;
begin
  Result := FStdAcc.get_accHelpTopic(pszHelpFile, varChild, pidTopic);
end;

function TAccObject.get_accKeyboardShortcut(varChild: NewOleVariant;
  var pszKeyboardShortcut: NewWideString): HRESULT;
begin
  Result := FStdAcc.get_accKeyboardShortcut(varChild, pszKeyboardShortcut);
end;

function TAccObject.get_accName(varChild: NewOleVariant;
  var pszName: NewWideString): HRESULT;
begin
  Result := FStdAcc.get_accName(varChild, pszName);