能平铺图象的image控件,象wallpaper那样,谁有?(50分)

  • 主题发起人 主题发起人 fx
  • 开始时间 开始时间
do you have lmd controls 3.5.
LMDNImage.style.if can be download in http://www.netease.com/~bozhi/.
 
直接用StretchDraw自己画不行吗?
 
在Delphi4/Help/examples/BitMap/Bitmap.dpr是一个这样的例子.
 
请下载<a href="http://www.963.net/~lbz/download/lmd35.zip">LMD V3.5</a>
在该控件集中有一TLMDFill控件,可满足你的要求,你只要将该控件的
FillObject.Style设为stBitmap,并设置其Bitmap属性即可完成你的
要求。
 
http://www.gislab.ecnu.edu.cn/delphi/downloads/mdiwallp.zip
 
我有一个TTiler,可以实现这个功能
只要往form上一放,然后设置几个属性即可
干脆贴出来吧,反正不大^_^

--
unit uTiler;
//------------------------------------------------------------------------------
// TTiler V1.4
// By Martijn Tonies / Upscene Productions Holland
// EMail: seal97@dds.nl - http://surf.to/seal97
// m.tonies@upscene.demon.nl
//
// Copyright 1998 by Upscene Productions
// This code may be used, but may not be modified/used for commercial use
// without notifying the author.
//
// Commercial use will be charged $10 US.
//------------------------------------------------------------------------------
// History:
// --------
// V1.4:
// - Fixed resize problem when using one of the 'spot' tilemodes. All tilemodes
// work no matter MDI of SDI form.
// - Added method 'Redraw', handy if you change the bitmap property.
//
// V1.3:
// - Automatic Attach if you want to. No need to call Attach method.
// - Changed a local bitmap handle from a Integer to a HBITMAP (LongInt).
//
// V1.2:
// - added tilemodes different than tmTile, tmStretch and tmCenter - only seem
// to work when the form is a fsNormal form instead of a fsMDIClient form.
// Tiling always works.
// - put back Attach method (much easier to use!)
// - made public Detach method. Detach the TTiler and Attach another TTiler
// component for different pictures without changing its Bitmap property.
//
// V1.1:
// - lost Attach method
//
// V1.0
// - First version (tilemodes: tmTile, tmStretch, tmCenter).
//------------------------------------------------------------------------------
// How To Use:
// -----------
// In the OnCreate event of your form, put: <tilename>.Attach
// example: Tiler.Attach;
//------------------------------------------------------------------------------


interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;

type
TTileMode = (tmTile, tmStretch, tmCenter, // standard Window Wallpaper tilemodes (v1.0)
tmLeftVCenter, tmLeftVTop, tmLeftVBottom, // piccy on the left (v1.2)
tmRightVCenter, tmRightVTop, tmRightVBottom, // piccy on the right (v1.2)
tmCenterVTop, tmCenterVBottom); // piccy centered (v1.2)

TTiler = class(TComponent)
private
FAutomaticAttach: Boolean;
FActive: Boolean;
FBitmap: TBitmap;
FTileMode: TTileMode;

FHandle: HWND;
Form: TForm;

VOffset: Integer;
HOffset: Integer;

FClientInstance: TFarProc;
FDefClientProc: TFarProc;

procedure SetActive(Value: Boolean);
procedure SetBitmap(Value: TBitmap);
procedure SetTileMode(Value: TTileMode);

procedure ClientWndProc(var Message: TMessage);
procedure FillClientArea(DC: HDC);

procedure Stretch(DC: HDC);
procedure Tile(DC: HDC);
procedure Center(DC: HDC);
procedure Spot(DC: HDC);

{ Private declarations }
protected
procedure Loaded; override;
{ Protected declarations }
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;

procedure Attach;
procedure Detach;
procedure Redraw;
{ Public declarations }
published
property AutomaticAttach: Boolean read FAutomaticAttach write FAutomaticAttach;
property Active: Boolean read FActive write SetActive;
property Bitmap: TBitmap read FBitmap write SetBitmap;
property TileMode: TTileMode read FTileMode write SetTileMode;
{ Published declarations }
end;

procedure Register;

implementation

constructor TTiler.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FBitmap := TBitmap.Create;
FAutomaticAttach := True;
end;

destructor TTiler.Destroy;
begin
Detach;
FBitmap.Free;
inherited Destroy;
end;

procedure TTiler.Attach;
begin
if not (Owner is TForm)
then raise Exception.Create('Can''t attach TTiler component to something else than a TForm.');
if not Assigned(FClientInstance) // only attach once!
then begin
if (Owner as TForm).FormStyle = fsMDIForm
then FHandle := (Owner as TForm).ClientHandle
else FHandle := (Owner as TForm).Handle;

FClientInstance := MakeObjectInstance(ClientWndProc);
FDefClientProc := Pointer(GetWindowLong(FHandle, GWL_WNDPROC));
SetWindowLong(FHandle, GWL_WNDPROC, LongInt(FClientInstance));
Form := Owner as TForm;
if Active
then begin
Active := False;
Active := True;
end;
end;
end;

procedure TTiler.Detach;
begin
if Active and Assigned(FClientInstance)
then begin
Active := False; // clear client area
FActive := True; // put old value back for redrawing when attach again
end;
if Assigned(FClientInstance) // if attached
then begin
SetWindowLong(FHandle, GWL_WNDPROC, LongInt(FDefClientProc));
FreeObjectInstance(FClientInstance);
end;
FClientInstance := nil;
end;

procedure TTiler.Redraw;
var b: Boolean;
begin
b := Active;
Active := False;
Active := b;
end;

procedure TTiler.ClientWndProc(var Message: TMessage);
procedure Default;
begin
with Message
do Result := CallWindowProc(FDefClientProc, FHandle, Msg, wParam, lParam);
end;
begin
with Message
do begin
case Msg of
WM_NCHITTEST : begin
Default;
if FHandle = Form.ClientHandle
then if Result = HTCLIENT
then Result := HTTRANSPARENT;
end;
WM_ERASEBKGND : begin
if Assigned(FBitmap) and Active and (FHandle <> 0) and (FBitmap.Handle <> 0)
then FillClientArea(TWMEraseBkgnd(Message).DC)
else FillRect(TWMEraseBkgnd(Message).DC, (Owner as TForm).ClientRect, (Owner as TForm).Brush.Handle);
Result := 1;
end;
WM_VSCROLL,
WM_HSCROLL,
WM_SIZE : begin
Default;
InvalidateRect(FHandle, nil, True);
end;
else Default;
end;
end;
end;

procedure TTiler.Loaded;
begin
inherited Loaded;
if AutomaticAttach
then Attach;
end;

procedure TTiler.FillClientArea(DC: HDC);
begin
if FHandle <> 0
then case FTileMode of
tmTile : Tile(DC);
tmStretch : Stretch(DC);
tmCenter : Center(DC);
tmLeftVCenter,
tmLeftVTop,
tmLeftVBottom,
tmRightVCenter,
tmRightVTop,
tmRightVBottom,
tmCenterVTop,
tmCenterVBottom : Spot(DC);
end;
ReleaseDC(FHandle, DC);
end;

procedure TTiler.Spot(DC: HDC);
var y, x: LongInt;
begin
x := 0;
y := 0;

if TileMode in [tmRightVTop, tmRightVCenter, tmRightVBottom]
then x := Form.ClientWidth - FBitmap.Width - 1;

if TileMode in [tmCenterVTop, tmCenterVBottom]
then x := (Form.ClientWidth div 2) - (FBitmap.Width div 2);

case TileMode of
tmLeftVCenter,
tmRightVCenter : y := (Form.ClientHeight div 2) - (FBitmap.Height div 2);
tmLeftVTop,
tmRightVTop,
tmCenterVTop : y := 0;
tmLeftVBottom,
tmRightVBottom,
tmCenterVBottom : y := Form.ClientHeight - FBitmap.Height;
end;
FillRect(DC, (Owner as TForm).ClientRect, (Owner as TForm).Brush.Handle);
BitBlt(DC, x, y, FBitmap.Width, FBitmap.Height, FBitmap.Canvas.Handle, 0, 0, SRCCOPY);
end;

procedure TTiler.Center(DC: HDC);
var R: TRect;
x, y: LongInt;
w, h: LongInt;
begin
R := Form.ClientRect;
x := (R.Right div 2) - (FBitmap.Width div 2);
y := (R.Bottom div 2) - (FBitmap.Height div 2);
w := x + FBitmap.Width;
h := y + FBitmap.Height;
FillRect(DC, R, Form.Brush.Handle);
BitBlt(DC, x, y, w, h, FBitmap.Canvas.Handle, 0, 0, SRCCOPY);
end;

procedure TTiler.Stretch(DC: HDC);
var R: TRect;
begin
R := Form.ClientRect;
StretchBlt(DC, R.Left, R.Top, R.Right, R.Bottom, FBitmap.Canvas.Handle, 0, 0, FBitmap.Width, FBitmap.Height, SRCCOPY);
end;

procedure TTiler.Tile(DC: HDC);
var x, y, bmWidth, bmHeight: Integer;
bmHandle: HBITMAP;
begin
bmWidth := FBitmap.Width;
bmHeight := FBitmap.Height;
bmHandle := FBitmap.Canvas.Handle;

x := HOffset;

while x < Form.Width
do begin
y := 0;
while y < Form.Height
do begin
BitBlt(DC, x, y, x + bmWidth, y + bmHeight,
bmHandle, 0, 0, SRCCOPY);
BitBlt(DC, x, y + bmHeight, x + bmWidth, y + bmHeight,
bmHandle, 0, 0, SRCCOPY);
BitBlt(DC, x + bmWidth, y, x + bmWidth, y + bmHeight,
bmHandle, 0, 0, SRCCOPY);
BitBlt(DC, x + bmWidth, y + bmHeight, x + bmWidth, y + bmHeight,
bmHandle, 0, 0, SRCCOPY);
y := y + bmHeight * 1;
end;
x := x + bmWidth * 1;
end;
end;


procedure TTiler.SetActive(Value: Boolean);
var msg: TMessage;
begin
if (Value <> FActive) and Assigned(Owner)
then begin
FActive := Value;
if not (csDesigning in ComponentState)
then begin
if FHandle <> 0 // draw, but only if there is a handle!!
then begin
msg.Msg := WM_ERASEBKGND;
TWMEraseBkgnd(msg).DC := GetDC(FHandle);
ClientWndProc(msg) // fire once!
end;
end
else {if FActive and not (csReading in ComponentState) and not (csLoading in ComponentState)
then ShowMessage('TTiler won''t show any drawing at designtime...')};
end;
end;

procedure TTiler.SetBitmap(Value: TBitmap);
begin
FBitmap.Assign(Value);
end;

procedure TTiler.SetTileMode(Value: TTileMode);
begin
if Value <> FTileMode
then begin
FTileMode := Value;
if (not (csDesigning in ComponentState)) and Active
then begin
Active := False; // clear all
Active := True; // start drawing again
end;
end;
end;


procedure Register;
begin
RegisterComponents('Others', [TTiler]);
end;

end.
 
to MocroZenf,flier:你们的方法均可行,但我更需要现成的控件。
to 蛋:StretchDraw不能满足我的要求。:(
to 其他朋友:你们提供的LMD(for 4) or mdiwallp.zip 的网址我都连不上,不知谁能提供一个在教育网上的网址,或直接透到我的信箱吧,多谢。
 
这里下载:
<a href="http://www.zg169.net/~huangkai/download_vcl/sys/lmd4.zip">LMD 4.0 For D3,D4 (1.3M)</a>
已破解,对于Delphi应使用Update 2。
其它地方:
<a href="http://delphi.ncc.com.tw/vcl/packs/lmdt4_d3.exe">LMDt4_d3.exe</a>
<a href="http://delphi.ncc.com.tw/vcl/packs/lmdt4_d4.exe">LMDt4_d4.exe</a>
 
创建一个bitmap并载入图形(jpeg也可)
将bitmap画布copy到你的image上就可以了
当然是像铺砖一样的copy了
 
多人接受答案了。
 

Similar threads

D
回复
0
查看
802
DelphiTeacher的专栏
D
D
回复
0
查看
747
DelphiTeacher的专栏
D
D
回复
0
查看
696
DelphiTeacher的专栏
D
后退
顶部