unit1.pas

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

      if (Pos('{', mLineStr) > 0) or (Pos('}', mLineStr) > 0) then
      begin
        CLine := '';
        for j := 1 to StrCnt do
        begin
          if (mLineStr[j] <> '}') and (mLineStr[j] <> '{') then
            if JiCnt = 0 then CLine := CLine + mLineStr[j];

          if mLineStr[j] = '{' then
          begin
            JiCnt := 1;
            CLine := CLine + ' ';
          end;

          if mLineStr[j] = '}' then
            if JiCnt = 1 then
              JiCnt := 0;
        end;

        PosI := Pos('//', CLine);
        if PosI > 0 then
          Delete(CLine, PosI, StrCnt);

        mLineStr := CLine;

        goto aa;
      end;

      if JiCnt = 0 then
      begin
        PosI := Pos('//', mLineStr);
        if PosI > 0 then
          Delete(mLineStr, PosI, StrCnt);

        goto aa;
      end;

      if JiCnt = 1 then
        mLineStr := '';

      //----------<<<----------------------------------------------------------

      aa:

      if FindKeyStr(mLineStr, 'begin') or FindKeyStr(mLineStr, 'case')
        or FindKeyStr(mLineStr, 'try') then
        ACnt := ACnt + 1;
      if FindKeyStr(mLineStr, 'end') or FindKeyStr(mLineStr, 'end;') then
      begin
        ACnt := ACnt - 1;
        if ACnt < 0 then Break; //第一行是end， 退出

      end;

      if ACnt = 0 then
      begin
        ToLine := i;
        if FromLine <> ToLine then
          result := true;
        Break;
      end;
    end;

  end

    //------------------------------------------------------------------------------
  else if FindKeyStr(mLineStr, 'end') or FindKeyStr(mLineStr, 'end;') then
  begin
    for i := FromLine downto 0 do
    begin

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

      if (Pos('{', mLineStr) > 0) or (Pos('}', mLineStr) > 0) then
      begin
        TmpLine := '';
        CLine := '';
        for j := StrCnt downto 1 do
        begin
          if (mLineStr[j] <> '}') and (mLineStr[j] <> '{') then
            if JiCnt = 0 then TmpLine := TmpLine + mLineStr[j];

          if mLineStr[j] = '}' then
          begin
            JiCnt := 1;
            TmpLine := TmpLine + ' ';
          end;

          if mLineStr[j] = '{' then
            if JiCnt = 1 then
              JiCnt := 0;
        end;
        for j := Length(TmpLine) downto 1 do
          CLine := CLine + TmpLine[j];

        PosI := Pos('//', CLine);
        if PosI > 0 then
          Delete(CLine, PosI, StrCnt);

        mLineStr := CLine;

        goto bb;
      end;

      if JiCnt = 0 then
      begin
        PosI := Pos('//', mLineStr);
        if PosI > 0 then
          Delete(mLineStr, PosI, StrCnt);

        goto bb;
      end;

      if JiCnt = 1 then
        mLineStr := '';

      //----------<<<----------------------------------------------------------

      bb:

      if FindKeyStr(mLineStr, 'begin') or FindKeyStr(mLineStr, 'case')
        or FindKeyStr(mLineStr, 'try') then
        ACnt := ACnt - 1;
      if FindKeyStr(mLineStr, 'end') or FindKeyStr(mLineStr, 'end;') then
      begin
        ACnt := ACnt + 1;
        if ACnt < 0 then Break; //第一行是end， 退出

      end;

      if ACnt = 0 then
      begin
        ToLine := i;
        if FromLine <> ToLine then
          result := true;
        Break;
      end;
    end;
  end;

end;

procedure TForm1.SynMemo1Change(Sender: TObject);
begin
  sBar1.Panels[1].Text :=
    '已修改内容，请重新点击“折叠刷新”才能正确折叠！'
end;

procedure TForm1.Button5Click(Sender: TObject);
var i: Integer;
begin
  DoLockScreen('正在全部展开中,请稍等');

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

  DoUnLockScreen;
  ScrollTree;
end;

procedure TForm1.SynMemo1KeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
  //  Key := 0;
  sBar1.Panels[1].Text := '本工具只供函数查看使用，不是编辑器！老兄！'

end;

procedure TForm1.N1Click(Sender: TObject);
begin
  N1.Checked := not N1.Checked;
  if N1.Checked then
    FScrollTree := true
  else
    FScrollTree := False;

end;

procedure DoIt(Strings: TStrings);
var
  InBrass: Boolean;
  InDiv: Boolean;
  InString: Boolean;
  s: string;
  i, j: Integer;
  OldLength: Integer;
begin
  InBrass := False;
  InDiv := False;
  InString := False;
  i := 0;
  while i <= Strings.count - 1 do
  begin
    s := Strings[i] + ' ';
    OldLength := Length(s);
    j := 1;
    while j <= Length(s) do
    begin
      if not InString then
      begin
        if InBrass then
        begin
          if s[j] = '}' then
          begin
            Delete(s, j, 1);
            InBrass := False
          end
          else
            Delete(s, j, 1)
        end
        else if InDiv then
        begin
          if (s[j] = '*') and (s[j] = ')') then
          begin
            Delete(s, j, 2);
            InDiv := False
          end
          else
            Delete(s, j, 1)
        end
        else
        begin
          if (s[j] = '/') and (s[j + 1] = '/') then
            Delete(s, j, Length(s) - j + 1)
          else if (s[j] = '{') and (s[j + 1] <> '$') then
          begin
            Delete(s, j, 1);
            InBrass := true
          end
          else if (s[j] = '(') and (s[j + 1] = '*') then
          begin
            Delete(s, j, 2);
            InDiv := true
          end
          else if s[j] = '''' then
          begin
            InString := true;
            inc(j)
          end
          else
            inc(j)
        end
      end
      else
      begin
        if (s[j] = '''') and (s[j + 1] <> '''') then
          InString := False
        else if (s[j] = '''') and (s[j + 1] = '''') then
          inc(j);
        inc(j)
      end
    end;
    if Length(s) < OldLength then
    begin
      if s = DupeString(' ', Length(s)) then
        Strings.Delete(i)
      else
      begin
        Strings[i] := s;
        inc(i)
      end
    end
    else
    begin
      Strings[i] := s;
      inc(i)
    end
  end
end;

procedure TForm1.Button1Click(Sender: TObject);
var X, Y: Integer;
begin
  DoIt(SynMemo1.Lines);
  Exit;
  Memo1.Lines := self.FStrList;
  Exit;
  FindBeginEnd(X, Y);
  ShowMessage(IntToStr(X) + ':' + IntToStr(Y));

end;

procedure TForm1.Button8Click(Sender: TObject);
var i: Integer;
  PLine: ^string;
  AList: TStrings;

begin
  if self.SaveDialog1.Execute then
  begin
    AList := TStringList.Create;
    try
      for i := 0 to TreeView1.Items.count - 1 do
      begin
        PLine := TreeView1.Items[i].data;
        AList.Add(string(PLine^));
      end;
      AList.SaveToFile(self.SaveDialog1.FileName);
    finally
      FreeAndNil(AList);
    end;

    //Button4Click(nil);
  end;

end;

procedure TForm1.Button7Click(Sender: TObject);
var i: Integer;
  ThisNode: TTreeNode;
  PLine: ^string;
begin
  if self.OpenDialog1.Execute then
    TreeView1.LoadFromFile(self.OpenDialog1.FileName);

  for i := 0 to TreeView1.Items.count - 1 do
  begin
    ThisNode := TreeView1.Items[i];
    if ThisNode.IsVisible then
    begin
      PLine := ThisNode.data;
      SynMemo1.Lines.Insert(i + 1, string(PLine^));
    end;
  end;

  Exit;
  { 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.N2Click(Sender: TObject);
var s: string;
begin
  s := '【功能说明】' + #13 +
    '1、“打开文件按钮”' + #13 +
    '  打开一个pas文件，加载到编辑区。当提示是否折叠刷新时，请点确定。' + #13 +
    '' + #13 +
    '2、“保存文件按钮”' + #13 +
    '  首先确保已经“折叠刷新”过，否则不能保存。' + #13 +
    '' + #13 +
    '3、“折叠刷新按钮”' + #13 +
    '  打开或粘贴一段程序后，首先要进行“折叠刷新”才能折叠。' + #13 +
    '' + #13 +
    '4、“折叠级数”' + #13 +
    '  录入折叠级数，或把光标置于要折叠的行，可进行该层的折叠。' + #13 +
    '' + #13 +
    '5、“画线按钮”' + #13 +
    '  选中后，光标置于含有begin /end 的行，会自动出现红色线标识。' + #13 +
    '' + #13 +
    '6、折叠方法：' + #13 +
    '  光标置于含有begin的行，点击编辑区左面的灰色区域，即可实现折叠。';

  showhelp('函数折叠', s);
end;

procedure TForm1.Button9Click(Sender: TObject);
var i: Integer;
  ThisNode: TTreeNode;
begin
  if TreeView1.Items.count <= 0 then Exit;
  DoLockScreen('正在折叠中,请稍等');

  ThisNode := VisNode(SynMemo1.Carety - 1);
  for i := 0 to ThisNode.count - 1 do
    if ThisNode.Item[i].Expanded then
      ThisNode.Item[i].Expanded := False;

  //if thisnode.Expanded then thisnode.Expanded:=false;

  DoUnLockScreen;
end;

procedure TForm1.Button10Click(Sender: TObject);
var i: Integer;
  ThisNode: TTreeNode;
begin
  if TreeView1.Items.count <= 0 then Exit;
  DoLockScreen('正在折叠中,请稍等');

  ThisNode := VisNode(SynMemo1.Carety - 1);
  for i := 0 to ThisNode.count - 1 do
    if not ThisNode.Item[i].Expanded then
      ThisNode.Item[i].Expanded := true;

  //if thisnode.Expanded then thisnode.Expanded:=false;

  DoUnLockScreen;

end;

procedure TForm1.ShowSearchReplaceDialog(AReplace: Boolean);
var
  dlg: TTextSearchDialog;
begin
  //Statusbar.SimpleText := '';
  sBar1.Panels[1].Text := '';

  if AReplace then
    dlg := TTextReplaceDialog.Create(self)
  else
    dlg := TTextSearchDialog.Create(self);
  with dlg do
  try
    // assign search options
    SearchBackwards := gbSearchBackwards;
    SearchCaseSensitive := gbSearchCaseSensitive;
    SearchFromCursor := gbSearchFromCaret;
    SearchInSelectionOnly := gbSearchSelectionOnly;
    // start with last search text
    SearchText := gsSearchText;
    if gbSearchTextAtCaret then
    begin
      // if something is selected search for that text
      if SynMemo1.SelAvail and (SynMemo1.BlockBegin.Line = SynMemo1.BlockEnd.Line)
        then
        SearchText := SynMemo1.SelText
      else
        SearchText := SynMemo1.GetWordAtRowCol(SynMemo1.CaretXY);
    end;
    SearchTextHistory := gsSearchTextHistory;
    if AReplace then
      with dlg as TTextReplaceDialog do
      begin
        ReplaceText := gsReplaceText;
        ReplaceTextHistory := gsReplaceTextHistory;
      end;
    SearchWholeWords := gbSearchWholeWords;
    if ShowModal = mrOK then
    begin
      gbSearchBackwards := SearchBackwards;
      gbSearchCaseSensitive := SearchCaseSensitive;
      gbSearchFromCaret := SearchFromCursor;
      gbSearchSelectionOnly := SearchInSelectionOnly;
      gbSearchWholeWords := SearchWholeWords;
      gbSearchRegex := SearchRegularExpression;
      gsSearchText := SearchText;
      gsSearchTextHistory := SearchTextHistory;
      if AReplace then
        with dlg as TTextReplaceDialog do
        begin
          gsReplaceText := ReplaceText;
          gsReplaceTextHistory := ReplaceTextHistory;
        end;
      fSearchFromCaret := gbSearchFromCaret;
      if gsSearchText <> '' then
      begin
        DoSearchReplaceText(AReplace, gbSearchBackwards);
        fSearchFromCaret := true;
      end;
    end;
  finally
    dlg.Free;
  end;
end;

procedure TForm1.DoSearchReplaceText(AReplace: Boolean;
  ABackwards: Boolean);
var
  Options: TSynSearchOptions;
begin
  sBar1.Panels[1].Text := '';
  if AReplace then
    Options := [ssoPrompt, ssoReplace, ssoReplaceAll]
  else
    Options := [];
  if ABackwards then
    Include(Options, ssoBackwards);
  if gbSearchCaseSensitive then
    Include(Options, ssoMatchCase);
  if not fSearchFromCaret then
    Include(Options, ssoEntireScope);
  if gbSearchSelectionOnly then
    Include(Options, ssoSelectedOnly);
  if gbSearchWholeWords then
    Include(Options, ssoWholeWord);
  if gbSearchRegex then
    SynMemo1.SearchEngine := SynEditRegexSearch
  else
    SynMemo1.SearchEngine := SynEditSearch;
  if SynMemo1.SearchReplace(gsSearchText, gsReplaceText, Options) = 0 then
  begin
    MessageBeep(MB_ICONASTERISK);
    sBar1.Panels[1].Text := STextNotFound;
    if ssoBackwards in Options then
      SynMemo1.BlockEnd := SynMemo1.BlockBegin
    else
      SynMemo1.BlockBegin := SynMemo1.BlockEnd;
    SynMemo1.CaretXY := SynMemo1.BlockBegin;
  end;

  if ConfirmReplaceDialog <> nil then
    ConfirmReplaceDialog.Free;
end;

procedure TForm1.AcSearchExecute(Sender: TObject);
begin
  ShowSearchReplaceDialog(False); //查找
  //ShowSearchReplaceDialog(TRUE); //替换
end;

procedure TForm1.AcSearchNextExecute(Sender: TObject);
begin
  DoSearchReplaceText(False, False);
end;

procedure TForm1.AcSearchBackExecute(Sender: TObject);
begin
  DoSearchReplaceText(False, true);
end;

procedure TForm1.AcSearchNextUpdate(Sender: TObject);
begin
  (Sender as TAction).Enabled := gsSearchText <> '';
end;

procedure TForm1.AcSearchBackUpdate(Sender: TObject);
begin
  (Sender as TAction).Enabled := gsSearchText <> '';
end;

end.