老问题：半透明窗体？？(200分)

有没有哪位大虾可以给出98下实现半透明的源代码
不要以下这种的，例如说：
procedure TForm1.TranslucentBmp(Bmp:
TBitmap;AColor:TColor;ATransparent:Longint);
var BkColor:COLORREF;
ForeColor:Longint;
R,G,B:Int64;
i,j:Integer;
begin
ForeColor:=ColorToRGB(AColor);
with Bmp.Canvas do
for i:=ClientHeight-1 downto 0 do
for j:=ClientWidth-1 downto 0 do
begin
BkColor:=GetPixel(Handle,j,i); //取得每一象素
R:=Byte(ForeColor)+
(Byte(BkColor)-Byte(ForeColor))*ATransparent;
G:=Byte(ForeColor shr 8)+
(Byte(BkColor shr 8)-Byte(ForeColor
shr 8))*ATransparent;
B:=Byte(ForeColor shr 16)+
(Byte(BkColor shr 16)-Byte(ForeColor
shr 16))*ATransparent;
SetPixelV(Handle,j,i,RGB(R,G,B));//合成象素
end;
end;
也不要什么 Brush.Style := bsNone; 这种的
有没有更好的 能实现像Win2K中的半透明的？？

用delphi7就可轻实现!

在delphi6中,設置ALPHABLEND=TRUE; ALPHABLEND=185;

在xp下有效，98下无效，你看flashget的下载框就知道了。

同意：qinmingzsj

qinmingzsj的只对W2K以下的OS有效

半透明窗体
半透明窗体并不是win2000的新特效，凡是用过金山词霸的同志都会发现在屏幕取词设置中有一个半透明背景的选项，这说明在win98下是可以实现半透明窗口的。但我还是要首先谈谈在win2000实现半透明窗体的新函数setlayeredwindowattributes。利用这个函数就可以轻松创建一个半透明窗体，但是利用这个函数的程序编译后在win98下是无法运行的。

setlayeredwindowattributes api函数介绍如下： 函数功能：设置窗口透明颜色 参数：setlayeredwindowattributes( hwnd hwnd, //窗口手柄 colorref crkey, //指定颜色值 byte balpha, //混合函数值 dword dwflags //动作 参数解释： hwnd:窗口句柄。当使用createwindowex函数创建窗口时，窗口由ws_ex_layered指定的值创建；或者窗口已经创建后，由setwindowlong根据ws_ex_layered指定的值改变。 crkey:指向一个color值，该值指定一个透明颜色值，当创建窗口时，窗口将使用该值。 balpha:混合函数值。该值用于描述窗口的不透明度。当balpha 值为0时，窗口完全透明，当balpha值为255时，窗口完全不透明。 dwflags:指定动作。这个参数可以取一个或多个值。用它我们可以创建一个不规则的窗体。

setlayeredwindowattributes函数的api声明: setlayeredwindowattributes(hwnd: hwnd; crkey: dword;balpha: byte; dwflag: dword): boolean; stdcall; ---------

程序代码1： const ws_ex_layered = $80000; lwa_colorkey = $1; lwa_alpha = $2; procedure tform1.formcreate(sender: tobject); var l:longint; begin l :=getwindowlong(handle, gwl_exstyle); l := l or ws_ex_layered; setwindowlong (handle, gwl_exstyle, l); setlayeredwindowattributes(handle, 180, 120, lwa_alpha); end; 还有一些其它的常量定义如: ac_src_alpha = $1; ac_dst_no_premult_alpha = $10; ulw_colorkey = $1; ulw_alpha = $2; ulw_opaque = $400; 等还要参看msdn。

有些我还没有搞明白，如果哪位同志知道的话，请告诉我。 那么在win98下又是如何实现半透明窗体的呢?其基本原理是:在窗口显示前其获取背景图然后对背景图象进行滤镜效果处理再将处理过的背景图象显示在窗口前面。 有一种方法是:首先，做出一个透明窗体，然后在窗体上添加一个shape，将其扩展至全屏幕，将shape的pen的mode属性设为pmmask,pen的style属性设为psclear,最后改变brush的color属性即可。 因为没有api支持，win9x下只能模拟，效果不太好，就象金山词霸的取词窗口，背景改变而窗体上还是不变。但我们可以利用timer控件来解决窗体的刷新率和时时更新的问题。 不过听说“金山词霸的半透明窗口效果只能在带mmx指令集的处理器中才起作用”不知是真是假，由于手头没有这样的电脑，还请同志们自己验证吧。



--------------------------------------------------------------------------------


在windows2000下增加了一些API,可以轻易的实现半透明的窗体，源程序如下，必要的地方我加上了注释

unit Unit1;

interface

uses

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

const

WS_EX_LAYERED = $80000;

AC_SRC_OVER = $0;

AC_SRC_ALPHA = $1;

AC_SRC_NO_PREMULT_ALPHA = $1;

AC_SRC_NO_ALPHA = $2;

AC_DST_NO_PREMULT_ALPHA = $10;

AC_DST_NO_ALPHA = $20;

LWA_COLORKEY = $1;

LWA_ALPHA = $2;

ULW_COLORKEY = $1

ULW_ALPHA = $2

ULW_OPAQUE = $4

//新增加的常量定义

type

TForm1 = class(TForm)

procedure FormCreate(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

end;

function SetLayeredWindowAttributes(hwnd:HWND; crKey:Longint; bAlpha:byte; dwFlags:longint ):longint; stdcall; external user32;//函数声明

var

Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);

var l:longint;

begin

l:=getWindowLong(Handle, GWL_EXSTYLE);

l := l Or WS_EX_LAYERED;

SetWindowLong (handle, GWL_EXSTYLE, l);

SetLayeredWindowAttributes (handle, 0, 180, LWA_ALPHA);

//第二个参数是指定透明颜色

//第二个参数为0则使用第四个参数设置alpha值，从0到255，其他的我不太清楚，因为没有api帮助

end;







end.

unit main;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ExtCtrls, Buttons, Mask;

type
TForm1 = class(TForm)
Exit: TButton;
Shape1: TShape;
Image1: TImage;
HalfTranSparent: TButton;
Label1: TLabel;
Edit1: TEdit;
procedure ExitClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure HalfTranSparentClick(Sender: TObject);
procedure Image1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure GetBKBmp;
procedure MakeTransparent(bmp:TBitMap;Transparence:longint);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
private
{ Private declarations }

public
{ Public declarations }
end;

var
Form1: TForm1;
BKImage: TBitMap;

implementation

{$R *.DFM}
procedure TForm1.ExitClick(Sender: TObject);
begin
close;
end;

procedure TForm1.MakeTransparent(bmp: TBitMap; Transparence: Integer);
var
bkcolor:colorref;
r,g,b:int64;
i,j:integer;
begin
with bmp.Canvas do
for i:=clientheight-1 downto 0 do
for j:=clientwidth-1 downto 0 do
begin
bkcolor:=getpixel(handle,j,i);
r:=(byte(bkcolor))*Transparence div 100;
g:=(byte(bkcolor shr 8))*Transparence div 100;
b:=(byte(bkcolor shr 16))*Transparence div 100;
setpixelv(handle,j,i,rgb(r,g,b));
end;
end;

Procedure TForm1.GetBKBmp;
var
s:TCanvas;
h,w:integer;
begin
s:=TCanvas.Create;
h:=clientheight;
w:=clientwidth;
try
Form1.Visible:=False;
sleep(50);
s.Handle:=getdc(0);
BKImage.Canvas.CopyRect(rect(0,0,w,h),s,rect(left,top,left+w,top+h));
releasedc(0,s.handle);
Sleep(50);
Form1.Visible:=true;
finally
s.free;
end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
BKImage:=TBitMap.Create;
BKImage.Height:=Image1.Height;
BKImage.Width:=Image1.Width;
BKImage.PixelFormat:=pf24bit;
try
GetBKBmp;
MakeTransparent(BKImage,70);
Image1.Picture.Bitmap:=BKImage;
finally
end;
end;

procedure TForm1.HalfTransparentClick(Sender: TObject);
var
i:integer;
begin
i:=strtoint(edit1.text);
try
GetBKBmp;
MakeTransparent(BKImage,i);
Image1.Picture.Bitmap:=BKImage;
finally
end;
Image1.Refresh;
end;

procedure TForm1.Image1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
ReleaseCapture;
Perform(WM_SYSCOMMAND,$F012,0);
HalfTransparentClick(nil);
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
BKImage.Free;
end;

end.

但移动时效果不好。

请注意：
各位的源代码实现的半透明窗体，当窗体后面的东西发生变化时不能反映出来，
而Win2K是可以实现这点的

在delphi6中,設置ALPHABLEND=TRUE; ALPHABLEND=185;只对2K有用。
这里抄别人的也太多了，一字都不改，让人感到有点。。。。。。。。。。。

SkinEngine这个控件能够做到！

http://www.ithome-cn.net/technology/delphi/de098.htm

Win2000本身就支持半透明窗体，而Win98则不支持。如果想在Win98下实现半透明，
除了在显示窗口前把背景拷贝下来做Alpha混合，我想不会有别的办法。但是这样的
方法其实是假的半透明，如果背景变了是无法及时更新的。

结论：放弃98

98好像很麻烦的
以前看过一个文章说是把窗口下面的界面copy出来，做为窗体的背景然后对背景进行透明，不过我觉得
这种方法不怎么好哦，太占资源

试试我的这个
unit JtoCXPAuto;

interface

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ExtCtrls, ShellApi;

type
TAutoForm = class(TForm)
BackImg: TImage;
procedure FormShow(Sender: TObject);
procedure BackImgMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure BackImgMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
private
{ Private declarations }
public
{ Public declarations }
end;

var
AutoForm: TAutoForm;
EMailRect:TRect;
implementation



{$R *.dfm}

procedure TAutoForm.FormShow(Sender: TObject);
var
ScreenDc,DestDc:Hdc;
BHandle:THandle;
X,Y:integer;
Color:TColor;
Color1,Color2,Color3:Byte;
FormRgn:Hrgn;
begin
FormRgn:=CreateRoundRectRgn(0,0,Width,Height,15,15);
SetWindowRgn(Handle,FormRgn,True);

EnableWindow(MainForm.Handle,False);
ScreenDc:=CreateDc(/'DISPLAY/',nil,nil,nil);
DestDc:=CreateCompatibleDc(ScreenDc);
BHandle:=CReateCompatibleBitmap(ScreenDc,Width,Height);
SelectObject(DestDc,Bhandle);
BitBlt(DestDc,0,0,Width,Height,ScreenDc,MainForm.Left+(MainForm.Width -Width)div 2,
MainForm.Top +(MainForm.Height -Height)div 2,SRCCOPY);
for x:=0 to Width-1 do begin
for y:=0 to Height-1 do begin
Color:=GetPixel(DestDc,x,y);
Color1:=GetRValue(Color) div 3;
Color2:=GetGValue(Color) div 3;
Color3:=GetBValue(Color) div 3;
Color:=RGB(Color1,Color2,Color3);
SetPixel(DestDC,x,y,Color);
end;
end;
BitBlt(BackImg.Canvas.Handle,0,0,Width,Height,DestDC ,0,0,SRCCOPY);
DeleteDc (DestDc);
ReleaseDc (Bhandle,ScreenDc);
with BackImg.Canvas do begin
Moveto(0,0);
Pen.Color :=rgb(192,192,192);
Lineto(BackImg.Width -1,0);
// Pen.Color :=rgb(64,64,64);
Lineto(BackImg.Width -1,backImg.Height -1);
Lineto(0,BackImg.Height-1);
Pen.Color :=rgb(192,192,192);
Lineto(0,0);

Font.Size :=16;
Font.Color :=RGB(255,255,255);
Brush.Style :=bsClear;
TextOut((Width-TextWidth(/'欢迎你使用---对译/'))div 2,5,/'欢迎你使用---对译/');
Font.Size :=12;
TextOut(20,40,/'版本信息：/');
TextOut(120,40,/'( 2002.03.08 )/');
TextOut(20,70,/'电子邮件：/');
TextOut((Width-TextWidth(/'这是我个人编写的,请指教!/'))div 2,105,/'这是我个人编写的,请指教!/');
Font.Color :=Rgb(255,0,0);
Font.Style :=[fsUnderline];
TextOut(120,70,/'sbjane9@163.com/');
end;
end;

procedure TAutoForm.BackImgMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
var
pt:Tpoint;
begin
GetCursorpos(pt);
if PtinRect(EMailRect,pt) then begin
ShellExecute(handle,nil,pchar(/'MailTo:/'+MyEmail),nil,nil,SW_SHOWNORMAL);
exit;end
else begin
AutoForm.Close;
EnableWindow(MainForm.Handle,True);
end;
end;

procedure TAutoForm.BackImgMouseMove(Sender: TObject; Shift: TShiftState;
X, Y: Integer);
var
Pt:Tpoint;
begin
EMailRect:=Bounds(Left+120,Top+70,16*12,14);
GetCursorpos(pt);
if PtinRect(EMailRect,pt) then
Cursor:=crHandPoint
else
Cursor:=crDefault;

end;

end.

多人接受答案了。