A component to make transparent (shaped) forms

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.

 

Share this article!

Follow us!

Find more helpful articles: