Dynamic resizing of frames and forms in Delphi - delphi

I have a TFrame descendent that has on it a sizable panel which is a third-party component (TLMDSimplePanel)). The sizing on that panel works great, but I want the frame it is contained in to resize dynamically when the user changes the size of the panel. (The panel has a little sizing thumb grip on it that the user can just click and drag with the mouse).
The code for this frame is below:
unit SizeableFrame;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, TcmBaseFrameFrame, LMDCustomControl, LMDCustomPanel, LMDCustomBevelPanel,
LMDSimplePanel, StdCtrls;
type
TcmSizeableFrame = class(TcmBaseFrame)
LMDSimplePanel1: TLMDSimplePanel;
Memo1: TMemo;
Memo2: TMemo;
procedure LMDSimplePanel1Resize(Sender: TObject);
procedure FrameCanResize(Sender: TObject; var NewWidth, NewHeight: Integer;
var Resize: Boolean);
private
{ Private declarations }
public
{ Public declarations }
end;
var
cmSizeableFrame: TcmSizeableFrame;
implementation
{$R *.dfm}
procedure TcmSizeableFrame.FrameCanResize(Sender: TObject; var NewWidth,
NewHeight: Integer; var Resize: Boolean);
begin
inherited;
Resize := True;
end;
procedure TcmSizeableFrame.LMDSimplePanel1Resize(Sender: TObject);
const
ExpandByPixels = 60;
var
MyFrame : TFrame;
begin
inherited;
Self.Height := LMDSimplePanel1.Height + ExpandByPixels;
Self.Width := LMDSimplePanel1.Width + ExpandByPixels;
end;
end.
It works wonderfully, if the user is shrinking the the size of the frame, but if they try to stretch it larger than its original bounds, they can only expand it to what appears to be its original size + ExpandByPixels, after which the user cannot continue to fluidly drag it to a larger size.
If they stop, and then click and drag the size grip again, they can then drag it out to a larger size, but again this is constrained in the same way (current size + ExpandByPixels = the outer bound). They can repeat this cycle endlessly, expanding the frame to any size, but not fluidly in one mouse movement, which is what I want.
I have tested this same problem against TForm descendents as well, and get the same symptoms.
What am I missing here?
Thanks in advance for any and all help. :-)

Have you tried to set the Frame.Autosize to true?
Or you would need to resize the frame when the mouse moves. So that the contained object could expand while staying within the boundaries of the container.
Update: some simple code that works with a regular TPanel to resize horizontally...
type
TFrame5 = class(TFrame)
Panel1: TPanel;
procedure Panel1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
procedure Panel1Resize(Sender: TObject);
end;
implementation
{$R *.dfm}
procedure TFrame5.Panel1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
begin
with Sender as TPanel do
if ssLeft in Shift then
begin
Width := X;
end;
end;
procedure TFrame5.Panel1Resize(Sender: TObject);
begin
with Sender as TPanel do
begin
(Parent as TFrame).Width := Width + 2*Left;
end;
end;

Related

Delphi change color of main menu

I am creating my own OnAdvancedDrawItem to change the color of the MainMenu. It works well but I get an annoying white line at the bottom.
It disappears when running the mouse over the menu but comes back when another application is selected. How can I get rid of it?
Here is my basic code for the background coloring.
unit MenMain;
interface
uses Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,Dialogs, Menus, ImgList, StdCtrls;
type
TForm1 = class(TForm)
MainMenu1: TMainMenu;
File2: TMenuItem;
Edit1: TMenuItem;
Window1: TMenuItem;
procedure Window1AdvancedDrawItem(Sender: TObject; ACanvas: TCanvas; ARect: TRect; State: TOwnerDrawState);
private
public
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.Window1AdvancedDrawItem(Sender: TObject; ACanvas: TCanvas; ARect: TRect; State: TOwnerDrawState);
begin
with TMenuItem(Sender) do
begin
with ACanvas do
begin
Brush.Color := clMoneyGreen;
Inc(ARect.Bottom,1);
FillRect(ARect);
Font.Color := clBlue;
DrawText(ACanvas.Handle, PChar(Caption),Length(Caption),ARect, DT_SINGLELINE or DT_VCENTER);
end;
end;
end;
end.
The ARect parameter of the OnAdvancedDrawItem event handler is the rcItem of the DRAWITEMSTRUCT that's passed to the WM_DRAWITEM message. The documentation has this to say about the rectangle:
A rectangle that defines the boundaries of the control to be drawn.
This rectangle is in the device context specified by the hDC member.
The system automatically clips anything that the owner window draws in
the device context for combo boxes, list boxes, and buttons, but does
not clip menu items. When drawing menu items, the owner window must
not draw outside the boundaries of the rectangle defined by the rcItem
member.
So although the device context is not clipped to the rectangle, you're responsible for not drawing outside of it. That happens when you execute Inc(ARect.Bottom,1); before filling the rectangle.
You can change the color of the grey area. Use this in OnCreate and OnCanResize
global var - fMenuBrushHandle: THandle;
var
lMenuInfo: TMenuInfo;
lMenuColor: TColor;
begin
lMenuColor := clRed;
DeleteObject(fMenuBrushHandle);
fMenuBrushHandle := CreateSolidBrush(ColorToRGB(lMenuColor));
FillChar(lMenuInfo, SizeOf(lMenuInfo), 0);
lMenuInfo.cbSize := SizeOf(lMenuInfo);
lMenuInfo.hbrBack := fMenuBrushHandle;
lMenuInfo.fMask := MIM_BACKGROUND;
SetMenuInfo(MainMenu1.Handle, lMenuInfo);
end;
or
global var - FBrush: TBrush;
var
lMenuInfo: TMenuInfo;
begin
if not Assigned(FBrush) then
FBrush := TBrush.Create;
FBrush.Color := clRed;
FBrush.Style := bsSolid;
lMenuInfo.cbSize := SizeOf(lMenuInfo);
lMenuInfo.fMask := MIM_BACKGROUND;
lMenuInfo.hbrBack := FBrush.Handle;
SetMenuInfo(MainMenu1.Handle, lMenuInfo);
end;
or even draw bitmap
global var
fMenuHandle:THandle;
fBitmap:Tbitmap;
var
lMenuInfo:TMenuInfo;
begin
if Assigned(fBitmap) then
fBitmap.Free;
fBitmap:=TBitmap.Create;
fBitmap.Width:=21;
fBitmap.Height:=Form1.Width;
DeleteObject(fMenuHandle);
fMenuHandle:=CreatePatternBrush(fBitmap.Handle);
Fillchar(lMenuInfo,SizeOf(lMenuInfo),0);
lMenuInfo.cbSize:=SizeOf(lMenuInfo);
lMenuInfo.fMask:=MIM_BACKGROUND;
lMenuInfo.hbrBack:=fMenuHandle;
SetMenuInfo(MainMenu1.Handle,lMenuInfo);
end;

Getting the MaxLen parameter to use with MinimizeName

I am trying to put a very long filename on a TLabel using the MinimizeName function from Vcl.FileCtrl unit but I can't figure out how to get the MaxLen parameter used by the function
If I hardcode a value I can see a valid result. But since the form can be resized I would like it to be dynamic = changing on resize event.
Some of the things I have tried is
lblLicenseFile.Width // string is too long
lblLicenseFile.Width - 10 //string is too long
Trunc(lblLicenseFile.Width / lblLicenseFile.Font.Size) // string is very short
There must be some method of calculating this number of pixels
MinimizeName(const Filename: TFileName; Canvas: TCanvas; MaxLen: Integer): TFileName;
MaxLen is the lenght, in pixels, available for drawing the file name on the canvas.
To let the label control automatically shorten path, you can set the AutoSize property to False and the EllipsisPosition property to epPathEllipsis if you're using a recent version of Delphi.
To get rid of dependencies of form resizing, resize could also happen if you using e.g. splitters, you can override the CanResize Event to adapt your caption.
as example:
unit Unit3;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls;
type
TLabel = Class(StdCtrls.TLabel)
private
FFullCaption: String;
procedure SetFullname(const Value: String);
published
function CanResize(var NewWidth, NewHeight: Integer): Boolean; override;
property FullCaption: String read FFullCaption Write SetFullname;
End;
TForm3 = class(TForm)
FileNameLabel: TLabel;
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
{ Private-Deklarationen }
public
{ Public-Deklarationen }
end;
var
Form3: TForm3;
implementation
uses FileCtrl;
{$R *.dfm}
procedure TForm3.Button1Click(Sender: TObject);
begin
FileNameLabel.FullCaption := 'C:\ADirectory\ASubDirectory\ASubSubDirectory\AFileN.ame'
end;
{ TLabel }
function TLabel.CanResize(var NewWidth, NewHeight: Integer): Boolean;
begin
inherited;
if Assigned(Parent) then
Caption := MinimizeName(FFullCaption, Canvas, NewWidth)
end;
procedure TLabel.SetFullname(const Value: String);
begin
FFullCaption := Value;
Caption := MinimizeName(FFullCaption, Canvas, Width)
end;
end.

Delphi local net app

Trying to learn how to make server-client apps and stuff like. I trying to draw circles(on mouse click) in all clients so this is how i trying to do that. But it's not working - no errors but form is empty. What i need to fix?
Client code
unit Client;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ExtCtrls, {Figure, Ball,} IdBaseComponent, IdComponent,
IdTCPConnection, IdTCPClient, ScktComp;
type
TForm1 = class(TForm)
Timer1: TTimer;
Button1: TButton;
ClientSocket: TClientSocket;
procedure FormCreate(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
private
public
{ Public declarations }
end;
var
Form1: TForm1;
f:boolean;
p:MyPoint;
s:MyPoint;
z:TCanvas;
obj: MyFigure;
pX, pY:Integer;
myBuf: array[1..32] of Integer;
dataBuf: array[1..32] of Integer;
implementation
{$R *.dfm}
procedure TForm1.FormCreate(Sender: TObject);
begin
Timer1.Enabled:=false;
Timer1.Interval:=5;
z:=Form1.Canvas;//TCanvas.Create;
Button1.Caption:='Пуск';
f:=false;
ClientSocket.Port:=1234;
ClientSocket.Active:= False;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if not f then
begin
Timer1.Enabled:=true;
Button1.Caption:='Стоп';
f:=not f;
end
else
begin
Timer1.Enabled:=false;
Button1.Caption:='Пуск';
ClientSocket.Active:= True;
f:=not f;
end;
end;
procedure TForm1.Timer1Timer(Sender: TObject);
begin
//z.Lock;
//z.Brush.Color:=ClWhite;
//z.FillRect(Canvas.ClipRect);
//obj.Draw(z);
if ClientSocket.Active then
ClientSocket.Socket.ReceiveBuf(dataBuf, 32);
z.Brush.Color:=ClRed;
z.Ellipse(dataBuf[1] + 10, dataBuf[2] + 10,dataBuf[1] - 10, dataBuf[2] - 10);
//z.Unlock;
end;
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
ClientSocket.Active := false;
end;
procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
myBuf[1]:=X;
myBuf[2]:=Y;
if ClientSocket.Active then
ClientSocket.Socket.SendBuf(myBuf, 32);
end;
end.
Server
unit ServerProject;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ScktComp;
type
TForm1 = class(TForm)
ServerSocket1: TServerSocket;
procedure FormCreate(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure ServerSocket1ClientRead(Sender: TObject;
Socket: TCustomWinSocket);
procedure ServerSocket1ClientWrite(Sender: TObject;
Socket: TCustomWinSocket);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
sBufer : array [1..32] of Integer;
implementation
{$R *.dfm}
procedure TForm1.FormCreate(Sender: TObject);
begin
ServerSocket1.Port:=1234;
ServerSocket1.Active := True;
end;
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
ServerSocket1.Active := false;
end;
procedure TForm1.ServerSocket1ClientRead(Sender: TObject;
Socket: TCustomWinSocket);
var
i:integer;
begin
for i := 0 to ServerSocket1.Socket.ActiveConnections-1 do
begin
with ServerSocket1.Socket.Connections[i] do
begin
ReceiveBuf(sBufer, 32);
end;
end;
end;
procedure TForm1.ServerSocket1ClientWrite(Sender: TObject;
Socket: TCustomWinSocket);
var
i:integer;
begin
for i := 0 to ServerSocket1.Socket.ActiveConnections-1 do
begin
with ServerSocket1.Socket.Connections[i] do
begin
SendBuf(sBufer, 32);
end;
end;
end;
end.
Your painting code is in the wrong place and is painting to the wrong thing. In Windows programs you are meant to paint in response to a WM_PAINT message. You are not doing so. What's more, you have to paint on a device context that is provided by a call to BeginPaint.
The VCL wraps all those details up for you, but you still need to follow the rules. In your case I recommend that you add a TPaintBox component to your form. Then implement an OnPaint event handler for the paint box. Finally, whenever you wish to repaint the paint box, for example on a timer, call the Invalidate method of the paint box.
I suspect that you want your each new ellipse to be drawn in addition to the earlier drawn ellipses. In which case you are probably best served by drawing them to an off-screen bitmap first and then, when you come to paint to the paint box, draw that bitmap on the paint box. The point is that a window needs to be able to re-paint itself in its entirety. When you paint to a screen device, what you painted is lost the next time that window needs to be painted. So it's the responsibility of the application to be able to paint its entire self at any point, if it is asked.
More generally I urge you to stop using global variables. They will cause you no end of trouble. Prefer local variables wherever possible. If you need state to persist between different method calls, use member variables. The guiding principle is to use the narrowest scope possible.
Your current design uses a timer to poll for new data. That's a very poor approach. The most efficient and effective approach is to use synchronous blocking communication. Indy takes that approach. Windows sockets components instead tend to be used in an asynchronous mode. Irrespective of the relative merits of these two approaches, you should not be polling on a timer. If you do use asynchronous communication, then respond to new data by handling an event rather than polling.
Your program is currently trying to mix together GDI painting, and network communication. I suggest that you attempt to get on top of these concepts one at a time. Learn how to paint without the distraction of communication. Then when you have cracked painting, try to bring in the communication aspect.

How to drag a thumbnail from JvtThumbview?

I am writing a WYSIWYG type of editor program in which the user can drag image thumbnails onto an editor surface (TPanel) and then create a PDF by rendering the editor surface onto the PDF.
On my TPanel, I have a TImage which the user can resize and move. I am using TSizeCtrl for this.
I have a TJvThumbview which is being loaded with images from a disk folder.
I want to accomplish drag-drop from the JvThumbview onto the TImage - but cannot do this.
Please can someone detail how I would accomplish this?
Thanks so much in advance.
I cannot resist.
My demo project consists of:
one TJvThumbView and
one TImage
Dragging is achieved by:
starting the drag operation when the user mouse-downs on the thumb view,
managing the dragged image by a TDragObject derivative,
drawing the dragged image when the drag object says the drag operation ended on the TImage.
This is how it could look like:
unit Unit1;
interface
uses
Classes, Graphics, Controls, Forms, JvExForms, JvBaseThumbnail, JvThumbViews,
ExtCtrls;
type
TMyDragObject = class(TDragControlObjectEx)
private
FDragImages: TDragImageList;
FPictureToDrag: TPicture;
protected
function GetDragImages: TDragImageList; override;
procedure Finished(Target: TObject; X, Y: Integer;
Accepted: Boolean); override;
public
constructor CreateFromThumbView(ThumbView: TJvThumbView);
destructor Destroy; override;
end;
TForm1 = class(TForm)
JvThumbView1: TJvThumbView;
Image1: TImage;
procedure FormCreate(Sender: TObject);
procedure JvThumbView1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure JvThumbView1StartDrag(Sender: TObject;
var DragObject: TDragObject);
procedure Image1DragOver(Sender, Source: TObject; X, Y: Integer;
State: TDragState; var Accept: Boolean);
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.FormCreate(Sender: TObject);
begin
// Fill our image list with arbitrary images
if JvThumbView1.Directory = '' then
JvThumbView1.Directory := 'C:\Users\Public\Pictures\Sample Pictures';
// Style all controls for showing the drag image if Delphi version is D7 or
// lower. See also comment in TMyDragObject.CreateFromThumbView
JvThumbView1.ControlStyle := JvThumbView1.ControlStyle +
[csDisplayDragImage];
Image1.ControlStyle := Image1.ControlStyle + [csDisplayDragImage];
ControlStyle := ControlStyle + [csDisplayDragImage];
end;
procedure TForm1.Image1DragOver(Sender, Source: TObject; X, Y: Integer;
State: TDragState; var Accept: Boolean);
begin
// The destination image component accepts all drag operations
Accept := True;
end;
procedure TForm1.JvThumbView1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
// If mouse down on a thumb...
if JvThumbView1.SelectedFile <> '' then
// then let's start dragging
JvThumbView1.BeginDrag(False, Mouse.DragThreshold);
end;
procedure TForm1.JvThumbView1StartDrag(Sender: TObject;
var DragObject: TDragObject);
begin
// DragObject will automatically be destroyed when necessary when it's
// derived from TDragControlObjectEx
DragObject := TMyDragObject.CreateFromThumbView(JvThumbView1);
end;
{ TMyDragObject }
const
DragImageSize = 100;
constructor TMyDragObject.CreateFromThumbView(ThumbView: TJvThumbView);
begin
inherited Create(ThumbView);
// This is the picture the user will drag around
FPictureToDrag := TPicture.Create;
FPictureToDrag.LoadFromFile(ThumbView.SelectedFile);
// We want a nice drag image, but this property is only available in >D7
{ AlwaysShowDragImages := True; }
end;
destructor TMyDragObject.Destroy;
begin
FDragImages.Free;
FPictureToDrag.Free;
inherited Destroy;
end;
procedure TMyDragObject.Finished(Target: TObject; X, Y: Integer;
Accepted: Boolean);
begin
// Finished dragging
inherited Finished(Target, X, Y, Accepted);
// If we are over an Image component, then draw the picture
if Accepted and (Target is TImage) then
TImage(Target).Canvas.StretchDraw(Bounds(X, Y, DragImageSize,
DragImageSize), FPictureToDrag.Graphic);
end;
function TMyDragObject.GetDragImages: TDragImageList;
var
DragImage: TBitmap;
begin
if FDragImages = nil then
begin
FDragImages := TDragImageList.Create(nil);
// Set dimensions of drag image list
FDragImages.Width := DragImageSize;
FDragImages.Height := DragImageSize;
// Prepare drag image
DragImage:= TBitmap.Create;
try
DragImage.Width := DragImageSize;
DragImage.Height := DragImageSize;
DragImage.Canvas.StretchDraw(Rect(0, 0, DragImage.Width,
DragImage.Height), FPictureToDrag.Graphic);
FDragImages.AddMasked(DragImage, clWhite);
finally
DragImage.Free;
end;
end;
Result := FDragImages;
end;
end.

DBGrid scroll page instead of row

Well I have an issue with DBGrid vertical scrolling. When I scroll it vertically with mousewheel or vertical scrollbar it moves selected row up and down. I want to make it scroll not selected row but entire grid. Just like it works in Microsoft Excel for example (just to let you know what I mean). Any suggestions?
Well, almost what I'd like to see. Found the post of hanuleye on swissdelhicenter.ch. This code let's you freely scroll DBGrid with mouse wheel.
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, Grids, DBGrids, DB, DBTables;
type
TForm1 = class(TForm)
DataSource1: TDataSource;
Table1: TTable;
DBGrid1: TDBGrid;
procedure FormCreate(Sender: TObject);
procedure DBGridMouseWheel(Sender: TObject; Shift: TShiftState;
WheelDelta: Integer; MousePos: TPoint; var Handled: Boolean);
private
{ Private declarations }
public
{ Public declarations }
end;
TWheelDBGrid = class(TDBGrid)
public
property OnMouseWheel;
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.FormCreate(Sender: TObject);
begin
TWheelDBGrid(DBGrid1).OnMouseWheel := DBGridMouseWheel;
end;
function GetNumScrollLines: Integer;
begin
SystemParametersInfo(SPI_GETWHEELSCROLLLINES, 0, #Result, 0);
end;
procedure TForm1.DBGridMouseWheel(Sender: TObject; Shift: TShiftState;
WheelDelta: Integer; MousePos: TPoint; var Handled: Boolean);
var
Direction: Shortint;
begin
Direction := 1;
if WheelDelta = 0 then
Exit
else if WheelDelta > 0 then
Direction := -1;
with TDBGrid(Sender) do
begin
if Assigned(DataSource) and Assigned(DataSource.DataSet) then
DataSource.DataSet.MoveBy(Direction * GetNumScrollLines);
Invalidate;
end;
end;
end.
I don't think that's possible, since to me it seems that scrollbar on DBGrids are more like a progress indicator rather than a scroll. It behaves differently from the scrolls in ListViews where you scroll "pages", in the db controls even if you move up or down a single row the scrollbar changes to reflect the "current row"/"total rows" fraction

Resources