J
jxc163
Unregistered / Unconfirmed
GUEST, unregistred user!
关于背景图片的问题？
1、 如何使用JPG图片来做一个MDI窗体的背景，并实现平铺、拉伸以及居中等效果？
2、 如下的代码可以完成BMP图片做背景的问题，但在子窗体的大小变化时会引起窗体的抖动，怎样才能解决这个问题？引用一段别人的作品：
unit MainFrm;
interface
uses Windows, SysUtils, Classes, Graphics, Forms, Controls, Menus,
StdCtrls, Dialogs, Buttons, Messages, ExtCtrls, JPeg;
type
TMainForm = class(TForm)
mmMain: TMainMenu;
mmifile: TMenuItem;
mmiNew: TMenuItem;
mmiClose: TMenuItem;
N1: TMenuItem;
mmiExit: TMenuItem;
mmiImage: TMenuItem;
mmiTile: TMenuItem;
mmiCenter: TMenuItem;
mmiStretch: TMenuItem;
imgMain: TImage;
procedure mmiNewClick(Sender: TObject);
procedure mmiCloseClick(Sender: TObject);
procedure mmiExitClick(Sender: TObject);
procedure mmiTileClick(Sender: TObject);
private
FOldClientProc,
FNewClientProc: TFarProc;
FDrawDC: hDC;
procedure CreateMDIChild(const Name: string);
procedure ClientWndProc(var Message: TMessage);
procedure DrawStretched;
procedure DrawCentered;
procedure DrawTiled;
protected
procedure CreateWnd; override;
end;
var
MainForm: TMainForm;
implementation
uses MdiChildFrm;
{$R *.DFM}
procedure TMainForm.CreateWnd;
begin
inherited CreateWnd;
// Turn the ClientWndProc method into a valid window procedure
FNewClientProc := MakeObjectInstance(ClientWndProc);
// Get a pointer to the original window procedure
FOldClientProc := Pointer(GetWindowLong(ClientHandle, GWL_WNDPROC));
// Set ClientWndProc as the new window procedure
SetWindowLong(ClientHandle, GWL_WNDPROC, LongInt(FNewClientProc));
end;
procedure TMainForm.DrawCentered;
{ This procedure centers the image on the form's client area }
var
CR: TRect;
begin
GetWindowRect(ClientHandle, CR);
with imgMain do
BitBlt(FDrawDC, ((CR.Right - CR.Left) - Picture.Width) div 2,
((CR.Bottom - CR.Top) - Picture.Height) div 2,
Picture.Graphic.Width, Picture.Graphic.Height,
Picture.Bitmap.Canvas.Handle, 0, 0, SRCCOPY);
end;
procedure TMainForm.DrawStretched;
{ This procedure stretches the image on the form's client area }
var
CR: TRect;
begin
GetWindowRect(ClientHandle, CR);
StretchBlt(FDrawDC, 0, 0, CR.Right, CR.Bottom,
imgMain.Picture.Bitmap.Canvas.Handle, 0, 0,
imgMain.Picture.Width, imgMain.Picture.Height, SRCCOPY);
end;
procedure TMainForm.DrawTiled;
{ This procedure tiles the image on the form's client area }
var
Row, Col: Integer;
CR, IR: TRect;
NumRows, NumCols: Integer;
begin
GetWindowRect(ClientHandle, CR);
IR := imgMain.ClientRect;
NumRows := CR.Bottom div IR.Bottom;
NumCols := CR.Right div IR.Right;
with imgMain do
for Row := 0 to NumRows+1 do
for Col := 0 to NumCols+1 do
BitBlt(FDrawDC, Col * Picture.Width, Row * Picture.Height,
Picture.Width, Picture.Height, Picture.Bitmap.Canvas.Handle,
0, 0, SRCCOPY);
end;
procedure TMainForm.ClientWndProc(var Message: TMessage);
begin
case Message.Msg of
// Capture the WM_ERASEBKGND messages and perform the client area drawing
WM_ERASEBKGND:
begin
CallWindowProc(FOldClientProc, ClientHandle, Message.Msg, Message.wParam,
Message.lParam);
FDrawDC := TWMEraseBkGnd(Message).DC;
if mmiStretch.Checked then
DrawStretched
else if mmiCenter.Checked then
DrawCentered
else DrawTiled;
Message.Result := 1;
end;
{ Capture the scrolling messages and ensure the client area
is redrawn by calling InvalidateRect }
WM_VSCROLL, WM_HSCROLL:
begin
Message.Result := CallWindowProc(FOldClientProc, ClientHandle, Message.Msg,
Message.wParam, Message.lParam);
InvalidateRect(ClientHandle, nil, True);
end;
else
// By Default, call the original window procedure
Message.Result := CallWindowProc(FOldClientProc, ClientHandle, Message.Msg,
Message.wParam, Message.lParam);
end; { case }
end;
procedure TMainForm.CreateMDIChild(const Name: string);
var
MdiChild: TMDIChildForm;
begin
MdiChild := TMDIChildForm.Create(Application);
MdiChild.Caption := Name;
end;
procedure TMainForm.mmiNewClick(Sender: TObject);
begin
CreateMDIChild('NONAME' + IntToStr(MDIChildCount + 1));
end;
procedure TMainForm.mmiCloseClick(Sender: TObject);
begin
if ActiveMDIChild <> nil then
ActiveMDIChild.Close;
end;
procedure TMainForm.mmiExitClick(Sender: TObject);
begin
Close;
end;
procedure TMainForm.mmiTileClick(Sender: TObject);
begin
mmiTile.Checked := false;
mmiCenter.Checked := False;
mmiStretch.Checked := False;
{ Set the Checked property for the menu item which invoked }
{ this event handler to Checked }
if Sender is TMenuItem then
TMenuItem(Sender).Checked := not TMenuItem(Sender).Checked;
{ Redraw the client area of the form }
InvalidateRect(ClientHandle, nil, True);
end;
end.
object mmMain: TMainMenu
Left = 404
Top = 36
object mmifile: TMenuItem
Caption = '&File'
Hint = 'File related commands'
object mmiNew: TMenuItem
Caption = '&New'
Hint = 'Create a new file'
onClick = mmiNewClick
end
object mmiClose: TMenuItem
Caption = '&Close'
Hint = 'Close current file'
onClick = mmiCloseClick
end
object N1: TMenuItem
Caption = '-'
end
object mmiExit: TMenuItem
Caption = 'E&xit'
Hint = 'Exit the application'
onClick = mmiExitClick
end
end
object mmiImage: TMenuItem
Caption = '&Image'
object mmiTile: TMenuItem
Caption = '&Tile'
GroupIndex = 1
onClick = mmiTileClick
end
object mmiCenter: TMenuItem
Caption = '&Center'
GroupIndex = 1
onClick = mmiTileClick
end
object mmiStretch: TMenuItem
Caption = '&Stretch'
Checked = True
GroupIndex = 1
onClick = mmiTileClick
end
end
end
3、在一个PANEL上使用CANVAS来实现背景设置的预览功能，通过按钮可以正常实现，但在程序失去焦点后再得到焦点时不能出现选定的功能，以及在窗体的创建时也不能出现选定的功能？
窗体设置:
object Form1: TForm1
Left = 176
Top = 169
Width = 334
Height = 197
Caption = 'Form1'
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
OldCreateOrder = False
OnCreate = FormCreate
PixelsPerInch = 96
TextHeight = 13
object Bevel1: TBevel
Left = 16
Top = 24
Width = 172
Height = 133
Shape = bsFrame
end
object Panel1: TPanel
Left = 21
Top = 30
Width = 160
Height = 121
BevelOuter = bvNone
Color = clBackground
TabOrder = 0
end
object TPanel
Left = 192
Top = 24
Width = 113
Height = 103
BevelOuter = bvLowered
TabOrder = 1
object RBCenter: TRadioButton
Tag = 4
Left = 14
Top = 10
Width = 79
Height = 17
Caption = '居中（&E）'
TabOrder = 0
onClick = RBCenterClick
end
object RBExpand: TRadioButton
Tag = 3
Left = 14
Top = 32
Width = 79
Height = 17
Caption = '扩展（&X）'
TabOrder = 1
onClick = RBCenterClick
end
object RBTile: TRadioButton
Tag = 2
Left = 14
Top = 55
Width = 79
Height = 17
Caption = '平铺（&I）'
Checked = True
TabOrder = 2
TabStop = True
onClick = RBCenterClick
end
object RBNoBMP: TRadioButton
Tag = 1
Left = 14
Top = 76
Width = 79
Height = 17
Caption = '无图（&N）'
TabOrder = 3
onClick = RBCenterClick
end
end
object BtnSelectBMP: TButton
Left = 192
Top = 131
Width = 113
Height = 25
Caption = '背景图（&P）...'
TabOrder = 2
onClick = BtnSelectBMPClick
end
object opd1: TOpenDialog
Filter = 'BMP图片|*.BMP'
Left = 65
Top = 164
end
end
单元文件:
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ExtCtrls;
type
TForm1 = class(TForm)
Panel1: TPanel;
Bevel1: TBevel;
RBCenter: TRadioButton;
RBExpand: TRadioButton;
RBTile: TRadioButton;
RBNoBMP: TRadioButton;
BtnSelectBMP: TButton;
opd1: TOpenDialog;
procedure FormCreate(Sender: TObject);
procedure RBCenterClick(Sender: TObject);
procedure BtnSelectBMPClick(Sender: TObject);
private
Fmode:integer;
FName:string;
procedure SetBGPreview(BGMode:integer;FName:string;Pl:TPanel);
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.FormCreate(Sender: TObject);
begin
Fname:='1.bmp';
FMode:=2;
Setbgpreview(fmode,fname,panel1);
end;
procedure TForm1.SetBGPreview(BGMode:integer;FName:string;Pl:TPanel);
var BMP:TBitMap;
Col,Row:integer;
DR,SR:TRect;
NumCols,NumRows:integer;
Canvas:TCanvas;
OldColor:TColor;
Procedure NoImageProc;
begin
Canvas.Brush.Color:=OldColor;
FloodFill(Canvas.Handle,0,0,OldColor);
end;
begin
BMP:=TBitMap.Create;
BMP.LoadFromFile(FName);
Canvas:=TCanvas.Create;
Canvas.Handle:=GetDC(PL.Handle);
OldColor:=PL.Color;
case BGMode of
1:
begin
NoImageProc;
end;
2:
begin
SR:=Rect(0,0,BMP.Width,BMP.Height);
DR:=pl.ClientRect;
NumRows:=DR.Bottom div SR.Bottom;
NumCols:=DR.Right div SR.Right;
// Canvas.Brush.Bitmap:=BMP;
// Canvas.FillRect(DR);
for Row:=0 to NumRows+1 do
for Col:=0 to NumCols+1 do
BitBlt(Canvas.Handle,Col*BMP.Width,Row*BMP.Height,BMP.Width,BMP.Height,BMP.Canvas.Handle,0,0,SrcCopy);
end;
3:
begin
StretchBlt(Canvas.Handle,0,0,PL.Width,PL.Height,BMP.Canvas.Handle,0,0,BMP.Width,BMP.Height,SrcCopy);
end;
4:
begin
NoImageProc;
BitBlt(Canvas.Handle,(PL.Width-BMP.Width) DIV 2,(PL.Height-BMP.Height) DIV 2,BMP.Width,BMP.Height,BMP.Canvas.Handle,0,0,SrcCopy);
end;
end;{end of case}
bmp.Free;
canvas.Free;
end;
procedure TForm1.RBCenterClick(Sender: TObject);
begin
fmode:=(sender as TRadiobutton).Tag;
Setbgpreview(fmode,fname,panel1);
end;
procedure TForm1.BtnSelectBMPClick(Sender: TObject);
begin
if opd1.Execute then
begin
fname:=opd1.FileName;
setbgpreview(fmode,fname,panel1);
end;
end;
end.
1、 如何使用JPG图片来做一个MDI窗体的背景，并实现平铺、拉伸以及居中等效果？
2、 如下的代码可以完成BMP图片做背景的问题，但在子窗体的大小变化时会引起窗体的抖动，怎样才能解决这个问题？引用一段别人的作品：
unit MainFrm;
interface
uses Windows, SysUtils, Classes, Graphics, Forms, Controls, Menus,
StdCtrls, Dialogs, Buttons, Messages, ExtCtrls, JPeg;
type
TMainForm = class(TForm)
mmMain: TMainMenu;
mmifile: TMenuItem;
mmiNew: TMenuItem;
mmiClose: TMenuItem;
N1: TMenuItem;
mmiExit: TMenuItem;
mmiImage: TMenuItem;
mmiTile: TMenuItem;
mmiCenter: TMenuItem;
mmiStretch: TMenuItem;
imgMain: TImage;
procedure mmiNewClick(Sender: TObject);
procedure mmiCloseClick(Sender: TObject);
procedure mmiExitClick(Sender: TObject);
procedure mmiTileClick(Sender: TObject);
private
FOldClientProc,
FNewClientProc: TFarProc;
FDrawDC: hDC;
procedure CreateMDIChild(const Name: string);
procedure ClientWndProc(var Message: TMessage);
procedure DrawStretched;
procedure DrawCentered;
procedure DrawTiled;
protected
procedure CreateWnd; override;
end;
var
MainForm: TMainForm;
implementation
uses MdiChildFrm;
{$R *.DFM}
procedure TMainForm.CreateWnd;
begin
inherited CreateWnd;
// Turn the ClientWndProc method into a valid window procedure
FNewClientProc := MakeObjectInstance(ClientWndProc);
// Get a pointer to the original window procedure
FOldClientProc := Pointer(GetWindowLong(ClientHandle, GWL_WNDPROC));
// Set ClientWndProc as the new window procedure
SetWindowLong(ClientHandle, GWL_WNDPROC, LongInt(FNewClientProc));
end;
procedure TMainForm.DrawCentered;
{ This procedure centers the image on the form's client area }
var
CR: TRect;
begin
GetWindowRect(ClientHandle, CR);
with imgMain do
BitBlt(FDrawDC, ((CR.Right - CR.Left) - Picture.Width) div 2,
((CR.Bottom - CR.Top) - Picture.Height) div 2,
Picture.Graphic.Width, Picture.Graphic.Height,
Picture.Bitmap.Canvas.Handle, 0, 0, SRCCOPY);
end;
procedure TMainForm.DrawStretched;
{ This procedure stretches the image on the form's client area }
var
CR: TRect;
begin
GetWindowRect(ClientHandle, CR);
StretchBlt(FDrawDC, 0, 0, CR.Right, CR.Bottom,
imgMain.Picture.Bitmap.Canvas.Handle, 0, 0,
imgMain.Picture.Width, imgMain.Picture.Height, SRCCOPY);
end;
procedure TMainForm.DrawTiled;
{ This procedure tiles the image on the form's client area }
var
Row, Col: Integer;
CR, IR: TRect;
NumRows, NumCols: Integer;
begin
GetWindowRect(ClientHandle, CR);
IR := imgMain.ClientRect;
NumRows := CR.Bottom div IR.Bottom;
NumCols := CR.Right div IR.Right;
with imgMain do
for Row := 0 to NumRows+1 do
for Col := 0 to NumCols+1 do
BitBlt(FDrawDC, Col * Picture.Width, Row * Picture.Height,
Picture.Width, Picture.Height, Picture.Bitmap.Canvas.Handle,
0, 0, SRCCOPY);
end;
procedure TMainForm.ClientWndProc(var Message: TMessage);
begin
case Message.Msg of
// Capture the WM_ERASEBKGND messages and perform the client area drawing
WM_ERASEBKGND:
begin
CallWindowProc(FOldClientProc, ClientHandle, Message.Msg, Message.wParam,
Message.lParam);
FDrawDC := TWMEraseBkGnd(Message).DC;
if mmiStretch.Checked then
DrawStretched
else if mmiCenter.Checked then
DrawCentered
else DrawTiled;
Message.Result := 1;
end;
{ Capture the scrolling messages and ensure the client area
is redrawn by calling InvalidateRect }
WM_VSCROLL, WM_HSCROLL:
begin
Message.Result := CallWindowProc(FOldClientProc, ClientHandle, Message.Msg,
Message.wParam, Message.lParam);
InvalidateRect(ClientHandle, nil, True);
end;
else
// By Default, call the original window procedure
Message.Result := CallWindowProc(FOldClientProc, ClientHandle, Message.Msg,
Message.wParam, Message.lParam);
end; { case }
end;
procedure TMainForm.CreateMDIChild(const Name: string);
var
MdiChild: TMDIChildForm;
begin
MdiChild := TMDIChildForm.Create(Application);
MdiChild.Caption := Name;
end;
procedure TMainForm.mmiNewClick(Sender: TObject);
begin
CreateMDIChild('NONAME' + IntToStr(MDIChildCount + 1));
end;
procedure TMainForm.mmiCloseClick(Sender: TObject);
begin
if ActiveMDIChild <> nil then
ActiveMDIChild.Close;
end;
procedure TMainForm.mmiExitClick(Sender: TObject);
begin
Close;
end;
procedure TMainForm.mmiTileClick(Sender: TObject);
begin
mmiTile.Checked := false;
mmiCenter.Checked := False;
mmiStretch.Checked := False;
{ Set the Checked property for the menu item which invoked }
{ this event handler to Checked }
if Sender is TMenuItem then
TMenuItem(Sender).Checked := not TMenuItem(Sender).Checked;
{ Redraw the client area of the form }
InvalidateRect(ClientHandle, nil, True);
end;
end.
object mmMain: TMainMenu
Left = 404
Top = 36
object mmifile: TMenuItem
Caption = '&File'
Hint = 'File related commands'
object mmiNew: TMenuItem
Caption = '&New'
Hint = 'Create a new file'
onClick = mmiNewClick
end
object mmiClose: TMenuItem
Caption = '&Close'
Hint = 'Close current file'
onClick = mmiCloseClick
end
object N1: TMenuItem
Caption = '-'
end
object mmiExit: TMenuItem
Caption = 'E&xit'
Hint = 'Exit the application'
onClick = mmiExitClick
end
end
object mmiImage: TMenuItem
Caption = '&Image'
object mmiTile: TMenuItem
Caption = '&Tile'
GroupIndex = 1
onClick = mmiTileClick
end
object mmiCenter: TMenuItem
Caption = '&Center'
GroupIndex = 1
onClick = mmiTileClick
end
object mmiStretch: TMenuItem
Caption = '&Stretch'
Checked = True
GroupIndex = 1
onClick = mmiTileClick
end
end
end
3、在一个PANEL上使用CANVAS来实现背景设置的预览功能，通过按钮可以正常实现，但在程序失去焦点后再得到焦点时不能出现选定的功能，以及在窗体的创建时也不能出现选定的功能？
窗体设置:
object Form1: TForm1
Left = 176
Top = 169
Width = 334
Height = 197
Caption = 'Form1'
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
OldCreateOrder = False
OnCreate = FormCreate
PixelsPerInch = 96
TextHeight = 13
object Bevel1: TBevel
Left = 16
Top = 24
Width = 172
Height = 133
Shape = bsFrame
end
object Panel1: TPanel
Left = 21
Top = 30
Width = 160
Height = 121
BevelOuter = bvNone
Color = clBackground
TabOrder = 0
end
object TPanel
Left = 192
Top = 24
Width = 113
Height = 103
BevelOuter = bvLowered
TabOrder = 1
object RBCenter: TRadioButton
Tag = 4
Left = 14
Top = 10
Width = 79
Height = 17
Caption = '居中（&E）'
TabOrder = 0
onClick = RBCenterClick
end
object RBExpand: TRadioButton
Tag = 3
Left = 14
Top = 32
Width = 79
Height = 17
Caption = '扩展（&X）'
TabOrder = 1
onClick = RBCenterClick
end
object RBTile: TRadioButton
Tag = 2
Left = 14
Top = 55
Width = 79
Height = 17
Caption = '平铺（&I）'
Checked = True
TabOrder = 2
TabStop = True
onClick = RBCenterClick
end
object RBNoBMP: TRadioButton
Tag = 1
Left = 14
Top = 76
Width = 79
Height = 17
Caption = '无图（&N）'
TabOrder = 3
onClick = RBCenterClick
end
end
object BtnSelectBMP: TButton
Left = 192
Top = 131
Width = 113
Height = 25
Caption = '背景图（&P）...'
TabOrder = 2
onClick = BtnSelectBMPClick
end
object opd1: TOpenDialog
Filter = 'BMP图片|*.BMP'
Left = 65
Top = 164
end
end
单元文件:
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ExtCtrls;
type
TForm1 = class(TForm)
Panel1: TPanel;
Bevel1: TBevel;
RBCenter: TRadioButton;
RBExpand: TRadioButton;
RBTile: TRadioButton;
RBNoBMP: TRadioButton;
BtnSelectBMP: TButton;
opd1: TOpenDialog;
procedure FormCreate(Sender: TObject);
procedure RBCenterClick(Sender: TObject);
procedure BtnSelectBMPClick(Sender: TObject);
private
Fmode:integer;
FName:string;
procedure SetBGPreview(BGMode:integer;FName:string;Pl:TPanel);
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.FormCreate(Sender: TObject);
begin
Fname:='1.bmp';
FMode:=2;
Setbgpreview(fmode,fname,panel1);
end;
procedure TForm1.SetBGPreview(BGMode:integer;FName:string;Pl:TPanel);
var BMP:TBitMap;
Col,Row:integer;
DR,SR:TRect;
NumCols,NumRows:integer;
Canvas:TCanvas;
OldColor:TColor;
Procedure NoImageProc;
begin
Canvas.Brush.Color:=OldColor;
FloodFill(Canvas.Handle,0,0,OldColor);
end;
begin
BMP:=TBitMap.Create;
BMP.LoadFromFile(FName);
Canvas:=TCanvas.Create;
Canvas.Handle:=GetDC(PL.Handle);
OldColor:=PL.Color;
case BGMode of
1:
begin
NoImageProc;
end;
2:
begin
SR:=Rect(0,0,BMP.Width,BMP.Height);
DR:=pl.ClientRect;
NumRows:=DR.Bottom div SR.Bottom;
NumCols:=DR.Right div SR.Right;
// Canvas.Brush.Bitmap:=BMP;
// Canvas.FillRect(DR);
for Row:=0 to NumRows+1 do
for Col:=0 to NumCols+1 do
BitBlt(Canvas.Handle,Col*BMP.Width,Row*BMP.Height,BMP.Width,BMP.Height,BMP.Canvas.Handle,0,0,SrcCopy);
end;
3:
begin
StretchBlt(Canvas.Handle,0,0,PL.Width,PL.Height,BMP.Canvas.Handle,0,0,BMP.Width,BMP.Height,SrcCopy);
end;
4:
begin
NoImageProc;
BitBlt(Canvas.Handle,(PL.Width-BMP.Width) DIV 2,(PL.Height-BMP.Height) DIV 2,BMP.Width,BMP.Height,BMP.Canvas.Handle,0,0,SrcCopy);
end;
end;{end of case}
bmp.Free;
canvas.Free;
end;
procedure TForm1.RBCenterClick(Sender: TObject);
begin
fmode:=(sender as TRadiobutton).Tag;
Setbgpreview(fmode,fname,panel1);
end;
procedure TForm1.BtnSelectBMPClick(Sender: TObject);
begin
if opd1.Execute then
begin
fname:=opd1.FileName;
setbgpreview(fmode,fname,panel1);
end;
end;
end.