Mega Code Archive
A component to make transparent [shaped] forms
<![CDATA[
The code below is for a component that can create transparent (shaped) forms ...
The code below is for a component that can create transparent (shaped) forms using either bitmaps or controls, or both. There are two ways of telling the component what you want used as a mask: the Tag setting (TransTag) or a Component list where you just insert the component name as a new line of text.
There is even an event to follow the progress of the process, when it is long.
For the images there is a Mask Color property, that is the color that will be transparent.
Use the Execute method to make the transparent form. When there aren't a lot of images, the process is quite fast and you can use it to create even animation effects on your desktop.
NOTE: for the creation of the Mask from images the component takes into account the TImage component.
unit TransMake;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,ExtCtrls;
type
TProcessEvent=procedure(progress:longint) of object;
TBy =(TBTag,TBComponentList);
TTransMake = class(TComponent)
private
{ Private declarations }
ITransTag:integer;
ImageTrans:Boolean;
ColorMask:TColor;
region:hrgn;
TransByV:TBy;
ComponentListV:TStrings;
fullitems:LongInt;
FOnProgress:TProcessEvent;
procedure DrawTransparent;
procedure ComponentListWrite(value:TStrings);
procedure SetTransBy(value:TBy);
protected
{ Protected declarations }
procedure DoOnProgress(progress:longint);dynamic;
public
{ Publc declarations }
Procedure Execute;
Constructor Create(AOwner:TComponent);override;
published
{ Published declarations }
Property TransTag:Integer read ITransTag write ITransTag;
Property ImageRegion:boolean read ImageTrans write ImageTrans;
property MaskColor:TColor read ColorMask write ColorMask;
property TransBy:TBy read TransByV write SetTransBy default TBTag;
property ComponentList:TStrings read ComponentListV write ComponentListWrite;
property OnProgress:TProcessEvent read FOnProgress write FOnProgress;
end;
procedure Register;
implementation
procedure TTransMake.DoOnProgress(progress:longint);
begin
if assigned(FonProgress) then
TProcessEvent(FonProgress)(progress);
end;
procedure TTransMake.SetTransBy(Value:TBy);
begin
TransByV := Value;
end;
procedure TTransMake.ComponentListWrite(Value:TStrings);
begin
ComponentListV.Assign(value);
end;
constructor TTransMake.Create(AOwner:TComponent);
begin
inherited Create(AOwner);
ComponentListV:=TStringList.Create;
ComponentListV.Add('Place your component names here.');
FullItems:=0;
end;
procedure TTransMake.DrawTransparent;
var
OForm:TForm;
i,o,x,y,rx,ry:integer;
tr:Trect;
tregion,imgregion:Hrgn;
proceed:boolean;
TempBitmap: TBitmap;
Rgn1, Rgn2: HRgn;
Col, StartCol, Row,test: integer;
Line: PByteArray;
doing,perc:integer;
begin
OForm:=TForm(owner);
region:=0;
imgregion:=0;
rgn1:=0;
fullitems:=0;
doing:=0;
perc:=0;
region:=createRectRgn(0,0,0,0);
rgn1:=createRectRgn(0,0,0,0);
OForm.visible:=false;
OForm.BorderStyle:=bsNone;
for i:=0 to OForm.ComponentCount-1 do
begin
if TransBy=TBTag then
if (OForm.Components[i]).tag=TransTag then
begin
proceed:=true;
fullitems:=fullitems+1;
end;
if TransBy=TBComponentList then
begin
if componentlistV.Count>0 then
for o:=0 to componentlistv.Count-1 do
begin
if (Uppercase((OForm.Components[i]).name)=uppercase(componentlistv.Strings[o])) then
begin
fullitems:=fullitems+1;
end;
end;
end;
end;
for i:=0 to OForm.ComponentCount-1 do
begin
proceed:=false;
if TransBy=TBTag then
if (OForm.Components[i]).tag=TransTag then
begin
proceed:=true;
end;
if TransBy=TBComponentList then
begin
if componentlistV.Count>0 then
for o:=0 to componentlistv.Count-1 do
begin
if (Uppercase((OForm.Components[i]).name)=uppercase(componentlistv.Strings[o])) then
begin
proceed:=true;
end;
end;
end;
if proceed then
begin
if TControl(OForm.components[i]).visible then
begin
if (OForm.components[i] is TImage) and ImageRegion then
begin
with TImage(OForm.components[i]).picture.bitmap do
begin
for Row := 0 to TImage(OForm.components[i]).picture.bitmap.height-1 do
begin
Col := 0;
while Col < TImage(OForm.components[i]).picture.bitmap.Width do
begin
while (Col < TImage(OForm.components[i]).picture.bitmap.Width) and (Canvas.pixels[col,row] = ColorMask) do inc(Col);
if Col >= TImage(OForm.components[i]).picture.bitmap.Width then Continue;
StartCol := Col;
while (Col < TImage(OForm.components[i]).picture.bitmap.Width) and (Canvas.pixels[col,row] <> ColorMask) do inc(Col);
if Col >= TImage(OForm.components[i]).picture.bitmap.Width then Col := TImage(OForm.components[i]).picture.bitmap.Width;
if Rgn1 = 0 then Rgn1 := CreateRectRgn(TImage(OForm.components[i]).left+StartCol, TImage(OForm.components[i]).top+Row, TImage(OForm.components[i]).left+Col, TImage(OForm.components[i]).top+Row + 1)
else begin
Rgn2 := CreateRectRgn(TImage(OForm.components[i]).left+StartCol, TImage(OForm.components[i]).top+Row, TImage(OForm.components[i]).left+Col, TImage(OForm.components[i]).top+Row + 1);
if (Rgn2 <> 0) then CombineRgn(Rgn1,Rgn1,Rgn2,RGN_OR);
Deleteobject(Rgn2);
end;
end;
end;
end;
doing:=doing+1;
perc:=round(100*(doing/fullitems));
DoOnProgress(perc);
combinergn(region,region,rgn1,rgn_or);
rgn1:=0;
end
else
begin
tr:=TControl(OForm.components[i]).BoundsRect;
tr.left:=tr.left;
tr.Top:=tr.Top;
tr.Right:=tr.Right;
tr.Bottom:=tr.Bottom;
if region=0 then
region:=createRectRgn(tr.Left,tr.Top,tr.Right,tr.Bottom)
else
begin
tregion:=createRectRgn(tr.Left,tr.Top,tr.Right,tr.Bottom);
doing:=doing+1;
perc:=round(100*(doing/fullitems));
DoOnProgress(perc);
combinergn(region,region,tregion,rgn_or);
deleteObject(tregion);
end;
end;
end;
end;
end;
setwindowrgn(OForm.handle,region,true);
OForm.visible:=true;
end;
Procedure TTransMake.Execute;
begin
DrawTransparent;
end;
procedure Register;
begin
RegisterComponents('VNPVcls', [TTransMake]);
end;
end.
]]>