How to resize Popup Window dynamically at runtime? - delphi

I try to create a custom Combobox control that popups a Treeview.
Everything looks fine.
But when i try to add runtime resize functionality to that control, the popup window (Treeview) just move and won't change its size.
Any suggestion would be appreciated.
Snippets for Popup Window :
On Create :
ControlStyle := ControlStyle + [csNoDesignVisible, csReplicatable, csDoubleClicks];
On Create Params :
begin
inherited CreateParams(Params);
with Params do
begin
Style := Style or WS_POPUP or WS_VSCROLL or WS_BORDER;
ExStyle := WS_EX_TOOLWINDOW;
AddBiDiModeExStyle(ExStyle);
//WindowClass.Style := CS_SAVEBITS; {this would prevent ondoubleclick event}
end;
On Mouse Move :
var
ARect, RR: TRect;
DragStyle: TDragStyle;
Procedure SetDragStyle(ds:TDragStyle; c:TCursor);
begin
FDragStyle:=ds;
Cursor:=c;
end;
begin
inherited;
FMouseMoveSelected := GetNodeAt(x, y);
if FDragged then begin
case FDragStyle of
dsSizeLeft :begin
SetWindowPos(Handle, HWND_TOP, Left+(x-FDragPos.X), Top, Width, Height,
SWP_NOACTIVATE or SWP_SHOWWINDOW);
//Left:=Left+(x-FDragPos.X); {alternate code that doesn't work either}
end;
end;
FDragPos:=Point(x,y);
end else begin
SetDragStyle(dsMove,crDefault);
ARect := GetClientRect;
RR:=ARect;
InflateRect(RR,-2,-2);
if (x>=0) and (x<=Width) and (y>=0) and (y<=Height) and (not PtInRect(RR,Point(x,y))) then begin
if (x<=RR.Left) then begin
//if (y<=RR.Top) then SetDragStyle(dsSizeTopLeft,crSizeNWSE)else
if (y>=RR.Bottom) then SetDragStyle(dsSizeBottomLeft,crSizeNESW)
else SetDragStyle(dsSizeLeft,crSizeWE);
end else if (x>=RR.Right) then begin
//if (y<=RR.Top) then SetDragStyle(dsSizeTopRight,crSizeNESW) else
if (y>=RR.Bottom) then SetDragStyle(dsSizeBottomRight,crSizeNWSE)
else SetDragStyle(dsSizeRight,crSizeWE);
end else begin
//if (y<=RR.Top) then SetDragStyle(dsSizeTop,crSizeNS) else
if (y>=RR.Bottom) then SetDragStyle(dsSizeBottom,crSizeNS)
else SetDragStyle(dsMove,crDefault);
end;
end;
end;
end;
end;
On Mouse Down :
begin
inherited;
if FDragStyle<>dsMove then begin
FDragPos:=point(x,y);
FDragged:=true;
end;
end;
On Mouse Up :
begin
inherited;
FDragged:=false;
end;

You're mixing client coordinates with screen coordinates in the SetWindowPos call. That's because you're floating a window that's not supposed to float and the VCL has no knowledge of it. When you refer to its Left, the VCL returns a coordinate relative to its parent, probably the form. Also don't change the point you saved while you started to drag during the drag (that being FDragPos):
procedure TPanel.MouseMove(Shift: TShiftState; X, Y: Integer);
var
ARect, RR: TRect;
DragStyle: TDragStyle;
Procedure SetDragStyle(ds:TDragStyle; c:TCursor);
begin
FDragStyle:=ds;
Cursor:=c;
end;
var
DragOffset: Integer;
begin
inherited;
FMouseMoveSelected := GetNodeAt(x, y);
if FDragged then begin
case FDragStyle of
dsSizeLeft:
begin
DragOffset := X - FDragPos.X;
winapi.windows.GetWindowRect(Handle, ARect);
SetWindowPos(Handle, HWND_TOP,
ARect.Left + DragOffset,
ARect.Top,
ARect.Right - ARect.Left - DragOffset,
ARect.Bottom - ARect.Top,
SWP_NOACTIVATE or SWP_SHOWWINDOW);
//Left:=Left+(x-FDragPos.X); {alternate code that doesn't work either}
end;
end;
// FDragPos:=Point(x,y); // do not change drag origin while you're dragging
end else begin
..

Related

It is possible to render the whole content of a TScrollBox control to a image file?

I tried this function, but it only caputre the visible client area... It is possible to capture the whole area of the control, like it is expanded that no vertical scroll bar is needed ?
function CaptureWinCtrlImage(AWinControl: TWinControl; AImg: TGraphic): Boolean;
var
vBmp: Graphics.TBitmap;
vControlDC: HDC;
begin
Result:= False;
if not AWinControl.HandleAllocated then Exit;
vControlDC:= GetWindowDC(AWinControl.Handle);
try
vBmp:= Graphics.TBitmap.Create;
try
vBmp.PixelFormat := pf24bit;
vBmp.Height := AWinControl.Height;
vBmp.Width := AWinControl.Width;
BitBlt(vBmp.Canvas.Handle, 0, 0, vBmp.Width, vBmp.Height, vControlDC, 0, 0, SRCCOPY);
AImg.Assign(vBmp);
Result:= True;
finally
vBmp.Free;
end;
finally
ReleaseDC(AWinControl.Handle, vControlDC);
end;
end;
I did it by scrolling the box and making a capture every time. It's not nice to see that flicker on the screen, but at least it works. And it might capture something else if some window appears on the screen at that time...
procedure CaptureScrollBox(ABox: TScrollBox; FileName: String);
var vBmp: Graphics.TBitmap;
vControlDC: HDC;
Org: TPoint;
PngImg: TPngImage;
Y, P: Integer;
begin
PngImg:= TPngImage.Create;
vControlDC:= GetWindowDC(ABox.Handle);
vBmp:= Graphics.TBitmap.Create;
vBmp.PixelFormat := pf24bit;
vBmp.Width := ABox.ClientWidth;
vBmp.Height := ABox.VertScrollBar.Range;
Org.X:= ABox.Left; Org.Y:= ABox.Top;
Org:= ABox.Parent.ClientToScreen(Org);
Org.X:= ABox.ClientOrigin.X - Org.X;
Org.Y:= ABox.ClientOrigin.Y - Org.Y;
P:= ABox.VertScrollBar.Position;
Y:= 0;
repeat
ABox.VertScrollBar.Position:= Y; ABox.Repaint;
if ABox.VertScrollBar.Position <> Y then begin
Org.Y:= Org.Y + ( Y - ABox.VertScrollBar.Position );
BitBlt(vBmp.Canvas.Handle, 0, Y, vBmp.Width, vBmp.Height, vControlDC, Org.X, Org.Y, SRCCOPY);
Break;
end
else begin
BitBlt(vBmp.Canvas.Handle, 0, Y, vBmp.Width, vBmp.Height, vControlDC, Org.X, Org.Y, SRCCOPY);
Inc(Y, ABox.ClientHeight);
end;
until False;
ABox.VertScrollBar.Position:= P;
PngImg.Assign(vBmp);
PngImg.SaveToFile(FileName);
vBmp.Free;
ReleaseDC(ABox.Handle, vControlDC);
PngImg.Free;
end;

TImage Not Showing up

When dropping this component onto the form, The TImage is not showing the map image (hexagons) Until i drag the component around on the form , Then it will show it until i stop dragging it around on the form. (this is all in desgin mode). How do i make it show all the time? not when just dragging it.
type
THexMap = Class(TScrollingWinControl)
Constructor
Constructor THexMap.Create(AOwner: Tcomponent);
begin
inherited Create(AOwner);
Width := DEFAULT_MAP_WIDTH;
Height := DEFAULT_MAP_HEIGHT;
FCanvas := timage.Create(self);
tempMap := timage.Create(self);
fcanvas.Parent := self;
tempmap.Parent := self;
fCanvas.Width := DEFAULT_MAP_WIDTH;
fCAnvas.Height := DEFAULT_MAP_WIDTH;
{ Set intial property values for component }
//create map
MakeSolidMap;
end;
MakeSolidMap
Procedure THexMap.MakeSolidMap;
var
p0 : TPoint;
looprow,Loopcol : integer;
begin
TempMap.width := ((HexColumns-1) * round((1.5 * HexRadius))) + (2 * hexRadius);
TempMap.height := ((HexRows) * (2 * rise)) + rise;
With TempMap.Canvas do
begin
{set Background color}
brush.Color := BackColor;
fillrect(rect(0,0,TempMap.Width,TempMap.Height));
{draw Hex's left to right / top to bottom}
for looprow := 1 to HexRows do
begin
for loopcol := 1 to HexColumns do
begin
{compute center coords}
p0 := ConvertCoords(Point(LoopCol,LoopRow),ptROWCOL);
{draw the hex}
DrawSolidHex(Tempmap,bsSolid,hexColor,psSolid,LineColor,P0.X,p0.Y,hexRadius,hex3d);
end;
end;
end;
end;
DrawSoildHex
procedure THexMap.DrawSolidHex(Target: timage;
FillStyle: TBrushStyle;
FillColor: TColor;
LineStyle: TPenStyle;
LineColor: TColor;
x: Integer;
y: Integer;
Radius: Integer;
button: Boolean);
var
p0,p1,p2,p3,p4,p5,p6:TPoint;
begin
p0 := Point(x,y);
{compute each point based on hex center}
p1.X := p0.X - round(Radius /2);
p1.Y := p0.Y - rise;
p2.X := p0.X + round(Radius/2);
p2.Y := p1.Y;
p3.X := p0.X + Radius;
p3.Y := p0.Y;
p4.X := p2.X;
p4.Y := p0.Y + rise;
p5.X := p1.X;
p5.Y := p4.Y;
p6.X := p0.X - Radius;
p6.Y := p0.Y;
{set color / style of lines}
target.canvas.Pen.Color := LineColor;
target.canvas.Pen.Style := LineStyle;
{set color / style of hex}
target.canvas.Brush.Color := FillColor;
Target.canvas.Brush.Style := FillStyle;
{draw the hex}
target.canvas.Polygon([p1,p2,p3,p4,p5,p6]);
{if desired, draw the boarder for the hex}
if button = true then
begin
with target.canvas do
begin
pen.Mode :=pmCopy;
pen.Color :=clWhite;
moveto(p5.X+1,p5.Y-1);
lineto(p6.X+1,p6.Y);
lineto(p1.X+1,p1.Y+1);
lineto(p2.X-1,p2.Y+1);
pen.Color :=clBlack;
lineto(p3.X-1,p3.Y);
lineto(p4.X-1,p4.Y-1);
lineto(p5.X+1,p5.Y-1);
end;
end;
invalidate;
end;
WndProc
procedure THexMap.WndProc(var Message: TMessage);
const
DISCARD_CURRENT_ORIGIN = nil;
var
R : TRect;
PS : PAINTSTRUCT;
begin
if Message.Msg = WM_PAINT then
begin
if GetUpdateRect( Handle, nil, false ) then
begin
BeginPaint( Handle, PS );
try
R := PS.rcPaint;
bitblt(fCanvas.Canvas.Handle, R.Left, R.Top, R.Width, R.Height, TempMap.Canvas.Handle, R.Left+FOffset.X, R.Top+FOffset.Y, SRCCOPY);
finally
EndPaint( Handle, PS );
end;
end
else
inherited;
end
else
inherited;
end;
Nothing shows because you have taken over painting the control by handing WM_PAINT. And in your handling of WM_PAINT you do not paint anything to the device context returned by BeginPaint. You do not call the inherited handler which would call Paint and then paint children. Hence nothing appears in your control.
It seems to me that you need to decide to either use visual controls and let the VCL paint them, or paint your control yourself. You are currently attempting to do both but achieving neither!
I cannot suggest a fix because I've really no idea what you are doing. I don't understand why you have visual controls and override the paint message handler. To go forward you'll need to pick one approach or the other.

TEdit not redrawing correctly with Invalidate in Delphi 5

There's a problem with the TScrollBox in Delphi 5 when using Cirtix, on some systems, when a user scrolls by clicking the button at the top or bottom of the end of scrollbar the whole application freezes. We had the issue in QucikReports previews initially and got round it by implementing our own scrollbars in the TScrollBox.
We now have a piece of bespoke work that uses a TScrollBox and the client is reporting a similar problem so I'm working round it in the same way. I hide the TScrollBox scrollbars and add in my own. When those are clicked I call the following.
Note, this test code is not currently running in Citrix, I've tested on XP and Window 7.
I am turning off redrawing of the control, moving all the child controls, then turning drawing back on and calling Invalidate. I would expect invalidate to fully redraw the control but that's not happening.
procedure TScrollBoxScrollReplacement.ScrollControls(x: Integer; y: Integer);
var
I: Integer;
begin
if (x = 0) and (y = 0) then
Exit;
// Stop the control from repaining while we're updating it
try
SendMessage(FScrollBox.Handle, WM_SETREDRAW, 0, 0);
for I := 0 to FScrollBox.ControlCount - 1 do
begin
if (FScrollBox.Controls[I] = FVScrollBar) or (FScrollBox.Controls[I] = FHScrollBar) then
Continue;
FScrollBox.Controls[I].Left := FScrollBox.Controls[I].Left + x;
FScrollBox.Controls[I].Top := FScrollBox.Controls[I].Top + y;
end;
finally
// Turn on painting again
SendMessage(FScrollBox.Handle, WM_SETREDRAW, 1, 0);
end;
// Redraw everything
InvalidateEverything(FScrollBox);
end;
Code to redraw controls
procedure TScrollBoxScrollReplacement.InvalidateEverything(AControl: TControl);
var
I: Integer;
begin
AControl.Invalidate();
if (AControl is TWinControl) then
for I := 0 to TWinControl(AControl).ControlCount - 1 do
InvalidateEverything(TWinControl(AControl).Controls[I]);
end;
I added in the Invalidate, Refresh and Reapint and loop through all child controls in an effort to get it working, but still no luck. The edit boxes look as follows:
If I set Visible to false and back to true then they'll redraw correctly, but there is obviously a horrible flicker. They also redraw correctly if I minimise the maximise the window, or drag it off and on the screen.
Any help would be much appreciated.
edit : Some info about the answers.
Users looking for a solution, I'd recommend you try both. David's and Sertac's. David's looks like it is the correct solution according to Microsoft's documentation. However, with the Delphi scrollbox, labels placed directly in the scrollbox flicker, where are labels placed in groupboxes in the scrollbox are perfectly smooth. I think this might be an issue with all components that don't descend from TWinControl. Scrolling itself is smoother with David's solution, but there's less flicking using WM_SETREDRAW and RedrawWindow. I would have liked to accept both as answers as both have their advantages and disadvantages.
edit : Code for the whole class below
To test just add a scrollbox with some controls to your form and call
TScrollBoxScrollReplacement.Create(ScrollBox1);
.
unit ScrollBoxScrollReplacement;
interface
uses extctrls, stdctrls, SpScrollBox, forms, Controls, classes, Messages, Windows, Sysutils, Math;
type
TScrollBoxScrollReplacement = class(TComponent)
private
FLastVScrollPos: Integer;
FLastHScrollPos: Integer;
FScrollBox: TScrollBox;
FVScrollBar: TScrollBar;
FHScrollBar: TScrollBar;
FVScrollBarVisible: Boolean;
FHScrollBarVisible: Boolean;
FCornerPanel: TPanel;
FMaxRight: Integer;
FMaxBottom: Integer;
FOriginalResizeEvent: TNotifyEvent;
FOriginalCanResizeEvent: TCanResizeEvent;
FInScroll: Boolean;
function GetHScrollHeight: Integer;
function GetVScrollWidth: Integer;
procedure ReplaceScrollBars;
function SetUpScrollBar(AControlScrollBar: TControlScrollBar; AKind: TScrollBarKind): TScrollBar;
procedure ScrollBoxResize(Sender: TObject);
procedure ScrollBarEnter(Sender: TObject);
procedure PositionScrollBars;
procedure Scroll(Sender: TObject; ScrollCode: TScrollCode; var ScrollPos: Integer);
procedure ScrollControls(x, y: Integer);
procedure CalculateControlExtremes();
procedure ResetVScrollBarRange;
procedure ResetHScrollBarRange;
function IsReplacementControl(AControl: TControl): Boolean;
property HScrollHeight: Integer read GetHScrollHeight;
property VScrollWidth: Integer read GetVScrollWidth;
procedure ScrollBoxCanResize(Sender: TObject; var NewWidth,
NewHeight: Integer; var Resize: Boolean);
public
constructor Create(AScrollBox: TScrollBox); reintroduce; overload;
destructor Destroy(); override;
procedure ResetScrollBarRange();
procedure BringReplacementControlsToFront();
end;
implementation
{ TScrollBoxScrollReplacement }
constructor TScrollBoxScrollReplacement.Create(AScrollBox: TScrollBox);
begin
// Set up the scrollbox as our owner so we're destroyed when the scrollbox is
inherited Create(AScrollBox);
FScrollBox := AScrollBox;
ReplaceScrollBars();
// We make a note of any existing resize and can resize events so we can call them to make sure we don't break anything
FOriginalResizeEvent := FScrollBox.OnResize;
FScrollBox.OnResize := ScrollBoxResize;
FOriginalCanResizeEvent := FScrollBox.OnCanResize;
FScrollBox.OnCanResize := ScrollBoxCanResize;
end;
// This is called (unintuitively) when controls are moved within the scrollbox. We can use this to reset our scrollbar ranges
procedure TScrollBoxScrollReplacement.ScrollBoxCanResize(Sender: TObject; var NewWidth,
NewHeight: Integer; var Resize: Boolean);
begin
if (not FInScroll) then
begin
ResetScrollBarRange();
BringReplacementControlsToFront();
end;
if (Assigned(FOriginalCanResizeEvent)) then
FOriginalCanResizeEvent(Sender, NewWidth, NewHeight, Resize);
end;
procedure TScrollBoxScrollReplacement.ScrollBoxResize(Sender: TObject);
begin
if (Assigned(FOriginalResizeEvent)) then
FOriginalResizeEvent(Sender);
ResetScrollBarRange();
end;
// Hides the original scrollbars and adds in ours
procedure TScrollBoxScrollReplacement.ReplaceScrollBars();
begin
FVScrollBar := SetUpScrollBar(FScrollBox.VertScrollBar, sbVertical);
FVScrollBarVisible := FVScrollBar.Visible;
FHScrollBar := SetUpScrollBar(FScrollBox.HorzScrollBar, sbHorizontal);
FHScrollBarVisible := FHScrollBar.Visible;
FCornerPanel := TPanel.Create(FScrollBox);
FCornerPanel.Parent := FScrollBox;
ResetScrollBarRange();
end;
procedure TScrollBoxScrollReplacement.PositionScrollBars();
begin
// Align our scrollbars correctly
FVScrollBar.Top := 0;
FVScrollBar.Left := FScrollBox.ClientWidth - FVScrollBar.Width;
FVScrollBar.Height := FScrollBox.ClientHeight - HScrollHeight;
// FVScrollBar.BringToFront();
FHScrollBar.Left := 0;
FHScrollBar.Top := FScrollBox.ClientHeight - FHScrollBar.Height;
FHScrollBar.Width := FScrollBox.ClientWidth - VScrollWidth;
// FHScrollBar.BringToFront();
// If both scrollbars are visible we'll put a panel in the corner so we can't see components through it
if (FVScrollBar.Visible) and (FHScrollBar.Visible) then
begin
FCornerPanel.Left := FHScrollBar.Width;
FCornerPanel.Top := FVScrollBar.Height;
FCornerPanel.Width := FVScrollBar.Width;
FCornerPanel.Height := FHScrollBar.Height;
FCornerPanel.Visible := True;
// FCornerPanel.BringToFront();
end
else
FCornerPanel.Visible := False;
end;
procedure TScrollBoxScrollReplacement.ResetScrollBarRange();
begin
CalculateControlExtremes();
ResetVScrollBarRange();
ResetHScrollBarRange();
PositionScrollBars();
end;
procedure TScrollBoxScrollReplacement.ResetVScrollBarRange();
var
ScrollMax: Integer;
ScrollAmount: Integer;
begin
// If all the controls fit to the right of the screen, but there are controls off the left then we'll scroll right.
ScrollMax := FMaxBottom - FScrollBox.ClientHeight + FHScrollBar.Height;
if (ScrollMax < 0) and (FLastVScrollPos > 0) then
begin
ScrollAmount := Min(Abs(ScrollMax), FLastVScrollPos);
ScrollControls(0, ScrollAmount);
FLastVScrollPos := FLastVScrollPos - ScrollAmount;
CalculateControlExtremes();
end;
FVScrollBar.Max := Max(FMaxBottom - FScrollBox.ClientHeight + FHScrollBar.Height + FLastVScrollPos, 0);
FVScrollBar.Visible := (FVScrollBar.Max > 0) and FVScrollBarVisible;
end;
procedure TScrollBoxScrollReplacement.ResetHScrollBarRange();
var
ScrollMax: Integer;
ScrollAmount: Integer;
begin
// If all the controls fit to the bottom of the screen, but there are controls off the top then we'll scroll up.
ScrollMax := FMaxRight - FScrollBox.ClientWidth + FVScrollBar.Width;
if (ScrollMax < 0) and (FLastHScrollPos > 0) then
begin
ScrollAmount := Min(Abs(ScrollMax), FLastHScrollPos);
ScrollControls(ScrollAmount, 0);
FLastHScrollPos := FLastHScrollPos - ScrollAmount;
CalculateControlExtremes();
end;
FHScrollBar.Max := Max(FMaxRight - FScrollBox.ClientWidth + FVScrollBar.Width + FLastHScrollPos, 0);
FHScrollBar.Visible := (FHScrollBar.Max > 0) and FHScrollBarVisible;
end;
function TScrollBoxScrollReplacement.SetUpScrollBar(AControlScrollBar: TControlScrollBar; AKind: TScrollBarKind): TScrollBar;
begin
Result := TScrollBar.Create(FScrollBox);
Result.Visible := AControlScrollBar.Visible;
Result.Parent := FScrollBox;
Result.Kind := AKind;
Result.Ctl3D := False;
Result.Max := AControlScrollBar.Range;
Result.OnEnter := ScrollBarEnter;
Result.OnScroll := Scroll;
Result.SmallChange := 5;
Result.LargeChange := 20;
AControlScrollBar.Visible := False;
end;
destructor TScrollBoxScrollReplacement.Destroy;
begin
inherited;
end;
procedure TScrollBoxScrollReplacement.ScrollBarEnter(Sender: TObject);
begin
// We just call this here to make sure our ranges are set correctly - a backup in case things go wrong
ResetScrollBarRange();
end;
procedure TScrollBoxScrollReplacement.Scroll(Sender: TObject;
ScrollCode: TScrollCode; var ScrollPos: Integer);
var
Change: Integer;
begin
ResetScrollBarRange();
if (Sender = FVScrollBar) then
begin
Change := FLastVScrollPos - ScrollPos;
ScrollControls(0, Change);
FLastVScrollPos := ScrollPos;
end
else if (Sender = FHScrollBar) then
begin
Change := FLastHScrollPos - ScrollPos;
ScrollControls(Change, 0);
FLastHScrollPos := ScrollPos;
end;
end;
// Moves all the controls in the scrollbox except for the scrollbars we've added
{procedure TScrollBoxScrollReplacement.ScrollControls(x: Integer; y: Integer);
var
I: Integer;
begin
if (x = 0) and (y = 0) then
Exit;
// Stop the control from repaining while we're updating it
SendMessage(FScrollBox.Handle, WM_SETREDRAW, 0, 0);
FInScroll := True;
try
for I := 0 to FScrollBox.ControlCount - 1 do
begin
if IsReplacementControl(FScrollBox.Controls[I]) then
Continue;
FScrollBox.Controls[I].Left := FScrollBox.Controls[I].Left + x;
FScrollBox.Controls[I].Top := FScrollBox.Controls[I].Top + y;
end;
finally
// Turn on painting again
FInScroll := False;
SendMessage(FScrollBox.Handle, WM_SETREDRAW, 1, 0);
end;
// Redraw everything
RedrawWindow(FSCrollBox.Handle, nil, 0, RDW_ERASE or RDW_INVALIDATE or RDW_ALLCHILDREN);
end; }
procedure TScrollBoxScrollReplacement.ScrollControls(x: Integer; y: Integer);
var
I: Integer;
Control: TControl;
WinControl: TWinControl;
hWinPosInfo: HDWP;
begin
if (x = 0) and (y = 0) then
Exit;
hWinPosInfo := BeginDeferWindowPos(0);
Win32Check(hWinPosInfo<>0);
try
for I := 0 to FScrollBox.ControlCount - 1 do
begin
Control := FScrollBox.Controls[I];
if (Control = FVScrollBar) or (Control = FHScrollBar) then
Continue;
if Control is TWinControl then
begin
WinControl := FScrollBox.Controls[I] as TWinControl;
hWinPosInfo := DeferWindowPos(
hWinPosInfo,
WinControl.Handle,
0,
WinControl.Left + x,
WinControl.Top + y,
WinControl.Width,
WinControl.Height,
SWP_NOZORDER or SWP_NOOWNERZORDER or SWP_NOACTIVATE
);
Win32Check(hWinPosInfo<>0);
end
else
Control.SetBounds(Control.Left + x, Control.Top + y, Control.Width, Control.Height);
end;
finally
EndDeferWindowPos(hWinPosInfo);
end;
end;
// works out where our right most and bottom most controls are so we can set the scrollbars correctly
procedure TScrollBoxScrollReplacement.CalculateControlExtremes();
var
I: Integer;
Right: Integer;
Bottom: Integer;
begin
FMaxRight := 0;
FMaxBottom := 0;
for I := 0 to FScrollBox.ControlCount - 1 do
begin
if IsReplacementControl(FScrollBox.Controls[I]) then
Continue;
Right := FScrollBox.Controls[I].Left + FScrollBox.Controls[I].Width;
Bottom := FScrollBox.Controls[I].Top + FScrollBox.Controls[I].Height;
FMaxRight := Max(FMaxRight, Right);
FMaxBottom := Max(FMaxBottom, Bottom);
end;
end;
function TScrollBoxScrollReplacement.GetHScrollHeight: Integer;
begin
if (FHScrollBar.Visible) then
Result := FHScrollBar.Height
else
Result := 0;
end;
function TScrollBoxScrollReplacement.GetVScrollWidth: Integer;
begin
if (FVScrollBar.Visible) then
Result := FVScrollBar.Width
else
Result := 0;
end;
// Returns true if the passed control is one of the controls we've added
function TScrollBoxScrollReplacement.IsReplacementControl(
AControl: TControl): Boolean;
begin
Result := (AControl = FVScrollBar) or (AControl = FHScrollBar) or (AControl = FCornerPanel);
end;
procedure TScrollBoxScrollReplacement.BringReplacementControlsToFront;
begin
FVScrollBar.BringToFront();
FHScrollBar.BringToFront();
FCornerPanel.BringToFront();
end;
end.
I found that your code started working once I remove the two WM_SETREDRAW messages. That's your fundamental problem. You will need to remove the WM_SETREDRAW messages.
That will no doubt mean you still need to solve your problem with flickering, but that's a different problem. My quick experiments suggest that DeferWindowPos could solve that problem. For example:
procedure TScrollBoxScrollReplacement.ScrollControls(x: Integer; y: Integer);
var
I: Integer;
Control: TControl;
WinControl: TWinControl;
hWinPosInfo: HDWP;
begin
if (x = 0) and (y = 0) then
Exit;
hWinPosInfo := BeginDeferWindowPos(0);
Win32Check(hWinPosInfo<>0);
try
for I := 0 to FScrollBox.ControlCount - 1 do
begin
Control := FScrollBox.Controls[I];
if (Control = FVScrollBar) or (Control = FHScrollBar) then
Continue;
if Control is TWinControl then
begin
WinControl := FScrollBox.Controls[I] as TWinControl;
hWinPosInfo := DeferWindowPos(
hWinPosInfo,
WinControl.Handle,
0,
WinControl.Left + x,
WinControl.Top + y,
WinControl.Width,
WinControl.Height,
SWP_NOZORDER or SWP_NOOWNERZORDER or SWP_NOACTIVATE
);
Win32Check(hWinPosInfo<>0);
end
else
Control.SetBounds(Control.Left + x, Control.Top + y, Control.Width, Control.Height);
end;
finally
EndDeferWindowPos(hWinPosInfo);
end;
end;
Your non-windowed controls will still flicker, but you can make them windowed, or indeed put the whole content of the scroll box inside a windowed control. Heck, if you just did that, it would be enough to solve the problem!
For what it is worth, my trials indicate that DeferWindowPos gives smoother scrolling than WM_SETREDRAW and RedrawWindow. But these tests were hardly exhaustive and you might find different outcomes in your app.
Some asides regarding your code:
Your use of try/finally is incorrect. The pattern must be:
BeginSomething;
try
Foo;
finally
EndSomething;
end;
You get that wrong with your calls to SendMessage.
And you use an incorrect cast in InvalidateEverything. You cannot blindly cast a TControl to TWinControl. That said, that function does no good. You can remove it altogether. What it is attempting to do can be performed with a single call to Invalidate of the parent control.
You can replace your
FScrollBox.Invalidate();
with
RedrawWindow(FSCrollBox.Handle, nil, 0,
RDW_ERASE or RDW_INVALIDATE or RDW_ALLCHILDREN);
to have all controls invalidated and updated properly. RDW_ERASE is for erasing the previous positions of controls and RDW_ALLCHILDREN is for taking care of windowed controls inside. Non-win controls like labels should already be repainted because of RDW_INVALIDATE.
Although this approach may help avoiding the flicker that you observe, it may also cause some loss of smoothness of scrolling while thumb tracking. That's because the scroll position might need to be updated more often than a paint cycle is processed. To circumvent this, instead of invalidating you can update the control positions immediately:
RedrawWindow(FSCrollBox.Handle, nil, 0,
RDW_ERASE or RDW_INVALIDATE or RDW_UPDATENOW or RDW_ALLCHILDREN);

How to get a image of a panel with a combobox

I need to capture an image of panel.
The problem I am running into is that if the Panel contains a TCombobox the Text does not appear.
procedure AssignPanelImageToPicture(Panel : TPanel;Image : TImage);
var
B : TBitmap;
begin
B := TBitmap.Create;
try
B.Width := Panel.Width;
B.Height := Panel.Height;
B.Canvas.Lock;
Panel.PaintTo(B.Canvas.Handle,0,0);
B.Canvas.Unlock;
Image1.Picture.Assign(B);
finally
B.Free;
end;
end;
Using this code, I drop a panel with a TCombobox on it. Then Enter a value into the Text Property. I also drop a TImage Next two it. Then I add a button to call the above
code.
Here is the result:
Is there a better way to capture a true image of the panel.
What about using the GetDC and BitBlt functions?
procedure AssignPanelImageToPicture(Panel : TPanel;Image : TImage);
var
B : TBitmap;
SrcDC: HDC;
begin
B := TBitmap.Create;
try
B.Width := Panel.Width;
B.Height := Panel.Height;
SrcDC := GetDC(Panel.Handle);
try
BitBlt(B.Canvas.Handle, 0, 0, Panel.ClientWidth, Panel.ClientHeight, SrcDC, 0, 0, SRCCOPY);
finally
ReleaseDC(Panel.Handle, SrcDC);
end;
Image.Picture.Assign(B);
finally
B.Free;
end;
end;

Delphi: sliding (animated) panel

Is there a sliding (animated) panel component for Delphi?
For instance it can be found in Raize Components (a left panel with a "Hot Spot" or hide/show button).
I need not a resizeable panel but a panel that can slide horizontally and smoothly from the left to the right + that has a hide/show button (it's not a big deal if without that button).
Thanks!
Try NLDSideBar, a container component written by myself that is collapsable and aligned along the left or right side of its parent.
Interface:
property Align: TSideBarAlign default alLeft;
property AutoHide: Boolean default False;
property Hint: String;
property MinWidth: Integer default DefWidth;
property OnAutoHideChanged: TNotifyEvent;
property OnHide: TNotifyEvent;
property PinButtonDownHint: String;
property PinButtonUpHint: String;
property PinButtonVisible: Boolean default True;
property Resizable: Boolean default True;
property SideButtonWidth: Integer default DefSideButtonWidth;
property Caption;
property Color default clBtnFace;
property Font;
property ParentColor default False;
property ParentFont;
property ParentShowHint;
property PopupMenu;
property TabOrder;
property TabStop;
Or maybe this older version which is animated. Free to use, free to modify.
Sorry for being self-promotive, but I think it's an answer to the question.
We ended up building our own control. We could not find anything that worked quite how we wanted. It ended up not being that hard. I'm sure there are situations we are not handling correctly, but so for this is working good for us.
The code below is using cxGroupBox because we needed that look to match the rest of our application. That can be switched out for a normal GroupBox.
We are using this in two places. In one case we have a number of these panels inside a standard Delphi Flow Panel (I'm not sure what version that was added). When our DynPanel collapses everything automatically moves up and fills the space.
In the other case we have a window that is split between a main section and a toolbox. The two are separated by a standard splitter. The main window is set to align to client. When our panel collapses or expands. the splitter automatically moves and expands the main section.
We never did quite get the "container" control stuff to work so items you add to the panel can be moved outside the bounds you would normally expect in a group box. But that does not cause us any major problems so we just left it. This also does not account for DPI changes in relation to the button size. The caption will get bigger but the button will not.
unit DynPanel;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ExtCtrls, cxGroupBox;
const
DEFAULTBUTTONWIDTH = 16;
DEFAULTWIDTH = 161;
DEFAULTHEIGHT = 81;
cButtonPadding = 8;
cCollapsePadding = 3;
cCaptionPadding = ' ';
cCollapsedSize = DEFAULTBUTTONWIDTH + cCollapsePadding;
cAutoCollapseSize = DEFAULTBUTTONWIDTH + cButtonPadding;
type
TCollapseDirection = (cdUp, cdRight, cdLeft);
TMinDemension = cAutoCollapseSize..High(Integer);
TDynPanel = class(TPanel)
private
FGroupBox: TcxGroupBox;
FButtonPanel: TPanel;
FButtonImage: TImage;
FExpand: Boolean;
FOldHeight: Integer;
FOldWidth: Integer;
FCollapseDirection: TCollapseDirection;
FOrigGroupBoxCaption: String;
FAutoCollapseHeight: TMinDemension;
FAutoCollapseWidth: TMinDemension;
FButtonPadding: integer;
FCollapsePadding: integer;
FCollapsedSize: integer;
procedure SetExpand(Value: Boolean);
procedure SetGroupBoxCaption(Value: string);
procedure ButtonMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
procedure CMShowingChanged(var Message: TMessage); message CM_SHOWINGCHANGED;
procedure EnableControls(Value: Boolean);
procedure SetCollapseDirection(Value: TCollapseDirection);
procedure ConfigurePanel;
procedure SetMinHeight(Value: TMinDemension);
procedure SetMinWidth(Value: TMinDemension);
procedure UpdateImage();
protected
procedure Resize; override;
procedure ChangeScale(M, D: Integer); override;
public
constructor Create(AOwner: TComponent); override;
property OldHeight: Integer read FOldHeight write FOldHeight;
property OldWidth: Integer read FOldWidth write FOldWidth;
property GroupBox: TcxGroupBox read FGroupBox;
published
property Caption: string read FOrigGroupBoxCaption write SetGroupBoxCaption;
property Expand: Boolean read FExpand write SetExpand;
property BevelOuter default bvNone;
property CollapseDirection: TCollapseDirection read FCollapseDirection write SetCollapseDirection default cdUp;
property AutoCollapseHeight: TMinDemension read FAutoCollapseHeight write SetMinHeight default cAutoCollapseSize;
property AutoCollapseWidth: TMinDemension read FAutoCollapseWidth write SetMinWidth default cAutoCollapseSize;
end;
procedure Register;
implementation
{$R 'ButtonImages\ButtonImages.res' 'ButtonImages\ButtonImages.rc'}
uses cxEdit;
procedure Register;
begin
RegisterComponents('AgWare', [TDynPanel]);
end;
{ TDynPanel }
{
TDynPanel.Create
---------------------------------------------------------------------------
}
constructor TDynPanel.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Self.ControlStyle := ControlStyle - [csSetCaption];
Self.Width := DEFAULTWIDTH;
Self.Height := DEFAULTHEIGHT;
BevelOuter := bvNone;
FExpand := True;
FOldHeight := Self.Height;
FOldWidth := Self.Width;
FOrigGroupBoxCaption := 'AgDynPanel';
FCollapseDirection := cdUp;
FAutoCollapseHeight := cAutoCollapseSize;
FAutoCollapseWidth := cAutoCollapseSize;
FGroupBox := TcxGroupBox.Create(Self);
FGroupBox.Parent := Self;
FGroupBox.Align := alClient;
FGroupBox.Alignment := alTopLeft;
FButtonPanel := TPanel.Create(Self);
FButtonPanel.Parent := Self;
FButtonPanel.Top := 0;
FButtonPanel.Width := DEFAULTBUTTONWIDTH;
FButtonPanel.Height := DEFAULTBUTTONWIDTH;
FButtonPanel.Left := Width - DEFAULTBUTTONWIDTH - FButtonPadding;
FButtonPanel.OnMouseDown := ButtonMouseDown;
FButtonImage := TImage.Create(Self);
FButtonImage.Parent := FButtonPanel;
FButtonImage.Align := alClient;
FButtonImage.Stretch := false;
FButtonImage.Center := true;
FButtonImage.OnMouseDown := ButtonMouseDown;
UpdateImage;
// The click should also work for the entire top of the group box.
FGroupBox.OnMouseDown := ButtonMouseDown;
FGroupBox.Caption := FOrigGroupBoxCaption;
FGroupBox.Style.Font.Style := FGroupBox.Style.Font.Style + [fsBold];
FButtonPadding := cButtonPadding;
FCollapsePadding := cCollapsePadding;
FCollapsedSize := cCollapsedSize;
end;
{
TDynPanel.SetGroupBoxCaption
---------------------------------------------------------------------------
}
procedure TDynPanel.SetGroupBoxCaption(Value: String);
begin
FOrigGroupBoxCaption := Value;
ConfigurePanel;
end;
{
TDynPanel.SetMinHeight
---------------------------------------------------------------------------
}
procedure TDynPanel.SetMinHeight(Value: TMinDemension);
begin
if Value = FAutoCollapseHeight then
Exit; // >>----->
FAutoCollapseHeight := Value;
if Showing then
Resize;
end;
{
TDynPanel.SetMinWidth
---------------------------------------------------------------------------
}
procedure TDynPanel.SetMinWidth(Value: TMinDemension);
begin
if Value = FAutoCollapseWidth then
Exit; // >>----->
FAutoCollapseWidth := Value;
if Showing then
Resize;
end;
{
TDynPanel.ButtonMouseDown
---------------------------------------------------------------------------
}
procedure TDynPanel.ButtonMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
if Button mbLeft then
Exit; // >>----->
if ((FExpand = True) and (Y FCollapsePadding)) or
((FExpand = False) and (FCollapseDirection = cdLeft) and (X >----->
FExpand := Value;
//ConfigurePanel;
//--------------------------------------------------------------------------
// Set the group box size
//--------------------------------------------------------------------------
//
// I chose to do the resizing of the control here rather than in
// ConfigurePanel because if you do it there the SetBounds will call ReSize
// which will call ConfigurePanel again so that you would need to keep track
// of a boolean variable to determine if you are making recursive calls into
// ConfigurePanel. That is one reason. Another is that when the dfm values
// are streamed in and the properties get set you will resize the control
// before the actual Height and Width properties are set. This will cause
// bogus default values to be stored for FOldHeight and FOldWidth and when
// the control is displayed the dimensions will be wrong. If you size the
// control here then, on creation, Resize will not get called and the
// FOldHeight and FOldWidth values will not get saved off until
// CMShowingChanged will explicitly call ReSize after the dimensions are
// properly set. If you move this code into ConfigurePanel then when the
// caption is streamed in and set from the dfm then ConfigurePanel would get
// called, we would SetBounds there and then Resize would fire storing off the
// default invalid values for the FOld variables as mentioned above.
// Hope this makes sense. Leave the SetBounds calls here and make your life
// easier. :)
//--------------------------------------------------------------------------
// Changing to Expanded
if FExpand = True then
begin
// Up
if FCollapseDirection = cdUp then
SetBounds(Left, Top, Width, FOldHeight)
// Right
else if FCollapseDirection = cdRight then
SetBounds((Left + Width) - FOldWidth, Top, FOldWidth, Height)
// Left
else if FCollapseDirection = cdLeft then
SetBounds(Left, Top, FOldWidth, Height);
end
// Changing to Collapsed
else
begin
// Up
if FCollapseDirection = cdUp then
begin
// Reset the AutoCollapseHeight just to make sure we don't try to
// recollapse on resize.
if FAutoCollapseHeight FGroupBox) and
(Self.Controls[i] FButtonPanel) then
begin
Self.Controls[i].Enabled := Value;
Self.Controls[i].Visible := Value;
end;
end;
end;
{
TDynPanel.CMShowingChanged
---------------------------------------------------------------------------
}
procedure TDynPanel.CMShowingChanged(var Message: TMessage);
begin
inherited;
if Showing then
Resize;
end;
{
TDynPanel.Resize
---------------------------------------------------------------------------
}
procedure TDynPanel.Resize;
begin
if FExpand = True then
begin
if (FCollapseDirection = cdUp) and (Height FAutoCollapseHeight then
begin
FOldHeight := Height;
Expand := True;
end
else
Height := FCollapsedSize;
end
else if (FCollapseDirection = cdLeft) or (FCollapseDirection = cdRight) then
begin
if (Width > FAutoCollapseWidth) then
begin
FOldWidth := Width;
Expand := True;
end
else
Width := FCollapsedSize;
end;
end;
ConfigurePanel;
end;
{
TDynPanel.ChangeScale
---------------------------------------------------------------------------
}
procedure TDynPanel.ChangeScale(M, D: Integer);
begin
FAutoCollapseHeight := MulDiv(FAutoCollapseHeight, M, D);
FAutoCollapseWidth := MulDiv(FAutoCollapseWidth, M, D);
FButtonPadding := MulDiv(FButtonPadding, M, D);
FCollapsePadding := MulDiv(FCollapsePadding, M, D);
FCollapsedSize := MulDiv(FCollapsedSize, M, D);
FOldHeight := MulDiv(FOldHeight, M, D);
FOldWidth := MulDiv(FOldWidth, M, D);
// inherited will cause resize to be called. I need to update
// my internal values before that happens, otherwise I will resize based
// on the old values.
inherited;
end;
{
TDynPanel.SetCollapseDirection
---------------------------------------------------------------------------
}
procedure TDynPanel.SetCollapseDirection(Value: TCollapseDirection);
begin
if Value = FCollapseDirection then
Exit; // >>----->
FCollapseDirection := Value;
ConfigurePanel;
end;
{
TDynPanel.ConfigurePanel
---------------------------------------------------------------------------
}
procedure TDynPanel.ConfigurePanel;
begin
//--------------------------------------------------------------------------
// Set the group box style, caption alignment, caption, button position, and
// button image
//--------------------------------------------------------------------------
// Changing to Expanded
if FExpand = True then
begin
FGroupBox.Style.Color := clWhite;
// Up
if FCollapseDirection = cdUp then
begin
FGroupBox.Alignment := alTopLeft;
FGroupBox.Caption := FOrigGroupBoxCaption;
FButtonPanel.Top := 0;
FButtonPanel.Left := Width - FButtonPanel.Width - FButtonPadding;
end
// Right
else if FCollapseDirection = cdRight then
begin
FGroupBox.Alignment := alTopLeft;
FGroupBox.Caption := ' ' + FOrigGroupBoxCaption;
FButtonPanel.Top := 0;
FButtonPanel.Left := FButtonPadding;
end
// Left
else if FCollapseDirection = cdLeft then
begin
FGroupBox.Alignment := alTopLeft;
FGroupBox.Caption := FOrigGroupBoxCaption;
FButtonPanel.Top := 0;
FButtonPanel.Left := Width - FButtonPanel.Width - FButtonPadding;
end;
end
// Changing to Collapsed
else
begin
FGroupBox.Style.Color := clGradientActiveCaption;
// Up
if FCollapseDirection = cdUp then
begin
FGroupBox.Alignment := alTopLeft;
FGroupBox.Caption := FOrigGroupBoxCaption;
FButtonPanel.Top := 0;
FButtonPanel.Left := Width - FButtonPanel.Width - FButtonPadding;
end
// Right
else if FCollapseDirection = cdRight then
begin
FGroupBox.Alignment := alRightTop;
FGroupBox.Caption := ' ' + FOrigGroupBoxCaption;
FButtonPanel.Top := FButtonPadding;
FButtonPanel.Left := FCollapsePadding;
end
// Left
else if FCollapseDirection = cdLeft then
begin
FGroupBox.Alignment := alLeftTop;
FGroupBox.Caption := FOrigGroupBoxCaption + ' ';
FButtonPanel.Top := FButtonPadding;
FButtonPanel.Left := 0;
end;
end;
UpdateImage;
// Now draw the button and invalidate Self
Self.Invalidate;
end;
{
TDynPanel.UpdateImage
---------------------------------------------------------------------------
}
procedure TDynPanel.UpdateImage();
begin
case FCollapseDirection of
cdUp:
begin
if FExpand = true then
FButtonImage.Picture.Bitmap.LoadFromResourceName(HInstance, 'ButtonImageUp')
else
FButtonImage.Picture.Bitmap.LoadFromResourceName(HInstance, 'ButtonImageDown');
end;
cdLeft:
begin
if FExpand = true then
FButtonImage.Picture.Bitmap.LoadFromResourceName(HInstance, 'ButtonImageLeft')
else
FButtonImage.Picture.Bitmap.LoadFromResourceName(HInstance, 'ButtonImageRight');
end;
cdRight:
begin
if FExpand = true then
FButtonImage.Picture.Bitmap.LoadFromResourceName(HInstance, 'ButtonImageRight')
else
FButtonImage.Picture.Bitmap.LoadFromResourceName(HInstance, 'ButtonImageLeft');
end;
end;
end;
end.
Close to the Left
Close to the Top
The new Delphi version will include such kind of sliding panels ( trough the integration of FireMonkey, formely vgScene/dxScene ). You'll just have to click on height or position props and an option will allow to create a animation for this, with various option ( interpolation kind, duration etc).
Since version 2009, there is a TCategoryPanelGroup where you add TCategoryPanel.
FoldingPanel
See FoldingPanel v1.3 here: http://www.torry.net/authorsmore.php?id=2386
I used it for years.
It comes with nice chevron bitmap too.
Small issue: it does not support composite controls (like TLabeledEdit).
Advantage: The component comes as a single PAS file (easy to install into the Palette). They say that it is for Delphi 5 but I have it installed in XE7 and works without problems (which indicates quality).
Freeware
TSplitView
If you have a newer version of Delphi (like Tokyo) you can use TSplitView.
Note: The Align property it missing. And at the beginning it might seems that it can only be aligned to Left. But it is not true. Instead of an Align property it has a Placement property (with two values: svpRight / svpLeft).
Note: It has some small glitches related to control size/placement.
Note: It is not (NOT EVEN BY FAR) as complete as FoldingPanel. You still have to write some cod eto implement some kind of chevron to collapse/expend the panel.
https://www.youtube.com/watch?v=3hUG8o7PpCU
Freeware (if you have Delphi Tokyo).
TCategoryPanelGroup
Also take a look at TCategoryPanelGroup. It might or might not work, depending on what you need it for.
Freeware (if you have Delphi XE7)

Resources