Creating non-rectangular window from Delphi form

[Jaelani C. Utomo]

How can I create non-rectangular window from ordinary Delphi form ?
You know... Like Sonique or something like donut formed window with a hole at
the middle.

[Jon Oliver]

"Jaelani C. Utomo" <jael...@telkom.net> wrote in message
news:3c1595c8_2@dnews...

I posted an example of using a bitmap mask to create a form
region (although it's in VB) over in
...delphi.vcl.components.using.

[Jon Oliver]

"Jaelani C. Utomo" <jael...@telkom.net> wrote in message
news:3c1595c8_2@dnews...

Sorry I can't give an exact answer, but I've provided some VB
code that does this below. The basics of it should work
similarly in Delphi, as it uses the Win API.

g_window_mask_region is called with the form that is to be
shaped, and oMask contains a picture (roughly equivalent to
TBitmap?) that's to be the skin of the window--transparent areas
are in magenta. (It's an ugly color, so I don't mind giving it
up from my palette.)

The most important part for what you want to do is:

'clip transparent region
hRegion = mh_bitmap_region(oForm.hDC, fWidth /
Screen.TwipsPerPixelX, fHeight / Screen.TwipsPerPixelY,
vbMagenta)
SetWindowRgn oForm.hWnd, hRegion, True

The TwipsPerPixel business just puts the coordinates into
pixels, and mh_bitmap_region is pretty much VB-idiom free.

________________

Attribute VB_Name = "basWindow"
Option Explicit

'GetDeviceCaps constants
Private Const VERTRES = 10
Private Const HORZRES = 8

'CombineRgn constants
Private Const RGN_OR = 2

Private Type Size
cx As Long
cy As Long
End Type

Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As
Long, ByVal nIndex As Long) As Long
Private Declare Function GetWindowRgn Lib "user32" (ByVal hWnd
As Long, ByVal hRgn As Long) As Long
Private Declare Function GetPixel Lib "gdi32" (ByVal hDC As
Long, ByVal X As Long, ByVal Y As Long) As Long
Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As
Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As
Long
Private Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn
As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal
nCombineMode As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject
As Long) As Long
Private Declare Function SetWindowRgn Lib "user32" (ByVal hWnd
As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
Private Declare Function GetBitmapDimensionEx Lib "gdi32" (ByVal
hBitmap As Long, lpDimension As Size) As Long

Public Sub g_window_mask_region(ByVal oForm As Form, ByVal oMask
As StdPicture)
Dim fLeft As Single
Dim fTop As Single
Dim fWidth As Single
Dim fHeight As Single
Dim hRegion As Long

If (oMask Is Nothing) Then
'don't mask any of the form
Set oForm.Picture = Nothing
SetWindowRgn oForm.hWnd, 0&, True

Else
'determine where to position and/or size the form to the
picture
fWidth = oForm.ScaleX(oMask.Width, vbHimetric, vbTwips)
fHeight = oForm.ScaleX(oMask.Height, vbHimetric, vbTwips)

fLeft = oForm.Left
fTop = oForm.Top
' fLeft = 0.5 * (Screen.Width - fWidth)
' fTop = 0.5 * (Screen.Height - fHeight)

'place the picture in the properly sized form
oForm.AutoRedraw = True
oForm.Move fLeft, fTop, fWidth, fHeight
Set oForm.Picture = oMask

'clip transparent region
hRegion = mh_bitmap_region(oForm.hDC, fWidth /
Screen.TwipsPerPixelX, fHeight / Screen.TwipsPerPixelY,
vbMagenta)
SetWindowRgn oForm.hWnd, hRegion, True
End If
End Sub

Private Function mh_bitmap_region(ByVal hDC As Long, ByVal
iWidth As Long, ByVal iHeight As Long, ByVal nMaskColor As Long)
As Long
Dim hBitmapRgn As Long
Dim iStart As Long
Dim iRow As Long
Dim iCol As Long
Dim nPixelColor As Long
Dim hAdd As Long
Dim eRet As Long

'create a region to accumulate the bitmap regions into
hBitmapRgn = CreateRectRgn(0, 0, 0, 0)
iStart = -1

'look at every pixel (unfortunately)
For iRow = 0 To iHeight - 1
For iCol = 0 To iWidth - 1
'inspect the pixel
nPixelColor = GetPixel(hDC, iCol, iRow)
If nPixelColor = nMaskColor Then
If iStart >= 0 Then
'add the region that's now completed
hAdd = CreateRectRgn(iStart, iRow, iCol, iRow + 1)
eRet = CombineRgn(hBitmapRgn, hBitmapRgn, hAdd,
RGN_OR)
Call DeleteObject(hAdd)
iStart = -1
End If
Else
If iStart < 0 Then
'remember the beginning of this region
iStart = iCol
End If
End If
Next iCol

'did we exit while in a new region?
If iStart >= 0 Then
hAdd = CreateRectRgn(iStart, iRow, iWidth, iRow + 1)
eRet = CombineRgn(hBitmapRgn, hBitmapRgn, hAdd, RGN_OR)
DeleteObject hAdd
iStart = -1
End If
Next iRow

mh_bitmap_region = hBitmapRgn
End Function

[Uwe Molzahn]

Jaelani

If you like have a look at the Delphi Pool at
http://www.lmc-mediaagentur.de/dpool.htm

Under Delphi -> Tips&Tricks -> Win API -> Regions -> 0002 and 0003 you will
find some examples.

Cheers
Uwe

"Jaelani C. Utomo" <jael...@telkom.net> wrote in message
news:3c1595c8_2@dnews...

[Peter Below (TeamB)]

Go to http://groups.google.com, http://www.mers.com/searchsite.html or
http://www.tamaracka.com/search.htm and search the newsgroups for SetWindowRgn,
that will turn up examples.

>

Peter Below (TeamB) 10011...@compuserve.com)
No e-mail responses, please, unless explicitly requested!
Note: I'm unable to visit the newsgroups every day at the moment,
so be patient if you don't get a reply immediately.

[Jaelani C. Utomo]

Great! Thanks! I'll have to do some translation first, though. :)

"Jon Oliver" <jol...@no.spam.maam.com> wrote in message
news:3c162a13_2@dnews...

[Jaelani C. Utomo]

Thanks. Many thanks.

"Peter Below (TeamB)" <10011...@compuXXserve.com> wrote in message
news:VA.00007f5...@antispam.compuserve.com...

[Jaelani C. Utomo]

Thanks for the link. I'll read it.

"Uwe Molzahn" <dp...@lmc-mediaagentur.de> wrote in message
news:3c165b10$1_2@dnews...

[Jon Oliver]

I've been playing with this in delphi a bit as well, I'll post
what I have this evening--though there's no implicit or explicit
guarantee.

"Jaelani C. Utomo" <jael...@telkom.net> wrote in message

news:3c169514_1@dnews...

[Grinder]

> > Sorry I can't give an exact answer, but I've provided some
VB
> > code that does this below. The basics of it should work
> > similarly in Delphi, as it uses the Win API.

Here's some Delphi code to start with as well:

procedure TForm1.Form_OnShow(Sender: TObject);
begin
ShapeFormClient_Mask(Self, ImageSkin.Picture.Bitmap,
clFuchsia);
end;

procedure TForm1.Form_OnPaint(Sender: TObject);
begin
Self.Canvas.Draw(0, 0, ImageSkin.Picture.Bitmap);
end;

procedure TForm1.Form_OnKeyPress(Sender: TObject; var Key:
Char);
begin
case Key of
#27: Application.Terminate;
end;
end;

______

function NonClientRgn(const oForm: TCustomForm): HRGN;
var
iLeft: Integer;
iTop: Integer;
hAdd: HRGN;
begin
iLeft := oForm.ClientOrigin.x - oForm.Left;
iTop := oForm.ClientOrigin.y - oForm.Top;

Result := CreateRectRgn(0, 0, oForm.Width, oForm.Height);
hAdd := CreateRectRgn(iLeft, iTop, iLeft + oForm.ClientWidth,
iTop + oForm.ClientHeight);
CombineRgn(Result, Result, hAdd, RGN_XOR);
DeleteObject(hAdd);
end;

function ShapeFormClient_Mask(const oForm: TCustomForm; const
oMask: TBitmap; const iMaskColor: TColor): Boolean;
var
iLeft: Integer;
iTop: Integer;
iRow: Integer;
iCol: Integer;
iStart: Integer;
bMask: Boolean;
hMask: HDC;
hAdd: HRGN;
hComp: HRGN;
begin
iStart := -1;
hMask := oMask.Canvas.Handle;

iLeft := oForm.ClientOrigin.x - oForm.Left;
iTop := oForm.ClientOrigin.y - oForm.Top;
hComp := NonClientRgn(oForm);

if hComp = 0 then
Result := False

else begin
for iRow := 0 to oMask.Height - 1 do begin
for iCol := 0 to oMask.Width - 1 do begin
bMask := TColor(GetPixel(hMask, iCol, iRow)) =
iMaskColor;
if (iStart < 0) and not bMask then
iStart := iCol
else if (iStart >= 0) and bMask then begin
hAdd := CreateRectRgn(iStart + iLeft, iRow + iTop,
iCol + iLeft, iRow + iTop + 1);
CombineRgn(hComp, hComp, hAdd, RGN_OR);
DeleteObject(hAdd);
iStart := -1;
end;
end;

if iStart >= 0 then begin
hAdd := CreateRectRgn(iStart + iLeft, iRow + iTop,
oMask.Width + iLeft, iRow + iTop + 1);
CombineRgn(hComp, hComp, hAdd, RGN_OR);
DeleteObject(hAdd);
iStart := -1;
end;
end;

Result := SetWindowRgn(oForm.Handle, hComp, True) <> 0;
// Result := True;
// oForm.Canvas.Draw(0, 0, oMask);
end;

end;