outline.pas

这是不可多得的源代码

      FCurItem := FRootNode.GetNodeAtIndex(Value);
    except
      on OutlineError do Error(SOutlineIndexError);
    end;
end;

procedure TCustomOutline.SetOutlineStyle(Value: TOutlineStyle);
begin
  if FOutlineStyle <> Value then
  begin
    FOutlineStyle := Value;
    SetHorzScrollBar;
    Invalidate;
  end;
end;

procedure TCustomOutline.CMFontChanged(var Message: TMessage);
begin
  inherited;
  SetRowHeight;
  SetHorzScrollBar;
end;

procedure TCustomOutline.SetDisplayWidth(Value: Integer);
begin
  FSettingWidth := True;
  try
    if DefaultColWidth <> Value then DefaultColWidth := Value;
  finally
    FSettingWidth := False;
  end;
end;

function TCustomOutline.GetNodeDisplayWidth(Node: TOutlineNode): Integer;
var
  Delta: Integer;
  TextLength: Integer;
begin
  Result := 0;
  Delta := (DefaultRowHeight - FFontSize) div 2;

  with Canvas do
  begin
    Font := Self.Font;
    TextLength := TextWidth(Node.Text) + 1;
  end;

  case OutlineStyle of
    osText: Inc(Result, DefaultRowHeight * (Integer(Node.Level) - 1));
    osPlusMinusPictureText: Inc(Result, DefaultRowHeight * (Integer(Node.Level) + 1));
    osPlusMinusText,
    osPictureText: Inc(Result, DefaultRowHeight * Integer(Node.Level));
    osTreeText:
      begin
        Inc(Result, DefaultRowHeight * (Integer(Node.Level) - 1) - Delta);
        if ooDrawTreeRoot in Options then Inc(Result, DefaultRowHeight);
      end;
    osTreePictureText:
      begin
        Inc(Result, DefaultRowHeight * (Integer(Node.Level)) - Delta);
        if ooDrawTreeRoot in Options then Inc(Result, DefaultRowHeight);
      end;
  end;
  Inc(Result, TextLength);
  if Result < 0 then Result := 0;
end;

function TCustomOutline.GetVisibleNode(Index: LongInt): TOutlineNode;
begin
  Result := FRootNode.GetVisibleNode(Index + 1);
end;

procedure TCustomOutline.DrawCell(ACol, ARow: Longint; ARect: TRect; AState: TGridDrawState);
var
  Node: TOutlineNode;
  Expanded: Boolean;
  HasChildren: Boolean;
  IndentLevel: Word;
  Bitmap1, Bitmap2: TBitmap;
  TextLength: Integer;
  Delta: Integer;
  InitialLeft: Integer;

  function GetBitmap(Value: TOutlineBitmap): TBitmap;
  begin
    Result := FPictures[Ord(Value)];
  end;

  procedure DrawFocusCell;
  begin
    Inc(ARect.Right, TextLength);
    if (Row = ARow) and (Node.Text <> '') then
      Canvas.FillRect(ARect);
  end;

  procedure DrawTheText;
  begin
    Inc(ARect.Left, DefaultRowHeight * (IndentLevel - 1));
    ARect.Right := ARect.Left;
    DrawFocusCell;
    DrawText(Node, ARect);
  end;

  procedure DrawPlusMinusPicture;
  begin
    Inc(ARect.Left, DefaultRowHeight * (IndentLevel - 1));
    if HasChildren then
    begin
      if Expanded then
      begin
        Bitmap1 := GetBitmap(obMinus);
        Bitmap2 := GetBitmap(obOpen);
      end
      else begin
        Bitmap1 := GetBitmap(obPlus);
        Bitmap2 := GetBitmap(obClose);
      end;
    end
    else begin
      Bitmap1 := nil;
      Bitmap2 := GetBitmap(obLeaf);
    end;
    ARect.Left := ARect.Left + DefaultRowHeight * 2;
    ARect.Right := ARect.Left;
    DrawFocusCell;
    DrawText(Node, ARect);
    Dec(ARect.Left, DefaultRowHeight * 2);
    DrawPictures([Bitmap1, Bitmap2], ARect);
  end;

  procedure DrawPictureText;
  var
    Style: TOutlineBitmap;
  begin
    Inc(ARect.Left, DefaultRowHeight * (IndentLevel - 1));
    if HasChildren then
    begin
      if Expanded then Style := obOpen
      else Style := obClose
    end
    else Style := obLeaf;
    Bitmap1 := GetBitmap(Style);
    ARect.Left := ARect.Left + DefaultRowHeight;
    ARect.Right := ARect.Left;
    DrawFocusCell;
    DrawText(Node, ARect);
    Dec(ARect.Left, DefaultRowHeight);
    DrawPictures([Bitmap1], ARect);
  end;

  procedure DrawPlusMinusText;
  var
    Style: TOutlineBitmap;
  begin
    Inc(ARect.Left, DefaultRowHeight * IndentLevel);
    ARect.Right := ARect.Left;
    DrawFocusCell;
    DrawText(Node, ARect);
    if HasChildren then
    begin
      if Expanded then Style := obMinus
      else Style := obPlus;
      Bitmap1 := GetBitmap(Style);
      Dec(ARect.Left, DefaultRowHeight);
      DrawPictures([Bitmap1], ARect);
    end;
  end;

  procedure DrawTheTree;
  begin
    DrawTree(ARect, Node);
    Inc(ARect.Left, DefaultRowHeight * (IndentLevel - 1) - Delta);
    if ooDrawTreeRoot in Options then Inc(ARect.Left, DefaultRowHeight);
    ARect.Right := ARect.Left + Delta;
    DrawFocusCell;
    Inc(ARect.Left, Delta);
    DrawText(Node, ARect);
  end;

  procedure DrawTreePicture;
  var
    Style: TOutlineBitmap;
  begin
    DrawTree(ARect, Node);
    Inc(ARect.Left, DefaultRowHeight * (IndentLevel - 1) - Delta);
    if ooDrawTreeRoot in Options then Inc(ARect.Left, DefaultRowHeight);
    ARect.Left := ARect.Left + DefaultRowHeight;
    ARect.Right := ARect.Left + Delta;
    DrawFocusCell;
    DrawText(Node, ARect);
    Dec(ARect.Left, DefaultRowHeight - Delta);
    if HasChildren then
    begin
      if Expanded then Style := obOpen
      else Style := obClose;
    end
    else Style := obLeaf;
    Bitmap1 := GetBitmap(Style);
    DrawPictures([Bitmap1], ARect);
  end;

begin
  if FRootNode.List.Count = 0 then
  begin
    with Canvas do
    begin
      Brush.Color := Color;
      FillRect(ARect);
    end;
    Exit;
  end;

  if (Style = otOwnerDraw) and Assigned(FOnDrawItem) then
  begin
    if Row = ARow then
    begin
      if GetFocus = Self.Handle then
      begin
        FOnDrawItem(Self, ARow, ARect, [odFocused, odSelected]);
        if ooDrawFocusRect in Options then
          DrawFocusRect(Canvas.Handle, ARect);
      end
      else FOnDrawItem(Self, ARow, ARect, [odSelected])
    end
    else OnDrawItem(Self, ARow, ARect, []);
    Exit;
  end;

  InitialLeft := ARect.Left;
  Node := GetVisibleNode(ARow);
  Delta := (ARect.Bottom - ARect.Top - FFontSize) div 2;

  with Canvas do
  begin
    Font := Self.Font;
    Brush.Color := Color;
    FillRect(ARect);
    TextLength := TextWidth(Node.Text) + 1;
    if Row = ARow then
    begin
      Brush.Color := clHighlight;
      Font.Color := clHighlightText;
    end;
  end;

  Expanded := Node.Expanded;
  HasChildren := Node.HasItems;
  IndentLevel := Node.GetLevel;
  case OutlineStyle of
    osText: DrawTheText;
    osPlusMinusText: DrawPlusMinusText;
    osPlusMinusPictureText: DrawPlusMinusPicture;
    osPictureText: DrawPictureText;
    osTreeText: DrawTheTree;
    osTreePictureText: DrawTreePicture;
  end;

  if (Row = ARow) and (Node.Text <> '') then
  begin
    ARect.Left := InitialLeft + DefaultRowHeight * (IndentLevel - 1);
    if OutlineStyle >= osTreeText then
    begin
      Dec(ARect.Left, Delta);
      if ooDrawTreeRoot in Options then Inc(ARect.Left, DefaultRowHeight);
    end;
    if (OutlineStyle <> osText) and (OutlineStyle <> osTreeText) then
      Inc(ARect.Left, DefaultRowHeight);
    if OutlineStyle = osPlusMinusPictureText then
      Inc(ARect.Left, DefaultRowHeight);
    if (GetFocus = Self.Handle) and (ooDrawFocusRect in Options) then
      DrawFocusRect(Canvas.Handle, ARect);
  end;
end;

procedure TCustomOutline.DrawTree(ARect: TRect; Node: TOutlineNode);
var
  Offset: Word;
  Height: Word;
  OldPen: TPen;
  I: Integer;
  ParentNode: TOutlineNode;
  IndentLevel: Integer;
begin
  Offset := DefaultRowHeight div 2;
  Height := ARect.Bottom;
  IndentLevel := Node.GetLevel;
  I := IndentLevel - 3;
  if ooDrawTreeRoot in Options then Inc(I);
  OldPen := TPen.Create;
  try
    OldPen.Assign(Canvas.Pen);
    with Canvas do
    begin
      Pen.Color := clBlack;
      Pen.Width := 1;
      try
        ParentNode := Node.Parent;
        while (ParentNode.Parent <> nil) and
          ((ooDrawTreeRoot in Options) or
          (ParentNode.Parent.Parent <> nil)) do
        begin
          with ParentNode.Parent do
          begin
            if List.IndexOf(ParentNode) < List.Count - 1 then
            begin
              Canvas.MoveTo(ARect.Left + DefaultRowHeight * I + Offset, ARect.Top);
              Canvas.LineTo(ARect.Left + DefaultRowHeight * I + Offset, Height);
            end;
          end;
          ParentNode := ParentNode.Parent;
          Dec(I);
        end;

        with Node.Parent do
          if List.IndexOf(Node) = List.Count - 1 then
            Height := ARect.Top + Offset;

        if (ooDrawTreeRoot in Options) or (IndentLevel > 1) then
        begin
          if not (ooDrawTreeRoot in Options) then Dec(IndentLevel);
          with ARect do
          begin
            Inc(Left, DefaultRowHeight * (IndentLevel - 1));
            MoveTo(Left + Offset, Top);
            LineTo(Left + Offset, Height);
            MoveTo(Left + Offset, Top + Offset);
            LineTo(Left + Offset + FFontSize div 2, Top + Offset);
          end;
        end;
      finally
        Pen.Assign(OldPen);
      end;
    end;
  finally
    OldPen.Destroy;
  end;
end;

procedure TCustomOutline.DrawPictures(BitMaps: array of TBitmap; ARect: TRect);
var
  I: Word;
  Rect: TRect;
  Value: TBitmap;
  Offset: Word;
  Delta: Integer;
  OldTop: Integer;
  OldColor: TColor;
begin
  OldColor := Canvas.Brush.Color;
  Canvas.Brush.Color := Color;
  Offset := (DefaultRowHeight - FFontSize) div 2;
  Rect.Top := ARect.Top + Offset;
  Rect.Bottom := Rect.Top + FFontSize;
  for I := Low(Bitmaps) to High(Bitmaps) do
  begin
    Value := BitMaps[I];
    Rect.Left := ARect.Left + Offset - 1;
    Rect.Right := Rect.Left + FFontSize;
    Inc(ARect.Left, DefaultRowHeight);
    if Value <> nil then
    begin
      if not (ooStretchBitmaps in Options) then
      begin
        if Rect.Top + Value.Height < Rect.Bottom then
          Rect.Bottom := Rect.Top + Value.Height;
        if Rect.Left + Value.Width < Rect.Right then
          Rect.Right := Rect.Left + Value.Width;
        Delta := (FFontSize - (Rect.Bottom - Rect.Top)) div 2;
        if Delta > 0 then
        begin
          Delta := (DefaultRowHeight - (Rect.Bottom - Rect.Top)) div 2;
          OldTop := Rect.Top;
          Rect.Top := ARect.Top + Delta;
          Rect.Bottom := Rect.Bottom - OldTop + Rect.Top;
        end;
        Canvas.BrushCopy(Rect, Value,
          Bounds(0, 0, Rect.Right - Rect.Left, Rect.Bottom - Rect.Top),
          Value.TransparentColor);
      end else
        Canvas.BrushCopy(Rect, Value,
          Bounds(0, 0, Value.Width, Value.Height),
          Value.TransparentColor);
    end;
  end;
  Canvas.Brush.Color := OldColor;
end;

procedure TCustomOutline.DrawText(Node: TOutlineNode; Rect: TRect);
begin
  Windows.DrawText(Canvas.Handle, PChar(Node.Text), Length(Node.Text), Rect,
    DT_LEFT or DT_SINGLELINE or DT_VCENTER or DT_NOPREFIX);
end;

function TCustomOutline.StoreBitmap(Index: Integer): Boolean;
begin
  Result := TOutlineBitmap(Index) in FUserBitmaps;
end;

procedure TCustomOutline.ClearBitmap(var Bitmap: TBitmap; Kind: TOutlineBitmap);
begin
  if Bitmap <> nil then
  begin
    Bitmap.Free;
    Bitmap := nil;
  end;
end;

procedure TCustomOutline.ChangeBitmap(Value: TBitmap; Kind: TOutlineBitmap);
var
  Bitmap: ^TBitmap;
begin
  Bitmap := @FPictures[Ord(Kind)];
  Include(FUserBitmaps, Kind);
  if Value = nil then ClearBitmap(Bitmap^, Kind)
  else Bitmap^.Assign(Value);
  Invalidate;
end;

procedure TCustomOutline.SetPicture(Index: Integer; Value: TBitmap);
begin
  ChangeBitmap(Value, TOutlineBitmap(Index));
end;

function TCustomOutline.GetPicture(Index: Integer): TBitmap;
begin
  if csLoading in ComponentState then
    Include(FUserBitmaps, TOutlineBitmap(Index));
  Result := FPictures[Index];
end;

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

{procedure TCustomOutline.SetMaskColor(Value: TColor);
begin
  FMaskColor := Value;
  Invalidate;
end;}

procedure TCustomOutline.SetItemHeight(Value: Integer);
begin
  FItemHeight := Value;
  if Style <> otOwnerDraw then SetRowHeight
  else begin
    DefaultRowHeight := ItemHeight;
    FFontSize := MulDiv(ItemHeight, 100, 120);
    Invalidate;
  end;
end;

procedure TCustomOutline.SetStyle(Value: TOutlineType);
begin
  if Style <> Value then
  begin
    FStyle := Value;
    if Value = otStandard then SetRowHeight;
  end;
end;

procedure TCustomOutline.SetOutlineOptions(Value: TOutlineOptions);
begin
  if Value <> FOptions then
  begin
    FOptions := Value;
    Invalidate;
  end;
end;

function LineStart(Buffer, BufPos: PChar): PChar;
begin
  if BufPos - Buffer - 2 > 0 then
  begin
    Dec(BufPos, 2);
    while (B