Mega Code Archive
Transparent Form Component
<![CDATA[
Title: Transparent Form Component
Question: Making A Controllable Transparent Form, Or Transparencies For A Certain Colour Or Both, Great For Shaped Forms.
Answer:
(* CopyRight 2004, C. Lormand *)
Unit SpectralTransForm;
Interface
uses Messages, Windows, SysUtils, Classes, Controls, Forms, Menus, Graphics,
StdCtrls;
Type
TSpectralFadeForm = Class(TComponent)
Private
FWindowHandle: HWND;
FLevel: Integer;
FFormFade: Boolean;
FColourFade: Boolean;
FColour: TColor;
Procedure TransparentWind;
Procedure SetFormFade(bValue : Boolean);
Procedure SetColourFade(bValue : Boolean);
Procedure SetTransColour(cValue: TColor);
Procedure SetTransForm(Value: Integer);
Function LoadSDK: Boolean;
Function UnLoadSDK: Boolean;
Public
Constructor Create(AOwner: TComponent); override;
Destructor Destroy; override;
Published
Property Level : Integer Read FLevel Write SetTransForm Default 0;
Property FormFade : Boolean Read FFormFade Write SetFormFade Default False;
Property ColourFade : Boolean Read FColourFade Write SetColourFade Default False;
Property FadeColour : TColor Read FColour Write SetTransColour;
End;
Procedure Register;
Implementation
Var
LayerFunc: Function(Handle: HWND; crKey: DWord; bAlpha: Byte; dwFlags: DWORD): Bool; stdcall;
hDLL: HWND;
{$R *.DCR}
// CONSTANTS FOR WINSDK
Const
WS_EX_LAYERED = $00080000;
LWA_COLORKEY = $00000001;
LWA_ALPHA = $00000002;
ULW_COLORKEY = $00000001;
ULW_ALPHA = $00000002;
ULW_OPAQUE = $00000004;
Function Compatible: Boolean;
Var
OSVer: TOSVersionInfo;
Begin
Result := False;
Try
OSVer.dwOSVersionInfoSize := SizeOf(TOSVersionInfo);
GetVersionEx(OSVer);
If (OSVer.dwPlatformID = VER_PLATFORM_WIN32_NT) Then
If (OSVer.dwMajorVersion = 5) Then Result := True;
Except
Result := False;
End;
End;
Constructor TSpectralFadeForm.Create(AOwner: TComponent);
Begin
Inherited Create(AOwner);
FWindowHandle := (AOwner AS TForm).Handle;
LoadSDK;
End;
Destructor TSpectralFadeForm.Destroy;
begin
SetFormFade(False);
SetColourFade(False);
TransparentWind;
UnLoadSDK;
Inherited Destroy;
end;
Procedure TSpectralFadeForm.SetTransForm(Value: Integer);
Begin
FLevel := Value;
TransparentWind;
End;
Procedure TSpectralFadeForm.SetTransColour(cValue: TColor);
Begin
FColour := cValue;
TransparentWind;
End;
Procedure TSpectralFadeForm.SetFormFade(bValue: Boolean);
Begin
FFormFade := bValue;
TransparentWind;
End;
Procedure TSpectralFadeForm.SetColourFade(bValue: Boolean);
Begin
FColourFade := bValue;
TransparentWind;
End;
Function TSpectralFadeForm.LoadSDK: Boolean;
Begin
If (Compatible) Then
Begin
Try
hDLL := LoadLibrary('user32.dll');
If (hDLL 0) Then @LayerFunc := GetProcAddress(hDLL, 'SetLayeredWindowAttributes');
Result := true;
Except
Result := false;
End;
End Else
Result := false;
End;
Function TSpectralFadeForm.UnLoadSDK: Boolean;
Begin
If (Compatible) Then
Begin
Try
@LayerFunc := NIL;
FreeLibrary(hDLL);
Result := true;
Except
Result := false;
End;
End Else
Result := False;
End;
Procedure TSpectralFadeForm.TransparentWind;
Begin
If (Compatible) Then
Begin
If ((FFormFade) Or (FColourFade)) Then
Begin // turn it on
Try
If (Level Else If (Level 255) Then Level := 255; // anything higher is blank
SetWindowLong(FWindowHandle, GWL_EXSTYLE, GetWindowLong(FWindowHandle, GWL_EXSTYLE) or WS_EX_LAYERED);
If ((FColourFade) And (Not FFormFade)) Then LayerFunc(FWindowHandle, RGB((FColour and $ff), ((FColour and $ff00) shr 8),((FColour and $ff0000) shr 16)), dWord(Level), LWA_COLORKEY);
If ((Not FColourFade) And (FFormFade)) Then LayerFunc(FWindowHandle, RGB(0,0,0), dWord(Level), LWA_ALPHA);
If ((FColourFade) And (FFormFade)) Then LayerFunc(FWindowHandle, RGB((FColour and $ff), ((FColour and $ff00) shr 8),((FColour and $ff0000) shr 16)), dWord(Level), LWA_ALPHA OR LWA_COLORKEY);
Except
End;
End
Else
Begin // turn it off
Try
SetWindowLong(FWindowHandle, GWL_EXSTYLE, GetWindowLong(FWindowHandle, GWL_EXSTYLE) And (NOT WS_EX_LAYERED));
Except
End;
End;
End
Else
End;
Procedure Register;
Begin
RegisterComponents('Spectral Transparent Components', [TSpectralFadeForm]);
End;
End.
]]>