2

No meu projeto VCL, eu tenho um TMemo com o seguinte texto(| é cursor):

|                   |
|Hello world |      |
|                   |
|test               |
|                   |
|                   |

Quando eu pressiono Down button, o cursor move-se para aqui:

|                   |
|Hello world        |
||                  |
|test               |
|                   |
|                   |

O que eu preciso é que ele se mova para aqui:

|                   |
|Hello world        |
|            |      |
|test               |
|                   |
|                   |

O meu objectivo seria o memo ficar igual ao editor do delphi carregando na tecla para baixo e ele ir para a linha abaixo mas na mesma coluna. Existe alguma forma de fazer sem ser através do evento onKeyDown do memo?

6
  • Acredito que terá de ser programado o efeito que desejas. Como sugestão, ao ser pressionado o caractere #40 (seta para baixo), podes também por meio da função KeyBd_Event pressionar um número específico de caractere #32 (espaço). O fato é que para o cursor poder se posicionar em algum local, precisa existir algum caractere no local.
    – Andrey
    Commented 31/10/2016 às 12:02
  • @Andrey pois entendo o que dizes, e obrigado pela dica, no entanto gostava de saber se existe alguma forma mais de o fazer sem ser desta forma
    – Tmc
    Commented 31/10/2016 às 12:06
  • O que acontece ai, é que o Down no ´Memo´, vai passar o foco para um outro objeto. cada linha do ´Memo´ é um ´Line´ diferente. Commented 31/10/2016 às 12:57
  • @VictorZanella conhece alguma forma de evitar isso sem ser pelo keydown?
    – Tmc
    Commented 31/10/2016 às 13:00
  • @VictorZanella Não entendi o que você quis dizer... Ficou meio confuso seu comentário. Podes exemplificar?
    – Andrey
    Commented 31/10/2016 às 13:00

2 Respostas 2

4

Não aconselho você a fazer isso, porque é uma bela duma gambiarra. Mas se você quiser dar uma olhada segue o código:

unit Unit2;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Vcl.ExtCtrls;

type
  TForm2 = class(TForm)
    Memo1: TMemo;
    Timer1: TTimer;
    Button1: TButton;
    procedure Memo1KeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
    procedure Timer1Timer(Sender: TObject);
    procedure Button1Click(Sender: TObject);

  private

    function getBiggestLine(AMemo: TMemo): Integer;
    function getCurrentLine(AMemo: TMemo): Integer;
    function getCurrentColumn(AMemo: TMemo): Integer;
    function whiteSpaceCountToString(ASpaces: Integer): String;

    procedure MemoAdjustment(var AMemo: TMemo);

  public
    { Public declarations }
  end;

var
  Form2: TForm2;

implementation

{$R *.dfm}

procedure TForm2.Button1Click(Sender: TObject);
begin
  MemoAdjustment(Memo1);
end;

function TForm2.getBiggestLine(AMemo: TMemo): Integer;
var
  i: Integer;
  iCurrentLinesCount: Integer;
  iBiggestLinesCount: Integer;
begin
  iBiggestLinesCount := 0;

  for i := 0 to AMemo.Lines.Count - 1 do
  begin
    iCurrentLinesCount := Length(AMemo.Lines[i]);
    if (iCurrentLinesCount > iBiggestLinesCount) then
    begin
      iBiggestLinesCount := iCurrentLinesCount;
      Result             := iBiggestLinesCount;
    end;
  end;
end;

function TForm2.getCurrentColumn(AMemo: TMemo): Integer;
var
  Coordinate: TPoint;
Begin
  Coordinate := AMemo.CaretPos;
  Result     := Coordinate.X + 1;
End;

function TForm2.getCurrentLine(AMemo: TMemo): Integer;
var
  Coordinate: TPoint;
Begin
  Coordinate := AMemo.CaretPos;
  Result     := Coordinate.Y + 1;
End;

procedure TForm2.Memo1KeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
  if (Key = VK_RETURN) and (Memo1.Lines.Count > 0) then
    Timer1.Enabled := True;
end;

procedure TForm2.MemoAdjustment(var AMemo: TMemo);
var
  i: Integer;
  whiteSpaceCount: Integer;
  whiteSpaceToAdd: Integer;

  X, Y: Integer;
  Coordinate: TPoint;
begin
  X := getCurrentColumn(AMemo);
  Y := getCurrentLine(AMemo);

  whiteSpaceCount := getBiggestLine(Memo1);
  for i           := 0 to AMemo.Lines.Count - 1 do
  begin
    whiteSpaceToAdd := whiteSpaceCount - Length(trim(AMemo.Lines[i]));
    AMemo.Lines[i]  := trim(AMemo.Lines[i]) + whiteSpaceCountToString(whiteSpaceToAdd);
  end;

  Coordinate.X := X -1;
  Coordinate.Y := Y -1;

  AMemo.CaretPos := Coordinate;
end;

procedure TForm2.Timer1Timer(Sender: TObject);
begin
  Timer1.Enabled := False;
  MemoAdjustment(Memo1);
end; 

function TForm2.whiteSpaceCountToString(ASpaces: Integer): String;
var
  i: Integer;
begin
  Result   := '';
  for i    := 1 to ASpaces do
    Result := Result + '-';
end;

end.

Outra hora vou dar uma melhorada nele, mas por hora é isso. Qualquer duvida pergunte.

PS.: Para funcionar corretamente, é necessário mudar a fonte do TMemo para uma fonte onde todos os caracteres tenham o mesmo tamanho. Ex: "Lucida Console".

Edit1: Adicionado método MemoAdjustment.

Edit2: Mudei um pouco a Lógica, e fiz alguns ajustes baseado nos testes o TMC

Edit3: Adicionado método para voltar o foco para a posição inicial no memo.

8
  • 1
    Discordo de você pela parte da "Gambiarra" como o componente não possui esse comportamento, é natural implementá-lo, caberia criar uma propriedade para ficar Top (favoritei para adicionar minha lista de casa). Outra coisa, a função whiteSpaceCountToStringé dispensável ali, pode passar '' que funciona perfeitamente. +1 pela Ótima Resposta! Commented 31/10/2016 às 17:57
  • Obrigado @JúniorMoreira. Tenho um certo receio de mexer com esse tipo de coisa, pois é difícil ter controle absoluto. Quanto ao whiteSpaceCountToString, acredito que seja necessário pois é ele quem vai converter o Length do maior linha do memo, em espaços em branco. Você cosneguiu remover o método whiteSpaceCountToString ? Commented 31/10/2016 às 19:53
  • Sim, removi ele passei como parâmetro ''diretamente, funciona normalmente. Commented 1/11/2016 às 17:48
  • @Tmc, implementei um novo método, ve se com ele funciona para voce. Commented 3/11/2016 às 12:46
  • @VictorZanella como pode ver abaixo eu subtituindo o ' ' (espaço) por um caracter '-' mostra onde são criados os espaços em branco e demontra que ainda tem algumas falhas, o que me aconselha? dfsdfsdfsdfsdf sdfsdfsdfsddfsfsdfsdf-------------- sdffffffffffffffffsdfsdfsdf------------------------------------------------------------------------------- sdfffffffffffffffsdfsdfs----------- sdfsdsfdsfsddddddddddddd------------------------------------------------------------------------------- fffffffffffffsfsdsdf--------------------------- -----------------------------------------------------
    – Tmc
    Commented 3/11/2016 às 13:00
0

Com a ajuda do @VictorZanella e da sua resposta desenvolvi o Projecto ainda não esta a 100%, mas já faz o que desejava, quando terminar eu actualizo:

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, ExtCtrls;

type
  TForm1 = class(TForm)
    Memo1: TMemo;
    procedure Memo1KeyPress(Sender: TObject; var Key: Char);
    procedure Memo1KeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);
  private
    function GetCurrentLine(AMemo: TMemo): Integer;
    function whiteSpaceCount(ASpaces: Integer): String;
    function GetMaxCharacter(AMemo: TMemo): Integer;
    procedure CleanWhiteSpace(var AMemo: TMemo);
    procedure CreateWhiteSpace(var AMemo: TMemo);
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

function TForm1.GetCurrentLine(AMemo: TMemo): Integer;
Var Coordinate: TPoint;
Begin
  Coordinate := AMemo.CaretPos;
  Result := Coordinate.Y + 1;
End;   

function TForm1.GetMaxCharacter(AMemo: TMemo): Integer;
Var MaxChar: Integer;
Begin
  MaxChar := (AMemo.Width div 7) - 1; //feito para font_name := "courier new"; size := "8"

  Result := MaxChar;
End;

function TForm1.WhiteSpaceCount(ASpaces: Integer): String;
var i: Integer;
begin
  Result := '';
  for i := 1 to ASpaces do Result := Result + ' ';
end;

procedure TForm1.Memo1KeyPress(Sender: TObject; var Key: Char);
var ILine, WSCount, WSAdd: Integer;
begin
  CleanWhiteSpace(Memo1); 

  if Key = #13 then 
    Begin
      ILine := GetCurrentLine(Memo1) - 1;

      WSCount := GetMaxCharacter(Memo1);
      WSAdd := WSCount - Length(Memo1.Lines[ILine]);

      Memo1.Lines[ILine] := Memo1.Lines[ILine] + WhiteSpaceCount(WSAdd);
    End; 
end;

procedure TForm1.Memo1KeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
  CreateWhiteSpace(Memo1);
end;

procedure TForm1.CreateWhiteSpace(AMemo: TMemo);
var ILine, ILine2, PColuna, WSAdd, WSCount: Integer;
Begin
  ILine2 := GetCurrentLine(AMemo);
  PColuna := Amemo.SelStart - Perform(EM_LINEINDEX, ILine2, 0);
    ILine := GetCurrentLine(AMemo) - 1;

    WSCount := GetMaxCharacter(AMemo);
    WSAdd := WSCount - Length(AMemo.Lines[ILine]);

    AMemo.Lines[ILine] := AMemo.Lines[ILine] + WhiteSpaceCount(WSAdd);
  Amemo.SelStart := Perform(EM_LINEINDEX, ILine2, 0) + PColuna;
End;

procedure TForm1.CleanWhiteSpace(var AMemo: TMemo);
var ILine, PColuna: Integer;
    SLine, CLine: String;
begin
  ILine := GetCurrentLine(AMemo);

  SLine := AMemo.Lines.Strings[ILine - 1];
  SLine := Copy(SLine, GetMaxCharacter(AMemo)-2, 2);

  if SLine = '  ' then
    Begin
      PColuna := AMemo.SelStart - Perform(EM_LINEINDEX, ILine, 0);

        CLine := AMemo.lines[ILine - 1];
        CLine := copy(CLine, 1, Length(CLine) - 1);
        AMemo.lines[ILine - 1] := CLine;

      AMemo.SelStart := Perform(EM_LINEINDEX, ILine, 0) + PColuna;
    End;
end;

UPDATE 1

Correção da tecla enter, antes saltava linhas ou não avançava.

Você deve fazer log-in para responder a esta pergunta.

Esta não é a resposta que você está procurando? Pesquise outras perguntas com a tag .