I am programming a tlistview so that it displays its columns from right to left (so as to properly display Hebrew text). I am using the following code in the form's create method, where 'lv' is the listview
SetWindowLong (lv.Handle, GWL_EXSTYLE,
GetWindowLong(lv.Handle, GWL_EXSTYLE) or
WS_EX_LAYOUTRTL or WS_EX_NOINHERITLAYOUT);
lv.invalidate;
Whilst this code makes the lines in the listview display correctly, the header line displays from left to right! The columns don't match up and the heading for each column is wrong.
Does anyone have an idea how to get the header line to display right to left?
I am using Delphi 7, not that this should make much difference.
TIA,
No'am
Here is the full code to set the header and the lines:
procedure TForm1.FormCreate(Sender: TObject);
const
LVM_FIRST = $1000; // ListView messages
LVM_GETHEADER = LVM_FIRST + 31;
var
header: thandle;
begin
header:= SendMessage (lv.Handle, LVM_GETHEADER, 0, 0);
SetWindowLong (header, GWL_EXSTYLE,
GetWindowLong (header, GWL_EXSTYLE) or
WS_EX_LAYOUTRTL or WS_EX_NOINHERITLAYOUT);
SetWindowLong (lv.Handle, GWL_EXSTYLE,
GetWindowLong (lv.Handle, GWL_EXSTYLE) or
WS_EX_LAYOUTRTL or WS_EX_NOINHERITLAYOUT);
lv.invalidate; // get the list view to display right to left
end;
I hope this sample'll be useful for you :
var
aCol: TListColumn;
tmp: TListView;
i: integer;
begin
tmp := TListView.Create(Self);
LV.Columns.BeginUpdate;
try
for i := LV.Columns.Count-1 downto 0 do
begin
aCol := tmp.Columns.Add;
aCol.Width := LV.Columns[i].Width;
aCol.Caption := LV.Columns[i].Caption;
end;
LV.Columns := tmp.Columns;
finally
LV.Columns.EndUpdate;
tmp.Free;
end;
end;
Related
Need a component derived from TMemo (not TSyn components)
I need a line to the left(inside or outside) of a TMemo whose thickness(optional) and color can be controlled just for the purposes of indication. It need not be functional as a gutter but looks like one especially like that of a SynMemo as shown in the image. The problem with SynMemo is that it doesn't support variable width fonts like Tahoma but the TMemo does.
I tried making a few composite components with CustomContainersPack by combining a TShape with TMemo, even superimposing a TMemo on top of TSynMemo but didn't succeed as the paint while dragging made it look disassembled and CCPack is not that robust for my IDE.
KMemo, JvMemo and many other Torry.net components were installed and checked for any hidden support for achieving the same but none worked.
Grouping of components together is also not a solution for me since many mouse events are tied to the Memo and calls to FindVCLWindow will return changing components under the mouse. Furthermore many components will be required so grouping with TPanel will up the memory usage.
You can use the WM_Paint message and a hack to do this without creating a new component,
Otherwise create a descendant of TMemo and apply the same changes below
TMemo = class(Vcl.StdCtrls.TMemo)
private
FSidecolor: TColor;
FSideColorWidth: Integer;
FAskForAttention: Boolean;
procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
procedure SetSideColorWidth(const Value: Integer);
procedure SetSideColor(const Value: TColor);
procedure SetAskForAttention(const Value: Boolean);
published
property SideColor: TColor read FSideColor write SetSideColor default clRed;
property SideColorWidth: Integer read FSideColorWidth write SetSideColorWidth default 2;
property AskForAttension: Boolean read FAskForAttention write SetAskForAttention;
end;
{ TMemo }
procedure TMemo.SetAskForAttention(const Value: Boolean);
begin
FAskForAttention := Value;
Invalidate;
end;
procedure TMemo.SetSideColor(const Value: TColor);
begin
FSideColor := Value;
Invalidate;
end;
procedure TMemo.SetSideColorWidth(const Value: Integer);
begin
FSideColorWidth := Value;
Invalidate;
end;
procedure TMemo.WMPaint(var Message: TWMPaint);
var
DC: HDC;
Pen: HPen;
R,G,B: Byte;
begin
inherited;
if FAskForAttention then
begin
DC := GetWindowDC(Handle);
try
B := Byte(FSidecolor);
G := Byte(FSidecolor shr 8);
R := Byte(FSidecolor shr 16);
Pen := CreatePen(PS_SOLID, FSideColorWidth, RGB(R,G,B));
SelectObject(DC, Pen);
SetBkColor(DC, RGB(R,G,B));
Rectangle(DC, 1, 1, FSideColorWidth, Height - 1);
DeleteObject(Pen);
finally
ReleaseDC(Handle, DC);
end;
end;
end;
And you can use it like this
procedure TForm15.Button1Click(Sender: TObject);
begin
memo1.SideColor := ColorBox1.Selected;
memo1.SideColorWidth := 2;
memo1.AskForAttension := True;
end;
and you get this result
Limitations:
As this is merely another hack to draw a simple rectangle on the side, do not expect it to be perfect on all situations. I did notice the following when testing:
If the border is too thick you get the following effect
When on mouse move the line sometimes disappear and don't get painted (I think it is because of drawing focus rect).
Note: I see the guys in comments suggested to create a custom component with panel and memo put together, If you want to try this, take a look at my answer to
Creating a new components by combining two controls (TEdit and TTrackBar) in Delphi VCL
It is basically the same Ideas.
Edit:
Ok I took into consideration what is mentioned in comments and adapted my answer,
I also changed the way I'm getting the canvas of the component. The new implementation becomes this
{ TMemo }
procedure TMemo.SetAskForAttention(const Value: Boolean);
var
FormatRect: TRect;
begin
if FAskForAttention <> Value then
begin
FAskForAttention := Value;
if not FAskForAttention then
begin
Perform(EM_SETRECT, 0, nil);
end
else
begin
FormatRect := GetClientRect;
if IsRightToLeft then
FormatRect.Right := FormatRect.Right - FSideColorWidth - 3
else
FormatRect.Left := FormatRect.Left + FSideColorWidth + 3;
Perform(EM_SETRECT, 0, FormatRect);
end;
Invalidate;
end;
end;
procedure TMemo.SetSideColor(const Value: TColor);
begin
if FSideColor <> Value then
begin
FSideColor := Value;
Invalidate;
end;
end;
procedure TMemo.SetSideColorWidth(const Value: Integer);
var
FormatRect: TRect;
begin
if FSideColorWidth <> Value then
begin
FSideColorWidth := Value;
FormatRect := GetClientRect;
if IsRightToLeft then
FormatRect.Right := FormatRect.Right - FSideColorWidth - 3
else
FormatRect.Left := FormatRect.Left + FSideColorWidth + 3;
Perform(EM_SETRECT, 0, FormatRect);
end;
end;
procedure TMemo.WMPaint(var Message: TWMPaint);
var
Canvas: TControlCanvas;
CRect: TRect;
begin
inherited;
if FAskForAttention then
begin
Canvas := TControlCanvas.Create;
try
Canvas.Control := Self;
Canvas.Font.Assign(Self.Font);
CRect := GetClientRect;
if IsRightToLeft then
CRect.Left := CRect.Right - FSideColorWidth
else
CRect.Width := FSideColorWidth;
Canvas.Brush.Color := FSidecolor;
Canvas.Brush.Style := bsSolid;
Canvas.FillRect(CRect);
finally
Canvas.Free;
end;
end;
end;
There is no limitations for the size and it does not overlap the scrollbars.
Final result:
References I used to write this answer:
MSDN Painting and Drawing Functions
MSDN Using the WM_PAINT Message
Creating Colored Pens and Brushes example
Vcl.Controls TWinControl WM_Paint message implementation
EM_SETRECT message
How can I get a TEdit's canvas in Delphi? (Kobik's answer)
Instead of writing a custom control, put a panel or a shape beside the standard memo and give it any colour you like.
If this is too tedious to repeat many times, then put the memo and the shape on a frame and put that in the repository. Set the anchors to make sure they resize correctly. You don't even need to write code for that and you have an instant "imitation custom control".
Much better and simpler than writing, installing and testing a custom control, IMO.
Now if you want to put text or numbers or icons in the gutter, then it would pay out to write a custom control. Use EM_SETRECT to set the internal formatting rectangle, and custom draw the gutter in the overridden Paint method. Do not forget to call inherited.
Can you explain how I can get used colors of the TDialogService.MessageDialog window?
Update: Which created using this command:
TDialogService.MessageDialog('Test3: Confirmation', MsgDlgType.mtConfirmation,
[TMsgDlgBtn.mbOK], TMsgDlgBtn.mbOK, 0,
procedure(const AResult: TModalResult)
begin
end);
I need color of the bottom panel (Button parent) and background color of the message. I need this color to make my own dialog looks like FMX default dialog.
Currently I have my own highly customizable dialog which looks like this:
And also where I can get icons which used in TDialogService.MessageDialog window?
Thanks to the answer of David Heffernan and Triber:
procedure GetThemeBackgroud(AImage: TImage; ATheme: HTHEME; APartID: Integer);
var
stream: TMemoryStream;
bitmap: Vcl.Graphics.TBitmap;
begin
bitmap := Vcl.Graphics.TBitmap.Create;
try
bitmap.Width := Round(AImage.Width);
bitmap.Height := Round(AImage.Height);
DrawThemeBackground(ATheme, bitmap.Canvas.Handle, APartID, 0,
Rect(0, 0, bitmap.Width, bitmap.Height), nil);
stream := TMemoryStream.Create;
try
bitmap.SaveToStream(stream);
AImage.Bitmap.LoadFromStream(stream);
finally
stream.Free;
end;
finally
bitmap.Free;
end;
end;
procedure GetThemeBackgroud;
var
theme: HTHEME;
begin
theme := OpenThemeData(0, 'TASKDIALOG');
if theme <> 0 then
try
// Client color
GetThemeBackgroud(imgClient, theme, TDLG_PRIMARYPANEL);
// Bottom color
GetThemeBackgroud(imgBottom, theme, TDLG_SECONDARYPANEL);
finally
CloseThemeData(theme);
end;
end;
Here we should to add 2 TImages: client and buttons parents:
Now I should investigate of the system icons loading
I want to put a label inside progress bar. And this label caption is dynamic.
How can I get the label position ALWAYS on center inside the ProgressBar?
What I've tried ;
Label1.Parent := progressBar1;
Label1Top := progressBar1.Height div 2;
Label1.Left := progressBar1.Width div 2
It shows ugly, and not in center like I want.
If I set Label1.Left := progresBar1.Width div 2 - xxx it will be on center only for certain caption. I want to have any caption be placed on center.
Edited
Answer from #KenWhite is working good.
Solution from #DavidHeffernan just great.
Set the label's AutoSize property to False. Change the Alignment property to taCenter and Layout to tlCenter. Size the label to the progressbar's ClientWidth and ClientHeight, and set its Left to 0.
Label1.Parent := progressBar1;
Label1.AutoSize := False;
Label1.Transparent := True;
Label1.Top := 0;
Label1.Left := 0;
Label1.Width := progressBar1.ClientWidth;
Label1.Height := progressBar1.ClientHeight;
Label1.Alignment := taCenter;
Label1.Layout := tlCenter;
Here's an example of the appearance:
You might decide to derive a progress bar control that paints the text itself rather than relying on a separate label. Some sample code to demonstrate:
type
TProgressBarWithText = class(TProgressBar)
private
FProgressText: string;
protected
procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
published
property ProgressText: string read FProgressText write FProgressText;
end;
procedure TProgressBarWithText.WMPaint(var Message: TWMPaint);
var
DC: HDC;
prevfont: HGDIOBJ;
prevbkmode: Integer;
R: TRect;
begin
inherited;
if ProgressText <> '' then
begin
R := ClientRect;
DC := GetWindowDC(Handle);
prevbkmode := SetBkMode(DC, TRANSPARENT);
prevfont := SelectObject(DC, Font.Handle);
DrawText(DC, PChar(ProgressText), Length(ProgressText),
R, DT_SINGLELINE or DT_CENTER or DT_VCENTER);
SelectObject(DC, prevfont);
SetBkMode(DC, prevbkmode);
ReleaseDC(Handle, DC);
end;
end;
The advantage of this approach is that your progress bar and text display are self-contained. There's no need for two separate controls that you have to coordinate.
I create a captionless window.
I resize it manually (or programmatically) so that its height is 30 pixels or less.
When I then grab the bottom border to resize it vertically, it behaves as
if I were dragging the top border. Indeed when debugging the program, the WM_SIZING parameter contains WMSZ_TOP instead of WMSZ_BOTTOM.
My program is written in Delphi, basically the problem is reproducible with a main form with the following FormCreate:
procedure TForm2.FormCreate(Sender: TObject);
var oldStyle : LongInt;
var newStyle : LongInt;
begin
// Adapt windows style.
oldStyle := WINDOWS.GetWindowLong (
handle,
GWL_STYLE);
newStyle := oldStyle and
(not WS_CAPTION) and
(not WS_MAXIMIZEBOX);
WINDOWS.SetWindowLong(
handle,
GWL_STYLE,
newStyle);
// SetWindowPos with SWP_FRAMECHANGED needs to be called at that point
// in order for the style change to be taken immediately into account.
WINDOWS.SetWindowPos(
handle,
0,
0,
0,
0,
0,
SWP_NOZORDER or
SWP_NOMOVE or
SWP_NOSIZE or
SWP_FRAMECHANGED or
SWP_NOACTIVATE);
end;
Looks like a bug to me with the OS. Under the conditions of your test case, hit test handling is wrong, default window procedure returns HTTOP when it should return HTBOTTOM. You can override hit test handling for a workaround:
procedure TForm1.WMNCHitTest(var Message: TWMNCHitTest);
begin
inherited;
if (Message.Result = HTTOP) and
(Message.Pos.Y > Top + Height - GetSystemMetrics(SM_CYSIZEFRAME)) then
Message.Result := HTBOTTOM;
end;
Well done, thanks. I confirm that it is an OS bug and nothing related to delphi (I was able to reproduce the problem with a simple window created using the WINDOWS API).
I now ended up with:
procedure TForm2.WMNcHitTest(
var msg : TWMNCHitTest);
begin
inherited;
case msg.result of
HTTOP:
begin
if msg.pos.y > top + height div 2 then
msg.result := HTBOTTOM;
end;
HTTOPRIGHT:
begin
if msg.pos.y > top + height div 2 then
msg.result := HTBOTTOMRIGHT;
end;
HTTOPLEFT:
begin
if msg.pos.y > top + height div 2 then
msg.result := HTBOTTOMLEFT;
end;
end;
end;
I am trying to create transparent child window.
procedure TForm1.BtnGoClick(Sender: TObject);
var
bmp:TBitmap;
BitmapPos: TPoint;
BitmapSize: TSIZE;
BlendFunction: _BLENDFUNCTION;
exStyle: Cardinal;
begin
bmp := TBitmap.Create;
bmp.LoadFromFile('my32bitbitmap.bmp');
exStyle := GetWindowLongA(Form2.Handle, GWL_EXSTYLE);
if (exStyle and WS_EX_LAYERED = 0) then
SetWindowLong(Form2.Handle, GWL_EXSTYLE, exStyle or WS_EX_LAYERED);
BitmapPos := Point(0, 0);
BitmapSize.cx := bmp.Width;
BitmapSize.cy := bmp.Height;
BlendFunction.BlendOp := AC_SRC_OVER;
BlendFunction.BlendFlags := 0;
BlendFunction.SourceConstantAlpha := 200;
BlendFunction.AlphaFormat := AC_SRC_ALPHA;
UpdateLayeredWindow(Form2.Handle, 0, nil, #BitmapSize, bmp.Canvas.Handle, #BitmapPos, 0, #BlendFunction, ULW_ALPHA);
Windows.SetParent(Form2.Handle, Form1.Handle);
bmp.Free;
end;
It almost works: Form2 become nice transparent window inside Form1. But it looks like Form2 does not move with Form1. When i move Form1, Form2-Window moves, but on screen i see it when it was. When Form1 is moved i cant click on Form2, clicks goes through, so i know window was moved.
So question is how to make child transparent window without these features? (just normal window that moves with it's parrent)
You need to call UpdateLayeredWindow after each move or resize of your Form2. Or you can replace it with TCustomTransparentControl descendant.