如何制作半透明的form

Question

这里有例子我不知道在98下如何
这里还有以前一位朋友提供的使用控件方法，这个例子如何按以下的方法使用阿，我的问题是，如何用这个把系统里其他任何窗体设为半透明，这个例子不知道可以用设置属性的方法
创建单元文件Unit2
把上面的单元复制到Unit2中，unit WinLayer改为unit Unit2
你要设置透明的窗体包含unit2单元
设置按钮事件
procedure TForm1.Button1Click(Sender: TObject);
begin
  SetWindowTransparency(Form1.Handle,40);在这样的例子里如何设置这一句阿
end;以下是代码分开2次发
unit SGlass;
{*******************************************************
 *          TStainedGlass version 14.06.99             *
 *            written by Grigoriev Anton               *
 *                                                     *
 *******************************************************} interface  uses Windows,Messages,SysUtils,Classes,Graphics,Controls,Forms,Dialogs,Math;   type TTransparencyStyle=(tsConstant,tsHorGradient,tsVertGradient,tsCustom);
        TBackgroundStyle=(bsSimple,bsMosaic,bsCentered,bsStretched,bsCustom);
        TTransparency=0..100;        TGetTransparencyEvent=procedure(Sender:TObject;X,Y,Width,Height:Integer;var Transparency:TTransparency) of object;
        TCreateBackgroundEvent=procedure(Sender:TObject;Back:TBitmap) of object;        TStainedGlass=class(TComponent)
                       private
                        FGlyph,ScrImage,Back:TBitmap;
                        FTranspStyle:TTransparencyStyle;
                        FBackStyle:TBackgroundStyle;
                        OldWidth,OldHeight:Integer;
                        FTransparency,FAltTransparency:TTransparency;
                        FDrawOnDesigning:Boolean;
                        OldWndProc:TFarProc;
                        NewWndProc:Pointer;
                        NeedRefresh,Moving:Boolean;
                        FDelayTime:Cardinal;
                        FOnGetTransparency:TGetTransparencyEvent;
                        FOnCreateBackground:TCreateBackgroundEvent;
                        procedure HookOwner;
                        procedure UnhookOwner;
                        procedure SetAltTransparency(Value:TTransparency);
                        procedure SetBackStyle(Value:TBackgroundStyle);
                        procedure SetDrawOnDesigning(Value:Boolean);
                        procedure SetGlyph(Value:TBitmap);
                        procedure SetTransparency(Value:TTransparency);
                        procedure SetTranspStyle(Value:TTransparencyStyle);
                        function ConstantTransparency(X,Y,W,H:Integer):TTransparency;
                        function HGTransparency(X,Y,W,H:Integer):TTransparency;
                        function VGTransparency(X,Y,W,H:Integer):TTransparency;
                        function CustomTransparency(X,Y,W,H:Integer):TTransparency;
                        procedure GlyphChanged(Sender:TObject);
                       protected
                        procedure CreateBack(W,H:Integer);
                        procedure CallDefault(var Msg:TMessage);
                        procedure HookWndProc(var Msg:TMessage);virtual;
                       public
                        constructor Create(AOwner:TComponent);override;
                        destructor Destroy;override;
                        procedure Refresh;
                       published
                        property AltTransparency:TTransparency read FAltTransparency write SetAltTransparency default 100;
                        property BackStyle:TBackgroundStyle read FBackStyle write SetBackStyle default bsSimple;
                        property DelayTime:Cardinal read FDelayTime write FDelayTime default 400;
                        property DrawOnDesigning:Boolean read FDrawOnDesigning write SetDrawOnDesigning default False;
                        property Glyph:TBitmap read FGlyph write SetGlyph;
                        property Transparency:TTransparency read FTransparency write SetTransparency default 40;
                        property TranspStyle:TTransparencyStyle read FTranspStyle write SetTranspStyle default tsConstant;
                        property OnCreateBackground:TCreateBackgroundEvent read FOnCreateBackground write FOnCreateBackground default nil;
                        property OnGetTransparency:TGetTransparencyEvent read FOnGetTransparency write FOnGetTransparency default nil;
                      end;    procedure Register; implementation  type TTransparencyFunc=function(X,Y,W,H:Integer):TTransparency of object;       PRGBArray=^TRGBArray;
       TRGBArray=array[0..1000000] of TRGBTriple;   constructor TStainedGlass.Create;
    var I:Integer;
     begin
      if not (AOwner is TForm) then
       raise EInvalidCast.Create('TStainedGlass can be put on TForm or its destendant only');
      with AOwner do
       for I:=0 to ComponentCount-1 do
        if (Components[I] is TStainedGlass) and (Components[I]<>Self) then
         raise EComponentError.Create('Only one TStainedGlass component on a form is allowed');
      inherited Create(AOwner);
      FGlyph:=TBitmap.Create;
      FGlyph.OnChange:=GlyphChanged;
      ScrImage:=TBitmap.Create;
      ScrImage.Width:=GetSystemMetrics(SM_CXScreen);
      ScrImage.Height:=GetSystemMetrics(SM_CYScreen);
      ScrImage.PixelFormat:=pf24Bit;
      Back:=TBitmap.Create;
      Back.PixelFormat:=pf24Bit;
      OldWidth:=-1;
      OldHeight:=-1;
      NeedRefresh:=True;
      FAltTransparency:=100;
      FBackStyle:=bsSimple;
      FTransparency:=40;
      FTranspStyle:=tsConstant;
      FDelayTime:=400;
      Moving:=False;
      FOnCreateBackground:=nil;
      FOnGetTransparency:=nil;
      HookOwner
     end;   destructor TStainedGlass.Destroy;
    begin
     UnhookOwner;
     ScrImage.Free;
     FGlyph.Free;
     Back.Free;
     inherited Destroy
    end;   procedure TStainedGlass.HookOwner;
    begin
     if not Assigned(Owner) then
      Exit;
     OldWndProc:=TFarProc(GetWindowLong(TForm(Owner).Handle,GWL_WndProc));
     NewWndProc:=MakeObjectInstance(HookWndProc);
     SetWindowLong(TForm(Owner).Handle,GWL_WndProc,LongInt(NewWndProc))
    end;   procedure TStainedGlass.UnhookOwner;
    begin
     if Assigned(Owner) and Assigned(OldWndProc) then
      SetWindowLong(TForm(Owner).Handle,GWL_WndProc,LongInt(OldWndProc));
     if Assigned(NewWndProc) then
      FreeObjectInstance(NewWndProc);
     NewWndProc:=nil;
     OldWndProc:=nil
    end;

Answer 1

procedure TStainedGlass.CallDefault;
    begin
     Msg.Result:=CallWindowProc(OldWndProc,TForm(Owner).Handle,Msg.Msg,Msg.wParam,Msg.lParam)
    end;   procedure TStainedGlass.HookWndProc;
    var DC:HDC;
        PS:TPaintStruct;
        CW,CH,CX,CY:Integer;
        SL,BL:PRGBArray;
        X,Y,T:Integer;
        TicksNow:Integer;
        BM2:TBitmap;
        TranspFunc:TTransparencyFunc;
     begin
      case Msg.Msg of
       WM_Paint:if (csDesigning in ComponentState) and not FDrawOnDesigning then
                 CallDefault(Msg)
                else
                 with Owner as TForm do
                  begin
                   if Msg.WParam<>0 then
                    raise EComponentError.Create('TStainedGlass: incompatibilities were detected. See ReadMe file');
                   CW:=ClientWidth;
                   CH:=ClientHeight;
                   CX:=ClientOrigin.X;
                   CY:=ClientOrigin.Y;
                   if not Moving then
                    begin
                     ShowWindow(Handle,SW_Hide);
                     SetActiveWindow(0);
                     TicksNow:=GetTickCount;
                     repeat
                      Application.ProcessMessages
                     until GetTickCount-TicksNow>=DelayTime;
                     DC:=GetDC(0);
                     BitBlt(ScrImage.Canvas.Handle,0,0,ScrImage.Width,ScrImage.Height,DC,0,0,SrcCopy);
                     ReleaseDC(0,DC)
                    end;
                   BM2:=TBitmap.Create;
                   BM2.Width:=CW+1;
                   BM2.Height:=CH+1;
                   BM2.PixelFormat:=pf24bit;
                   BM2.Canvas.Draw(-CX,-CY,ScrImage);
                   if NeedRefresh or (CW<>OldWidth) or (CH<>OldHeight) then
                    CreateBack(CW,CH);
                   case FTranspStyle of
                    tsConstant:TranspFunc:=ConstantTransparency;
                    tsHorGradient:TranspFunc:=HGTransparency;
                    tsVertGradient:TranspFunc:=VGTransparency;
                    tsCustom:if Assigned(FOnGetTransparency) then
                              TranspFunc:=CustomTransparency
                             else
                              TranspFunc:=ConstantTransparency
                   end;
                   for Y:=0 to CH do
                    begin
                     SL:=BM2.ScanLine[Y];
                     BL:=Back.ScanLine[Y];
                     for X:=0 to CW do
                      begin
                       T:=TranspFunc(X,Y,CW,CH);
                       SL[X].rgbtRed:=(T*SL[X].rgbtRed+(100-T)*BL[X].rgbtRed) div 100;
                       SL[X].rgbtGreen:=(T*SL[X].rgbtGreen+(100-T)*BL[X].rgbtGreen) div 100;
                       SL[X].rgbtBlue:=(T*SL[X].rgbtBlue+(100-T)*BL[X].rgbtBlue) div 100
                      end
                    end;
                   ShowWindow(Handle,SW_Show);
                   Msg.WParam:=BeginPaint(Handle,PS);
                   BitBlt(Msg.WParam,0,0,BM2.Width,BM2.Height,BM2.Canvas.Handle,0,0,SrcCopy);
                   BM2.Free;
                   CallDefault(Msg);
                   EndPaint(Handle,PS)
                  end;
       WM_EraseBkgnd:if (csDesigning in ComponentState) and not FDrawOnDesigning then
                      CallDefault(Msg)
                     else
                      Msg.Result:=1;
       WM_WindowPosChanged:begin
                            CallDefault(Msg);
                            if not (csDesigning in ComponentState) or FDrawOnDesigning then
                             TForm(Owner).Invalidate
                           end;
       WM_EnterSizeMove:begin
                         Moving:=True;
                         CallDefault(Msg)
                        end;
       WM_ExitSizeMove:begin
                        CallDefault(Msg);
                        Moving:=False
                       end;
       WM_DisplayChange:begin
                         CallDefault(Msg);
                         ScrImage.Width:=Msg.LParamLo;
                         ScrImage.Height:=Msg.LParamHi;
                         Refresh
                        end
      else
       CallDefault(Msg)
      end
     end;   procedure TStainedGlass.CreateBack;
    var WX,W1,HX,H1,FY,FX:Integer;
     begin
      NeedRefresh:=False;
      OldWidth:=W;
      OldHeight:=H;
      Back.Width:=W+1;
      Back.Height:=H+1;
      with Back.Canvas do
       begin
        Pen.Style:=psClear;
        Brush.Style:=bsSolid;
        Brush.Color:=TForm(Owner).Color;
        Rectangle(0,0,W+1,H+1);
        case FBackStyle of
         bsMosaic:if not FGlyph.Empty then
                   begin
                    WX:=FGlyph.Width;
                    HX:=FGlyph.Height;
                    FY:=0;
                    while FY<H do
                     begin
                      H1:=MinIntValue([H-FY,HX]);
                      FX:=0;
                      while FX<W do
                       begin
                        W1:=MinIntValue([W-FX,WX]);
                        Draw(FX,FY,FGlyph);
                        Inc(FX,W1)
                       end;
                      Inc(FY,H1)
                     end
                   end;
         bsCentered:if not FGlyph.Empty then
                     Draw((W-FGlyph.Width) div 2,(H-FGlyph.Height) div 2,FGlyph);
         bsStretched:if not FGlyph.Empty then
                      StretchDraw(Rect(0,0,W,H),FGlyph);
         bsCustom:if Assigned(FOnCreateBackground) then
                   FOnCreateBackground(Self,Back)
        end
       end
     end;   procedure TStainedGlass.Refresh;
    begin
     NeedRefresh:=True;
     TForm(Owner).Invalidate
    end;   procedure TStainedGlass.SetAltTransparency;
    begin
     if Value<>FAltTransparency then
      begin
       FAltTransparency:=Value;
       if FTranspStyle<>tsConstant then
        TForm(Owner).Invalidate
      end
    end;   procedure TStainedGlass.SetBackStyle;
    begin
     if Value<>FBackStyle then
      begin
       FBackStyle:=Value;
       Refresh
      end
    end;   procedure TStainedGlass.SetDrawOnDesigning;
    begin
     FDrawOnDesigning:=Value;
     if csDesigning in ComponentState then
      TForm(Owner).Invalidate
    end;   procedure TStainedGlass.SetGlyph;
    begin
     FGlyph.Assign(Value);
     Refresh
    end;   procedure TStainedGlass.SetTransparency;
    begin
     if Value<>FTransparency then
      begin
       FTransparency:=Value;
       TForm(Owner).Invalidate
      end
    end;   procedure TStainedGlass.SetTranspStyle;
    begin
     if Value<>FTranspStyle then
      begin
       FTranspStyle:=Value;
       TForm(Owner).Invalidate
      end
    end;   function TStainedGlass.ConstantTransparency;
    begin
     Result:=FTransparency
    end;   function TStainedGlass.HGTransparency;
    begin
     Result:=Transparency+Round((AltTransparency-Transparency)/W*X)
    end;   function TStainedGlass.VGTransparency;
    begin
     Result:=Transparency+Round((AltTransparency-Transparency)/H*Y)
    end;   function TStainedGlass.CustomTransparency;
    begin
     FOnGetTransparency(Self,X,Y,W,H,Result)
    end;   procedure TStainedGlass.GlyphChanged;
    begin
     TForm(Owner).Invalidate
    end;   procedure Register;
    begin
     RegisterComponents('SGlass', [TStainedGlass])
    end;

Answer 2

想不到delphi会有这么困难，.net里微软又给包好了。

Answer 3

嗯？ 从DELPHI6开始，TFORM不是就直接提供了半透明显示的属性吗？

Answer 4

可是我需要的是把系统里所有的窗体统统半透明显示，那个恐怕无法在98下运行。也无法和api一样方便的设置系统底层

Answer 5

其实这个程序实现的方法是首先取得背景的图片，然后在hook到消息后将背景画出来。因此你需要更改一下部分源代码就可以了。
更改的部分主要是在hook到消息后重新画的部分。即HookWndProc中的wmPaint部分。其中
BitBlt(ScrImage.Canvas.Handle,0,0,ScrImage.Width,ScrImage.Height,DC,0,0,SrcCopy);是将背景图片存储到ScrImage中，然后BM2.Canvas.Draw(-CX,-CY,ScrImage);将背景存储到Bm2中，然后对bm2中数据进行计算，最后BitBlt(Msg.WParam,0,0,BM2.Width,BM2.Height,BM2.Canvas.Handle,0,0,SrcCopy);将计算好的背景画到form上的要更新的部分，因此你只要对这个部分进行修改就可以了，主要是如何实现半透明的方法。
实际上就是一个颜色的与或者或的问题了，你自己试试看吧。不过改源代码很麻烦的。如果分数多一点，呵呵，倒可以考虑我来给你改改看。

Answer 6

98下通过
取窗体下背景图，后将各点的颜色的RGB各取一半。 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 uses JtoCXPMain,JtoCXPPubVar; {$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,'[email protected]'); 
  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.

Answer 7

可是我需要的是把系统里所有的窗体统统半透明显示，哪怕不是自己的程序也可以半透明的，可惜这个程序不是底层支持，非常慢，看vcd的时候跳来跳去，无法看

Answer 8

从DELPHI6开始，TFORM不是就直接提供了半透明显示的属性吗？
可是我需要的是把系统里所有的窗体统统半透明显示，这种方法只对自己的软件有效果，对别人的无效果，需要访问底层