Roadcrash
asked on
Question regarding a bitmap, as the form background, which is transparant but not smooth
Hi all
I have been searching through the answers here, and did not get what i wanted, i am using code i found here, to show a form that is rounded, and has transparant regions, see thew code below, but I think it cannot be antialiased, or simply said, smoothed edges?
I can live with it, if it cannot be done, so a simple "no" is an answer as well, then i can stop trying, but if it can be done pls help me out, i have enough knolwedge to create any sort of graphic in paint shop pro, that is not the point, but i cannot make delphi use just it as i created it.
unit unittr;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ExtDlgs, OleCtrls;
type
TForm1 = class(TForm)
Btn1: TButton;
dlgOpenPicOpenPicDialog1: TOpenPictureDialog;
btn2: TButton;
procedure Btn1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormPaint(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure Btn2Click(Sender: TObject);
private
{ Private declarations }
Region1: HRgn;
RgnStart: Boolean;
PixStart, RgnX, RgnY: Integer;
Adj: Byte;
SkinBmp: TBitmap;
function ReturnRgn(ThisRgn: HRgn): Hrgn;
function MakeRegion: Integer;
procedure SetRegion;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
function TForm1.ReturnRgn(ThisRgn: HRgn): Hrgn;
var
TempRgn2 : HRgn;
begin
{in Win 98 there is unusual problems when combining Regions,
if you Combine a region more than about 400 times, Win 98 does
strange things, this is my solution. This combines the region but
the pointer references to this function, ThisRgn, and TempRgn2 are
gone when the function is done}
TempRgn2 := 0;
if RgnStart then
begin
ThisRgn :=CreateRectRgn(PixStart,R gnY,RgnX+A dj,RgnY+1) ;
RgnStart := False;
Adj := 0;
PixStart := 0;
end
else
begin
TempRgn2 := CreateRectRgn(PixStart,Rgn Y,RgnX+Adj ,RgnY+1);
CombineRgn(ThisRgn, ThisRgn, TempRgn2, RGN_OR);
Adj := 0;
PixStart := 0;
end;
Result := ThisRgn;
if TempRgn2 <> 0 then
DeleteObject(TempRgn2);
end;
function TForm1.MakeRegion: Integer;
{DoMask sets the bitmap used to the Mask or Image}
Type
PRGBArray = ^TRGBArray;
TRGBArray = Array[0..16383] of TRGBTriple;
{I use TRGBArray to make the ScanLine output (array of byte) have color references
I have limited it to 16384 so your Bitmaps have to be less
than 16384 wide}
var
TempBmp: TBitmap;
TempRgn: HRgn;
x, y, Error1: Integer;
PixRgn: Boolean;
Prgb: PRGBArray;
xColor: TColor;
Variation, RLoVar, RHiVar, GLoVar, GHiVar, BLoVar, BHiVar: Byte;
function LimitToByte(Value: Integer): Byte;
begin
if Value < 0 then
Result := 0 else
If Value > 255 then
Result := 255 else
Result := Value;
end;
begin
{this makes a region by doing a scanline on an Image (MaskBmp or ImageBmp)
and then making a region for that line segment and then combining the
segment regions into the final region
the DoMask is used by me, because I do alot of graphics editing and Masks are
the easist way for me to deal with creating a region from an Image, often photo
images will have spots of the Transparent color, I can get rid of spots in the mask}
Result := 0;
RgnStart := True;
PixRgn := False;
PixStart := 0;
Adj := 0;
TempRgn := CreateRectRgn(0,0,0,0);
TempBmp := TBitmap.Create;
TempBmp.Assign(SkinBmp);
xColor := SkinBmp.Canvas.Pixels[0,Sk inBmp.Heig ht -1];
{the amount of color variation
allowed for the Transparent Color, I call it Variation}
Variation := 18;
{RLoWob and RHiWob are the Hi and Low limits of the Color allowed}
RLoVar := LimitToByte(GetRValue(xCol or) - Variation);
RHiVar := LimitToByte(GetRValue(xCol or) + Variation);
GLoVar := LimitToByte(GetGValue(xCol or) - Variation);
GHiVar := LimitToByte(GetGValue(xCol or) + Variation);
BLoVar := LimitToByte(GetBValue(xCol or) - Variation);
BHiVar := LimitToByte(GetBValue(xCol or) + Variation);
//end;
TempBmp.PixelFormat := pf24bit;
{for this Scanline the Image MUST be in pf24Bit}
Application.ProcessMessage s;
{This is the scanline, which may take a several seconds on large Images
I can not begin to explain using scanline here}
for y := 0 to TempBmp.Height -1 do
begin
RgnY := y;
Prgb := TempBmp.ScanLine[y];
for x := 0 to TempBmp.Width -1 do
begin
RgnX := x;
with Prgb[x] do
if (rgbtRed >= RLoVar) and (rgbtRed <= RHiVar) and (rgbtGreen >= GLoVar) and (rgbtGreen <= GHiVar) and (rgbtBlue >= BLoVar) and (rgbtBlue <= BHiVar) then
begin
if PixRgn then TempRgn := ReturnRgn(TempRgn);
PixRgn := False;
end
else
begin
if not PixRgn then PixStart := x;
if x = TempBmp.Width -1 then
begin
Adj := 1;
TempRgn := ReturnRgn(TempRgn);
end;
PixRgn := True;
end;
end;
end;
Result := CreateRectRgn(0,0,0,0);
Error1 := CombineRgn(Result, TempRgn, Result, RGN_COPY);
if (Error1 = NULLREGION) or (Error1 = ERROR) then
Result := 0;
DeleteObject(TempRgn);
FreeAndNil(TempBmp);
end;
procedure TForm1.Btn1Click(Sender: TObject);
begin
{this is the EXit button click}
Close;
end;
procedure TForm1.SetRegion;
var
Rgn2: HRGN;
begin
if not SkinBmp.Empty then
begin
Width := SkinBmp.Width;
Height := SkinBmp.Height;
{Button1.Left := Width-Button1.Width;
Button1.Top := 5;}
Btn1.Left := (Width div 2) - (Btn1.Width div 2);
Btn1.Top := ((Height div 2) - (Btn1.Height div 2))-16;
Btn2.Left := (Width div 2) - (Btn2.Width div 2);
Btn2.Top := (Height div 2) - (Btn2.Height div 2)+16;
end else Exit;
Region1 := MakeRegion;
if Region1 = 0 then
begin
SetWindowRgn(Handle, 0, TRUE);
ShowMessage('ERROR, Failed to make Shape Region');
Exit;
end;
{you can Not tell if your Buttons will be in the visible region
so I create 2 additional regions, one for each button and add them to
the visible region so you can use the buttons}
Rgn2 := CreateRectRgn(Btn1.Left, Btn1.Top, Btn1.Left+Btn1.Width,Btn1. Top+Btn1.H eight);
CombineRgn(Region1, Rgn2, Region1, RGN_OR);
DeleteObject(Rgn2);
Rgn2 := CreateRectRgn(Btn2.Left, Btn2.Top, Btn2.Left+Btn2.Width,Btn2. Top+Btn2.H eight);
CombineRgn(Region1, Rgn2, Region1, RGN_OR);
DeleteObject(Rgn2);
SetWindowRgn(Handle, Region1, TRUE);
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
SkinBmp := TBitmap.Create;
SkinBmp.LoadFromFile(Extra ctFilePath (Applicati on.ExeName )+'masked2 .bmp');
BorderStyle := bsNone;
SetRegion;
end;
procedure TForm1.FormPaint(Sender: TObject);
begin
Canvas.Draw(0,0, SkinBmp);
end;
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
SkinBmp.Free;
DeleteObject(Region1);
end;
procedure TForm1.Btn2Click(Sender: TObject);
var
Bmp2: TBitmap;
begin
{this is the Open Bitmap click}
dlgOpenPicOpenPicDialog1.I nitialDir := 'C:\';
dlgOpenPicOpenPicDialog1.F ilter := 'Bitmap|*.bmp';
dlgOpenPicOpenPicDialog1.F ilterIndex := 0;
if dlgOpenPicOpenPicDialog1.E xecute then
begin
Bmp2 := TBitmap.Create;
try
Bmp2.LoadFromFile(dlgOpenP icOpenPicD ialog1.Fil eName);
if (Bmp2.Height < Btn1.Height+ Btn2.Height+16) or
(Bmp2.Width < Btn2.Width+8) then
begin
ShowMessage('ERROR, This Bitmap Image is TOO SMALL');
Exit;
end;
SkinBmp.Assign(Bmp2);
finally
Bmp2.Free;
end;
SetRegion;
FormPaint(self);
end;
end;
initialization
form1 := Tform1.Create(nil);
Form1.Show;
form1.Update;
end;
end;
end.
I have been searching through the answers here, and did not get what i wanted, i am using code i found here, to show a form that is rounded, and has transparant regions, see thew code below, but I think it cannot be antialiased, or simply said, smoothed edges?
I can live with it, if it cannot be done, so a simple "no" is an answer as well, then i can stop trying, but if it can be done pls help me out, i have enough knolwedge to create any sort of graphic in paint shop pro, that is not the point, but i cannot make delphi use just it as i created it.
unit unittr;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ExtDlgs, OleCtrls;
type
TForm1 = class(TForm)
Btn1: TButton;
dlgOpenPicOpenPicDialog1: TOpenPictureDialog;
btn2: TButton;
procedure Btn1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormPaint(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure Btn2Click(Sender: TObject);
private
{ Private declarations }
Region1: HRgn;
RgnStart: Boolean;
PixStart, RgnX, RgnY: Integer;
Adj: Byte;
SkinBmp: TBitmap;
function ReturnRgn(ThisRgn: HRgn): Hrgn;
function MakeRegion: Integer;
procedure SetRegion;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
function TForm1.ReturnRgn(ThisRgn: HRgn): Hrgn;
var
TempRgn2 : HRgn;
begin
{in Win 98 there is unusual problems when combining Regions,
if you Combine a region more than about 400 times, Win 98 does
strange things, this is my solution. This combines the region but
the pointer references to this function, ThisRgn, and TempRgn2 are
gone when the function is done}
TempRgn2 := 0;
if RgnStart then
begin
ThisRgn :=CreateRectRgn(PixStart,R
RgnStart := False;
Adj := 0;
PixStart := 0;
end
else
begin
TempRgn2 := CreateRectRgn(PixStart,Rgn
CombineRgn(ThisRgn, ThisRgn, TempRgn2, RGN_OR);
Adj := 0;
PixStart := 0;
end;
Result := ThisRgn;
if TempRgn2 <> 0 then
DeleteObject(TempRgn2);
end;
function TForm1.MakeRegion: Integer;
{DoMask sets the bitmap used to the Mask or Image}
Type
PRGBArray = ^TRGBArray;
TRGBArray = Array[0..16383] of TRGBTriple;
{I use TRGBArray to make the ScanLine output (array of byte) have color references
I have limited it to 16384 so your Bitmaps have to be less
than 16384 wide}
var
TempBmp: TBitmap;
TempRgn: HRgn;
x, y, Error1: Integer;
PixRgn: Boolean;
Prgb: PRGBArray;
xColor: TColor;
Variation, RLoVar, RHiVar, GLoVar, GHiVar, BLoVar, BHiVar: Byte;
function LimitToByte(Value: Integer): Byte;
begin
if Value < 0 then
Result := 0 else
If Value > 255 then
Result := 255 else
Result := Value;
end;
begin
{this makes a region by doing a scanline on an Image (MaskBmp or ImageBmp)
and then making a region for that line segment and then combining the
segment regions into the final region
the DoMask is used by me, because I do alot of graphics editing and Masks are
the easist way for me to deal with creating a region from an Image, often photo
images will have spots of the Transparent color, I can get rid of spots in the mask}
Result := 0;
RgnStart := True;
PixRgn := False;
PixStart := 0;
Adj := 0;
TempRgn := CreateRectRgn(0,0,0,0);
TempBmp := TBitmap.Create;
TempBmp.Assign(SkinBmp);
xColor := SkinBmp.Canvas.Pixels[0,Sk
{the amount of color variation
allowed for the Transparent Color, I call it Variation}
Variation := 18;
{RLoWob and RHiWob are the Hi and Low limits of the Color allowed}
RLoVar := LimitToByte(GetRValue(xCol
RHiVar := LimitToByte(GetRValue(xCol
GLoVar := LimitToByte(GetGValue(xCol
GHiVar := LimitToByte(GetGValue(xCol
BLoVar := LimitToByte(GetBValue(xCol
BHiVar := LimitToByte(GetBValue(xCol
//end;
TempBmp.PixelFormat := pf24bit;
{for this Scanline the Image MUST be in pf24Bit}
Application.ProcessMessage
{This is the scanline, which may take a several seconds on large Images
I can not begin to explain using scanline here}
for y := 0 to TempBmp.Height -1 do
begin
RgnY := y;
Prgb := TempBmp.ScanLine[y];
for x := 0 to TempBmp.Width -1 do
begin
RgnX := x;
with Prgb[x] do
if (rgbtRed >= RLoVar) and (rgbtRed <= RHiVar) and (rgbtGreen >= GLoVar) and (rgbtGreen <= GHiVar) and (rgbtBlue >= BLoVar) and (rgbtBlue <= BHiVar) then
begin
if PixRgn then TempRgn := ReturnRgn(TempRgn);
PixRgn := False;
end
else
begin
if not PixRgn then PixStart := x;
if x = TempBmp.Width -1 then
begin
Adj := 1;
TempRgn := ReturnRgn(TempRgn);
end;
PixRgn := True;
end;
end;
end;
Result := CreateRectRgn(0,0,0,0);
Error1 := CombineRgn(Result, TempRgn, Result, RGN_COPY);
if (Error1 = NULLREGION) or (Error1 = ERROR) then
Result := 0;
DeleteObject(TempRgn);
FreeAndNil(TempBmp);
end;
procedure TForm1.Btn1Click(Sender: TObject);
begin
{this is the EXit button click}
Close;
end;
procedure TForm1.SetRegion;
var
Rgn2: HRGN;
begin
if not SkinBmp.Empty then
begin
Width := SkinBmp.Width;
Height := SkinBmp.Height;
{Button1.Left := Width-Button1.Width;
Button1.Top := 5;}
Btn1.Left := (Width div 2) - (Btn1.Width div 2);
Btn1.Top := ((Height div 2) - (Btn1.Height div 2))-16;
Btn2.Left := (Width div 2) - (Btn2.Width div 2);
Btn2.Top := (Height div 2) - (Btn2.Height div 2)+16;
end else Exit;
Region1 := MakeRegion;
if Region1 = 0 then
begin
SetWindowRgn(Handle, 0, TRUE);
ShowMessage('ERROR, Failed to make Shape Region');
Exit;
end;
{you can Not tell if your Buttons will be in the visible region
so I create 2 additional regions, one for each button and add them to
the visible region so you can use the buttons}
Rgn2 := CreateRectRgn(Btn1.Left, Btn1.Top, Btn1.Left+Btn1.Width,Btn1.
CombineRgn(Region1, Rgn2, Region1, RGN_OR);
DeleteObject(Rgn2);
Rgn2 := CreateRectRgn(Btn2.Left, Btn2.Top, Btn2.Left+Btn2.Width,Btn2.
CombineRgn(Region1, Rgn2, Region1, RGN_OR);
DeleteObject(Rgn2);
SetWindowRgn(Handle, Region1, TRUE);
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
SkinBmp := TBitmap.Create;
SkinBmp.LoadFromFile(Extra
BorderStyle := bsNone;
SetRegion;
end;
procedure TForm1.FormPaint(Sender: TObject);
begin
Canvas.Draw(0,0, SkinBmp);
end;
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
SkinBmp.Free;
DeleteObject(Region1);
end;
procedure TForm1.Btn2Click(Sender: TObject);
var
Bmp2: TBitmap;
begin
{this is the Open Bitmap click}
dlgOpenPicOpenPicDialog1.I
dlgOpenPicOpenPicDialog1.F
dlgOpenPicOpenPicDialog1.F
if dlgOpenPicOpenPicDialog1.E
begin
Bmp2 := TBitmap.Create;
try
Bmp2.LoadFromFile(dlgOpenP
if (Bmp2.Height < Btn1.Height+ Btn2.Height+16) or
(Bmp2.Width < Btn2.Width+8) then
begin
ShowMessage('ERROR, This Bitmap Image is TOO SMALL');
Exit;
end;
SkinBmp.Assign(Bmp2);
finally
Bmp2.Free;
end;
SetRegion;
FormPaint(self);
end;
end;
initialization
form1 := Tform1.Create(nil);
Form1.Show;
form1.Update;
end;
end;
end.
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
ASKER
Thank you Russel, I have been busy with all the suggestions you made, and came to the same conclusion, i will have to do with a less rounded window haha
Frank
Frank
procedure TForm1.ProcessImage;
var Antialias: TBitmap;
lpBlend: _BLENDFUNCTION;
begin
// Fill in blend function
lpBlend.BlendOp:=AC_SRC_OV
lpBlend.BlendFlags:=0;
lpBlend.SourceConstantAlph
lpBlend.AlphaFormat:=0;
if (SkinBmp.PixelFormat <> pf24bit) then SkinBmp.PixelFormat := pf24bit;
Antialias:=TBitmap.Create;
try
Antialias.PixelFormat := pf24bit;
Antialias.Width:=SkinBmp.W
Antialias.Height:=SkinBmp.
AlphaBlend(Antialias.Canva
SkinBmp.Assign(Antialias);
finally
AntiAlias.Free;
end;
end;
procedure TForm1.FormPaint(Sender: TObject);
begin
Canvas.Draw(0, 0, SkinBmp);
end;