G
Geoff
Hi
For those who may have followed this thread begun on 5th June, this
demonstrates that defining regions by colour sampling can work. It also
expands on Rick Rothstein's reply which uses hard coded nodes.
Region functionality is documented at
http://msdn.microsoft.com/en-us/library/ms536650(VS.85).aspx
The colour sampling method referred to in the previous post defines single
or multi regions and the basis is some VB6 code published by Steve McMahon in
January 2003 a
http://www.vbaccelerator.com/home/V...apes/Window_Shapes_Using_Layering/article.asp
Here, for the specific purpose of drawing irregular form shapes this has
been much adapted. Apologies to those more familiar with VB6 for any gaffs
but the edited code works as expected and no glitches so far.
Thanks Peter T for decompiling the public domain VB6 example and for further
help.
The method relies simply on producing an image with masking to delineate
unwanted areas and inserting the image on a form using the picture property.
By experiment the image must be saved as a gif - jpgs didn't work.
The masking colour is easily assigned using an RGB value in the procedure
where indicated and in this example is red. Using a mask means the resultant
shape or shapes can be as complex as desired.
The form needs to be sized appropriately. If this is not done correctly,
parts of the mask colour may remain visible. For this example a picture 300
pixels square was perfect on a form 225 square.
When the form is Shown it is 'clipped'. This means to move it, the form can
only be grabbed from opaque areas. If it is made modeless, cells underlying
transparent areas can be selected which may be of use if 'holes' have been
designed in. These features apply equally to both methods.
Using colour sampling to define regions on a form can be slower to Show
compared to using hard coded nodal points largely because more points are
calculated. And care has to be exercised regarding the choice of masking
colour to avoid unwanted transparencies. But it is much simpler to produce
complex shapes.
Each opaque region can of course have controls added. Of novel interest
perhaps - if irregular shaped 'island' regions have been created then an
oversized control is installed on the island, the control will assume the
shape of the island region too and the control area will be clipped. If
doing this, care is needed with sizing because the control is still a defined
shape and though its area may be clipped, its boundaries may become visible
on adjacent islands with unwanted results.
The second example extends Rick Rothstein's example in the previous post by
creating holes. In this, nodal points are hard coded. This method is quick
to Show though that is dependent on the number of nodes used. The
calculation of nodal points to fit a picture can be fiddly, dependant on its
complexity. But approximations may suit just as well depending how the form
is deployed. Images used do not need to be in gif format. If all that is
required however is a uniformly coloured shape then an image is not required
at all, just apply colour to the form's background.
Imo for more linear designs, hard coding is probably the best method as it
is quick to Show and requires less code but for those wanting more random
designs then masking offers simple flexibility.
I hope this is of some use.
Geoff
Please watch out for long code line discontinuation.
Method 1
Draw a picture, 300 pixels square with a black background. Paint 2 vertical
and 2 horizontal stripes, several pixels wide, in red. Squiggly or straight,
doesn't matter. Save as a gif. Insert on a modeless form 225 square using
the picture property.
Place a commandbutton on the form.
''******************** START OF METHOD 1
In UserForm1
Option Explicit
''form header removal
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal
lpWindowName As String) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
(ByVal hwnd As Long, ByVal nIndex As
Long, ByVal dwNewLong As Long) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _
(ByVal hwnd As Long, ByVal nIndex As
Long) As Long
Private Declare Function DrawMenuBar Lib "user32" _
(ByVal hwnd As Long) As Long
Private Const WS_CAPTION = &HC00000
Private Const GWL_STYLE = (-16)
'''form drag
Private Const WM_NCLBUTTONDOWN = &HA1
Private Const HTCAPTION = 2
Private Declare Function ReleaseCapture Lib "user32" () As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
(ByVal hwnd As Long, ByVal wMsg As
Long, _
ByVal wParam As Long, lParam As Any)
As Long
Dim mFrmHwnd As Long
Private m_cDibR As New cDIBSectionRegion
Private Sub UserForm_Initialize()
Dim lngFormStyle As Long
If Application.Version < 9 Then
mFrmHwnd = FindWindow("THUNDERXFRAME", Me.Caption)
Else
mFrmHwnd = FindWindow("THUNDERDFRAME", Me.Caption)
End If
'''remove form header
lngFormStyle = GetWindowLong(mFrmHwnd, GWL_STYLE)
lngFormStyle = lngFormStyle And Not WS_CAPTION
SetWindowLong mFrmHwnd, GWL_STYLE, lngFormStyle
DrawMenuBar mFrmHwnd
MakeTransparent
End Sub
Private Sub MakeTransparent()
Dim cDib As New cDIBSection
Dim myMask As Long
myMask = RGB(255, 0, 0) '''<<<< choose mask colour here
cDib.CreateFromPicture Me.Picture
m_cDibR.Create cDib, myMask
m_cDibR.Applied(mFrmHwnd) = True
End Sub
Private Sub UserForm_MouseDown(ByVal Button As Integer, ByVal Shift As
Integer, ByVal X As Single, ByVal Y As Single)
If Button And 1 Then
Call ReleaseCapture
Call SendMessage(mFrmHwnd, WM_NCLBUTTONDOWN, HTCAPTION, ByVal 0&)
End If
End Sub
Private Sub CommandButton1_Click()
Unload UserForm1
Set UserForm1 = Nothing
End Sub
In a class module cDIBSection
Option Explicit
'''adapted from:
' ==================================================================
' FileName: cDIBSection.cls
' Author: Steve McMahon
'
' A Wrapper around the GDI DIBSection (DIB = Device Independent Bitmap)
' object. A DIB gives you full control over colour depth. The
' DIBSection object also means that the bitmap bits are allocated
' into Windows memory, and so can be directly modified by Windows
' programs.
'
' This class gives you the control you need in VB over a DIBSection.
'
' ------------------------------------------------------------------
' Visit vbAccelerator - advanced, hardcore VB with full source code
' http://vbaccelerator.com/
' mailto:[email protected]
'
' ==================================================================
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
lpvDest As Any, lpvSource As Any, ByVal
cbCopy As Long)
Private Type SAFEARRAYBOUND
cElements As Long
lLbound As Long
End Type
Private Type SAFEARRAY2D
cDims As Integer
fFeatures As Integer
cbElements As Long
cLocks As Long
pvData As Long
Bounds(0 To 1) As SAFEARRAYBOUND
End Type
Private Declare Function VarPtrArray Lib "msvbvm60.dll" Alias "VarPtr"
(Ptr() As Any) As Long
Private Type RGBQUAD
rgbBlue As Byte
rgbGreen As Byte
rgbRed As Byte
rgbReserved As Byte
End Type
Private Type BITMAPINFOHEADER '40 bytes
biSize As Long
biWidth As Long
biHeight As Long
biPlanes As Integer
biBitCount As Integer
biCompression As Long
biSizeImage As Long
biXPelsPerMeter As Long
biYPelsPerMeter As Long
biClrUsed As Long
biClrImportant As Long
End Type
Private Type BITMAPINFO
bmiHeader As BITMAPINFOHEADER
bmiColors As RGBQUAD
End Type
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long)
As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long
' Note - this is not the declare in the API viewer - modify lplpVoid to be
' Byref so we get the pointer back:
Private Declare Function CreateDIBSection Lib "gdi32" _
(ByVal hdc As Long, _
pBitmapInfo As BITMAPINFO, _
ByVal un As Long, _
lplpVoid As Long, _
ByVal handle As Long, _
ByVal dw As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X
As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal
hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long)
As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal
hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As
Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Const BI_RGB = 0&
Private Const DIB_RGB_COLORS = 0 ' color table in RGBs
Private Type BITMAP
bmType As Long
bmWidth As Long
bmHeight As Long
bmWidthBytes As Long
bmPlanes As Integer
bmBitsPixel As Integer
bmBits As Long
End Type
Private Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal
hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
' Handle to the current DIBSection:
Private m_hDIb As Long
' Handle to the old bitmap in the DC, for clear up:
Private m_hBmpOld As Long
' Handle to the Device context holding the DIBSection:
Private m_hDC As Long
' Address of memory pointing to the DIBSection's bits:
Private m_lPtr As Long
' Type containing the Bitmap information:
Private m_tBI As BITMAPINFO
Public Function CreateDIB( _
ByVal lhDC As Long, _
ByVal lWidth As Long, _
ByVal lHeight As Long, _
ByRef hDib As Long _
) As Boolean
With m_tBI.bmiHeader
.biSize = Len(m_tBI.bmiHeader)
.biWidth = lWidth
.biHeight = lHeight
.biPlanes = 1
.biBitCount = 24
.biCompression = BI_RGB
.biSizeImage = BytesPerScanLine * .biHeight
End With
hDib = CreateDIBSection( _
lhDC, _
m_tBI, _
DIB_RGB_COLORS, _
m_lPtr, _
0, 0)
CreateDIB = (hDib <> 0)
End Function
Public Function CreateFromPicture( _
ByRef picThis As StdPicture _
)
Dim lhDC As Long
Dim lhDCDesktop As Long
Dim lhBmpOld As Long
Dim tBMP As BITMAP
GetObjectAPI picThis.handle, Len(tBMP), tBMP
If (Create(tBMP.bmWidth, tBMP.bmHeight)) Then
lhDCDesktop = GetDC(GetDesktopWindow())
If (lhDCDesktop <> 0) Then
lhDC = CreateCompatibleDC(lhDCDesktop)
DeleteDC lhDCDesktop
If (lhDC <> 0) Then
lhBmpOld = SelectObject(lhDC, picThis.handle)
LoadPictureBlt lhDC
SelectObject lhDC, lhBmpOld
DeleteObject lhDC
End If
End If
End If
End Function
Public Function Create( _
ByVal lWidth As Long, _
ByVal lHeight As Long _
) As Boolean
ClearUp
m_hDC = CreateCompatibleDC(0)
If (m_hDC <> 0) Then
If (CreateDIB(m_hDC, lWidth, lHeight, m_hDIb)) Then
m_hBmpOld = SelectObject(m_hDC, m_hDIb)
Create = True
Else
DeleteObject m_hDC
m_hDC = 0
End If
End If
End Function
Public Property Get BytesPerScanLine() As Long
' Scans must align on dword boundaries:
BytesPerScanLine = (m_tBI.bmiHeader.biWidth * 3 + 3) And &HFFFFFFFC
End Property
Public Property Get Width() As Long
Width = m_tBI.bmiHeader.biWidth
End Property
Public Property Get Height() As Long
Height = m_tBI.bmiHeader.biHeight
End Property
Public Sub LoadPictureBlt( _
ByVal lhDC As Long, _
Optional ByVal lSrcLeft As Long = 0, _
Optional ByVal lSrcTop As Long = 0, _
Optional ByVal lSrcWidth As Long = -1, _
Optional ByVal lSrcHeight As Long = -1, _
Optional ByVal eRop As Long = 13369376 _
)
If lSrcWidth < 0 Then lSrcWidth = m_tBI.bmiHeader.biWidth
If lSrcHeight < 0 Then lSrcHeight = m_tBI.bmiHeader.biHeight
BitBlt m_hDC, 0, 0, lSrcWidth, lSrcHeight, lhDC, lSrcLeft, lSrcTop, eRop
End Sub
Public Property Get DIBSectionBitsPtr() As Long
DIBSectionBitsPtr = m_lPtr
End Property
Public Sub ClearUp()
If (m_hDC <> 0) Then
If (m_hDIb <> 0) Then
SelectObject m_hDC, m_hBmpOld
DeleteObject m_hDIb
End If
DeleteObject m_hDC
End If
m_hDC = 0: m_hDIb = 0: m_hBmpOld = 0: m_lPtr = 0
End Sub
Private Sub Class_Terminate()
ClearUp
End Sub
In a class module cDIBSectionRegion
Option Explicit
'''adapted from:
' ==================================================================
' FileName: cDIBSectionRegion.cls
' Author: Steve McMahon
'
' Converts a cDIBSection object into a region which you can apply
' to a form, UserControl or PictureBox (in fact, anything with a
' hWnd property).
' ------------------------------------------------------------------
' Visit vbAccelerator - advanced, hardcore VB with full source code
' http://vbaccelerator.com/
' mailto:[email protected]
'
' ==================================================================
' API for creating a region:
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 Const RGN_AND = 1
Private Const RGN_COPY = 5
Private Const RGN_DIFF = 4
Private Const RGN_OR = 2
Private Const RGN_XOR = 3
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
' API for reading cDIBSection bits:
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
lpvDest As Any, lpvSource As Any, ByVal
cbCopy As Long)
Private Type SAFEARRAYBOUND
cElements As Long
lLbound As Long
End Type
Private Type SAFEARRAY2D
cDims As Integer
fFeatures As Integer
cbElements As Long
cLocks As Long
pvData As Long
Bounds(0 To 1) As SAFEARRAYBOUND
End Type
Private Declare Function VarPtrArray Lib "msvbvm60.dll" Alias "VarPtr"
(Ptr() As Any) As Long
' Implementation:
Private m_hRgn As Long
Private m_hWnd() As Long
Private m_iCount As Long
Public Property Let Applied(ByVal hwnd As Long, ByVal bState As Boolean)
Dim i As Long
Dim lIndex As Long
lIndex = plIndex(hwnd)
If bState Then
If (lIndex = 0) Then
' Apply to window:
m_iCount = m_iCount + 1
ReDim Preserve m_hWnd(1 To m_iCount) As Long
m_hWnd(m_iCount) = hwnd
SetWindowRgn m_hWnd(m_iCount), m_hRgn, True
Else
' already applied, reset apply state jic
SetWindowRgn m_hWnd(m_iCount), m_hRgn, True
End If
Else
If (lIndex = 0) Then
' Not applied, reset state jic
SetWindowRgn hwnd, 0, True
Else
' Applied, reset:
SetWindowRgn hwnd, 0, True
If m_iCount > 1 Then
For i = lIndex To m_iCount - 1
m_hWnd(i) = m_hWnd(i + 1)
Next i
m_iCount = m_iCount - 1
ReDim Preserve m_hWnd(1 To m_iCount) As Long
Else
m_iCount = 0
Erase m_hWnd
End If
End If
End If
End Property
Private Property Get plIndex(ByVal hwnd As Long) As Long
Dim i As Long
Dim lIndex As Long
For i = 1 To m_iCount
If hwnd = m_hWnd(i) Then
plIndex = i
Exit For
End If
Next i
End Property
Private Sub UnApply()
Dim i As Long
For i = 1 To m_iCount
If Not m_hWnd(i) = 0 Then
SetWindowRgn m_hWnd(i), 0, True
m_hWnd(i) = 0
End If
Next i
m_iCount = 0
End Sub
Public Sub Destroy()
UnApply
If Not m_hRgn = 0 Then
DeleteObject m_hRgn
End If
m_hRgn = 0
End Sub
Public Sub Create( _
ByRef cDib As cDIBSection, _
Optional ByRef lTransColor As Long = 0 _
)
Dim X As Long, Y As Long
Dim lX As Long
Dim yStart As Long
Dim bStart As Boolean
Dim hRgnTemp As Long
Dim Br As Byte, bG As Byte, bB As Byte
Dim lWidth As Long, lHeight As Long
Dim bDib() As Byte
Dim tSA As SAFEARRAY2D
Destroy
' The transparent colour:
Br = (lTransColor And &HFF&)
bG = (lTransColor And &HFF00&) \ &H100&
bB = (lTransColor And &HFF0000) \ &H10000
' Create the base region
m_hRgn = CreateRectRgn(0, 0, cDib.Width, cDib.Height)
Debug.Assert (m_hRgn <> 0)
If m_hRgn <> 0 Then
' Get the DIB into byte array:
With tSA
.cbElements = 1
.cDims = 2
.Bounds(0).lLbound = 0
.Bounds(0).cElements = cDib.Height
.Bounds(1).lLbound = 0
.Bounds(1).cElements = cDib.BytesPerScanLine()
.pvData = cDib.DIBSectionBitsPtr
End With
CopyMemory ByVal VarPtrArray(bDib()), VarPtr(tSA), 4
lWidth = cDib.BytesPerScanLine \ 3
lHeight = cDib.Height
For X = 0 To (lWidth - 1) * 3 Step 3
' DIB Sections are "upside down"
For Y = lHeight - 1 To 0 Step -1
If bDib(X, Y) = bB And bDib(X + 1, Y) = bG And bDib(X + 2,
Y) = Br Then
If Not bStart Then
yStart = lHeight - 1 - Y
bStart = True
End If
Else
If bStart Then
hRgnTemp = CreateRectRgn(lX, yStart, lX + 1, lHeight
- 1 - Y)
CombineRgn m_hRgn, hRgnTemp, m_hRgn, RGN_XOR
DeleteObject hRgnTemp
bStart = False
End If
End If
Next Y
If bStart Then
hRgnTemp = CreateRectRgn(lX, yStart, lX + 1, lHeight - 1 - Y)
CombineRgn m_hRgn, hRgnTemp, m_hRgn, RGN_XOR
DeleteObject hRgnTemp
bStart = False
End If
lX = lX + 1
Next X
CopyMemory ByVal VarPtrArray(bDib), 0&, 4
End If
End Sub
Private Sub Class_Terminate()
Destroy
End Sub
''******************** END OF METHOD 1
Method 2
On a modeless form 350 square apply a background colour. Place a
commandbutton on the form.
''******************** START OF METHOD 2
In UserForm2
Option Explicit
Private Type POINTAPI
X As Long
Y As Long
End Type
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String) 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 SetWindowRgn Lib "user32" ( _
ByVal hwnd As Long, _
ByVal hRgn As Long, ByVal bRedraw As
Long) As Long
Private Declare Function DeleteObject Lib "gdi32" ( _
ByVal hObject As Long) As Long
Private Const RGN_DIFF = 4
Dim hwnd As Long
Dim DefinedRegion As Long
Dim HoleRegion As Long
Private Declare Function ReleaseCapture Lib "user32" () As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" ( _
ByVal hwnd As Long, ByVal wMsg As Long, _
ByVal wParam As Long, lParam As Any) As
Long
Private Const WM_NCLBUTTONDOWN = &HA1
Private Const HTCAPTION = 2
Private Sub UserForm_Initialize()
Dim newRgn As Long
If Application.Version < 9 Then
hwnd = FindWindow("THUNDERXFRAME", Me.Caption)
Else
hwnd = FindWindow("THUNDERDFRAME", Me.Caption)
End If
DefinedRegion = CreateRectRgn(0, 30, 310, 350)
HoleRegion = CreateRectRgn(90, 0, 110, 350)
newRgn = CombineRgn(DefinedRegion, DefinedRegion, HoleRegion, RGN_DIFF)
HoleRegion = CreateRectRgn(200, 0, 220, 350)
newRgn = CombineRgn(DefinedRegion, DefinedRegion, HoleRegion, RGN_DIFF)
HoleRegion = CreateRectRgn(0, 130, 350, 150)
newRgn = CombineRgn(DefinedRegion, DefinedRegion, HoleRegion, RGN_DIFF)
HoleRegion = CreateRectRgn(0, 240, 350, 260)
newRgn = CombineRgn(DefinedRegion, DefinedRegion, HoleRegion, RGN_DIFF)
SetWindowRgn hwnd, DefinedRegion, True
DeleteObject DefinedRegion
DeleteObject HoleRegion
DeleteObject newRgn
End Sub
Private Sub UserForm_MouseDown(ByVal Button As Integer, ByVal Shift As
Integer, _
ByVal X As Single, ByVal Y As Single)
If Button And 1 Then
Call ReleaseCapture
Call SendMessage(hwnd, WM_NCLBUTTONDOWN, HTCAPTION, ByVal 0&)
End If
End Sub
Private Sub CommandButton1_Click()
Unload UserForm2
Set UserForm2 = Nothing
End Sub
''******************** END OF METHOD 2
For those who may have followed this thread begun on 5th June, this
demonstrates that defining regions by colour sampling can work. It also
expands on Rick Rothstein's reply which uses hard coded nodes.
Region functionality is documented at
http://msdn.microsoft.com/en-us/library/ms536650(VS.85).aspx
The colour sampling method referred to in the previous post defines single
or multi regions and the basis is some VB6 code published by Steve McMahon in
January 2003 a
http://www.vbaccelerator.com/home/V...apes/Window_Shapes_Using_Layering/article.asp
Here, for the specific purpose of drawing irregular form shapes this has
been much adapted. Apologies to those more familiar with VB6 for any gaffs
but the edited code works as expected and no glitches so far.
Thanks Peter T for decompiling the public domain VB6 example and for further
help.
The method relies simply on producing an image with masking to delineate
unwanted areas and inserting the image on a form using the picture property.
By experiment the image must be saved as a gif - jpgs didn't work.
The masking colour is easily assigned using an RGB value in the procedure
where indicated and in this example is red. Using a mask means the resultant
shape or shapes can be as complex as desired.
The form needs to be sized appropriately. If this is not done correctly,
parts of the mask colour may remain visible. For this example a picture 300
pixels square was perfect on a form 225 square.
When the form is Shown it is 'clipped'. This means to move it, the form can
only be grabbed from opaque areas. If it is made modeless, cells underlying
transparent areas can be selected which may be of use if 'holes' have been
designed in. These features apply equally to both methods.
Using colour sampling to define regions on a form can be slower to Show
compared to using hard coded nodal points largely because more points are
calculated. And care has to be exercised regarding the choice of masking
colour to avoid unwanted transparencies. But it is much simpler to produce
complex shapes.
Each opaque region can of course have controls added. Of novel interest
perhaps - if irregular shaped 'island' regions have been created then an
oversized control is installed on the island, the control will assume the
shape of the island region too and the control area will be clipped. If
doing this, care is needed with sizing because the control is still a defined
shape and though its area may be clipped, its boundaries may become visible
on adjacent islands with unwanted results.
The second example extends Rick Rothstein's example in the previous post by
creating holes. In this, nodal points are hard coded. This method is quick
to Show though that is dependent on the number of nodes used. The
calculation of nodal points to fit a picture can be fiddly, dependant on its
complexity. But approximations may suit just as well depending how the form
is deployed. Images used do not need to be in gif format. If all that is
required however is a uniformly coloured shape then an image is not required
at all, just apply colour to the form's background.
Imo for more linear designs, hard coding is probably the best method as it
is quick to Show and requires less code but for those wanting more random
designs then masking offers simple flexibility.
I hope this is of some use.
Geoff
Please watch out for long code line discontinuation.
Method 1
Draw a picture, 300 pixels square with a black background. Paint 2 vertical
and 2 horizontal stripes, several pixels wide, in red. Squiggly or straight,
doesn't matter. Save as a gif. Insert on a modeless form 225 square using
the picture property.
Place a commandbutton on the form.
''******************** START OF METHOD 1
In UserForm1
Option Explicit
''form header removal
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal
lpWindowName As String) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
(ByVal hwnd As Long, ByVal nIndex As
Long, ByVal dwNewLong As Long) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _
(ByVal hwnd As Long, ByVal nIndex As
Long) As Long
Private Declare Function DrawMenuBar Lib "user32" _
(ByVal hwnd As Long) As Long
Private Const WS_CAPTION = &HC00000
Private Const GWL_STYLE = (-16)
'''form drag
Private Const WM_NCLBUTTONDOWN = &HA1
Private Const HTCAPTION = 2
Private Declare Function ReleaseCapture Lib "user32" () As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
(ByVal hwnd As Long, ByVal wMsg As
Long, _
ByVal wParam As Long, lParam As Any)
As Long
Dim mFrmHwnd As Long
Private m_cDibR As New cDIBSectionRegion
Private Sub UserForm_Initialize()
Dim lngFormStyle As Long
If Application.Version < 9 Then
mFrmHwnd = FindWindow("THUNDERXFRAME", Me.Caption)
Else
mFrmHwnd = FindWindow("THUNDERDFRAME", Me.Caption)
End If
'''remove form header
lngFormStyle = GetWindowLong(mFrmHwnd, GWL_STYLE)
lngFormStyle = lngFormStyle And Not WS_CAPTION
SetWindowLong mFrmHwnd, GWL_STYLE, lngFormStyle
DrawMenuBar mFrmHwnd
MakeTransparent
End Sub
Private Sub MakeTransparent()
Dim cDib As New cDIBSection
Dim myMask As Long
myMask = RGB(255, 0, 0) '''<<<< choose mask colour here
cDib.CreateFromPicture Me.Picture
m_cDibR.Create cDib, myMask
m_cDibR.Applied(mFrmHwnd) = True
End Sub
Private Sub UserForm_MouseDown(ByVal Button As Integer, ByVal Shift As
Integer, ByVal X As Single, ByVal Y As Single)
If Button And 1 Then
Call ReleaseCapture
Call SendMessage(mFrmHwnd, WM_NCLBUTTONDOWN, HTCAPTION, ByVal 0&)
End If
End Sub
Private Sub CommandButton1_Click()
Unload UserForm1
Set UserForm1 = Nothing
End Sub
In a class module cDIBSection
Option Explicit
'''adapted from:
' ==================================================================
' FileName: cDIBSection.cls
' Author: Steve McMahon
'
' A Wrapper around the GDI DIBSection (DIB = Device Independent Bitmap)
' object. A DIB gives you full control over colour depth. The
' DIBSection object also means that the bitmap bits are allocated
' into Windows memory, and so can be directly modified by Windows
' programs.
'
' This class gives you the control you need in VB over a DIBSection.
'
' ------------------------------------------------------------------
' Visit vbAccelerator - advanced, hardcore VB with full source code
' http://vbaccelerator.com/
' mailto:[email protected]
'
' ==================================================================
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
lpvDest As Any, lpvSource As Any, ByVal
cbCopy As Long)
Private Type SAFEARRAYBOUND
cElements As Long
lLbound As Long
End Type
Private Type SAFEARRAY2D
cDims As Integer
fFeatures As Integer
cbElements As Long
cLocks As Long
pvData As Long
Bounds(0 To 1) As SAFEARRAYBOUND
End Type
Private Declare Function VarPtrArray Lib "msvbvm60.dll" Alias "VarPtr"
(Ptr() As Any) As Long
Private Type RGBQUAD
rgbBlue As Byte
rgbGreen As Byte
rgbRed As Byte
rgbReserved As Byte
End Type
Private Type BITMAPINFOHEADER '40 bytes
biSize As Long
biWidth As Long
biHeight As Long
biPlanes As Integer
biBitCount As Integer
biCompression As Long
biSizeImage As Long
biXPelsPerMeter As Long
biYPelsPerMeter As Long
biClrUsed As Long
biClrImportant As Long
End Type
Private Type BITMAPINFO
bmiHeader As BITMAPINFOHEADER
bmiColors As RGBQUAD
End Type
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long)
As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long
' Note - this is not the declare in the API viewer - modify lplpVoid to be
' Byref so we get the pointer back:
Private Declare Function CreateDIBSection Lib "gdi32" _
(ByVal hdc As Long, _
pBitmapInfo As BITMAPINFO, _
ByVal un As Long, _
lplpVoid As Long, _
ByVal handle As Long, _
ByVal dw As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X
As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal
hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long)
As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal
hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As
Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Const BI_RGB = 0&
Private Const DIB_RGB_COLORS = 0 ' color table in RGBs
Private Type BITMAP
bmType As Long
bmWidth As Long
bmHeight As Long
bmWidthBytes As Long
bmPlanes As Integer
bmBitsPixel As Integer
bmBits As Long
End Type
Private Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal
hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
' Handle to the current DIBSection:
Private m_hDIb As Long
' Handle to the old bitmap in the DC, for clear up:
Private m_hBmpOld As Long
' Handle to the Device context holding the DIBSection:
Private m_hDC As Long
' Address of memory pointing to the DIBSection's bits:
Private m_lPtr As Long
' Type containing the Bitmap information:
Private m_tBI As BITMAPINFO
Public Function CreateDIB( _
ByVal lhDC As Long, _
ByVal lWidth As Long, _
ByVal lHeight As Long, _
ByRef hDib As Long _
) As Boolean
With m_tBI.bmiHeader
.biSize = Len(m_tBI.bmiHeader)
.biWidth = lWidth
.biHeight = lHeight
.biPlanes = 1
.biBitCount = 24
.biCompression = BI_RGB
.biSizeImage = BytesPerScanLine * .biHeight
End With
hDib = CreateDIBSection( _
lhDC, _
m_tBI, _
DIB_RGB_COLORS, _
m_lPtr, _
0, 0)
CreateDIB = (hDib <> 0)
End Function
Public Function CreateFromPicture( _
ByRef picThis As StdPicture _
)
Dim lhDC As Long
Dim lhDCDesktop As Long
Dim lhBmpOld As Long
Dim tBMP As BITMAP
GetObjectAPI picThis.handle, Len(tBMP), tBMP
If (Create(tBMP.bmWidth, tBMP.bmHeight)) Then
lhDCDesktop = GetDC(GetDesktopWindow())
If (lhDCDesktop <> 0) Then
lhDC = CreateCompatibleDC(lhDCDesktop)
DeleteDC lhDCDesktop
If (lhDC <> 0) Then
lhBmpOld = SelectObject(lhDC, picThis.handle)
LoadPictureBlt lhDC
SelectObject lhDC, lhBmpOld
DeleteObject lhDC
End If
End If
End If
End Function
Public Function Create( _
ByVal lWidth As Long, _
ByVal lHeight As Long _
) As Boolean
ClearUp
m_hDC = CreateCompatibleDC(0)
If (m_hDC <> 0) Then
If (CreateDIB(m_hDC, lWidth, lHeight, m_hDIb)) Then
m_hBmpOld = SelectObject(m_hDC, m_hDIb)
Create = True
Else
DeleteObject m_hDC
m_hDC = 0
End If
End If
End Function
Public Property Get BytesPerScanLine() As Long
' Scans must align on dword boundaries:
BytesPerScanLine = (m_tBI.bmiHeader.biWidth * 3 + 3) And &HFFFFFFFC
End Property
Public Property Get Width() As Long
Width = m_tBI.bmiHeader.biWidth
End Property
Public Property Get Height() As Long
Height = m_tBI.bmiHeader.biHeight
End Property
Public Sub LoadPictureBlt( _
ByVal lhDC As Long, _
Optional ByVal lSrcLeft As Long = 0, _
Optional ByVal lSrcTop As Long = 0, _
Optional ByVal lSrcWidth As Long = -1, _
Optional ByVal lSrcHeight As Long = -1, _
Optional ByVal eRop As Long = 13369376 _
)
If lSrcWidth < 0 Then lSrcWidth = m_tBI.bmiHeader.biWidth
If lSrcHeight < 0 Then lSrcHeight = m_tBI.bmiHeader.biHeight
BitBlt m_hDC, 0, 0, lSrcWidth, lSrcHeight, lhDC, lSrcLeft, lSrcTop, eRop
End Sub
Public Property Get DIBSectionBitsPtr() As Long
DIBSectionBitsPtr = m_lPtr
End Property
Public Sub ClearUp()
If (m_hDC <> 0) Then
If (m_hDIb <> 0) Then
SelectObject m_hDC, m_hBmpOld
DeleteObject m_hDIb
End If
DeleteObject m_hDC
End If
m_hDC = 0: m_hDIb = 0: m_hBmpOld = 0: m_lPtr = 0
End Sub
Private Sub Class_Terminate()
ClearUp
End Sub
In a class module cDIBSectionRegion
Option Explicit
'''adapted from:
' ==================================================================
' FileName: cDIBSectionRegion.cls
' Author: Steve McMahon
'
' Converts a cDIBSection object into a region which you can apply
' to a form, UserControl or PictureBox (in fact, anything with a
' hWnd property).
' ------------------------------------------------------------------
' Visit vbAccelerator - advanced, hardcore VB with full source code
' http://vbaccelerator.com/
' mailto:[email protected]
'
' ==================================================================
' API for creating a region:
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 Const RGN_AND = 1
Private Const RGN_COPY = 5
Private Const RGN_DIFF = 4
Private Const RGN_OR = 2
Private Const RGN_XOR = 3
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
' API for reading cDIBSection bits:
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
lpvDest As Any, lpvSource As Any, ByVal
cbCopy As Long)
Private Type SAFEARRAYBOUND
cElements As Long
lLbound As Long
End Type
Private Type SAFEARRAY2D
cDims As Integer
fFeatures As Integer
cbElements As Long
cLocks As Long
pvData As Long
Bounds(0 To 1) As SAFEARRAYBOUND
End Type
Private Declare Function VarPtrArray Lib "msvbvm60.dll" Alias "VarPtr"
(Ptr() As Any) As Long
' Implementation:
Private m_hRgn As Long
Private m_hWnd() As Long
Private m_iCount As Long
Public Property Let Applied(ByVal hwnd As Long, ByVal bState As Boolean)
Dim i As Long
Dim lIndex As Long
lIndex = plIndex(hwnd)
If bState Then
If (lIndex = 0) Then
' Apply to window:
m_iCount = m_iCount + 1
ReDim Preserve m_hWnd(1 To m_iCount) As Long
m_hWnd(m_iCount) = hwnd
SetWindowRgn m_hWnd(m_iCount), m_hRgn, True
Else
' already applied, reset apply state jic
SetWindowRgn m_hWnd(m_iCount), m_hRgn, True
End If
Else
If (lIndex = 0) Then
' Not applied, reset state jic
SetWindowRgn hwnd, 0, True
Else
' Applied, reset:
SetWindowRgn hwnd, 0, True
If m_iCount > 1 Then
For i = lIndex To m_iCount - 1
m_hWnd(i) = m_hWnd(i + 1)
Next i
m_iCount = m_iCount - 1
ReDim Preserve m_hWnd(1 To m_iCount) As Long
Else
m_iCount = 0
Erase m_hWnd
End If
End If
End If
End Property
Private Property Get plIndex(ByVal hwnd As Long) As Long
Dim i As Long
Dim lIndex As Long
For i = 1 To m_iCount
If hwnd = m_hWnd(i) Then
plIndex = i
Exit For
End If
Next i
End Property
Private Sub UnApply()
Dim i As Long
For i = 1 To m_iCount
If Not m_hWnd(i) = 0 Then
SetWindowRgn m_hWnd(i), 0, True
m_hWnd(i) = 0
End If
Next i
m_iCount = 0
End Sub
Public Sub Destroy()
UnApply
If Not m_hRgn = 0 Then
DeleteObject m_hRgn
End If
m_hRgn = 0
End Sub
Public Sub Create( _
ByRef cDib As cDIBSection, _
Optional ByRef lTransColor As Long = 0 _
)
Dim X As Long, Y As Long
Dim lX As Long
Dim yStart As Long
Dim bStart As Boolean
Dim hRgnTemp As Long
Dim Br As Byte, bG As Byte, bB As Byte
Dim lWidth As Long, lHeight As Long
Dim bDib() As Byte
Dim tSA As SAFEARRAY2D
Destroy
' The transparent colour:
Br = (lTransColor And &HFF&)
bG = (lTransColor And &HFF00&) \ &H100&
bB = (lTransColor And &HFF0000) \ &H10000
' Create the base region
m_hRgn = CreateRectRgn(0, 0, cDib.Width, cDib.Height)
Debug.Assert (m_hRgn <> 0)
If m_hRgn <> 0 Then
' Get the DIB into byte array:
With tSA
.cbElements = 1
.cDims = 2
.Bounds(0).lLbound = 0
.Bounds(0).cElements = cDib.Height
.Bounds(1).lLbound = 0
.Bounds(1).cElements = cDib.BytesPerScanLine()
.pvData = cDib.DIBSectionBitsPtr
End With
CopyMemory ByVal VarPtrArray(bDib()), VarPtr(tSA), 4
lWidth = cDib.BytesPerScanLine \ 3
lHeight = cDib.Height
For X = 0 To (lWidth - 1) * 3 Step 3
' DIB Sections are "upside down"
For Y = lHeight - 1 To 0 Step -1
If bDib(X, Y) = bB And bDib(X + 1, Y) = bG And bDib(X + 2,
Y) = Br Then
If Not bStart Then
yStart = lHeight - 1 - Y
bStart = True
End If
Else
If bStart Then
hRgnTemp = CreateRectRgn(lX, yStart, lX + 1, lHeight
- 1 - Y)
CombineRgn m_hRgn, hRgnTemp, m_hRgn, RGN_XOR
DeleteObject hRgnTemp
bStart = False
End If
End If
Next Y
If bStart Then
hRgnTemp = CreateRectRgn(lX, yStart, lX + 1, lHeight - 1 - Y)
CombineRgn m_hRgn, hRgnTemp, m_hRgn, RGN_XOR
DeleteObject hRgnTemp
bStart = False
End If
lX = lX + 1
Next X
CopyMemory ByVal VarPtrArray(bDib), 0&, 4
End If
End Sub
Private Sub Class_Terminate()
Destroy
End Sub
''******************** END OF METHOD 1
Method 2
On a modeless form 350 square apply a background colour. Place a
commandbutton on the form.
''******************** START OF METHOD 2
In UserForm2
Option Explicit
Private Type POINTAPI
X As Long
Y As Long
End Type
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String) 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 SetWindowRgn Lib "user32" ( _
ByVal hwnd As Long, _
ByVal hRgn As Long, ByVal bRedraw As
Long) As Long
Private Declare Function DeleteObject Lib "gdi32" ( _
ByVal hObject As Long) As Long
Private Const RGN_DIFF = 4
Dim hwnd As Long
Dim DefinedRegion As Long
Dim HoleRegion As Long
Private Declare Function ReleaseCapture Lib "user32" () As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" ( _
ByVal hwnd As Long, ByVal wMsg As Long, _
ByVal wParam As Long, lParam As Any) As
Long
Private Const WM_NCLBUTTONDOWN = &HA1
Private Const HTCAPTION = 2
Private Sub UserForm_Initialize()
Dim newRgn As Long
If Application.Version < 9 Then
hwnd = FindWindow("THUNDERXFRAME", Me.Caption)
Else
hwnd = FindWindow("THUNDERDFRAME", Me.Caption)
End If
DefinedRegion = CreateRectRgn(0, 30, 310, 350)
HoleRegion = CreateRectRgn(90, 0, 110, 350)
newRgn = CombineRgn(DefinedRegion, DefinedRegion, HoleRegion, RGN_DIFF)
HoleRegion = CreateRectRgn(200, 0, 220, 350)
newRgn = CombineRgn(DefinedRegion, DefinedRegion, HoleRegion, RGN_DIFF)
HoleRegion = CreateRectRgn(0, 130, 350, 150)
newRgn = CombineRgn(DefinedRegion, DefinedRegion, HoleRegion, RGN_DIFF)
HoleRegion = CreateRectRgn(0, 240, 350, 260)
newRgn = CombineRgn(DefinedRegion, DefinedRegion, HoleRegion, RGN_DIFF)
SetWindowRgn hwnd, DefinedRegion, True
DeleteObject DefinedRegion
DeleteObject HoleRegion
DeleteObject newRgn
End Sub
Private Sub UserForm_MouseDown(ByVal Button As Integer, ByVal Shift As
Integer, _
ByVal X As Single, ByVal Y As Single)
If Button And 1 Then
Call ReleaseCapture
Call SendMessage(hwnd, WM_NCLBUTTONDOWN, HTCAPTION, ByVal 0&)
End If
End Sub
Private Sub CommandButton1_Click()
Unload UserForm2
Set UserForm2 = Nothing
End Sub
''******************** END OF METHOD 2