unit1.pas

这是所谓的折叠函数的代码,有兴趣的可拿去研究研究,经典

           else    }

          ThisNode := TreeView1.Items.Add(ThisNode, '   '); //普通行

          //csw : Add >>添加function标题--------------------
          {if FindKeyStr(mLineStr, 'function') or FindKeyStr(mLineStr, 'procedure') then
          begin
            Delete(mLineStr, Pos('(', mLineStr), Length(mLineStr));
            ThisNode.Text := mLineStr;
          end;}

        end;
      end;

      LaNodeData: //标号
      New(PLine);
      PLine^ := SynMemo1.Lines[i];
      ThisNode.data := PLine;

      //  if ThisNode.StateIndex = 99 then
      //    ThisNode.ImageIndex := 2 //
       // else
      ThisNode.ImageIndex := -1; //

    end;

    //展开树
    TEvent := TreeView1.OnExpanded;
    TreeView1.OnExpanded := nil;

    for i := 0 to TreeView1.Items.count - 1 do
      TreeView1.Items[i].Expanded := true;

    sBar1.Panels[0].Text := '总行数：' + IntToStr(i);

    ScrollTree;
    TreeView1.OnExpanded := TEvent;
    //TreeView1.OnExpanding:=TreeView1Expanded(sender,nil);
  finally
    DoUnLockScreen;
  end;
end;

procedure TForm1.TreeView1Expanded(Sender: TObject; Node: TTreeNode);
var i: Integer;
  ThisNode: TTreeNode;
  PLine: ^string;
begin
  ThisNode := Node.getFirstChild;
  i := VisIndex(Node);
  while (ThisNode <> nil) and (ThisNode.Level > Node.Level) do
  begin
    PLine := ThisNode.data;
    SynMemo1.Lines.Insert(i + 1, string(PLine^));
    inc(i);
    // ThisNode := ThisNode.GetNext;
    if (not ThisNode.Expanded) and (ThisNode.HasChildren) then
      ThisNode := ThisNode.getNextSibling
    else
      ThisNode := ThisNode.GetNext;
  end;
  Node.ImageIndex := -1;
  // for i := Node.ImageIndex+1 to (Node.Count + Node.ImageIndex) do
   //
end;

procedure TForm1.AllCollapse(nLevel: Integer);

begin

  //
end;

procedure TForm1.TreeView1Collapsing(Sender: TObject; Node: TTreeNode;
  var AllowCollapse: Boolean);
var i, VisI: Integer;
  ThisNode: TTreeNode;
begin
  ThisNode := Node.getFirstChild;
  VisI := VisIndex(Node);

  LockWindowUpdate(handle);
  while (ThisNode <> nil) and (ThisNode.Level > Node.Level) do
  begin
    if ThisNode.IsVisible then
      SynMemo1.Lines.Delete(VisI + 1);

    ThisNode := ThisNode.GetNext;
  end;
  Node.ImageIndex := 2;

  AllowCollapse := true;
  LockWindowUpdate(0);

end;

procedure TForm1.ToTree;
var ThisNode: TTreeNode;
begin
  //ShowMessage(IntToStr(SynMemo1.Carety));
  SynMemo1.SetBookMark(1, 1, SynMemo1.Carety);
  ThisNode := VisNode(SynMemo1.Carety - 1);
  if ThisNode <> nil then
    ThisNode.Selected := true;

end;

procedure TForm1.SynMemo1Click(Sender: TObject);
var ThisNode: TTreeNode;
begin
  //ShowMessage(IntToStr(SynMemo1.Carety));
  if TreeView1.Items.count <= 0 then Exit;

  SynMemo1.SetBookMark(1, 1, SynMemo1.Carety);
  ThisNode := VisNode(SynMemo1.Carety - 1);

  if ThisNode <> nil then
  begin
    Edit1.Text := IntToStr(ThisNode.Level);
    Edit2.Text := IntToStr(ThisNode.Level);
    Edit3.Text := IntToStr(ThisNode.Level);
    Edit4.Text := IntToStr(ThisNode.Level);

    if FScrollTree then
      ScrollTree;

    ThisNode.Selected := true;
    if CheckBox1.Checked then
      FDoPainEvent := true; //开始执行重画begin
  end;

end;

procedure TForm1.SynMemo1KeyUp(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
  if (Key = 38) or (Key = 40) then
    //    ToTree;
end;

procedure TForm1.TreeView1Click(Sender: TObject);
var ThisNode: TTreeNode;
begin
  ScrollTree;
  Exit; //

  SynMemo1.TopLine := VisIndex(TreeView1.TopItem) + 1;
  ThisNode := TreeView1.TopItem;
  // ShowMessage(thisnode.text);
  if ThisNode = nil then
    Exit;
  while ThisNode.AbsoluteIndex < TreeView1.Selected.AbsoluteIndex do
    ThisNode := ThisNode.GetNext;

  if ThisNode <> nil then
    SynMemo1.SetBookMark(1, 1, VisIndex(ThisNode) + 1);
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  DisPoseTree(TreeView1);
  FreeAndNil(FStrList);
end;

procedure TForm1.DoLockScreen(sHint: string);
begin
  sBar1.Panels[1].Text := sHint +
    '*************************************************************';
  screen.Cursor := crHourGlass;
  application.ProcessMessages;
  LockWindowUpdate(handle);
end;

procedure TForm1.DoUnLockScreen;
begin
  LockWindowUpdate(0);
  sBar1.Panels[1].Text := '';
  sBar1.Panels[0].Text := '总行数：' + IntToStr(SynMemo1.Lines.count);
  screen.Cursor := crDefault;
end;

procedure TForm1.Button3Click(Sender: TObject);
begin
  try

    if OpenDialog1.Execute then
    begin
      DoLockScreen('正在打开文件');

      SynMemo1.Lines.Clear;
      SynMemo1.Lines.LoadFromFile(OpenDialog1.FileName);

      Button4Click(nil); //建树

    end;
  finally
    DoUnLockScreen
  end;
end;
//------------------------------------------------------------------------------

procedure TForm1.Button2Click(Sender: TObject); //折叠
var i, nLevel: Integer;
begin
  if not IsNumber(Edit1.Text) then Exit;

  DoLockScreen('正在折叠中,请稍等');

  nLevel := StrToInt(Edit1.Text);
  for i := 0 to TreeView1.Items.count - 1 do
    if TreeView1.Items[i].Level = nLevel then
      TreeView1.Items[i].Expanded := False;

  DoUnLockScreen;
  ScrollTree;
end;

procedure TForm1.Button6Click(Sender: TObject); //展开
var i: Integer;
begin

  if not IsNumber(Edit2.Text) then Exit;

  DoLockScreen('正在展开中,请稍等');

  for i := 0 to TreeView1.Items.count - 1 do
    if TreeView1.Items[i].Level <= StrToInt(Edit2.Text) then
      TreeView1.Items[i].Expanded := true;

  DoUnLockScreen;
  ScrollTree;
end;

procedure TForm1.DrawRect(x1, y1, x2, y2: Integer);
begin
  with SynMemo1 do
  begin
    Canvas.Pen.width := 5;
    Canvas.Pen.Color := clred;
    Canvas.Pen.mode := pmCopy;
    Canvas.Pen.Style := psSolid;

    Canvas.Rectangle(x1, y1, x2, y2);

    Exit;
    Canvas.MoveTo(x1, y1);
    Canvas.LineTo(200, 200);

    Canvas.MoveTo(100, 10);
    Canvas.LineTo(100, 300);
  end;
end;

procedure TForm1.SynMemo1GutterClick(Sender: TObject; Button: TMouseButton;
  X, Y, Line: Integer; Mark: TSynEditMark);
var ThisNode: TTreeNode;
begin

  if TreeView1.Items.count <= 0 then Exit;

  ThisNode := VisNode(Line - 1);
  if ThisNode.Expanded then
    ThisNode.Expanded := False
  else
    ThisNode.Expanded := true;
end;

function FindFirstChar(s: string): Integer;
var i: Integer;
begin
  result := 0;
  for i := 1 to Length(s) do
  begin
    if s[i] <> ' ' then
    begin
      result := i;
      Break;
    end;
  end;
end;

//重划------------------------------------------------------------------------------
procedure TForm1.SynMemo1PaintTransient(Sender: TObject; Canvas: TCanvas;
  TransientType: TTransientType);
const AllBrackets = ['{', '[', '(', '<', '&', '}', ']', ')', '>', '#'];
var Editor: TSynEdit;
  OpenChars: array of Char; //[0..2] of Char=();
  CloseChars: array of Char; //[0..2] of Char=();

  function CharToPixels(p: TBufferCoord): TPoint;
  begin
    result := Editor.RowColumnToPixels(Editor.BufferToDisplayPos(p));
  end;

var

  { p: TBufferCoord;
    Pix: TPoint;

    i: Integer;

    PStr: ^string;
    nLine: Integer;
    ThisNode, CurNode: TTreeNode;
    nColor: Integer;   }

    //csw : Add >>--------------------
  PixBegin, PixEnd: TPoint;
  nBeginXy, nEndXY: TBufferCoord;
  FromLine, ToLine: Integer;
  s: string;
begin
  {ToDo : SynMemo1PaintTransient}
  if not FDoPainEvent then Exit;

  if TSynEdit(Sender).SelAvail then Exit;
  Editor := TSynEdit(Sender);

  if not FindBeginEnd(FromLine, ToLine) then Exit;

  with Editor do
  begin

    Canvas.Pen.width := 1;
    Canvas.Pen.Color := clred;
    Canvas.Pen.mode := pmCopy;
    Canvas.Pen.Style := psSolid;

    if (TransientType = ttAfter) then //关键，实现清除其他线的作用
      Canvas.Pen.Color := clred
    else
      Canvas.Pen.Color := clwhite;

    //定位begin----------------------
    nBeginXy.Line := FromLine + 1;
    s := Editor.Lines[FromLine];
    nBeginXy.Char := FindFirstChar(s);
    PixBegin := CharToPixels(nBeginXy);

    //定位end;-----------------------
    s := Editor.Lines[ToLine];
    nEndXY.Char := FindFirstChar(s);
    nEndXY.Line := ToLine + 1;
    PixEnd := CharToPixels(nEndXY);

    if ToLine > FromLine then
    begin
      //画上面短横线
      Canvas.MoveTo(PixBegin.X, PixBegin.Y);
      Canvas.LineTo(PixBegin.X + 10, PixBegin.Y);

      //画竖线
      Canvas.MoveTo(PixBegin.X, PixBegin.Y);
      Canvas.LineTo(PixEnd.X, PixEnd.Y + 16);

      //画下面横线
      Canvas.LineTo(PixEnd.X + 10, PixEnd.Y + 16);
    end
    else
    begin
      //画上面短横线
      Canvas.MoveTo(PixBegin.X, PixBegin.Y + 16);
      Canvas.LineTo(PixBegin.X + 10, PixBegin.Y + 16);

      //画竖线
      Canvas.MoveTo(PixBegin.X, PixBegin.Y + 16);
      Canvas.LineTo(PixEnd.X, PixEnd.Y);

      //画下面横线
      Canvas.LineTo(PixEnd.X + 10, PixEnd.Y);
    end;
  end;

  Exit;
  //下面的程序段是画当前及所有父节点的线------------------------------------------------------------------------------

  {
    if not FDoPainEvent then Exit;

    if TSynEdit(Sender).SelAvail then Exit;
    Editor := TSynEdit(Sender);

    nLine := Editor.Carety - 1;
    ThisNode := GetVisNode(nLine);
    while ThisNode <> nil do
    begin
      CurNode := ThisNode;
      if ThisNode.StateIndex = 99 then
      begin
        nColor := ThisNode.Level mod 4;

        with Editor do
        begin
          Canvas.Pen.width := 1;
          Canvas.Pen.Color := clred;
          Canvas.Pen.mode := pmCopy;
          Canvas.Pen.Style := psSolid;

          // Canvas.Rectangle(100, 100, 200, 200);

          //颜色
          case nColor of
            0:
              begin
                Editor.Canvas.Font.Color := clred; //clRed
                Editor.Canvas.Brush.Color := clinfobk; //clNone
                Canvas.Pen.Color := clGreen;
              end;
            1:
              begin
                Editor.Canvas.Font.Color := clFuchsia; //clRed
                Editor.Canvas.Brush.Color := clAqua; //clNone
                Canvas.Pen.Color := clFuchsia;
              end;
            2:
              begin
                Editor.Canvas.Font.Color := clPurple; //clRed
                Editor.Canvas.Brush.Color := clinfobk; //clNone
                Canvas.Pen.Color := clNavy;
              end;
            3:
              begin
                Editor.Canvas.Font.Color := clMaroon; //clRed
                Editor.Canvas.Brush.Color := clSilver; //clNone
                Canvas.Pen.Color := clMaroon;
              end;
            4:
              begin
                Editor.Canvas.Font.Color := clblue; //clRed
                Editor.Canvas.Brush.Color := clinfobk; //clNone
                Canvas.Pen.Color := clred;
              end;
          end;

          //字体
          Editor.Canvas.Font.Style := Editor.Font.Style;
          Editor.Canvas.Font.Style := Editor.Canvas.Font.Style + [fsbold];

          //p := Editor.CaretXY;
          p.Line := VisIndex(ThisNode) + 1;
          s := string(ThisNode.data^);
          p.Char := FindFirstChar(s);
          Pix := CharToPixels(p);

          // Editor.Canvas.TextOut(57, Pix.Y, s); //begin

           //csw : Add >> end--------------------

          CurNode := ThisNode;
          ThisNode := ThisNode.getNextSibling;
          if (ThisNode <> nil) and (ThisNode.StateIndex = 88) then
          begin
            s := string(ThisNode.data^);
            nEndXY.Char := FindFirstChar(s);
            nEndXY.Line := self.VisIndex(ThisNode) + 1;

            PixEnd := CharToPixels(nEndXY);

            //画上面短横线
            Canvas.MoveTo(Pix.X, Pix.Y);
            Canvas.LineTo(Pix.X + 10, Pix.Y);

            //画竖线
            Canvas.MoveTo(Pix.X, Pix.Y);
            Canvas.LineTo(PixEnd.X, PixEnd.Y + 16);

            //画下面横线
            Canvas.LineTo(PixEnd.X + 10, PixEnd.Y + 16);

            // self.Caption := s + IntToStr(nEndXY.Line);

             //  Editor.Canvas.TextOut(57, PixEnd.Y, s); //end
          end;
        end;
      end;
      ThisNode := CurNode.Parent;
    end;

    //FDoPainEvent := False;
    Exit;  }

end;

function TForm1.FunDefined(sLine: string): Boolean;
  function RightStr(Str: string; i: Integer): string;
  begin
    result := Copy(Str, Length(Str) - i + 1, i);
  end;
begin
  result := False;
  if not FfunOpen then FfunOpen := Pos('(', sLine) > 0;
  if not FfunClose then FfunClose := Pos(')', sLine) > 0;
  sLine := Trim(sLine);
  if RightStr(sLine, 1) = ';' then
  begin
    if FfunOpen and FfunClose then result := true;
    if (not FfunOpen) and (not FfunClose) then
    begin
      result := true;
      FfunOpen := False;
      FfunClose := False;
    end;
  end;
end;

procedure TForm1.CheckBox1Click(Sender: TObject);
begin
  if not CheckBox1.Checked then
    FDoPainEvent := False
  else
    FDoPainEvent := true;
end;

function TForm1.FindBeginEnd(var FromLine, ToLine: Integer): Boolean;

var //nLine: Integer;
  i, j: Integer;
  ACnt, StrCnt, JiCnt, PosI: Integer;
  mLineStr, CLine, TmpLine: string;

label aa, bb;
begin
  result := False;
  FromLine := SynMemo1.Carety - 1;
  ACnt := 0;
  JiCnt := 0;

  mLineStr := LowerCase(Trim(SynMemo1.Lines[FromLine]));

  if FindKeyStr(mLineStr, 'begin') or FindKeyStr(mLineStr, 'case')
    or FindKeyStr(mLineStr, 'try') then
  begin

    for i := FromLine to SynMemo1.Lines.count - 1 do
    begin

      //除掉注释---------->>>----------------------------------------------------------
      mLineStr := LowerCase(SynMemo1.Lines[i]);
      StrCnt := Length(mLineStr);