outline.pas

这是不可多得的源代码

    end
    else
      IncludeStart := True;
  end;

  if Parent <> nil then
    Parent.ReIndex(Self, EndNode, NewIndex, False);
end;

function TOutlineNode.Resync(var NewIndex: LongInt; EndNode: TOutlineNode): Boolean;
var
  I: Integer;
begin
  FIndex := NewIndex;
  if EndNode = Self then
  begin
    Result := True;
    Exit;
  end;

  Result := False;
  Inc(NewIndex);
  for I := 0 to List.Count - 1 do
  begin
    Result := Items[I].Resync(NewIndex, EndNode);
    if Result then Exit;
  end;
end;

function TOutlineNode.GetExpandedNodeCount: LongInt;
var
  I : Integer;
begin
  Result := 1;
  if Expanded then
    for I := 0 to List.Count - 1 do
      Inc(Result, Items[I].GetExpandedNodeCount);
end;


function TOutlineNode.GetMaxDisplayWidth(Value: Cardinal): Cardinal;
var
  I : Integer;
  Width: Cardinal;
begin
  Width := GetDisplayWidth;
  if Width > Value then Result := Width
  else Result := Value;
  if Expanded then
    for I := 0 to List.Count - 1 do
      Result := Items[I].GetMaxDisplayWidth(Result);
end;

procedure TOutlineNode.Error(const ErrorString: string);
begin
  raise EOutlineError.Create(ErrorString);
end;

function TOutlineNode.HasChildren: Boolean;
begin
  Result := List.Count > 0;
end;

procedure TOutlineNode.WriteNode(Buffer: PChar; Stream: TStream);
var
  BufPtr: PChar;
  NodeLevel: Word;
  I: Integer;
begin
  if Parent <> nil then
  begin
    BufPtr := Buffer;
    NodeLevel := Level;
    while NodeLevel > 1 do
    begin
      BufPtr^ := Tab;
      Dec(NodeLevel);
      Inc(BufPtr);
    end;
    BufPtr := PutString(BufPtr, Text);
    Stream.WriteBuffer(Buffer[0], BufPtr - Buffer);
  end;
  for I := 0 to List.Count - 1 do
    Items[I].WriteNode(Buffer, Stream);
end;

function TOutlineNode.IsEqual(Value: TOutlineNode): Boolean;
begin
  Result := (Text = Value.Text) and (Data = Value.Data) and
    (ExpandCount = Value.ExpandCount);
end;

{ TOutlineStrings }

function TOutlineStrings.Get(Index: Integer): string;
var
  Node: TOutlineNode;
  Level: Word;
  I: Integer;
begin
  Node := Outline[Index + 1];
  Level := Node.Level;
  Result := EmptyStr;
  for I := 0 to Level - 2 do
    Result := Result + TAB;
  Result := Result + Node.Text;
end;

function TOutlineStrings.GetCount: Integer;
begin
  Result := Outline.ItemCount;
end;

procedure TOutlineStrings.Clear;
begin
  Outline.Clear;
end;

procedure TOutlineStrings.DefineProperties(Filer: TFiler);

  function WriteNodes: Boolean;
  var
    I: Integer;
    Ancestor: TOutlineStrings;
  begin
    Ancestor := TOutlineStrings(Filer.Ancestor);
    if (Ancestor <> nil) and (Ancestor.Outline.ItemCount = Outline.ItemCount) and
      (Ancestor.Outline.ItemCount > 0) then
    begin
      Result := False;
      for I := 1 to Outline.ItemCount - 1 do
      begin
        Result := not Outline[I].IsEqual(Ancestor.Outline[I]);
        if Result then Break;
      end
    end else Result := Outline.ItemCount > 0;
  end;

begin
  Filer.DefineProperty('Nodes', ReadData, WriteData, WriteNodes);
end;

procedure TOutlineStrings.ReadData(Reader: TReader);
var
  StringList: TStringList;
  MemStream: TMemoryStream;
begin
  Reader.ReadListBegin;
  StringList := TStringList.Create;
  try
    while not Reader.EndOfList do StringList.Add(Reader.ReadString);
    MemStream := TMemoryStream.Create;
    try
      StringList.SaveToStream(MemStream);
      MemStream.Position := 0;
      Outline.LoadFromStream(MemStream);
    finally
      MemStream.Free;
    end;
  finally
    StringList.Free;
  end;
  Reader.ReadListEnd;
end;

procedure TOutlineStrings.WriteData(Writer: TWriter);
var
  I: Integer;
  MemStream: TMemoryStream;
  StringList: TStringList;
begin
  Writer.WriteListBegin;
  MemStream := TMemoryStream.Create;
  try
    Outline.SaveToStream(MemStream);
    MemStream.Position := 0;
    StringList := TStringList.Create;
    try
      StringList.LoadFromStream(MemStream);
      for I := 0 to StringList.Count - 1 do
        Writer.WriteString(StringList.Strings[I]);
    finally
      StringList.Free;
    end;
  finally
    MemStream.Free;
  end;
  Writer.WriteListEnd;
end;

function TOutlineStrings.Add(const S: string): Integer;
var
  Level, OldLevel, I: Cardinal;
  NewStr: string;
  NumNodes: LongInt;
  LastNode: TOutlineNode;
begin
  NewStr := GetBufStart(PChar(S), Level);
  NumNodes := Outline.ItemCount;
  if NumNodes > 0 then LastNode := Outline[Outline.ItemCount]
  else LastNode := Outline.FRootNode;
  OldLevel := LastNode.Level;
  if (Level > OldLevel) or (LastNode = Outline.FRootNode) then
  begin
    if Level - OldLevel > 1 then Outline.Error(SOutlineFileLoad);
  end
  else begin
    for I := OldLevel downto Level + 1 do
    begin
      LastNode := LastNode.Parent;
      if not Assigned(LastNode) then Outline.Error(SOutlineFileLoad);
    end;
  end;
  Result := Outline.AddChild(LastNode.Index, NewStr) - 1;
end;

procedure TOutlineStrings.Delete(Index: Integer);
begin
  Outline.Delete(Index + 1);
end;

procedure TOutlineStrings.Insert(Index: Integer; const S: string);
begin
  Outline.Insert(Index + 1, S);
end;

procedure TOutlineStrings.PutObject(Index: Integer; AObject: TObject);
var
  Node: TOutlineNode;
begin
  Node := Outline[Index + 1];
  Node.Data := Pointer(AObject);
end;

function TOutlineStrings.GetObject(Index: Integer): TObject;
begin
  Result := TObject(Outline[Index + 1].Data);
end;


{TCustomOutline}

const
  Images: array[TBitmapArrayRange] of PChar = ('PLUS', 'MINUS', 'OPEN', 'CLOSED', 'LEAF');

constructor TCustomOutline.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  Width := 121;
  Height := 97;
  Color := clWindow;
  ParentColor := False;
  SetRowHeight;
  RowCount := 0;
  ColCount := 1;
  FixedCols := 0;
  FixedRows := 0;
  DefaultDrawing := False;
  Init;
  FStrings := TOutlineStrings.Create;
  TOutlineStrings(FStrings).Outline := Self;
  inherited Options := [];
  Options := [ooDrawTreeRoot, ooDrawFocusRect];
  ItemSeparator := '\';
  FOutlineStyle := osTreePictureText;
  CreateGlyph;
end;

destructor TCustomOutline.Destroy;
var
  I: Integer;
begin
  FStrings.Free;
  FRootNode.Free;
  for I := Low(FPictures) to High(FPictures) do FPictures[I].Free;
  inherited Destroy;
end;

procedure TCustomOutline.Init;
begin
  if FRootNode = nil then FRootNode := TOutlineNode.Create(Self);
  FRootNode.FState := True;
  ResetSelectedItem;
  FGoodNode := FRootNode;
  FCurItem := FRootNode;
  FBlockInsert := False;
  UpdateCount := 0;
  ResizeGrid;
end;

procedure TCustomOutline.CreateGlyph;
var
  I: Integer;
begin
  FUserBitmaps := [];
  FOldBitmaps := [];
  for I := Low(FPictures) to High(FPictures) do
  begin
    FPictures[I] := TBitmap.Create;
    FPictures[I].Handle := LoadBitmap(HInstance, Images[I]);
  end;
end;

procedure TCustomOutline.SetRowHeight;
var
  ScreenDC: HDC;
begin
  if Style <> otOwnerDraw then
  begin
    ScreenDC := GetDC(0);
    try
      FFontSize := MulDiv(Font.Size, GetDeviceCaps(ScreenDC, LOGPIXELSY), 72);
      DefaultRowHeight := MulDiv(FFontSize, 120, 100);
      FItemHeight := DefaultRowHeight;
    finally
      ReleaseDC(0, ScreenDC);
    end;
  end
end;

procedure TCustomOutline.Clear;
begin
  FRootNode.Destroy;
  FRootNode := nil;
  Init;
end;

procedure TCustomOutline.DefineProperties(Filer: TFiler);

  function WriteOutline: Boolean;
  var
    Ancestor: TCustomOutline;
  begin
    Ancestor := TCustomOutline(Filer.Ancestor);
    if Ancestor <> nil then
      Result := (Ancestor.FUserBitmaps <> []) and
        (Ancestor.FUserBitmaps - FUserBitmaps <> [])
    else Result := FUserBitmaps <> [];
  end;

begin
  inherited DefineProperties(Filer);
  Filer.DefineBinaryProperty('Data', ReadBinaryData, WriteBinaryData,
    WriteOutline);
end;

procedure TCustomOutline.ReadBinaryData(Stream: TStream);
begin
  Stream.ReadBuffer(FOldBitmaps, SizeOf(FOldBitmaps));
end;

procedure TCustomOutline.WriteBinaryData(Stream: TStream);
begin
  Stream.WriteBuffer(FuserBitmaps, SizeOf(FUserBitmaps));
end;

function TCustomOutline.IsCurItem(Value: LongInt): Boolean;
begin
  Result := Value = FCurItem.Index;
end;

function TCustomOutline.GetItemCount: LongInt;
begin
  Result := FRootNode.GetLastIndex;
end;

procedure TCustomOutline.MoveNode(Destination, Source: LongInt;
  AttachMode: TAttachMode);
var
  SourceNode: TOutlineNode;
  DestNode: TOutLineNode;
  OldParent: TOutlineNode;
  OldIndex: Integer;
begin
  if Destination = Source then Exit;
  DestNode := FCurItem;
  if not IsCurItem(Destination) then
    try
      DestNode := FRootNode.GetNodeAtIndex(Destination);
    except
      on OutlineError do Error(SOutlineIndexError);
    end;

  SourceNode := FCurItem;
  if not IsCurItem(Source) then
    try
      SourceNode := FRootNode.GetNodeAtIndex(Source);
    except
      on OutlineError do Error(SOutlineIndexError);
    end;

  if DestNode.HasAsParent(SourceNode) then Exit;

  if DestNode.GetLevel > MaxLevels then Error(SOutlineMaxLevels);
  if (FGoodNode = FRootNode) and (FRootNode.List.Count <> 0) then
    TOutlineNode(FRootNode[0]).SetGoodIndex;
  OldParent := SourceNode.Parent;
  OldIndex := -1;
  case AttachMode of
    oaInsert:
      begin
        if DestNode.Parent = OldParent then
        begin
          OldIndex := OldParent.List.IndexOf(SourceNode);
          if OldParent.List.IndexOf(DestNode) < OldIndex then
            OldIndex := OldIndex + 1 else
            OldIndex := -1;
        end;
        DestNode.Parent.InsertNode(DestNode.Index, SourceNode);
      end;
    oaAddChild: DestNode.AddNode(SourceNode);
    oaAdd: DestNode.Parent.AddNode(SourceNode);
  end;
  if OldIndex <> -1 then
    OldParent.InternalRemove(SourceNode, OldIndex) else
    OldParent.Remove(SourceNode);
  if not DestNode.Expanded then SourceNode.Expanded := False;
  if (FGoodNode = FRootNode) and (FRootNode.List.Count <> 0) then
    TOutlineNode(FRootNode[0]).SetGoodIndex;
  ResizeGrid;
  Invalidate;
end;

function TCustomOutline.AttachNode(Index: LongInt; Str: string;
  Ptr: Pointer; AttachMode: TAttachMode): LongInt;
var
  NewNode: TOutlineNode;
  CurrentNode: TOutLineNode;
begin
  Result := 0;
  NewNode := TOutlineNode.Create(Self);
  with NewNode do
  begin
    Text := Str;
    Data := Ptr;
    FIndex := InvalidIndex;
  end;
  try
    CurrentNode := FCurItem;
    if not IsCurItem(Index) then
      try
        CurrentNode := FRootNode.GetNodeAtIndex(Index);
      except
        on OutlineError do Error(SOutlineIndexError);
      end;

    if AttachMode = oaAdd then
    begin
      CurrentNode := CurrentNode.Parent;
      if CurrentNode = nil then Error(SOutlineError);
      AttachMode := oaAddChild;
    end;

    with CurrentNode do
    begin
      case AttachMode of
        oaInsert: Result := Parent.InsertNode(Index, NewNode);
        oaAddChild:
          begin
             if GetLevel > MaxLevels then Error(SOutlineMaxLevels);
             Result := AddNode(NewNode);
          end;
      end;
    end;
    if ResizeGrid then Invalidate;
  except
    NewNode.Destroy;
    Application.HandleException(Self);
  end;
end;

function TCustomOutline.Get(Index: LongInt): TOutlineNode;
begin
  Result := FCurItem;
  if not IsCurItem(Index) then
    try
      Result := FRootNode.GetNodeAtIndex(Index);
    except
      on OutlineError do Error(SOutlineIndexError);
    end;
  if Result = FRootNode then Error(SOutlineError);
end;

function TCustomOutline.GetSelectedItem: LongInt;