i want to find the height that needs the TRichEdit control to render itself without showing the vertical scrollbar.
I use this code
function RichEditHeight(var RE : TRichEdit; aForm : TForm) : integer;
var fmtRange: TFormatRange;
begin
FillChar(fmtRange, SizeOf(fmtRange), 0);
with fmtRange do begin
hDC := aForm.canvas.Handle;
hdcTarget := hDC;
rc.left := 0;
rc.right := (RE.ClientWidth * 1440) div screen.pixelsPerInch;
rc.top := 0;
rc.Bottom := MaxInt;
rcPage := rc;
chrg.cpMin := 0;
chrg.cpMax := -1;
end;
RE.Perform(EM_FORMATRANGE, 0, Longint(#fmtRange));
result := round(fmtRange.rc.Bottom*screen.pixelsPerInch/1440);
RE.Perform(EM_FORMATRANGE, 0, 0);
end;
When the document has a few pages (<15 A4 portrait) the result is sufficient.
But with more pages, the rc.bottom seems to be trancated and the control needs the vertical scrollbar.
The question is : there are some limitations inside perform's code ?
If i increase the rc.bottom manually (approximately) then the control renders itself ok but this isn't the case i want.
PS. if matters, the richedit component, actually is a TjvRichEdit one.
Here is a minimal program that can reproduce the problem (for even 2 pages)
unit Unit32;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Vcl.ComCtrls, winAPI.richedit, JvExStdCtrls, JvRichEdit, Vcl.ExtCtrls;
type
TForm32 = class(TForm)
ScrollBox1: TScrollBox;
Button1: TButton;
RichEdit1: TJvRichEdit;
panel1: TPanel;
OpenDialog1: TOpenDialog;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var Form32: TForm32;
implementation
{$R *.dfm}
function RichEditHeight(var RE : TjvRichEdit; aForm : TForm) : integer;
var fmtRange: TFormatRange;
begin
FillChar(fmtRange, SizeOf(fmtRange), 0);
with fmtRange do begin
hDC := aForm.canvas.Handle;
hdcTarget := hDC;
rc.left := 0;
rc.right := (RE.ClientWidth * 1440) div screen.pixelsPerInch;
rc.top := 0;
rc.Bottom := 500000;
rcPage := rc;
chrg.cpMin := 0;
chrg.cpMax := -1;
end;
RE.Perform(EM_FORMATRANGE, 0, Longint(#fmtRange));
result := round(fmtRange.rc.Bottom*screen.pixelsPerInch/1440);
RE.Perform(EM_FORMATRANGE, 0, 0);
end;
procedure TForm32.Button1Click(Sender: TObject);
begin
with OpenDialog1 do
if execute then begin
RichEdit1.lines.LoadFromFile(filename);
panel1.height := RichEditHeight(RichEdit1,Form32);
end;
end;
end.
The form
object Form32: TForm32
Left = 0
Top = 0
Caption = 'Form32'
ClientHeight = 615
ClientWidth = 874
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'Tahoma'
Font.Style = []
OldCreateOrder = False
PixelsPerInch = 96
TextHeight = 13
object ScrollBox1: TScrollBox
Left = 0
Top = 0
Width = 874
Height = 615
Align = alClient
TabOrder = 0
ExplicitWidth = 885
ExplicitHeight = 583
object Button1: TButton
Left = 632
Top = 24
Width = 75
Height = 25
Caption = 'Button1'
TabOrder = 0
OnClick = Button1Click
end
object panel1: TPanel
Left = 0
Top = 0
Width = 457
Height = 561
Caption = 'panel1'
TabOrder = 1
object RichEdit1: TJvRichEdit
Left = 1
Top = 1
Width = 455
Height = 559
Align = alClient
Font.Charset = GREEK_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'Tahoma'
Font.Style = []
ParentFont = False
ScrollBars = ssVertical
SelText = ''
TabOrder = 0
ExplicitHeight = 279
end
end
end
object OpenDialog1: TOpenDialog
Left = 656
Top = 88
end
end
and the result with a RTF document (just 2 pages)
Finally, the solution was very simple!
TRichedit has the event onResizeRequest where the actual height of the control is given by the rect parameter
Related
I hate the title of this question. Anyway:
If you call TForm.Show with a custom theme (Windows10 Dark in this case), then close that form, then change the theme to the system Windows theme, then change back to the Windows10 Dark theme, and finally call TForm.Show on that form again, the border renders incorrectly and certain controls do not render properly, like a TComboBox.
I have a test project below, and a "fix" of sorts. But I do not like my fix and the reason for this question is that I do not really understand what is happening here that causes the form to render incorrectly only if it was hidden while the theme changed, and only if the theme is changed away from, and then back to, Windows10 Dark.
My fix is to track the theme change. If the condition I describe above occurs, I intercept the CM_SHOWINGCHANGED message, ignore it, then force the window to be recreated and then process the inherited CM_SHOWINGCHANGED the next time around. It is a very brittle fix and obviously not the way to go, so I am hoping someone can show me what is actually happening so I can fix it "for real."
Incidentally, I have submitted this as a bug to Embarcadero already. https://quality.embarcadero.com/browse/RSP-33977
Here is the test code. You'll need to add Windows10 Dark to the application's styles, obviously.
unit Unit22;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Vcl.ExtCtrls, Unit23, Vcl.Themes;
type
TForm22 = class(TForm)
Panel1: TPanel;
ComboBox1: TComboBox;
RadioGroup1: TRadioGroup;
ButtonShow: TButton;
Memo1: TMemo;
procedure ButtonShowClick(Sender: TObject);
procedure RadioGroup1Click(Sender: TObject);
procedure FormShow(Sender: TObject);
private
{ Private declarations }
FAllowChange: Boolean;
public
{ Public declarations }
end;
var
Form22: TForm22;
implementation
{$R *.dfm}
procedure TForm22.ButtonShowClick(Sender: TObject);
begin
Form23.Show;
end;
procedure TForm22.FormShow(Sender: TObject);
begin
if StyleServices.Name = 'Windows10 Dark' then
RadioGroup1.ItemIndex := 1
else
RadioGroup1.ItemIndex := 0;
FAllowChange := True;
end;
procedure TForm22.RadioGroup1Click(Sender: TObject);
begin
if not FAllowChange then
exit;
if RadioGroup1.ItemIndex = 0 then
TStyleManager.SetStyle('Windows');
if RadioGroup1.ItemIndex = 1 then
TStyleManager.SetStyle('Windows10 Dark');
end;
end.
Unit 22 DPR:
object Form22: TForm22
Left = 0
Top = 0
ActiveControl = Memo1
Caption = 'Form22'
ClientHeight = 305
ClientWidth = 511
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'Tahoma'
Font.Style = []
OldCreateOrder = False
OnShow = FormShow
PixelsPerInch = 96
TextHeight = 13
object Panel1: TPanel
Left = 0
Top = 0
Width = 511
Height = 305
Align = alClient
BevelEdges = []
BevelOuter = bvNone
Caption = 'Panel1'
ShowCaption = False
TabOrder = 0
object ComboBox1: TComboBox
Left = 16
Top = 8
Width = 145
Height = 21
Style = csDropDownList
ItemIndex = 0
TabOrder = 0
Text = 'one'
Items.Strings = (
'one'
'two'
'three')
end
object RadioGroup1: TRadioGroup
Left = 16
Top = 48
Width = 185
Height = 105
Caption = 'RadioGroup1'
Items.Strings = (
'windows'
'dark')
TabOrder = 1
OnClick = RadioGroup1Click
end
object ButtonShow: TButton
Left = 16
Top = 159
Width = 75
Height = 25
Caption = 'ButtonShow'
TabOrder = 2
OnClick = ButtonShowClick
end
object Memo1: TMemo
Left = 207
Top = 8
Width = 274
Height = 281
Lines.Strings = (
'Always start in dark.'
''
'Steps to reproduce:'
'1.'#9'Click ButtonShow.'
'2.'#9'Close the window that opened.'
'3.'#9'Click Windows (change to system them).'
'4.'#9'Click Dark (change back to dark VCL style).'
'5.'#9'Click ButtonShow again. The controls are '
'not properly painted. Combobox text is black and form '
'is wrong until resize.'
''
'Hacky fix:'
'1.'#9'Click ButtonShow.'
'2.'#9'Check the '#8220'Fix'#8221' button in the window that '
'opened, then close it.'
'3.'#9'Click Windows (change to system)'
'4.'#9'Click Dark (change back to vcl dark)'
'5.'#9'Click ButtonShow. See comments in source.'
'')
ReadOnly = True
TabOrder = 3
end
end
end
Unit23:
unit Unit23;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Vcl.ExtCtrls, Vcl.Themes;
type
TForm23 = class(TForm)
Panel1: TPanel;
ComboBox1: TComboBox;
ComboBox2: TComboBox;
ComboBox3: TComboBox;
Button1: TButton;
CheckBox1: TCheckBox;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
FFixing: Boolean;
FNeedFix: String;
FShowedStyle: String;
protected
procedure DoShow; override;
public
{ Public declarations }
procedure CMStyleChanged(var Message: TMessage); message CM_STYLECHANGED;
procedure CMShowingChanged(var Message: TMessage); message CM_SHOWINGCHANGED;
end;
var
Form23: TForm23;
implementation
{$R *.dfm}
procedure TForm23.Button1Click(Sender: TObject);
begin
PostMessage(Handle, CM_RECREATEWND, 0, 0);
end;
procedure TForm23.CMShowingChanged(var Message: TMessage);
var
DoFix: Boolean;
begin
if not Showing then
inherited
else
begin
// if the theme changed away from dark, then back to dark, while we were
// not visible, then we need to force the window to be recreated again
// before showing.
// This is a really bad hack but basically I am just preventing the
// normal response to CMShowingChanged and then setting up a message
// queue that will recreate the window and then process the CM_SHOWINGCHANGED
// message again. This will probably break the universe but it appears to work
// in this test.
FShowedStyle := StyleServices.Name;
Panel1.Caption := FShowedStyle;
DoFix := not FFixing and (FNeedFix <> '') and (FNeedFix = FShowedStyle);
FNeedFix := '';
if DoFix and CheckBox1.Checked then
begin
FFixing := True;
// SendMessage(Handle, WM_SETREDRAW, Winapi.Windows.WPARAM(LongBool(False)), 0);
PostMessage(Handle, CM_RECREATEWND, 0, 0);
// PostMessage(Handle, CM_SHOWINGCHANGED, Message.WParam, Message.LParam);
// do not allow inherited.
end else
begin
FFixing := False;
inherited;
end;
end;
end;
procedure TForm23.CMStyleChanged(var Message: TMessage);
begin
FNeedFix := FShowedStyle;
inherited;
end;
procedure TForm23.DoShow;
var
DoFix: Boolean;
begin
inherited;
exit;
end;
end.
Unit23 DPR:
object Form23: TForm23
Left = 0
Top = 0
Caption = 'Form23'
ClientHeight = 253
ClientWidth = 360
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'Tahoma'
Font.Style = []
OldCreateOrder = False
PixelsPerInch = 96
TextHeight = 13
object Panel1: TPanel
Left = 0
Top = 0
Width = 360
Height = 253
Align = alClient
Alignment = taRightJustify
BevelEdges = []
BevelOuter = bvNone
Caption = 'Panel1'
TabOrder = 0
object ComboBox1: TComboBox
Left = 16
Top = 32
Width = 145
Height = 21
Style = csDropDownList
ItemIndex = 0
TabOrder = 0
Text = 'one'
Items.Strings = (
'one'
'two'
'three')
end
object ComboBox2: TComboBox
Left = 16
Top = 59
Width = 145
Height = 21
Style = csDropDownList
ItemIndex = 1
TabOrder = 1
Text = 'two'
Items.Strings = (
'one'
'two'
'three')
end
object ComboBox3: TComboBox
Left = 16
Top = 86
Width = 145
Height = 21
Style = csDropDownList
ItemIndex = 2
TabOrder = 2
Text = 'three'
Items.Strings = (
'one'
'two'
'three')
end
object Button1: TButton
Left = 16
Top = 136
Width = 75
Height = 25
Caption = 'RecreateWnd'
TabOrder = 3
OnClick = Button1Click
end
object CheckBox1: TCheckBox
Left = 16
Top = 167
Width = 273
Height = 17
Caption = 'Fix with CM_SHOWINGCHANGED hack'
TabOrder = 4
end
end
end
I'm using the DrawTextRotatedB function from Josef Švejk's excellent answer to the question How to draw text in a canvas vertical + horizontal with Delphi 10.2
to draw text vertically on a TPanel (full code below, Win 32 program).
This is done in a message handler (message WM_DRAWTEXT). The PostMessage call is in the FormResize (which in the real program does a lot more).
Issue:
FormResize is called from FormShow, all relevant code is executed, but the vertical text does not show.
If I then resize the form, the same code gets executed again and it is visible.
How can this be, and how to fix it?
Structure view of form components (drawing on PnlLeftLeft):
Full test code below. Note that this logs to a text file specified by the cLogFileName constant at the top. This log contains (initial resize + one subsequent resize).
FormShow start
FormShow end
FormResize start
PostMessage left sent
FormResize end
RedrawMessage left: test text
(X,Y): (51,284)
RedrawMessage ends
FormResize start
PostMessage left sent
FormResize end
RedrawMessage left: test text
(X,Y): (51,285)
RedrawMessage ends
uFrmTest.Pas
unit uFrmTest;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.Imaging.pngimage, Vcl.ExtCtrls, System.UITypes;
const
WM_DRAWTEXT = WM_USER + 100;
cLogFileName = 'd:\temp\log.lst';
type
TFrmTest = class(TForm)
PnlClient: TPanel;
PnlLeft: TPanel;
PnlRight: TPanel;
PnlLeftLeft: TPanel;
procedure FormShow(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormResize(Sender: TObject);
private
FTextFile: TextFile; // Debugging do cLogFileName
procedure RedrawMessage(var Msg: TMessage); message WM_DRAWTEXT;
public
end;
var
FrmTest: TFrmTest;
implementation
{$R *.dfm}
procedure DrawTextRotated(ACanvas: TCanvas; Angle, X, Y: Integer; AText: String);
// DrawTextRotatedB from https://stackoverflow.com/a/52923681/512728
var
Escapement: Integer;
LogFont: TLogFont;
NewFontHandle: HFONT;
OldFontHandle: HFONT;
begin
if not Assigned(ACanvas) then
Exit;
// Get handle of font and prepare escapement
GetObject(ACanvas.Font.Handle, SizeOf(LogFont), #LogFont);
while Angle > 360 do Angle := Angle - 360;
while Angle < -360 do Angle := Angle + 360;
Escapement := Angle * 10;
// We must initialise all fields of the record structure
LogFont.lfWidth := 0;
LogFont.lfHeight := ACanvas.Font.Height;
LogFont.lfEscapement := Escapement;
LogFont.lfOrientation := 0;
if fsBold in ACanvas.Font.Style then
LogFont.lfWeight := FW_BOLD
else
LogFont.lfWeight := FW_NORMAL;
LogFont.lfItalic := Byte(fsItalic in ACanvas.Font.Style);
LogFont.lfUnderline := Byte(fsUnderline in ACanvas.Font.Style);
LogFont.lfStrikeOut := Byte(fsStrikeOut in ACanvas.Font.Style);
LogFont.lfCharSet := ACanvas.Font.Charset;
LogFont.lfOutPrecision := OUT_DEFAULT_PRECIS;
LogFont.lfClipPrecision := CLIP_DEFAULT_PRECIS;
LogFont.lfQuality := DEFAULT_QUALITY;
LogFont.lfPitchAndFamily := DEFAULT_PITCH;
StrPCopy(LogFont.lfFaceName, ACanvas.Font.Name);
// Create new font with rotation
NewFontHandle := CreateFontIndirect(LogFont);
try
// Select the new font into the canvas
OldFontHandle := SelectObject(ACanvas.Handle, NewFontHandle);
try
// Output result
ACanvas.Brush.Style := VCL.Graphics.bsClear;
try
ACanvas.TextOut(X, Y, AText);
finally
ACanvas.Brush.Style := VCL.Graphics.bsSolid;
end;
finally
// Restore font handle
NewFontHandle := SelectObject(ACanvas.Handle, OldFontHandle);
end;
finally
// Delete the deselected font object
DeleteObject(NewFontHandle);
end;
end;
procedure TFrmTest.FormCreate(Sender: TObject);
begin
AssignFile(FTextFile,cLogFileName);
Rewrite(FTextFile);
end;
procedure TFrmTest.FormDestroy(Sender: TObject);
begin
CloseFile(FTextFile);
end;
procedure TFrmTest.FormResize(Sender: TObject);
begin
WriteLn(FTextFile,'FormResize start');
PostMessage(Handle,WM_DRAWTEXT,0,0);
WriteLn(FTextFile,'PostMessage left sent');
WriteLn(FTextFile,'FormResize end');
end;
procedure TFrmTest.FormShow(Sender: TObject);
begin
WriteLn(FTextFile,'FormShow start');
WriteLn(FTextFile,'FormShow end');
end;
type
THackPanel = class(TPanel);
procedure TFrmTest.RedrawMessage(var Msg: TMessage);
const cLeftVertText = 'test text';
var lHorDrawOffset, lVertDrawOffset: Integer;
begin
WriteLn(FTextFile,'RedrawMessage left: ' + cLeftVertText);
THackPanel(PnlLeftLeft).Canvas.Font := PnlLeftLeft.Font;
lVertDrawOffset := (PnlLeftLeft.Height - THackPanel(PnlLeftLeft).Canvas.TextHeight(cLeftVertText)) DIV 2;
lHorDrawOffset := (PnlLeftLeft.Width - THackPanel(PnlLeftLeft).Canvas.TextWidth(cLeftVertText)) DIV 2;
DrawTextRotated(THackPanel(PnlLeftLeft).Canvas , 90, lHorDrawOffset, lVertDrawOffset, cLeftVertText);
WriteLn(FTextFile,Format('(X,Y): (%d,%d)',[lHorDrawOffset,lVertDrawOffset]));
WriteLn(FTextFile,'RedrawMessage ends');
WriteLn(FTextFile,'');
end;
end.
uFrmTest.dfm
object FrmTest: TFrmTest
Left = 0
Top = 0
Caption = 'FrmTest'
ClientHeight = 592
ClientWidth = 905
Color = clWhite
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'Tahoma'
Font.Style = []
OldCreateOrder = False
OnCreate = FormCreate
OnDestroy = FormDestroy
OnResize = FormResize
OnShow = FormShow
PixelsPerInch = 96
TextHeight = 13
object PnlClient: TPanel
Left = 0
Top = 0
Width = 905
Height = 592
Align = alClient
BevelOuter = bvNone
ParentColor = True
TabOrder = 0
ExplicitLeft = 88
ExplicitTop = 8
object PnlLeft: TPanel
AlignWithMargins = True
Left = 20
Top = 10
Width = 367
Height = 582
Margins.Left = 20
Margins.Top = 10
Margins.Right = 20
Margins.Bottom = 0
Align = alLeft
BevelOuter = bvNone
ParentColor = True
TabOrder = 0
object PnlLeftLeft: TPanel
Tag = -20
Left = 0
Top = 0
Width = 145
Height = 582
Align = alLeft
BevelOuter = bvNone
ParentColor = True
TabOrder = 0
end
end
object PnlRight: TPanel
AlignWithMargins = True
Left = 427
Top = 10
Width = 458
Height = 582
Margins.Left = 20
Margins.Top = 10
Margins.Right = 20
Margins.Bottom = 0
Align = alClient
BevelOuter = bvNone
TabOrder = 1
end
end
end
I'm using windows 10 theme in my project, and i've have noticed that: Panels that are positioned on edges of grids, they're shown under the grid scrollbar,
like this image:
I haven't changed any behavior of the VCL, or the grid or scroll behavior.
pas file:
unit Unit1;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Data.DB, Vcl.StdCtrls,
Datasnap.DBClient, Vcl.Grids, Vcl.DBGrids, Vcl.ExtCtrls;
type
TForm1 = class(TForm)
Panel1: TPanel;
DbGrid: TDBGrid;
Panel2: TPanel;
ClientDataSet: TClientDataSet;
DataSource1: TDataSource;
ButtonAdd: TButton;
ShowPanel: TButton;
ClientDataSetname: TStringField;
ClientDataSetaddress: TStringField;
procedure ButtonAddClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure ShowPanelClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.ButtonAddClick(Sender: TObject);
begin
ClientDataset.Append;
ClientDataSetname.AsString := 'Test name';
ClientDataSetaddress.AsString := 'Test address';
ClientDataset.Insert;
end;
procedure TForm1.ShowPanelClick(Sender: TObject);
begin
if Panel2.Visible then
Panel2.Visible := False
else
Panel2.Visible := True;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
ClientDataset.CreateDataSet;
end;
end.
dfm file:
object Form1: TForm1
Left = 0
Top = 0
Caption = 'Form1'
ClientHeight = 201
ClientWidth = 555
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'Tahoma'
Font.Style = []
OldCreateOrder = False
OnCreate = FormCreate
PixelsPerInch = 96
TextHeight = 13
object Panel1: TPanel
Left = 460
Top = 0
Width = 95
Height = 201
Align = alRight
TabOrder = 0
object ButtonAdd: TButton
Left = 10
Top = 16
Width = 75
Height = 25
Caption = 'ButtonAdd'
TabOrder = 0
OnClick = ButtonAddClick
end
object ShowPanel: TButton
Left = 10
Top = 47
Width = 75
Height = 25
Caption = 'ShowPanel'
TabOrder = 1
OnClick = ShowPanelClick
end
end
object DbGrid: TDBGrid
Left = 0
Top = 0
Width = 460
Height = 201
Align = alClient
DataSource = DataSource1
TabOrder = 1
TitleFont.Charset = DEFAULT_CHARSET
TitleFont.Color = clWindowText
TitleFont.Height = -11
TitleFont.Name = 'Tahoma'
TitleFont.Style = []
Columns = <
item
Expanded = False
FieldName = 'name'
Visible = True
end
item
Expanded = False
FieldName = 'address'
Visible = True
end>
end
object Panel2: TPanel
Left = 0
Top = 160
Width = 185
Height = 41
Caption = 'panel2'
TabOrder = 2
Visible = False
end
object ClientDataSet: TClientDataSet
Aggregates = <>
Params = <>
Left = 216
Top = 104
object ClientDataSetname: TStringField
FieldName = 'name'
Size = 50
end
object ClientDataSetaddress: TStringField
FieldName = 'address'
Size = 50
end
end
object DataSource1: TDataSource
DataSet = ClientDataSet
Left = 152
Top = 88
end
end
The bug happens after second click on ShowPanel.
You can Define DBgrid as parent of your panel.
procedure TForm1.FormShow(Sender: TObject);
begin
panel1.Parent := dbgrid1;
panel1.align := alBottom;
end;
I've found a way to "solve" this problem just changing grid seBorder to false, i used Notepad++ to locate in all project for ": TDBGrid"¹ and replace to ": TDBGrid StyleElements = [seFont, seClient]"¹. Isn't the better way to solve this problem i think, because changing seBorder to false will make the scrollbars style looks like the scrolls of your windows version.
¹ Ignore the quotes when you try to do it.
In fact, the only way is to work with the parent of the DBgrid.
This example work fine for me :
procedure TForm1.adjustPanelTo(const aPanel: TPanel; aWcontrol: TWinControl);
begin
if aPanel = nil then Exit;
if aWcontrol = nil then Exit;
if aWcontrol.Parent = nil then Exit;
aPanel.Parent := aWcontrol.Parent;
aPanel.Anchors := [akLeft, akTop];
aPanel.Left := aWcontrol.Left + 1;
aPanel.Top := aWcontrol.Top + aWcontrol.ClientHeight - aPanel.Height;
aPanel.BringToFront;
end;
procedure TForm1.FormShow(Sender: TObject);
begin
adjustPanelTo(Panel1, DBGrid1);
end;
In my (XE2) IDE I constantly have to switch the settings for Project Options/ Debugger / Parameters because I'm testing for different client configurations, databases etc.
The Parameters dropdown list is becoming unmanageable. Since these have no descriptions either, it's even hard to figure out which ones to remove (How can I clean the Parameters field in the Run -> Parameters menu?).
Any smart ideas on managing these?
In an ideal word I would like to give them a tag/description, reorder them, delete some...
Not ideal but a workaround would be to add a redundant tag parameter as first parameter.
That way at least, when you use the dropdown list, you'll have some indication on what parameter combination you are using.
In addition to Lievens answer I'm adding an answer to my own question.
I have started using [identifier] at the beginning of the run-time parameter, and I can put in there what I want. In addition I have written a small app that lets me clean up the parameters that are stored in the registry (at HKEY_CURRENT_USER\Software\Embarcadero\BDS\9.0\History Lists\hlRunParameters).
Here is the code for that Win32 app. It will let you delete and sort the registry values. It is written in Delphi XE2. Just create a new VCL project and use this as the main form.
uCleanIDEParams.pas
unit uCleanIDEParams;
// https://stackoverflow.com/questions/27502689/how-to-manage-constantly-changing-project-run-time-parameters-in-the-ide
// All 32 bit stuff, the Delphi IDE is 32 bit too
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Vcl.CheckLst, Registry,
Vcl.ExtCtrls;
type
TFrmCleanIDEParams = class(TForm)
PnlTop: TPanel;
BtnLoad: TButton;
EdtRegKey: TEdit;
Label1: TLabel;
ChkRedundant: TCheckBox;
PnlBottom: TPanel;
GBxSelection: TGroupBox;
BtnSelectAll: TButton;
BtnSelectNone: TButton;
BtnStartWith: TButton;
ChkNot: TCheckBox;
EdtStartWith: TEdit;
BtnInvert: TButton;
Label2: TLabel;
BtnWrite: TButton;
ChkSort: TCheckBox;
PnlCenter: TPanel;
CLBParams: TCheckListBox;
procedure BtnLoadClick(Sender: TObject);
procedure BtnSelectAllClick(Sender: TObject);
procedure BtnSelectNoneClick(Sender: TObject);
procedure BtnInvertClick(Sender: TObject);
procedure BtnStartWithClick(Sender: TObject);
procedure BtnWriteClick(Sender: TObject);
private
public
end;
var
FrmCleanIDEParams: TFrmCleanIDEParams;
implementation
{$R *.dfm}
procedure TFrmCleanIDEParams.BtnInvertClick(Sender: TObject);
var i: integer;
begin
for i := 0 to CLBParams.Items.Count-1 do CLBParams.Checked[i] := not CLBParams.Checked[i];
end;
procedure TFrmCleanIDEParams.BtnLoadClick(Sender: TObject);
var
lReg : TRegistry;
lValue,
lItem,
lKey : String;
i,
lNrRegVals: Integer;
begin
lKey := Trim(EdtRegKey.Text);
if lKey = '' then Exit;
if lKey[1] = '\' then lKey := Copy(lKey,2);
lReg := TRegistry.Create(KEY_READ);
lReg.RootKey := HKEY_CURRENT_USER;
if not lReg.OpenKey(lKey,false) then
begin
MessageDlg('Key not found', mtError, mbOKCancel, 0);
Exit;
end;
if not lReg.ValueExists('Count') then
begin
MessageDlg('Value ''Count'' not found', mtError, mbOKCancel, 0);
Exit;
end;
lNrRegVals := lReg.ReadInteger('Count');
for i := 0 to lNrRegVals-1 do
begin
lValue := 'Item' + IntToStr(i);
if lReg.ValueExists(lValue) then
begin
lItem := lReg.ReadString(lValue);
if ChkRedundant.Checked then
lItem := Trim(StringReplace(lItem,' ',' ',[rfReplaceAll]));
CLBParams.Items.Add(lItem);
end;
end;
end;
procedure TFrmCleanIDEParams.BtnSelectAllClick(Sender: TObject);
var i: integer;
begin
for i := 0 to CLBParams.Items.Count-1 do CLBParams.Checked[i] := true;
end;
procedure TFrmCleanIDEParams.BtnSelectNoneClick(Sender: TObject);
var i: integer;
begin
for i := 0 to CLBParams.Items.Count-1 do CLBParams.Checked[i] := true;
end;
procedure TFrmCleanIDEParams.BtnStartWithClick(Sender: TObject);
var
i : integer;
lStart,
lItem : string;
begin
lStart := Lowercase(Trim(EdtStartWith.Text));
if lStart = '' then Exit;
for i := 0 to CLBParams.Items.Count-1 do
begin
lItem := lowercase(CLBParams.Items[i]);
if (not ChkNot.Checked) and (Pos(lStart,lItem) = 1)
or (ChkNot.Checked) and (Pos(lStart,lItem) <> 1) then
CLBParams.Checked[i] := true;
end;
end;
procedure TFrmCleanIDEParams.BtnWriteClick(Sender: TObject);
var
lReg : TRegistry;
lValue,
lKey : String;
i,
lNrToWrite,
lNrRegVals: Integer;
begin
for i := CLBParams.Items.Count-1 downto 0 do
if not CLBParams.Checked[i] then
CLBParams.Items.Delete(i);
if CLBParams.Items.Count = 0 then
begin
MessageDlg('Nothing to do', mtInformation, mbOKCancel, 0);
Exit;
end;
if ChkSort.Checked then
CLBParams.Sorted := true;
// Now writing back
lKey := Trim(EdtRegKey.Text);
if lKey = '' then Exit;
if lKey[1] = '\' then lKey := Copy(lKey,2);
lReg := TRegistry.Create(KEY_READ or KEY_WRITE);
lReg.RootKey := HKEY_CURRENT_USER;
if not lReg.OpenKey(lKey,false) then
begin
MessageDlg('Key not found', mtError, mbOKCancel, 0);
Exit;
end;
if not lReg.ValueExists('Count') then
begin
MessageDlg('Value ''Count'' not found', mtError, mbOKCancel, 0);
Exit;
end;
lNrRegVals := lReg.ReadInteger('Count');
lNrToWrite := CLBParams.Items.Count;
lReg.WriteInteger('Count',lNrToWrite);
// Write TCheckListBox items:
for i := 0 to lNrToWrite-1 do
begin
lValue := 'Item' + IntToStr(i);
lReg.WriteString(lValue,CLBParams.Items[i]);
end;
// Remove the rest:
for i := lNrToWrite to lNrRegVals-1 do
lReg.DeleteValue('Item' + IntToStr(i));
end;
end.
uCleanIDEParams.dfm
object FrmCleanIDEParams: TFrmCleanIDEParams
Left = 0
Top = 0
Caption = 'Clean Delphi IDE runtime parameters'
ClientHeight = 560
ClientWidth = 549
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'Tahoma'
Font.Style = []
OldCreateOrder = False
Position = poScreenCenter
PixelsPerInch = 96
TextHeight = 13
object PnlTop: TPanel
Left = 0
Top = 0
Width = 549
Height = 58
Align = alTop
BevelOuter = bvNone
TabOrder = 0
object Label1: TLabel
Left = 19
Top = 11
Width = 308
Height = 13
Caption = 'HKEY_CURRENT_USER registry key for IDE runtime parameters:'
end
object BtnLoad: TButton
Left = 496
Top = 30
Width = 40
Height = 25
Caption = 'Load'
TabOrder = 0
OnClick = BtnLoadClick
end
object EdtRegKey: TEdit
Left = 16
Top = 32
Width = 473
Height = 21
TabOrder = 1
Text = '\Software\Embarcadero\BDS\9.0\History Lists\hlRunParameters'
end
object ChkRedundant: TCheckBox
Left = 388
Top = 10
Width = 151
Height = 17
Hint = 'Removes leading, trailing, and duplicate spaces'
Caption = 'Remove redundant spaces'
Checked = True
State = cbChecked
TabOrder = 2
end
end
object PnlBottom: TPanel
Left = 0
Top = 471
Width = 549
Height = 89
Align = alBottom
BevelOuter = bvNone
TabOrder = 1
object Label2: TLabel
Left = 74
Top = 62
Width = 287
Height = 13
Caption = 'Click button to write the selected items back to the registry:'
end
object GBxSelection: TGroupBox
Left = 16
Top = -3
Width = 520
Height = 51
Caption = ' Select '
TabOrder = 0
object BtnSelectAll: TButton
Left = 348
Top = 18
Width = 50
Height = 25
Caption = 'All'
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'Tahoma'
Font.Style = []
ParentFont = False
TabOrder = 0
OnClick = BtnSelectAllClick
end
object BtnSelectNone: TButton
Left = 404
Top = 18
Width = 50
Height = 25
Caption = 'None'
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'Tahoma'
Font.Style = []
ParentFont = False
TabOrder = 1
OnClick = BtnSelectNoneClick
end
object BtnStartWith: TButton
Left = 51
Top = 18
Width = 79
Height = 25
Hint = 'Selection is additive'
Caption = 'starting with:'
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'Tahoma'
Font.Style = []
ParentFont = False
ParentShowHint = False
ShowHint = True
TabOrder = 2
OnClick = BtnStartWithClick
end
object ChkNot: TCheckBox
Left = 11
Top = 22
Width = 40
Height = 17
Caption = 'NOT'
TabOrder = 3
end
object EdtStartWith: TEdit
Left = 136
Top = 20
Width = 121
Height = 21
Hint = 'Case insensitive match'
ParentShowHint = False
ShowHint = True
TabOrder = 4
Text = '['
end
object BtnInvert: TButton
Left = 460
Top = 18
Width = 50
Height = 25
Caption = 'Invert'
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'Tahoma'
Font.Style = []
ParentFont = False
TabOrder = 5
OnClick = BtnInvertClick
end
end
object BtnWrite: TButton
Left = 364
Top = 58
Width = 89
Height = 25
Hint = 'Write the selected items back to the registry'
Caption = 'Write back'
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'Tahoma'
Font.Style = [fsBold]
ParentFont = False
ParentShowHint = False
ShowHint = True
TabOrder = 1
OnClick = BtnWriteClick
end
object ChkSort: TCheckBox
Left = 459
Top = 62
Width = 57
Height = 17
Caption = '(sorted)'
Checked = True
State = cbChecked
TabOrder = 2
end
end
object PnlCenter: TPanel
Left = 0
Top = 58
Width = 549
Height = 413
Align = alClient
BevelOuter = bvNone
TabOrder = 2
object CLBParams: TCheckListBox
AlignWithMargins = True
Left = 15
Top = 10
Width = 522
Height = 393
Margins.Left = 15
Margins.Top = 10
Margins.Right = 12
Margins.Bottom = 10
Align = alClient
ItemHeight = 13
TabOrder = 0
end
end
end
Notes:
Do not forget to change the version number in the key if you are using anything other than XE2. For old Delphi versions you may even have to change Embarcadero to Borland.
Do not run this app from within the IDE. When it closes, Delphi will overwrite any changes you made to that registry key, and it looks like your program does not work ;=)
I have 2 controls on a form, TCheckBox and TEdit.
I want to use Live Binding to perform this:
When TCheckBox.Checked = True, set TEdit.PasswordChar = *
When TCheckBox.Checked = False, set TEdit.PasswordChar = #0
How may I write ControlExpression to achieve this? It would be great if I can avoid register custom method.
Here's a simple example. I couldn't find a boolean expression evaluator so I registered a new one, and also a string-to-char converter (seems to be missing, too).
The form:
object Form1: TForm1
Left = 0
Top = 0
Caption = 'Form1'
ClientHeight = 282
ClientWidth = 418
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'Tahoma'
Font.Style = []
OldCreateOrder = False
PixelsPerInch = 96
TextHeight = 13
object CheckBox1: TCheckBox
Left = 24
Top = 24
Width = 97
Height = 17
Caption = 'CheckBox1'
TabOrder = 0
OnClick = CheckBox1Click
end
object Edit1: TEdit
Left = 24
Top = 56
Width = 121
Height = 21
TabOrder = 1
Text = 'Edit1'
end
object BindingsList1: TBindingsList
Methods = <>
OutputConverters = <>
UseAppManager = True
Left = 212
Top = 13
object BindExpression1: TBindExpression
Category = 'Binding Expressions'
ControlComponent = Edit1
SourceComponent = CheckBox1
SourceExpression = 'iif(Checked, '#39'*'#39', '#39#39')'
ControlExpression = 'PasswordChar'
NotifyOutputs = True
Direction = dirSourceToControl
end
end
end
and the code:
unit Unit1;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Data.Bind.EngExt, Vcl.Bind.DBEngExt, System.Rtti,
Vcl.Bind.Editors, Data.Bind.Components, System.Bindings.Outputs;
type
TForm1 = class(TForm)
CheckBox1: TCheckBox;
Edit1: TEdit;
BindingsList1: TBindingsList;
BindExpression1: TBindExpression;
procedure CheckBox1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
uses
System.TypInfo,
System.Bindings.EvalProtocol,
System.Bindings.Methods;
resourcestring
sIifArgError = 'Expected three variables for Iif() call';
sIifExpectedBoolean = 'First argument to Iif() must be a boolean';
function MakeIif: IInvokable;
begin
Result := MakeInvokable(
function(Args: TArray<IValue>): IValue
var
V: IValue;
B: Boolean;
begin
if Length(Args) <> 3 then
raise EEvaluatorError.Create(sIifArgError);
V := Args[0];
if (V.GetType^.Kind <> tkEnumeration) or (V.GetType^.Name <> 'Boolean') then
raise EEvaluatorError.Create(sIifExpectedBoolean);
B := V.GetValue.AsBoolean;
if B then
Result := TValueWrapper.Create(Args[1].GetValue)
else
Result := TValueWrapper.Create(Args[2].Getvalue);
end
);
end;
procedure TForm1.CheckBox1Click(Sender: TObject);
begin
BindingsList1.Notify(CheckBox1, 'Checked');
end;
initialization
TBindingMethodsFactory.RegisterMethod(TMethodDescription.Create(MakeIif, 'iif', 'iif', '', True, '', nil));
TValueRefConverterFactory.RegisterConversion(TypeInfo(string), TypeInfo(Char),
TConverterDescription.Create(
procedure(const I: TValue; var O: TValue)
var
S: string;
begin
S := I.AsString;
if Length(S) = 1 then
O := S[1]
else
O := #0;
end,
'StringToChar', 'StringToChar', '', True, '', nil));
finalization
TValueRefConverterFactory.UnRegisterConversion('StringToChar');
TBindingMethodsFactory.UnRegisterMethod('iif');
end.