Preserving negative/reverse string selection after updating TMemo text in Delphi? - delphi

In Delphi I'm having trouble preserving the SelStart and SelLength in a Memo that updates it text every 5 seconds when the selection is negative/reverse.
With negative/reverse selection I mean that I have started the selection somewhere and while holding shift pressed the left arrow key some times.
Code:
var
caret: TPoint;
sel_start, sel_length: Integer;
begin
sel_start := Memo1.SelStart; // = 5
sel_length := Memo1.SelLength; // = 10
caret := Memo1.CaretPos; // caret.x = 15
//'adi and bl' selected
caret.x := sel_start;
Memo1.Lines.Clear;
Memo1.Lines.Add('laditadi and blah blah');
Memo1.SelStart := sel_start;
Memo1.SelLength := sel_length;
Memo1.CaretPos := caret;
end;
The thing is that setting the SelLength seems to actually move the caret. And setting the caret after setting SelLength makes SelLength := 0;. Since the text keeps changing I can't use TMemo.SelText / TMemo.SetSelText before and after.
I can't find a way to preserve the caret pos...any clues?

If sel_start has the same value as characterposition of the Caret, selection will be reversed by setting selstart to selstart+sellength and setting sellength to -sellength.
procedure TForm1.Button1Click(Sender: TObject);
var
caret: TPoint;
sel_start, sel_length,CharFromPos: Integer;
begin
Memo1.SetFocus;
GetCaretPos(Caret);
CharFromPos := SendMessage(Memo1.Handle, EM_CHARFROMPOS, 0 ,Caret.Y*$FFFF + Caret.X) AND $FFFF;
sel_start := Memo1.SelStart; // = 5
sel_length := Memo1.SelLength; // = 10
Memo1.Lines.Clear;
Memo1.Lines.Add('laditadi and blah blah'#13#10'laditadi and blah blah');
if sel_start<>CharFromPos then
begin
Memo1.SelStart := sel_start;
Memo1.SelLength := sel_length;
end
else
begin
Memo1.SelStart := sel_start + sel_length;
Memo1.SelLength := - sel_length;
end;
end;
procedure TForm1.Timer1Timer(Sender: TObject);
var
p:Tpoint;
b:Boolean;
CharFromPos:Integer;
begin
b := GetCaretPos(p);
CharFromPos := SendMessage(Memo1.Handle, EM_CHARFROMPOS, 0 ,p.Y*$FFFF + p.X) AND $FFFF;
Caption := Format('SelStart %d CharFromPos %d',[Memo1.SelStart,CharFromPos])
end;

Related

ActionMainMenuBar and auto-hiding doubled separators

with TMainMenu we have AutoLineReduction property to hide doubled separators when menu item is hidden, how to do the same with ActionMainMenuBar and ActionManager?
I didn't find an internal method for this, but we can do it manually.
We have to add the OnPopup method to the ActionMainMenuBar:
procedure TFormMain.MenuBarPopup(Sender: TObject; Item: TCustomActionControl);
begin
// Make all separators visible
for var I := 0 to Item.ActionClient.Items.Count - 1 do begin
var Itm := Item.ActionClient.Items[I];
if (Itm.Caption = '-') then
Itm.Visible := True;
end;
// Hide doubled separators
for var I := 0 to Item.ActionClient.Items.Count - 1 do begin
var Itm := Item.ActionClient.Items[I];
if (Itm.Caption = '-') then begin // Search next separator
var bFound := False;
for var J := I + 1 to Item.ActionClient.Items.Count - 1 do begin
var Itm2 := Item.ActionClient.Items[J];
if Itm2.Visible then begin
bFound := (Itm2.Caption <> '-');
Break;
end;
end;
Itm.Visible := bFound;
end;
end;
end;
Is it very strange that this component does not contain such a property...

Dynamically created buttons with equal alignment

I am a newbie to this Delphi. I have been given an assignment that to create buttons dynamically. But the problem is that all buttons have to be aligned in a manner that it should fit inside the whole screen. i.e, if 10 buttons created the whole screen should be filled. Or if 9 is given 9 should be present and filled in the screen. Is it possible to do that? I tried and searched everywhere. But was helpless.
Please help me if its possible. A good example is also appreciated since I mentioned earlier I am really new to this. The code I did follows here.
procedure TfrmMovieList.PnlMovieClick(Sender: TObject);
begin
for i := 0 to 9 do
begin
B := TButton.Create(Self);
B.Caption := Format('Button %d', [i]);
B.Parent := Panel1;
B.Height := 23;
B.Width := 100;
B.Left := 10;
B.Top := 10 + i * 25;
end;
end;
This looks workable to me:
procedure TForm1.CreateButtons(aButtonsCount, aColCount: Integer; aDestParent: TWinControl);
var
rowCount, row, col, itemWidth, itemHeight: Integer;
item: TButton;
begin
if aColCount>aButtonsCount then
aColCount := aButtonsCount;
rowCount := Ceil(aButtonsCount / aColCount);
itemHeight := aDestParent.Height div rowCount;
itemWidth := aDestParent.Width div aColCount;
for row := 0 to rowCount-1 do begin
for col := 0 to aColCount-1 do begin
item := TButton.Create(Self);
item.Caption := Format('Button %d', [(row*aColCount)+col+1]);
item.Left := itemWidth*col;
item.Top := itemHeight*row;
item.Width := itemWidth;
item.Height := itemHeight;
item.Parent := aDestParent;
Dec(aButtonsCount);
if aButtonsCount=0 then
Break;
end; // for cols
end; // for rows
end;
An example of usage is:
procedure TForm1.Button1Click(Sender: TObject);
begin
CreateButtons(10, 4, Panel1);
end;
The function Ceil requires the uses of unit Math.
The method receives the count of buttons and the numbers of columns to calculate the number of rows. It also receives the destination parent where the buttons will be located.

Send OnClick command to all Dynamic TColorButtons on TabSheet

I'm working on a PingTool and I've got a TabSheet of dynamically created buttons(anywhere from 1-150 based on user input) and I would like to be able to pass the OnClick command to all buttons on the given TabSheet. My individual button clicks successfully run my ping code, but I get a EStackOverflow message when clicking my PingAll button. Any help would be greatly appreciated. Code Excerpt below:
Code used for button creation:
begin
For x := 0 to CheckListBox1.Items.Count -1 Do
Begin
If CheckListBox1.Checked[x]=true then
begin
GLCount := (GLCount +1);
theIP :=(CheckListBox1.Items.Strings[x]);
if GLcount < 10 then begin
B := TColorButton.Create(Self);
B.Name:= ('BTN'+intToStr(GLCount+1));
B.Caption := theIP;
B.Parent := TabSheet2;
B.Height := 25;
B.Width := 97;
B.Left := 0 + GLCount * 96;
B.Top := 8;
B.BackColor := clBtnFace;
B.ForeColor := clBtnText;
B.OnClick := CustomButtonClick;
end;
CustomButtonClick Code:
Procedure TForm1.CustomButtonClick(Sender: TObject);
begin
GlobalIP:=TColorButton(Sender).caption;
IdIcmpClient1.Host := GlobalIP;
IdIcmpClient1.ReceiveTimeout := 500;
IdIcmpClient1.Ping();
case IdIcmpClient1.ReplyStatus.ReplyStatusType of
rsEcho:
TColorButton(Sender).BackColor := clGreen;
rsTimeOut:
TColorButton(Sender).BackColor := clRed;
end;
end;
PingAll Code(not working):
procedure TForm1.PingAllClick(Sender: TObject);
var
i: integer;
begin
For i := 0 to TabSheet2.ControlCount -1 do
if TabSheet2.Controls[i] is TColorButton then
begin
TColorButton(Sender).Click;
end;
end;
You are calling recurcive the method PingAllClick... look that you call TColorButton(Sender).Click instead
....
Control := tabSheet2.Controls[i]
if Control is TColorButton then
TColorButton(Control ).Click()
....

Autosize a memo [duplicate]

This question already has answers here:
Closed 10 years ago.
Possible Duplicate:
Can I make a TMemo size itself to the text it contains?
Need to do autosize memo: height and width.
I autosize the height as follows:
function TForm1.AutoSizeMemoY(Memo: TMemo): word;
begin
Canvas.Font := Memo.Font;
Result := Canvas.TextExtent(Memo.Lines.Strings[0]).cy * Memo.Lines.Count +
Canvas.TextExtent(Memo.Lines.Strings[0]).cy;
end;
But I do not know how to do autosize the width. I have an idea: if the scrollbar is activated, then increase the width until it becomes inactive, but I do not know how to implement that.
Not the best solution but it works:
function GetTextWidth(F: TFont; s: string): integer;
var
l: TLabel;
begin
l := TLabel.Create(nil);
try
l.Font.Assign(F);
l.Caption := s;
l.AutoSize := True;
result := l.Width + 8;
finally
l.Free;
end;
end;
And add following code to the end of Memo1.Onchange event in this answer
LineInd := Memo1.Perform(EM_LINEFROMCHAR, Memo1.SelStart, 0);//focused Memo1 line Index
Wd := GetTextWidth(Memo1.Font, Memo1.Lines[LineInd]);
//MaxWidthLineInd = index of the line which has the largest width.
//Init value of MaxWidthLineInd = 0
if MaxWidthLineInd = LineInd then
Memo1.Width := Wd
else begin
if Wd > Memo1.Width then
begin
Memo1.Width := Wd;
MaxWidthLineInd := LineInd;
end;
end;

how to wordwrap the button text?

i have created dynamic button with code below, the button caption is too long so i have to change the size of the caption to fit the button width but the wordwrap seen to be not function at all.
var
Reg: TRegistry;
lstKey, lstSubKey : TStringList;
sKeyName, sSubKeyName : string;
i, j, iSize, iSize2, iTop, iSpace, iComp : integer;
begin
lstKey := TStringList.Create;
lstSubKey := TStringList.Create;
lstBtnName := TStringList.Create;
Reg := TRegIniFile.Create;
try
Reg.OpenKeyReadOnly('registryPath');
Reg.GetKeyNames(lstSubKey); // get registry key
Reg.CloseKey;
iSize := 5;
iSize2 := 5;
iTop := 5;
iSpace := 5;
if ScrollBox1.ControlCount > 0 then begin
for j := ScrollBox1.ControlCount - 1 downto 0 do begin
with ScrollBox1.Controls[j] AS TBitBtn do begin
Free;
end;
end;
end;
for i := 0 to lstSubKey.Count - 1 do begin
with TBitBtn.Create(self) do begin // create dynamic buttons
Parent := ScrollBox1;
Height := 50;
Width := 50;
if iSize > ((Width + iSpace) * 3) then begin //2nd row, 3 btns in 1 row
Left := iSize2;
iSize2 := iSize2 + Width + iSpace;
Top := iTop + Height + iSpace;
end else begin //1st row
Left := iSize;
iSize := iSize + Width + iSpace;
Top := iTop;
end;
Caption := lstSubKey.Strings[i];
WordWrap := TRUE;
end;
end;
finally
lstKey.Free;
lstSubKey.Free;
Reg.Free;
end;
end;
Using #13 in caption can split the caption string to next row.
eg. Caption := 'Stock ID : Bread ' + #13 + 'Price : RM1.00';
Works for me with a simple example of three lstSubKey entries:
'Short'
'Medium Length'
'Longer'
However, if I remove the space between "Medium" and "Length", and make the 2nd item:
'MediumLength'
Then it does not wrap, but this is to be expected because there is no word break in the string on which the string can be broken in order to be wrapped.

Resources