checktreeview.pas

CheckTreeView 控件

  InitStateImages;
  FBmpWidth := FCheckImages.Width;

  ReadOnly := True;
  FSuspendCascades := False;
  FCascadeChecks := True;
  FSilentStateChanges := False;
  {&RCI}
end;


procedure TCheckTree.InitStateImages;
const
  BaseColors: array[ 0..6 ] of TColor = ( clWhite, clGray, clRed, clFuchsia, clBlue, clTeal, clOlive );
  ResNames: array[ TCheckBoxState ] of PChar = ( 'CheckCOMMON_CHECKBOX_UNCHECKED',
                                                 'CheckCOMMON_CHECKBOX_CHECKED',
                                                 'CheckCOMMON_CHECKBOX_GRAYED' );
var
  R: TRect;
  ReplaceColors: array[ 0..6 ] of TColor;
  ElementDetails: TThemedElementDetails;
  ChkBmp, ImgBmp: TBitmap;

  function CheckColor( Value: TColor ): TColor;
  begin
    if ( ColorToRGB( Value ) = ColorToRGB( clOlive ) ) or
       ( ColorToRGB( Value ) = ColorToRGB( clGray ) ) then
    begin
      Result := ColorToRGB( Value ) + 1;
    end
    else
      Result := Value;
  end;


begin
  FCheckImages.Clear;

  ChkBmp := TBitmap.Create;
  try
    ChkBmp.Width := 16;
    ChkBmp.Height := 16;
    R := Rect( 0, 0, 16, 16 );

    if ThemeServices.ThemesEnabled then
    begin
      ElementDetails := ThemeServices.GetElementDetails( tbCheckBoxUncheckedNormal );
      ThemeServices.DrawElement( ChkBmp.Canvas.Handle, ElementDetails, R );
      FCheckImages.Add( ChkBmp, nil );

      ThemeServices.DrawElement( ChkBmp.Canvas.Handle, ElementDetails, R );
      FCheckImages.Add( ChkBmp, nil );

      ElementDetails := ThemeServices.GetElementDetails( tbCheckBoxCheckedNormal );
      ThemeServices.DrawElement( ChkBmp.Canvas.Handle, ElementDetails, R );
      FCheckImages.Add( ChkBmp, nil );

      ElementDetails := ThemeServices.GetElementDetails( tbCheckBoxMixedNormal );
      ThemeServices.DrawElement( ChkBmp.Canvas.Handle, ElementDetails, R );
      FCheckImages.Add( ChkBmp, nil );

    end
    else // No Themes, but use HotTrack style check boxes
    begin
      ReplaceColors[ 0 ] := clWindow;
      ReplaceColors[ 1 ] := clBtnShadow;
      ReplaceColors[ 2 ] := clWindow;
      ReplaceColors[ 3 ] := clWindow;
      ReplaceColors[ 4 ] := CheckColor( FHighlightColor );

      ImgBmp := TBitmap.Create;
      try
        ImgBmp.Width := 16;
        ImgBmp.Height := 16;
        ImgBmp.Canvas.Brush.Color := clOlive;
        ImgBmp.Canvas.FillRect( R );

        ChkBmp.Handle := CreateMappedRes( HInstance, ResNames[ cbUnchecked ], BaseColors, ReplaceColors  );
        ImgBmp.Canvas.Draw( 2, 2, ChkBmp );
        FCheckImages.AddMasked( ImgBmp, clOlive );

        ChkBmp.Handle := CreateMappedRes( HInstance, ResNames[ cbUnchecked ], BaseColors, ReplaceColors  );
        ImgBmp.Canvas.Draw( 2, 2, ChkBmp );
        FCheckImages.AddMasked( ImgBmp, clOlive );

        ChkBmp.Handle := CreateMappedRes( HInstance, ResNames[ cbChecked ], BaseColors, ReplaceColors  );
        ImgBmp.Canvas.Draw( 2, 2, ChkBmp );
        FCheckImages.AddMasked( ImgBmp, clOlive );

        ChkBmp.Handle := CreateMappedRes( HInstance, ResNames[ cbGrayed ], BaseColors, ReplaceColors  );
        ImgBmp.Canvas.Draw( 2, 2, ChkBmp );
        FCheckImages.AddMasked( ImgBmp, clOlive );
      finally
        ImgBmp.Free;
      end;
    end;
  finally
    ChkBmp.Free;
  end;

end; {= TCheckTree.InitStateImages =}


destructor TCheckTree.Destroy;
begin
  FCheckImages.Free;
  inherited;
end;


procedure TCheckTree.Loaded;
begin
  inherited;

  UpdateImageWidth;
  {&RV}
end;


procedure TCheckTree.UpdateImageWidth;
begin
  if Images = nil then
    FImageWidth := 0
  else
    FImageWidth := Images.Width;
end;


procedure TCheckTree.SetHighlightColor( Value: TColor );
begin
  if FHighlightColor <> Value then
  begin
    FHighlightColor := Value;
    InitStateImages;
    Invalidate;
  end;
end;


procedure TCheckTree.WMPaint( var Msg: TWMPaint );
var
  I: Integer;
begin
  // Since we cannot hook into the TreeNodes themselves, we will hook
  // into the paint processing to ensure that all nodes have their
  // StateIndex set to a valid value.
  for I := 0 to Items.Count - 1 do
  begin
    if Items[ I ].StateIndex = -1 then
      Items[ I ].StateIndex := Ord( csUnchecked );
  end;
  inherited;
end;


function TCheckTree.GetItemState( AbsoluteIndex: Integer ): TCheckCheckState;
begin
  Result := TCheckCheckState( Items[ AbsoluteIndex ].StateIndex );
end;


procedure TCheckTree.SetItemState( AbsoluteIndex: Integer; Value: TCheckCheckState );
begin
  if TCheckCheckState( Items[ AbsoluteIndex ].StateIndex ) <> Value then
    ChangeNodeCheckState( Items[ AbsoluteIndex ], Value );
end;


procedure TCheckTree.SetNodeCheckState( Node:TTreeNode; NewState: TCheckCheckState );
begin
  if CanChangeState( Node, NewState ) then
  begin
    Node.StateIndex := Ord( NewState );
    if not FSilentStateChanges then
      StateChange( Node, NewState );
  end;
end;


function TCheckTree.CanChangeState( Node: TTreeNode; NewState: TCheckCheckState ): Boolean;
begin
  Result := True;
  if not FSilentStateChanges and Assigned( FOnStateChanging ) then
    FOnStateChanging( Self, Node, NewState, Result );
end;


procedure TCheckTree.StateChange( Node: TTreeNode; NewState: TCheckCheckState );
begin
  if Assigned( FOnStateChange ) then
    FOnStateChange( Self, Node, NewState );
end;


// Public method used to set a node and potentially parents in code

procedure TCheckTree.ForceCheckState( Node: TTreeNode;
                                        NewState: TCheckCheckState );
begin
  if Node.StateIndex <> Ord( NewState ) then
  begin
    Node.StateIndex := Ord( NewState );
    if not FSilentStateChanges then
      StateChange( Node, NewState );
  end;
end;


// Toggles state and cascades throughout tree
// The check state is actually stored in the StateIndex field

procedure TCheckTree.ToggleCheckState( Node: TTreeNode );
begin
  FChangingState := False;
  if Node.StateIndex = 0 then
    Exit;

  if Node.StateIndex = STATE_CHECKED then
    SetNodeCheckState( Node, csUnchecked )
  else
    SetNodeCheckState( Node, csChecked );
  if FCascadeChecks then
  begin
    UpdateChildren( Node, Node.StateIndex = STATE_CHECKED );
    UpdateParents( Node, Node.StateIndex = STATE_CHECKED );
  end;
end;


procedure TCheckTree.UpdateCascadingStates( Node: TTreeNode );
begin
  if FCascadeChecks then
  begin
    if ( Node.StateIndex = STATE_CHECKED ) or ( Node.StateIndex = STATE_UNCHECKED ) then
    begin
      UpdateChildren( Node, Node.StateIndex = STATE_CHECKED );
      UpdateParents( Node, Node.StateIndex = STATE_CHECKED );
    end;
  end;
end;


procedure TCheckTree.UpdateChildrenCascadingStates( ParentNode: TTreeNode );
var
  Node: TTreeNode;
begin
  if ( ParentNode = nil ) or not FCascadeChecks then
    Exit;

  Node := ParentNode.GetFirstChild;
  if Node = nil then
    UpdateCascadingStates( ParentNode )
  else
  begin
    while Node <> nil do
    begin
      if Node.HasChildren then
        UpdateChildrenCascadingStates( Node )
      else
        UpdateCascadingStates( Node );
      Node := Node.GetNextSibling;
    end;
  end;
end;



// Changes state and cascades throughout tree
// The check state is actually stored in the StateIndex field

procedure TCheckTree.ChangeNodeCheckState( Node: TTreeNode; NewState: TCheckCheckState );
begin
  FChangingState := False;
  if Node.StateIndex <> Ord( NewState ) then
    SetNodeCheckState( Node, NewState );
  if FCascadeChecks then
  begin
    UpdateChildren( Node, Node.StateIndex = STATE_CHECKED );
    UpdateParents( Node, Node.StateIndex = STATE_CHECKED );
  end;
end;


procedure TCheckTree.UpdateParents( Node: TTreeNode; NodeChecked: Boolean );
var
  CheckedCount, UnCheckedCount, NewState: Integer;
begin
  NewState := STATE_UNCHECKED;

  while ( Node <> nil ) and ( Node.Parent <> nil ) do
  begin
    Node := Node.Parent.GetFirstChild;
    CheckedCount := 0;
    UnCheckedCount := 0;
    while True do
    begin
      Inc( UnCheckedCount, Ord( Node.StateIndex = STATE_UNCHECKED ) );
      Inc( CheckedCount, Ord( Node.StateIndex = STATE_CHECKED ) );
      if ( Node.StateIndex = STATE_PARTCHECKED ) or
         ( ( CheckedCount > 0 ) and ( UnCheckedCount > 0 ) ) then
      begin
        NewState := STATE_PARTCHECKED;
        Break;
      end;
      if Node.GetNextSibling = nil then
      begin
        if CheckedCount > 0 then
          NewState := STATE_CHECKED
        else
          NewState := STATE_UNCHECKED;
        Break;
      end
      else
        Node := Node.GetNextSibling;
    end;
    Node := Node.Parent;
    if Node <> nil then
      SetNodeCheckState( Node, TCheckCheckState( NewState ) );
  end;
end;


procedure TCheckTree.RecurseChildren( Node: TTreeNode; NodeChecked: Boolean );
begin
  while Node <> nil do
  begin
    if NodeChecked then
      SetNodeCheckState( Node, csChecked )
    else
      SetNodeCheckState( Node, csUnchecked );
    if Node.GetFirstChild <> nil then
      RecurseChildren( Node.GetFirstChild, NodeChecked );
    Node := Node.GetNextSibling;
  end;
end;


procedure TCheckTree.UpdateChildren( Node: TTreeNode; NodeChecked: Boolean );
var
  WasSuspended: Boolean;
begin
  WasSuspended := FSuspendCascades;
  FSuspendCascades := True;
  RecurseChildren( Node.GetFirstChild, NodeChecked );
  FSuspendCascades := WasSuspended;

  if Assigned( FOnUpdateChildren ) then
    FOnUpdateChildren( Self );
end;


procedure TCheckTree.MouseDown( Button: TMouseButton; Shift: TShiftState; X, Y: Integer );
var
  R: TRect;
  Idx: Integer;
begin
  if Selected <> nil then
  begin
    if Selected.AbsoluteIndex > -1 then
    begin
      Idx := Selected.AbsoluteIndex;
      R := Selected.DisplayRect( True );
      if ( Button = mbLeft ) and ( X <= R.Left - FImageWidth ) and
         ( X > R.Left - FBmpWidth - FImageWidth ) and
         ( Y >= R.Top ) and ( Y <= R.Bottom ) then
      begin
        FChangingState := True;
        FSelectedItem := Idx;
      end;
    end;
  end;
  inherited;
end;


procedure TCheckTree.MouseUp( Button: TMouseButton; Shift: TShiftState; X, Y: Integer );
begin
  if ( Button = mbLeft ) and FChangingState and ( Selected.AbsoluteIndex = FSelectedItem ) and
     PtInRect( ClientRect, Point( X, Y ) ) then
  begin
    ToggleCheckState( Selected );
  end;
  inherited;
end;


procedure TCheckTree.KeyUp( var Key: Word; Shift: TShiftState );
begin
  if ( Key = vk_Space ) and not IsEditing and ( Selected <> nil ) then
    ToggleCheckState( Selected );
  inherited;
end;


procedure TCheckTree.WMChar( var Msg: TWMChar );
begin
  if Msg.CharCode <> vk_Space then
    inherited;
end;


procedure TCheckTree.SetAllChildren( Node: TTreeNode; NewState: TCheckCheckState );
begin
  while Node <> nil do
  begin
    Node.StateIndex := Ord( NewState );
    if Node.GetFirstChild <> nil then
      SetAllChildren( Node.GetFirstChild, NewState );          // Recursive call
    Node := Node.GetNextSibling;
  end;
end;


procedure TCheckTree.SetAllNodes( NewState: TCheckCheckState );
begin
  SetAllChildren( Items[ 0 ], NewState );
end;


function TCheckTree.GetImages: TCustomImageList;
begin
  Result := inherited Images;
end;


procedure TCheckTree.SetImages( Value: TCustomImageList );
begin
  inherited Images := Value;
  UpdateImageWidth;
end;


procedure TCheckTree.LoadFromFile( const FileName: string );
var
  Stream: TStream;
begin
  Stream := TFileStream.Create( FileName, fmOpenRead );
  try
    LoadFromStream( Stream );
  finally
    Stream.Free;
  end;
end;


procedure TCheckTree.LoadFromStream( Stream: TStream );
var
  S: TCheckTreeStrings;
begin
  S := TCheckTreeStrings.Create( Items );
  try
    S.LoadTreeFromStream( Stream );
  finally
    S.Free;
  end;
end;


procedure TCheckTree.SaveToFile( const FileName: string );
var
  Stream: TStream;
begin
  Stream := TFileStream.Create( FileName, fmCreate );
  try
    SaveToStream( Stream );
  finally
    Stream.Free;
  end;
end;


procedure TCheckTree.SaveToStream( Stream: TStream );
var
  S: TCheckTreeStrings;
begin
  S := TCheckTreeStrings.Create( Items );
  try
    S.SaveTreeToStream( Stream );
  finally
    S.Free;
  end;
end;


{&RUIF}
end.