如何限制窗体改变大小时按照某种比例? (100分)

  • 主题发起人 主题发起人 叮叮当当
  • 开始时间 开始时间

叮叮当当

Unregistered / Unconfirmed
GUEST, unregistred user!
使窗体改变大小时Width和Height保持某种比例(比如4:3),即截获窗体改变大小前的消息,在消息处理中将窗体宽度和高度的增减按一定比例进行。显然在窗体的OnResize事件中简单地设置Width和Height的比例是不行的,那样的话将使窗体改变大小时产生难看的抖动效果。

应该拦截窗体的哪个消息?请为这个简单功能给出例程。谢谢!
 
拦截WM_SIZE一样会出现抖动
type
TForm1 = class(TForm)
private
{ Private declarations }
procedure ReSize(var Msg: TMessage); message WM_SIZE;
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.dfm}

{ TForm1 }


procedure TForm1.ReSize(var Msg: TMessage);
begin
form1.Width := form1.Height div 2;
end;
 
在form的onCanResize事件中写程序:
procedure TForm1.FormCanResize(Sender: TObject; var NewWidth,
NewHeight: Integer; var Resize: Boolean);
begin
NewHeight:=NewWidth div 2
end;
就可以了,这种做法的好处是不会造成抖动
 
TO: 方栩

谢谢,方法是没错了,但是按你的程序,窗体就只能水平拉伸而不能垂直拉伸了。怎么办才好?
 
哇靠!你不会宽度除以2啊
 
To: 完颜康

方栩的程序是让高度随宽度变化,这样水平拉伸窗体改变大小的时候是没有问题的。但是当上下(垂直)拉伸窗体的时候问题就出来了,你可以自己试一下那段代码。由于限定了高度随宽度改变,高度主动改变的情况相当于就被屏蔽了。
 
我试了:

procedure TForm1.FormCanResize(Sender: TObject; var NewWidth,
NewHeight: Integer; var Resize: Boolean);
begin
if NewWidth <> Width then
NewHeight := NewWidth div 2
else if NewHeight <> Height then
NewWidth := NewHeight * 2;
end;

也是不行的,垂直拉伸时抖动得厉害!
 
procedure TForm1.FormCanResize(Sender: TObject; var NewWidth,
NewHeight: Integer; var Resize: Boolean);
var
k:real;
x1,y1:integer;
begin
k:=0.5;
x1:=newwidth;
y1:=newheight;
if width<>x1 then
NewHeight:=Trunc(x1*k)
else
if height<>y1 then
NewWidth:=Trunc(y1/k);
end;
 
To: daxia
不行,垂直拉伸窗体时还是抖动得很厉害。
 
我认为对于普通的窗体界面的程序来说,在重绘时产生抖动现象是难以避免的,窗体越复杂,
重绘时的抖动现象越明显。这涉及Windows GUI机制方面的问题,现状是难以改变的,除非
所有组件都采用图形方式,用绘图函数画上去,或者用DirectX也许效果会更好,当然,这
是不太现实的。还有一个办法可以部分的改善问题——用最快的CPU和显卡。^_^
 
To: Sachow
我明白你的意思,但请不要误解,我所说的“抖动”当然不是这种正常的“抖动”啦。
 
我在DELPHI6上试了,没有感到抖动呀?
 
我的也没有抖动,你的窗体设置有问题吧?
 
To: tanhua、jstkof
你们不要光横着拉呀,竖着拉拉看。

To: daxia
“windows的动画显示菜单和工具提示”默认是打开的吧?有没有什么解决办法?我看到别人做的锁定比例缩放窗体(多为视频播放软件)都是没这种问题的啊。
 
当你在重新计算你的窗口的时候屏蔽掉 Form 的 WM_PAINT 事件,计算完了在 Update
 
应该是拖动窗口时显示其内容。所以,最笨的办法是把它关掉。
 
var b:boolean;
b:=false;
procedure TForm1.FormCanResize(Sender: TObject; var NewWidth,
NewHeight: Integer; var Resize: Boolean);
begin
if NewHeight <> Height then
if b then NewHeight := NewWidth div 2
else NewWidth := NewHeight * 2
else if newwidth<>width then
begin
b:=true;
NewHeight := NewWidth div 2;
end;
end;
还有一些问题。比如,我不知道应该在哪里重设b:=false;显然,在onsize中
是不行的。还有,垂直拉动时最后要反弹一下,不知道是什么缘故?
 
解决了。
var a,b:boolean;
a:=false;b:=false;
procedure TForm1.FormCanResize(Sender: TObject; var NewWidth,
NewHeight: Integer; var Resize: Boolean);
begin
if NewHeight <> Height then
if b then NewHeight := trunc(NewWidth/1.5)
else
begin
a:=true;
NewWidth := trunc(NewHeight * 1.5);
end
else if newwidth<>width then
if a then NewWidth := trunc(NewHeight * 1.5)
else
begin
b:=true;
NewHeight := trunc(NewWidth/1.5);
end;
end;
procedure WMEXITSIZEMOVE(var Message: TMessage);
message WM_EXITSIZEMOVE;
procedure TForm1.WMEXITSIZEMOVE(var Message: TMessage);
begin
a:=false;
b:=false;
end;
感谢张工,WM_EXITSIZEMOVE这条消息是他提供的。
在高手眼里,我的程序可能有点笨。我的水平也就这样了,
请大家多多包涵。
 
这主要是你把windows的"拖动时显示窗口的内容"打开了这时你改变height和width时就会
重复发出窗口改变消息所以就抖动的历害。
 
谢谢jstkof。
 
后退
顶部