Use of interfaces?

T

tiredofit

Well-known Member
Joined
Apr 11, 2013
Messages
1,832
Office Version
  1. 365
  2. 2019
Platform
  1. Windows
I am trying to learn about class interfaces but don't appreciate them.

The first method uses it.

Method1:

' Standard Module1:

Code: 
Option Explicit

Public Sub abc()
   
    Dim a As IInterface
   
    Dim i As Long
   
    For i = 1 To 20
   
        Set a = CFactory(i)
       
        Sheet1.Cells(i, 2).Value = a.Fruit
       
    Next i
   
End Sub

Public Function CFactory(i As Long) As IInterface
   
    Dim b As IInterface
   
    If Sheet1.Cells(i, 1).Value Mod 2 = 1 Then
       
        Set b = New ClsApples

    Else
   
        Set b = New ClsOranges
       
    End If
   
    Set CFactory = b
   
End Function

' Class IInterface

Code: 
Option Explicit

Public Function Fruit() As String

End Function

' Class ClsApples

Code: 
Option Explicit

    Implements IInterface

Public Function Iinterface_Fruit() As String
   
    Iinterface_Fruit = "Apples"
   
End Function

' Class ClsOranges

Code: 
Option Explicit

    Implements IInterface

Public Function Iinterface_Fruit() As String
   
    Iinterface_Fruit = "Oranges"
   
End Function



Method2:

'Standard Module2:

Code: 
Option Explicit

Public Sub abc()
   
    Dim i As Long
   
    For i = 1 To 20
       
        Call Module2.CFactory(i)
       
    Next i
   
End Sub

Public Sub CFactory(i As Long)
   
    Dim b As ClsApples
    Dim c As ClsOranges
   
    If Sheet1.Cells(i, 1).Value Mod 2 = 1 Then
       
        Set b = New ClsApples
       
        Sheet1.Cells(i, 2).Value = b.Fruit
       
    Else
   
        Set c = New ClsOranges
       
        Sheet1.Cells(i, 2).Value = c.Fruit
       
    End If
    
End Sub

' Class ClsApples

Code: 
Option Explicit

Public Function Fruit() As String
  
    Fruit = "Apples"
   
End Function

'Class ClsOranges

Code: 
Option Explicit

Public Function Fruit() As String
   
    Fruit = "Oranges"
   
End Function

Method2 works without the need for the class IInterface, so why have it?

Can someone please explain.

Thanks
 

Excel Facts

Remove leading & trailing spaces
Save as CSV to remove all leading and trailing spaces. It is faster than using TRIM().
Sort by date Sort by votes
It is a matter of design.

Using different Interfaces of a Class is ideal when each Interface offers a unique functionality that clients need.

Imagine you design a ProgressBar with its own specific set of Methods and Properties based on a userform. If you call the ProgressBar directly by loading the userform, the client code will have access to the Public Properties and Methods of the ProgressBar as expected but will also be exposed to all the redundant default Properties and Methods of the UserForm whereas if you implement a ProgressBar Interface in the UserForm module, the client code will be exposed only to the specific ProgressBar Methods and Properties hence insulating it from all the redundant and not-needed Methods and Properties of the base userform.
 
Last edited:
Upvote 0
Here is the workbook example I told you about which illustrates the idea of polymorphism in vba.

In this example, we use a single blank UserForm as a base Class which creates basic floating shapes by implementing 3 different easy Interfaces ISquare, ICircle and ITriangle each Interface with its own set of Properties and Methods... Client codes of the Class need not deal with the redundant default Methods and Properties of the UserForm or those of other co-existing Interfaces.

The editor intellisense nicely displays the needed Interface members and hides all other unecessary members.

Sans titre2.png


Preview:



ICircle Interface
VBA Code: 
Option Explicit

Public Property Get FillColor() As Long
'
End Property

Public Property Let FillColor(ByVal vNewValue As Long)
'
End Property

Public Property Get RadiusLength() As Single
'
End Property

Public Property Let RadiusLength(ByVal vNewValue As Single)
'
End Property

Public Sub Show()
'
End Sub

ISquare Interface
VBA Code: 
Option Explicit

Public Property Get FillColor() As Long
'
End Property

Public Property Let FillColor(ByVal vNewValue As Long)
'
End Property

Public Property Get SideLength() As Single
'
End Property

Public Property Let SideLength(ByVal vNewValue As Single)
'
End Property

Public Sub Show()
'
End Sub

ITriangle Interface
VBA Code: 
Option Explicit

Public Property Get FillColor() As Long
'
End Property

Public Property Let FillColor(ByVal vNewValue As Long)
'
End Property

Public Property Get HeightLength() As Single
'
End Property

Public Property Let HeightLength(ByVal vNewValue As Single)
'
End Property

Public Sub Show()
'
End Sub


UserForm Code (Shapes):
VBA Code: 
Option Explicit

Private Type POINTAPI
    X As Long
    Y As Long
End Type

#If VBA7 Then
    #If Win64 Then
        Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
        Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
    #Else
        Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
        Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
    #End If
    Private Declare PtrSafe Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hUf As LongPtr) As Long
    Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
    Private Declare PtrSafe Function DrawMenuBar Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare PtrSafe Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As Long
    Private Declare PtrSafe Sub ReleaseCapture Lib "user32" ()
    Private Declare PtrSafe Function CreateEllipticRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As LongPtr
    Private Declare PtrSafe Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As LongPtr
    Private Declare PtrSafe Function CreatePolygonRgn Lib "gdi32" (lpPoint As Any, ByVal nCount As Long, ByVal nPolyFillMode As Long) As Long
    Private Declare PtrSafe Function SetWindowRgn Lib "user32" (ByVal hwnd As LongPtr, ByVal hRgn As LongPtr, ByVal bRedraw As Long) As Long
    Private Declare PtrSafe Function CreatePopupMenu Lib "user32" () As LongPtr
    Private Declare PtrSafe Function DestroyMenu Lib "user32" (ByVal hMenu As LongPtr) As Long
    Private Declare PtrSafe Function AppendMenu Lib "user32" Alias "AppendMenuA" (ByVal hMenu As LongPtr, ByVal wFlags As Long, ByVal wIDNewItem As LongPtr, ByVal lpNewItem As Any) As Long
    Private Declare PtrSafe Function TrackPopupMenuEx Lib "user32" (ByVal hMenu As LongPtr, ByVal un As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal hwnd As LongPtr, ByVal lpTPMParams As Long) As Long
    Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long

    Private hwnd As LongPtr, hRgn As LongPtr
#Else
    Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) 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 IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hUf As Long) As Long
    Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
    Private Declare Function DrawMenuBar Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Private Declare Sub ReleaseCapture Lib "user32" ()
    Private Declare Function CreateEllipticRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 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 CreatePolygonRgn Lib "gdi32" (lpPoint As Any, ByVal nCount As Long, ByVal nPolyFillMode 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 CreatePopupMenu Lib "user32" () As Long
    Private Declare Function DestroyMenu Lib "user32" (ByVal hMenu As Long) As Long
    Private Declare Function AppendMenu Lib "user32" Alias "AppendMenuA" (ByVal hMenu As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal lpNewItem As Any) As Long
    Private Declare Function TrackPopupMenuEx Lib "user32" (ByVal hMenu As Long, ByVal un As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal hwnd As Long, ByVal lpTPMParams As Long) As Long
    Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long

    Private hwnd As Long, hRgn As Long
#End If

Private lFill As Long
Private sngRHS As Single
 
Implements ICircle
Implements ISquare
Implements ITriangle


Private Sub UserForm_Initialize()
    Me.Height = 50
    Me.Width = Me.Height
    Call IUnknown_GetWindow(Me, VarPtr(hwnd))
    Call HideFormTitleBar
End Sub

Private Sub UserForm_Terminate()
    Call DeleteObject(hRgn)
End Sub

Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    If Button = 1 Then
        Call EnableFormDragging
    End If
End Sub

Private Sub UserForm_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    If Button = 2 Then
        CreateAndShowRightClickMenu
    End If
End Sub

Private Sub HideFormTitleBar()
    Const GWL_STYLE = -16
    Const WS_CAPTION = &HC00000

    #If Win64 Then
        Dim lStyle As LongLong
    #Else
        Dim lStyle As Long
    #End If
 
    lStyle = GetWindowLong(hwnd, GWL_STYLE)
    lStyle = lStyle And Not WS_CAPTION
    Call SetWindowLong(hwnd, GWL_STYLE, lStyle)
    Call DrawMenuBar(hwnd)
End Sub

Private Sub EnableFormDragging()
    Const WM_NCLBUTTONDOWN = &HA1
    Const HTCAPTION = 2
 
    Call ReleaseCapture
    Call PostMessage(hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0)
End Sub

Private Sub CreateAndShowRightClickMenu()
    Const TPM_RETURNCMD = &H100&
    Const MF_STRING = &H0&
 
    #If Win64 Then
        Dim hMenu As LongLong
    #Else
        Dim hMenu As Long
    #End If
    Dim tCursorPos As POINTAPI
    Dim lShowPopupMenu As Long
 
    hMenu = CreatePopupMenu()
    Call AppendMenu(hMenu, MF_STRING, 1, "C&lose")
    Call GetCursorPos(tCursorPos)
    lShowPopupMenu = TrackPopupMenuEx(hMenu, TPM_RETURNCMD, tCursorPos.X, tCursorPos.Y, hwnd, ByVal 0&)
    If lShowPopupMenu = 1 Then
        Unload Me
    End If
    Call DestroyMenu(hMenu)
End Sub


'____________________________________ Interfaces Members ________________________________

Private Property Let ICircle_FillColor(ByVal RHS As Long)
    lFill = RHS
End Property

Private Property Get ICircle_FillColor() As Long
    ICircle_FillColor = lFill
End Property

Private Property Let ICircle_RadiusLength(ByVal RHS As Single)
    Me.Width = RHS
    Me.Height = Me.Width
    sngRHS = RHS
End Property

Private Property Get ICircle_RadiusLength() As Single
    ICircle_RadiusLength = sngRHS
End Property

Private Sub ICircle_Show()
    Me.BackColor = lFill
    If sngRHS <= 50 Then sngRHS = 50
    hRgn = CreateEllipticRgn(10 + (Me.InsideWidth - sngRHS) / 2, 10 + (Me.InsideHeight - sngRHS) / 2, _
           (Me.InsideWidth + sngRHS) / 2, (Me.InsideHeight + sngRHS) / 2)
    Call SetWindowRgn(hwnd, hRgn, True)
    Me.Show vbModeless
End Sub

Private Property Get ISquare_FillColor() As Long
    ISquare_FillColor = lFill
End Property

Private Property Let ISquare_FillColor(ByVal RHS As Long)
    lFill = RHS
End Property

Private Property Let ISquare_SideLength(ByVal RHS As Single)
    Me.Width = RHS
    Me.Height = Me.Width
    sngRHS = RHS
End Property

Private Property Get ISquare_SideLength() As Single
    ISquare_SideLength = sngRHS
End Property

Private Sub ISquare_Show()
    Me.BackColor = lFill
    If sngRHS <= 50 Then sngRHS = 50
    hRgn = CreateRectRgn(10 + (Me.InsideWidth - sngRHS) / 2, 10 + (Me.InsideHeight - sngRHS) / 2, _
          (Me.InsideWidth + sngRHS) / 2, (Me.InsideHeight + sngRHS) / 2)
    Call SetWindowRgn(hwnd, hRgn, True)
    Me.Show vbModeless
End Sub

Private Property Let ITriangle_FillColor(ByVal RHS As Long)
    lFill = RHS
End Property

Private Property Get ITriangle_FillColor() As Long
    ITriangle_FillColor = lFill
End Property

Private Property Get ITriangle_HeightLength() As Single
    ITriangle_HeightLength = sngRHS
End Property

Private Property Let ITriangle_HeightLength(ByVal RHS As Single)
    Me.Width = RHS
    Me.Height = Me.Width
    sngRHS = RHS
End Property

Private Sub ITriangle_Show()
    Const ALTERNATE = 1
    Dim poly(0 To 2) As POINTAPI
 
    Me.BackColor = lFill
    If sngRHS <= 50 Then sngRHS = 50
    poly(0).X = sngRHS / 2
    poly(0).Y = 5
    poly(1).X = sngRHS - 5
    poly(1).Y = sngRHS - 5
    poly(2).X = 5
    poly(2).Y = sngRHS - 5
    hRgn = CreatePolygonRgn(poly(0), 3, ALTERNATE)
    Call SetWindowRgn(hwnd, hRgn, True)
    Me.Show vbModeless
End Sub


Client Code example (bas Module)
VBA Code: 
Option Explicit

Sub test1()

    Dim oSquare As ISquare
 
    Set oSquare = New Shapes
    With oSquare
        .FillColor = vbMagenta
        .SideLength = 100
        .Show
    End With

End Sub

Sub test2()

    Dim oCirlce As ICircle
 
    Set oCirlce = New Shapes
    With oCirlce
        .RadiusLength = 150
        .FillColor = vbYellow
        .Show
    End With

End Sub

Sub test3()

    Dim oTriangle As ITriangle
 
    Set oTriangle = New Shapes
    With oTriangle
        .FillColor = vbCyan
        .HeightLength = 150
        .Show
    End With
 
End Sub

Sub test4()

    Dim oCirlce As ICircle
 
    Set oCirlce = New Shapes
    With oCirlce
        .RadiusLength = 80
        .FillColor = vbGreen
        .Show
    End With

End Sub
 
Last edited:
Upvote 0
Jaafar Tribak said:
Here is the workbook example I told you about which illustrates the idea of polymorphism in vba.

In this example, we use a single blank UserForm as a base Class which creates basic floating shapes by implementing 3 different easy Interfaces ISquare, ICircle and ITriangle each Interface with its own set of Properties and Methods... Client codes of the Class need not deal with the redundant default Methods and Properties of the UserForm or those of other co-existing Interfaces.

The editor intellisense nicely displays the needed Interface members and hides all other unecessary members.

View attachment 57525

Preview:



ICircle Interface
VBA Code: 
Option Explicit

Public Property Get FillColor() As Long
'
End Property

Public Property Let FillColor(ByVal vNewValue As Long)
'
End Property

Public Property Get RadiusLength() As Single
'
End Property

Public Property Let RadiusLength(ByVal vNewValue As Single)
'
End Property

Public Sub Show()
'
End Sub

ISquare Interface
VBA Code: 
Option Explicit

Public Property Get FillColor() As Long
'
End Property

Public Property Let FillColor(ByVal vNewValue As Long)
'
End Property

Public Property Get SideLength() As Single
'
End Property

Public Property Let SideLength(ByVal vNewValue As Single)
'
End Property

Public Sub Show()
'
End Sub

ITriangle Interface
VBA Code: 
Option Explicit

Public Property Get FillColor() As Long
'
End Property

Public Property Let FillColor(ByVal vNewValue As Long)
'
End Property

Public Property Get HeightLength() As Single
'
End Property

Public Property Let HeightLength(ByVal vNewValue As Single)
'
End Property

Public Sub Show()
'
End Sub


UserForm Code (Shapes):
VBA Code: 
Option Explicit

Private Type POINTAPI
    X As Long
    Y As Long
End Type

#If VBA7 Then
    #If Win64 Then
        Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
        Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
    #Else
        Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
        Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
    #End If
    Private Declare PtrSafe Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hUf As LongPtr) As Long
    Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
    Private Declare PtrSafe Function DrawMenuBar Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare PtrSafe Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As Long
    Private Declare PtrSafe Sub ReleaseCapture Lib "user32" ()
    Private Declare PtrSafe Function CreateEllipticRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As LongPtr
    Private Declare PtrSafe Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As LongPtr
    Private Declare PtrSafe Function CreatePolygonRgn Lib "gdi32" (lpPoint As Any, ByVal nCount As Long, ByVal nPolyFillMode As Long) As Long
    Private Declare PtrSafe Function SetWindowRgn Lib "user32" (ByVal hwnd As LongPtr, ByVal hRgn As LongPtr, ByVal bRedraw As Long) As Long
    Private Declare PtrSafe Function CreatePopupMenu Lib "user32" () As LongPtr
    Private Declare PtrSafe Function DestroyMenu Lib "user32" (ByVal hMenu As LongPtr) As Long
    Private Declare PtrSafe Function AppendMenu Lib "user32" Alias "AppendMenuA" (ByVal hMenu As LongPtr, ByVal wFlags As Long, ByVal wIDNewItem As LongPtr, ByVal lpNewItem As Any) As Long
    Private Declare PtrSafe Function TrackPopupMenuEx Lib "user32" (ByVal hMenu As LongPtr, ByVal un As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal hwnd As LongPtr, ByVal lpTPMParams As Long) As Long
    Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long

    Private hwnd As LongPtr, hRgn As LongPtr
#Else
    Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) 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 IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hUf As Long) As Long
    Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
    Private Declare Function DrawMenuBar Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Private Declare Sub ReleaseCapture Lib "user32" ()
    Private Declare Function CreateEllipticRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 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 CreatePolygonRgn Lib "gdi32" (lpPoint As Any, ByVal nCount As Long, ByVal nPolyFillMode 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 CreatePopupMenu Lib "user32" () As Long
    Private Declare Function DestroyMenu Lib "user32" (ByVal hMenu As Long) As Long
    Private Declare Function AppendMenu Lib "user32" Alias "AppendMenuA" (ByVal hMenu As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal lpNewItem As Any) As Long
    Private Declare Function TrackPopupMenuEx Lib "user32" (ByVal hMenu As Long, ByVal un As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal hwnd As Long, ByVal lpTPMParams As Long) As Long
    Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long

    Private hwnd As Long, hRgn As Long
#End If

Private lFill As Long
Private sngRHS As Single
 
Implements ICircle
Implements ISquare
Implements ITriangle


Private Sub UserForm_Initialize()
    Me.Height = 50
    Me.Width = Me.Height
    Call IUnknown_GetWindow(Me, VarPtr(hwnd))
    Call HideFormTitleBar
End Sub

Private Sub UserForm_Terminate()
    Call DeleteObject(hRgn)
End Sub

Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    If Button = 1 Then
        Call EnableFormDragging
    End If
End Sub

Private Sub UserForm_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    If Button = 2 Then
        CreateAndShowRightClickMenu
    End If
End Sub

Private Sub HideFormTitleBar()
    Const GWL_STYLE = -16
    Const WS_CAPTION = &HC00000

    #If Win64 Then
        Dim lStyle As LongLong
    #Else
        Dim lStyle As Long
    #End If
 
    lStyle = GetWindowLong(hwnd, GWL_STYLE)
    lStyle = lStyle And Not WS_CAPTION
    Call SetWindowLong(hwnd, GWL_STYLE, lStyle)
    Call DrawMenuBar(hwnd)
End Sub

Private Sub EnableFormDragging()
    Const WM_NCLBUTTONDOWN = &HA1
    Const HTCAPTION = 2
 
    Call ReleaseCapture
    Call PostMessage(hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0)
End Sub

Private Sub CreateAndShowRightClickMenu()
    Const TPM_RETURNCMD = &H100&
    Const MF_STRING = &H0&
 
    #If Win64 Then
        Dim hMenu As LongLong
    #Else
        Dim hMenu As Long
    #End If
    Dim tCursorPos As POINTAPI
    Dim lShowPopupMenu As Long
 
    hMenu = CreatePopupMenu()
    Call AppendMenu(hMenu, MF_STRING, 1, "C&lose")
    Call GetCursorPos(tCursorPos)
    lShowPopupMenu = TrackPopupMenuEx(hMenu, TPM_RETURNCMD, tCursorPos.X, tCursorPos.Y, hwnd, ByVal 0&)
    If lShowPopupMenu = 1 Then
        Unload Me
    End If
    Call DestroyMenu(hMenu)
End Sub


'____________________________________ Interfaces Members ________________________________

Private Property Let ICircle_FillColor(ByVal RHS As Long)
    lFill = RHS
End Property

Private Property Get ICircle_FillColor() As Long
    ICircle_FillColor = lFill
End Property

Private Property Let ICircle_RadiusLength(ByVal RHS As Single)
    Me.Width = RHS
    Me.Height = Me.Width
    sngRHS = RHS
End Property

Private Property Get ICircle_RadiusLength() As Single
    ICircle_RadiusLength = sngRHS
End Property

Private Sub ICircle_Show()
    Me.BackColor = lFill
    If sngRHS <= 50 Then sngRHS = 50
    hRgn = CreateEllipticRgn(10 + (Me.InsideWidth - sngRHS) / 2, 10 + (Me.InsideHeight - sngRHS) / 2, _
           (Me.InsideWidth + sngRHS) / 2, (Me.InsideHeight + sngRHS) / 2)
    Call SetWindowRgn(hwnd, hRgn, True)
    Me.Show vbModeless
End Sub

Private Property Get ISquare_FillColor() As Long
    ISquare_FillColor = lFill
End Property

Private Property Let ISquare_FillColor(ByVal RHS As Long)
    lFill = RHS
End Property

Private Property Let ISquare_SideLength(ByVal RHS As Single)
    Me.Width = RHS
    Me.Height = Me.Width
    sngRHS = RHS
End Property

Private Property Get ISquare_SideLength() As Single
    ISquare_SideLength = sngRHS
End Property

Private Sub ISquare_Show()
    Me.BackColor = lFill
    If sngRHS <= 50 Then sngRHS = 50
    hRgn = CreateRectRgn(10 + (Me.InsideWidth - sngRHS) / 2, 10 + (Me.InsideHeight - sngRHS) / 2, _
          (Me.InsideWidth + sngRHS) / 2, (Me.InsideHeight + sngRHS) / 2)
    Call SetWindowRgn(hwnd, hRgn, True)
    Me.Show vbModeless
End Sub

Private Property Let ITriangle_FillColor(ByVal RHS As Long)
    lFill = RHS
End Property

Private Property Get ITriangle_FillColor() As Long
    ITriangle_FillColor = lFill
End Property

Private Property Get ITriangle_HeightLength() As Single
    ITriangle_HeightLength = sngRHS
End Property

Private Property Let ITriangle_HeightLength(ByVal RHS As Single)
    Me.Width = RHS
    Me.Height = Me.Width
    sngRHS = RHS
End Property

Private Sub ITriangle_Show()
    Const ALTERNATE = 1
    Dim poly(0 To 2) As POINTAPI
 
    Me.BackColor = lFill
    If sngRHS <= 50 Then sngRHS = 50
    poly(0).X = sngRHS / 2
    poly(0).Y = 5
    poly(1).X = sngRHS - 5
    poly(1).Y = sngRHS - 5
    poly(2).X = 5
    poly(2).Y = sngRHS - 5
    hRgn = CreatePolygonRgn(poly(0), 3, ALTERNATE)
    Call SetWindowRgn(hwnd, hRgn, True)
    Me.Show vbModeless
End Sub


Client Code example (bas Module)
VBA Code: 
Option Explicit

Sub test1()

    Dim oSquare As ISquare
 
    Set oSquare = New Shapes
    With oSquare
        .FillColor = vbMagenta
        .SideLength = 100
        .Show
    End With

End Sub

Sub test2()

    Dim oCirlce As ICircle
 
    Set oCirlce = New Shapes
    With oCirlce
        .RadiusLength = 150
        .FillColor = vbYellow
        .Show
    End With

End Sub

Sub test3()

    Dim oTriangle As ITriangle
 
    Set oTriangle = New Shapes
    With oTriangle
        .FillColor = vbCyan
        .HeightLength = 150
        .Show
    End With
 
End Sub

Sub test4()

    Dim oCirlce As ICircle
 
    Set oCirlce = New Shapes
    With oCirlce
        .RadiusLength = 80
        .FillColor = vbGreen
        .Show
    End With

End Sub
Click to expand...
Thanks, great example. I'll try and use this idea going forwards in my code.
 
Upvote 0
You must log in or register to reply here.

Similar threads

T
  • Question
Private vs Public class
Replies
6
Views
343
tiredofit
T
H
  • Solved
Catching the Mouse Click Error in Modal User Form
Replies
4
Views
278
huiettcm
H
SeniorNewbie
  • Solved
Need the first line of the VBA code of all my UDF
Replies
3
Views
60
Domenic
D
L
  • Question
I can not trigger OLEObject.GotFocus event by ConnectToConnectionPoint API
Replies
0
Views
143
loquat
L
M
  • Question
How To Allow Only One Checkbox to Be Checked in Excel per Table
Replies
1
Views
73
bobsan42
bobsan42

Forum statistics

Threads
1,214,653
Messages
6,120,752
Members
448,989
Latest member
mariah3

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top