Clicking on a region of an image..... Is there a control?

[TimBarnette]

I'd like to put up an image and allow the user to click on different areas of the image for different results..(Maybe in a click event for each area?).. I'd like to be comfortable this is going to work at any resolution (always a good thing)

Does anyone know of a control for this, or any idea on how to do it?

Take the X and Y from the mouseDown event and build a select case that will handle the clicked areas.

Kayan.

[Sam Finch]

Try an image control with no picture in it, There invisible but have a click event

[TimBarnette]

I forgot to mention I would also like to "shade in" some of the image when the user clicks it.. For instance, a geographical map.. They can click on a country and it will shade in.. They can click on as many countries as they want.. I want to be able to tell which country they clicked on..... I want it to work in 640 x 480, 800 x600, 1024x768, etc...

[Sam Finch]

Add a new user controll to your project, Change the backcolour to something thats not the default grey( This is just so you can see it)

Dont do anything else just insert this code into the control

[CODE]

Option Explicit

'API Constants and enums

Private Enum enmRegionCombinations

RGN_AND = 1
RGN_COPY = 5
RGN_DIFF = 4
RGN_OR = 2
RGN_XOR = 3
RGN_MAX = RGN_COPY
RGN_MIN = RGN_AND

End Enum

Const LEN_SMALLBITMAPINFO = 12

'API Structures

Private Type SMALLBITMAPINFO
biSize As Long
biWidth As Long
biHeight As Long
End Type


'API Declares
Private Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As enmRegionCombinations) 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 DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private Declare Function FillRgn Lib "gdi32" (ByVal hdc As Long, ByVal hRgn As Long, ByVal hBrush As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor 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 CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, 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 GetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRgn As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight 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 RasterOpConstants) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long

'control variables
Dim apiBmapInfo As SMALLBITMAPINFO

'Property Variables:
Dim m_Image As Picture
Dim m_ShowImage As Boolean
'Dim m_Image As Picture
'Default Property Values:
Const m_def_ShowImage = True
'Event Declarations:
Event Click() 'MappingInfo=UserControl,UserControl,-1,Click
Event DblClick() 'MappingInfo=UserControl,UserControl,-1,DblClick
Event MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single) 'MappingInfo=UserControl,UserControl,-1,MouseDown
Event MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single) 'MappingInfo=UserControl,UserControl,-1,MouseMove
Event MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single) 'MappingInfo=UserControl,UserControl,-1,MouseUp




'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=UserControl,UserControl,-1,BackColor
Public Property Get BackColor() As OLE_COLOR
BackColor = UserControl.BackColor
End Property

Public Property Let BackColor(ByVal New_BackColor As OLE_COLOR)
UserControl.BackColor() = New_BackColor
PropertyChanged "BackColor"
Draw
End Property
'
''WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
''MemberInfo=11,2,0,0
'Public Property Get Image() As Picture
' If Ambient.UserMode Then Err.Raise 393
' Set Image = m_Image
'End Property
'
'Public Property Set Image(ByVal New_Image As Picture)
' Set m_Image = New_Image
' PropertyChanged "Image"
'End Property

'Initialize Properties for User Control
Private Sub UserControl_InitProperties()
Set m_Image = LoadPicture("")
End Sub

'Load property values from storage
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)

UserControl.BackColor = PropBag.ReadProperty("BackColor", &H8000000F)
Set MouseIcon = PropBag.ReadProperty("MouseIcon", Nothing)
UserControl.MousePointer = PropBag.ReadProperty("MousePointer", 0)
Set m_Image = PropBag.ReadProperty("Image", Nothing)

End Sub

'Write property values to storage
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)

Call PropBag.WriteProperty("BackColor", UserControl.BackColor, &H8000000F)
Call PropBag.WriteProperty("MouseIcon", MouseIcon, Nothing)
Call PropBag.WriteProperty("MousePointer", UserControl.MousePointer, 0)
Call PropBag.WriteProperty("Image", m_Image, Nothing)

End Sub

Private Sub UserControl_Click()
RaiseEvent Click
End Sub

Private Sub UserControl_DblClick()
RaiseEvent DblClick
End Sub

Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
RaiseEvent MouseDown(Button, Shift, x, y)
End Sub

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=UserControl,UserControl,-1,MouseIcon
Public Property Get MouseIcon() As Picture
Set MouseIcon = UserControl.MouseIcon
End Property

Public Property Set MouseIcon(ByVal New_MouseIcon As Picture)
Set UserControl.MouseIcon = New_MouseIcon
PropertyChanged "MouseIcon"
End Property

Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
RaiseEvent MouseMove(Button, Shift, x, y)
End Sub

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=UserControl,UserControl,-1,MousePointer
Public Property Get MousePointer() As Integer
MousePointer = UserControl.MousePointer
End Property

Public Property Let MousePointer(ByVal New_MousePointer As Integer)
UserControl.MousePointer() = New_MousePointer
PropertyChanged "MousePointer"
End Property

Private Sub UserControl_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
RaiseEvent MouseUp(Button, Shift, x, y)
End Sub

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=UserControl,UserControl,-1,Refresh
Public Sub Refresh()
UserControl.Refresh
End Sub

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=11,0,0,0
Public Property Get Image() As Picture
Set Image = m_Image
End Property

Public Property Set Image(ByVal New_Image As Picture)
Set m_Image = New_Image
PropertyChanged "Image"
UpdateRegion
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=UserControl,UserControl,-1,HyperLink
Public Property Get HyperLink() As HyperLink
Set HyperLink = UserControl.HyperLink
End Property

Private Sub UpdateRegion()

Dim i As Integer
Dim j As Integer
Dim hNewRgn As Long
Dim hRgnTemp As Long
Dim hMemDC As Long

If IsPictNothing(m_Image) Then

hNewRgn = CreateRectRgn(0, 0, _
ScaleX(UserControl.ScaleWidth, UserControl.ScaleMode, vbPixels), _
ScaleY(UserControl.ScaleHeight, UserControl.ScaleMode, vbPixels))

Else

'Create empty region
hNewRgn = CreateRectRgn(1, 1, 1, 1)
CombineRgn hNewRgn, hNewRgn, hNewRgn, RGN_XOR


'Put picture into new DC
hMemDC = CreateCompatibleDC(UserControl.hdc)
DeleteObject SelectObject(hMemDC, m_Image.Handle)

'get image size
GetObject m_Image.Handle, LEN_SMALLBITMAPINFO, apiBmapInfo

'loop through pixels

For i = 1 To apiBmapInfo.biWidth - 2

For j = 1 To apiBmapInfo.biHeight - 1

'Check pixel colour
If Not GetPixel(hMemDC, i, j) = vbWhite Then

'if not white add to region
hRgnTemp = CreateRectRgn(i, j, i + 1, j + 1)
CombineRgn hNewRgn, hNewRgn, hRgnTemp, RGN_OR
DeleteObject hRgnTemp

End If

Next j

Next i


End If

'Get picture out of dc
SelectObject hMemDC, CreateCompatibleBitmap(hMemDC, 1, 1)

'delete dc
DeleteDC hMemDC

SetWindowRgn UserControl.hWnd, hNewRgn, True


End Sub

Private Sub Draw()
Dim hRgnTemp As Long
Dim hBrushTemp As Long

GetWindowRgn UserControl.hWnd, hRgnTemp

hBrushTemp = CreateSolidBrush(UserControl.BackColor)

FillRgn UserControl.hdc, hRgnTemp, hBrushTemp

DeleteObject hBrushTemp

UserControl.Refresh

End Sub

Private Function IsPictNothing(Pict As StdPicture) As Boolean

On Error GoTo ISNOTHING::

IsPictNothing = (Pict.Handle = 0)

On Error GoTo 0

Exit Function

ISNOTHING::

IsPictNothing = True

End Function

[CODE]

then Got to a paint program draw your contries on a white background, one bitmap for each country and save them to disk, put them in the top corner of the bitmap.



Next go back to your project insert one usercontrol for each country and set its image property to the bitmap file of the country you want it to be.

it will set its window region to the shape of your bitmap, then just fit the countries together like a jigsaw, Ive put a few properties and events in if you want to change them use the activeX control interface wizard.

Hope This Helps.

[TimBarnette]

Thanks for the answer... It will take some time to get this one going... I can see that now...<G> Isn't there a control or something to take care of some of that code?