- {*******************************************************}
- { }
- { GDI+用PNG图片做半透明异型窗口 }
- { }
- { 版权所有 (C) 2008 QQ:3150379 }
- { }
- {*******************************************************}
- unit Unit1;
- interface
- uses
- Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
- Dialogs,
- GDIPAPI, GDIPOBJ, Menus, StdCtrls;
- type
- TForm1 = class(TForm)
- PopupMenu1: TPopupMenu;
- mniClose: TMenuItem;
- mniChangeSkin: TMenuItem;
- About1: TMenuItem;
- Stayontop1: TMenuItem;
- procedure FormCreate(Sender: TObject);
- procedure FormMouseDown(Sender: TObject; Button: TMouseButton;
- Shift: TShiftState; X, Y: Integer);
- procedure About1Click(Sender: TObject);
- procedure Stayontop1Click(Sender: TObject);
- procedure mniChangeSkinClick(Sender: TObject);
- procedure mniCloseClick(Sender: TObject);
- private
- m_Blend: BLENDFUNCTION;
- procedure SetTransparent(lpSkinFile: WideString; nTran: integer);
- { Private declarations }
- public
- { Public declarations }
- end;
- var
- Form1: TForm1;
- implementation
- {$R *.dfm}
- procedure TForm1.FormCreate(Sender: TObject);
- begin
- BorderStyle := bsNone;
- m_Blend.BlendOp := AC_SRC_OVER; // the only BlendOp defined in Windows 2000
- m_Blend.BlendFlags := 0; // Must be zero
- m_Blend.AlphaFormat := AC_SRC_ALPHA; //This flag is set when the bitmap has an Alpha channel
- m_Blend.SourceConstantAlpha := 255;
- if (FileExists(ExtractFilePath(ParamStr(0)) + 'Security - Alert.png')) then
- SetTransparent(WideString(ExtractFilePath(ParamStr(0)) + 'Security - Alert.png'), 100);
- // Stay on top
- SetWindowPos(Handle, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE or SWP_NOSIZE);
- end;
- procedure TForm1.SetTransparent(lpSkinFile: WideString; nTran: integer);
- var
- GPImage: TGPImage;
- GPGraph: TGPGraphics;
- m_Image: TGPImage;
- m_hdcMemory: HDC;
- hdcScreen: HDC;
- hBMP: HBITMAP;
- sizeWindow: SIZE;
- rct: TRECT;
- ptSrc: TPOINT;
- begin
- // Use GDI+ load image
- GPImage := TGPImage.Create();
- m_Image := GPImage.FromFile(lpSkinFile);
- // Create Compatible Bitmap
- hdcScreen := GetDC(0);
- m_hdcMemory := CreateCompatibleDC(hdcScreen);
- hBMP := CreateCompatibleBitmap(hdcScreen, m_Image.GetWidth(), m_Image.GetHeight());
- SelectObject(m_hdcMemory, hBMP);
- // Alpha Value
- if (nTran < 0) or (nTran > 100) then
- nTran := 100;
- m_Blend.SourceConstantAlpha := round(nTran * 2.55); // 1~255
- GetWindowRect(Handle, rct);
- GPGraph := TGPGraphics.Create(m_hdcMemory);
- GPGraph.DrawImage(m_Image, 0, 0, m_Image.GetWidth(), m_Image.GetHeight());
- sizeWindow.cx := m_Image.GetWidth();
- sizeWindow.cy := m_Image.GetHeight();
- ptSrc.x := 0;
- ptSrc.y := 0;
- // Set Window style
- SetWindowLong(Handle, GWL_EXSTYLE, GetWindowLong(Handle, GWL_EXSTYLE) or WS_EX_LAYERED);
- // perform the alpha blend
- UpdateLayeredWindow(Handle, hdcScreen, nil,@sizeWindow, m_hdcMemory, @ptSrc, 0, @m_Blend, ULW_ALPHA);
- //Release resources
- GPGraph.ReleaseHDC(m_hdcMemory);
- ReleaseDC(0, hdcScreen);
- hdcScreen := 0;
- DeleteObject(hBMP);
- DeleteDC(m_hdcMemory);
- m_hdcMemory := 0;
- m_Image.Free;
- GPGraph.Free;
- end;
- procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
- Shift: TShiftState; X, Y: Integer);
- begin
- if (Button = mbLeft) then
- begin
- ReleaseCapture();
- Perform(WM_SYSCOMMAND, SC_MOVE or HTCAPTION, 0);
- end;
- end;
- procedure TForm1.About1Click(Sender: TObject);
- begin
- MessageDlg('效果还不行吧!'#13+'QQ:3150379', mtInformation, [mbOK], 0);
- end;
- procedure TForm1.Stayontop1Click(Sender: TObject);
- var
- mi: TMenuItem;
- WindowPos: HWND;
- begin
- mi := Sender as TMenuItem;
- mi.Checked := not mi.Checked;
- if mi.Checked then
- WindowPos := HWND_TOPMOST
- else
- WindowPos := HWND_NOTOPMOST;
- SetWindowPos(Handle, WindowPos,0, 0, 0, 0, SWP_NOMOVE or SWP_NOSIZE);
- end;
- procedure TForm1.mniChangeSkinClick(Sender: TObject);
- var
- dlgOpen: TOpenDialog;
- begin
- dlgOpen := TOpenDialog.Create(Self);
- dlgOpen.Filter := 'PNG file(*.png)|*.png';
- if (dlgOpen.Execute()) then
- begin
- SetTransparent(WideString(dlgOpen.FileName), 100);
- Invalidate();
- end;
- dlgOpen.Free;
- end;
- procedure TForm1.mniCloseClick(Sender: TObject);
- begin
- Close;
- end;
- end.