candybutton.ctl

simple supermarket for beginners

Private Function IsInRoundRect(i As Long, j As Long, X As Long, Y As Long, lWidth As Long, lHeight As Long, Radius As Long) As Boolean
Dim offX As Long, offY As Long
    offX = i - X
    offY = j - Y
    If offY > Radius And offY + Radius < lHeight And offX > Radius And offX + Radius < lWidth Then
        '/* This is to catch early most cases
        IsInRoundRect = True
    ElseIf offX < Radius And offY <= Radius Then
        If IsInCircle(offX - Radius, offY, Radius) Then IsInRoundRect = True
    ElseIf offX + Radius > lWidth And offY <= Radius Then
        If IsInCircle(offX - lWidth + Radius, offY, Radius) Then IsInRoundRect = True
    ElseIf offX < Radius And offY + Radius >= lHeight Then
        If IsInCircle(offX - Radius, offY - lHeight + Radius * 2, Radius) Then IsInRoundRect = True
    ElseIf offX + Radius > lWidth And offY + Radius >= lHeight Then
        If IsInCircle(offX - lWidth + Radius, offY - lHeight + Radius * 2, Radius) Then IsInRoundRect = True
    Else
        If offX > 0 And offX < lWidth And offY > 0 And offY < lHeight Then IsInRoundRect = True
    End If
End Function

Private Function IsInCircle(ByRef X As Long, ByRef Y As Long, ByRef r As Long) As Boolean
Dim lResult As Long
    '/* this detect a circunference centered on y=-r and x=0
    lResult = (r * r) - (X * X)
    If lResult >= 0 Then
        lResult = Sqr(lResult)
        If Abs(Y - r) < lResult Then IsInCircle = True
    End If
End Function

Public Function BlendColors(ByRef Color1 As Long, ByRef Color2 As Long, ByRef Percentage As Long) As Long
Dim r(2) As Long, g(2) As Long, b(2) As Long
    
    Percentage = SetBound(Percentage, 0, 100)
    
    GetRGB r(0), g(0), b(0), Color1
    GetRGB r(1), g(1), b(1), Color2
    
    r(2) = r(0) + (r(1) - r(0)) * Percentage \ 100
    g(2) = g(0) + (g(1) - g(0)) * Percentage \ 100
    b(2) = b(0) + (b(1) - b(0)) * Percentage \ 100
    
    BlendColors = RGB(r(2), g(2), b(2))
End Function

Private Function SetBound(ByRef Num As Long, ByRef MinNum As Long, ByRef MaxNum As Long) As Long
    If Num < MinNum Then
        SetBound = MinNum
    ElseIf Num > MaxNum Then
        SetBound = MaxNum
    Else
        SetBound = Num
    End If
End Function

Public Sub GetRGB(r As Long, g As Long, b As Long, Color As Long)
Dim TempValue As Long
    TranslateColor Color, 0, TempValue
    r = TempValue And &HFF&
    g = (TempValue And &HFF00&) \ &H100&
    b = (TempValue And &HFF0000) \ &H10000
End Sub

Private Function HiWord(lDWord As Long) As Integer
  HiWord = (lDWord And &HFFFF0000) \ &H10000
End Function

Private Function LoWord(lDWord As Long) As Integer
  If lDWord And &H8000& Then
    LoWord = lDWord Or &HFFFF0000
  Else
    LoWord = lDWord And &HFFFF&
  End If
End Function
'Read the properties from the property bag - also, a good place to start the subclassing (if we're running)
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
  Dim w As Long
  Dim h As Long
  Dim s As String
  
    With PropBag
        m_bEnabled = .ReadProperty("Enabled", True)
        Set UserControl.Font = .ReadProperty("Font", Ambient.Font)
        m_Caption = .ReadProperty("Caption", UserControl.Name)
        m_bCaptionHighLite = .ReadProperty("CaptionHighLite", False)
        m_lCaptionHighLiteColor = .ReadProperty("CaptionHighLiteColor", &HFF00&)
        m_bIconHighLite = .ReadProperty("IconHighLite", False)
        m_lIconHighLiteColor = .ReadProperty("IconHighLiteColor", &HFF00&)
        m_ForeColor = .ReadProperty("ForeColor", m_def_ForeColor)
        Set m_StdPicture = .ReadProperty("Picture", Nothing)
        m_PictureAlignment = .ReadProperty("PictureAlignment", m_def_PictureAlignment)
        m_Style = .ReadProperty("Style", 0)
        m_Checked = .ReadProperty("Checked", m_Checked)
        m_ColorButtonHover = .ReadProperty("ColorButtonHover", &HFFC090)
        m_ColorButtonUp = .ReadProperty("ColorButtonUp", &HE99950)
        m_ColorButtonDown = .ReadProperty("ColorButtonDown", &HE99950)
        m_ColorBright = .ReadProperty("ColorBright", &HFFEDB0)
        m_BorderBrightness = .ReadProperty("BorderBrightness", 0)
        m_DisplayHand = .ReadProperty("DisplayHand", False)
        m_ColorScheme = .ReadProperty("ColorScheme", 0)
    End With
    If m_DisplayHand Then UserControl.MousePointer = vbCustom Else UserControl.MousePointer = vbArrow
    UserControl.ForeColor = m_ForeColor
    
  If Ambient.UserMode Then                                                              'If we're not in design mode
    bTrack = True
    bTrackUser32 = IsFunctionExported("TrackMouseEvent", "User32")
  
    If Not bTrackUser32 Then
      If Not IsFunctionExported("_TrackMouseEvent", "Comctl32") Then
        bTrack = False
      End If
    End If
  
    If bTrack Then
      'OS supports mouse leave, so let's subclass for it
      With UserControl
        'Subclass the UserControl
        sc_Subclass .hWnd
        sc_AddMsg .hWnd, WM_PAINT, MSG_BEFORE
        sc_AddMsg .hWnd, WM_MOUSEMOVE
        sc_AddMsg .hWnd, WM_MOUSELEAVE
      End With
    End If
  End If
  m_InitCompleted = True
End Sub

'The control is terminating - a good place to stop the subclasser
Private Sub UserControl_Terminate()
  sc_Terminate                                                              'Terminate all subclassing
  If hButtonRegion Then DeleteObject hButtonRegion
End Sub

'Determine if the passed function is supported
Private Function IsFunctionExported(ByVal sFunction As String, ByVal sModule As String) As Boolean
  Dim hMod        As Long
  Dim bLibLoaded  As Boolean

  hMod = GetModuleHandleA(sModule)

  If hMod = 0 Then
    hMod = LoadLibraryA(sModule)
    If hMod Then
      bLibLoaded = True
    End If
  End If

  If hMod Then
    If GetProcAddress(hMod, sFunction) Then
      IsFunctionExported = True
    End If
  End If

  If bLibLoaded Then
    FreeLibrary hMod
  End If
End Function

'Track the mouse leaving the indicated window
Private Sub TrackMouseLeave(ByVal lng_hWnd As Long)
  Dim tme As TRACKMOUSEEVENT_STRUCT
  
  If bTrack Then
    With tme
      .cbSize = Len(tme)
      .dwFlags = TME_LEAVE
      .hwndTrack = lng_hWnd
    End With

    If bTrackUser32 Then
      TrackMouseEvent tme
    Else
      TrackMouseEventComCtl tme
    End If
  End If
End Sub

'-SelfSub code------------------------------------------------------------------------------------
Private Function sc_Subclass(ByVal lng_hWnd As Long, _
                    Optional ByVal lParamUser As Long = 0, _
                    Optional ByVal nOrdinal As Long = 1, _
                    Optional ByVal oCallback As Object = Nothing, _
                    Optional ByVal bIdeSafety As Boolean = True) As Boolean 'Subclass the specified window handle
'*************************************************************************************************
'* lng_hWnd   - Handle of the window to subclass
'* lParamUser - Optional, user-defined callback parameter
'* nOrdinal   - Optional, ordinal index of the callback procedure. 1 = last private method, 2 = second last private method, etc.
'* oCallback  - Optional, the object that will receive the callback. If undefined, callbacks are sent to this object's instance
'* bIdeSafety - Optional, enable/disable IDE safety measures. NB: you should really only disable IDE safety in a UserControl for design-time subclassing
'*************************************************************************************************
Const CODE_LEN      As Long = 260                                           'Thunk length in bytes
Const MEM_LEN       As Long = CODE_LEN + (8 * (MSG_ENTRIES + 1))            'Bytes to allocate per thunk, data + code + msg tables
Const PAGE_RWX      As Long = &H40&                                         'Allocate executable memory
Const MEM_COMMIT    As Long = &H1000&                                       'Commit allocated memory
Const MEM_RELEASE   As Long = &H8000&                                       'Release allocated memory flag
Const IDX_EBMODE    As Long = 3                                             'Thunk data index of the EbMode function address
Const IDX_CWP       As Long = 4                                             'Thunk data index of the CallWindowProc function address
Const IDX_SWL       As Long = 5                                             'Thunk data index of the SetWindowsLong function address
Const IDX_FREE      As Long = 6                                             'Thunk data index of the VirtualFree function address
Const IDX_BADPTR    As Long = 7                                             'Thunk data index of the IsBadCodePtr function address
Const IDX_OWNER     As Long = 8                                             'Thunk data index of the Owner object's vTable address
Const IDX_CALLBACK  As Long = 10                                            'Thunk data index of the callback method address
Const IDX_EBX       As Long = 16                                            'Thunk code patch index of the thunk data
Const SUB_NAME      As String = "sc_Subclass"                               'This routine's name
  Dim nAddr         As Long
  Dim nID           As Long
  Dim nMyID         As Long
  
  If IsWindow(lng_hWnd) = 0 Then                                            'Ensure the window handle is valid
    zError SUB_NAME, "Invalid window handle"
    Exit Function
  End If

  nMyID = GetCurrentProcessId                                               'Get this process's ID
  GetWindowThreadProcessId lng_hWnd, nID                                    'Get the process ID associated with the window handle
  If nID <> nMyID Then                                                      'Ensure that the window handle doesn't belong to another process
    zError SUB_NAME, "Window handle belongs to another process"
    Exit Function
  End If
  
  If oCallback Is Nothing Then                                              'If the user hasn't specified the callback owner
    Set oCallback = Me                                                      'Then it is me
  End If
  
  nAddr = zAddressOf(oCallback, nOrdinal)                                   'Get the address of the specified ordinal method
  If nAddr = 0 Then                                                         'Ensure that we've found the ordinal method
    zError SUB_NAME, "Callback method not found"
    Exit Function
  End If
    
  If z_Funk Is Nothing Then                                                 'If this is the first time through, do the one-time initialization
    Set z_Funk = New Collection                                             'Create the hWnd/thunk-address collection
    z_Sc(14) = &HD231C031: z_Sc(15) = &HBBE58960: z_Sc(17) = &H4339F631: z_Sc(18) = &H4A21750C: z_Sc(19) = &HE82C7B8B: z_Sc(20) = &H74&: z_Sc(21) = &H75147539: z_Sc(22) = &H21E80F: z_Sc(23) = &HD2310000: z_Sc(24) = &HE8307B8B: z_Sc(25) = &H60&: z_Sc(26) = &H10C261: z_Sc(27) = &H830C53FF: z_Sc(28) = &HD77401F8: z_Sc(29) = &H2874C085: z_Sc(30) = &H2E8&: z_Sc(31) = &HFFE9EB00: z_Sc(32) = &H75FF3075: z_Sc(33) = &H2875FF2C: z_Sc(34) = &HFF2475FF: z_Sc(35) = &H3FF2473: z_Sc(36) = &H891053FF: z_Sc(37) = &HBFF1C45: z_Sc(38) = &H73396775: z_Sc(39) = &H58627404
    z_Sc(40) = &H6A2473FF: z_Sc(41) = &H873FFFC: z_Sc(42) = &H891453FF: z_Sc(43) = &H7589285D: z_Sc(44) = &H3045C72C: z_Sc(45) = &H8000&: z_Sc(46) = &H8920458B: z_Sc(47) = &H4589145D: z_Sc(48) = &HC4836124: z_Sc(49) = &H1862FF04: z_Sc(50) = &H35E30F8B: z_Sc(51) = &HA78C985: z_Sc(52) = &H8B04C783: z_Sc(53) = &HAFF22845: z_Sc(54) = &H73FF2775: z_Sc(55) = &H1C53FF28: z_Sc(56) = &H438D1F75: z_Sc(57) = &H144D8D34: z_Sc(58) = &H1C458D50: z_Sc(59) = &HFF3075FF: z_Sc(60) = &H75FF2C75: z_Sc(61) = &H873FF28: z_Sc(62) = &HFF525150: z_Sc(63) = &H53FF2073: z_Sc(64) = &HC328&

    z_Sc(IDX_CWP) = zFnAddr("user32", "CallWindowProcA")                    'Store CallWindowProc function address in the thunk data
    z_Sc(IDX_SWL) = zFnAddr("user32", "SetWindowLongA")                     'Store the SetWindowLong function address in the thunk data
    z_Sc(IDX_FREE) = zFnAddr("kernel32", "VirtualFree")                     'Store the VirtualFree function address in the thunk data
    z_Sc(IDX_BADPTR) = zFnAddr("kernel32", "IsBadCodePtr")                  'Store the IsBadCodePtr function address in the thunk data
  End If
  
  z_ScMem = VirtualAlloc(0, MEM_LEN, MEM_COMMIT, PAGE_RWX)                  'Allocate executable memory

  If z_ScMem <> 0 Then                                                      'Ensure the allocation succeeded
    On Error GoTo CatchDoubleSub                                            'Catch double subclassing
      z_Funk.Add z_ScMem, "h" & lng_hWnd                                    'Add the hWnd/thunk-address to the collection
    On Error GoTo 0
  
    If bIdeSafety Then                                                      'If the user wants IDE protection
      z_Sc(IDX_EBMODE) = zFnAddr("vba6", "EbMode")                          'Store the EbMode function address in the thunk data
    End If
    
    z_Sc(IDX_EBX) = z_ScMem                                                 'Patch the thunk data address
    z_Sc(IDX_HWND) = lng_hWnd                                               'Store the window handle in the thunk data
    z_Sc(IDX_BTABLE) = z_ScMem + CODE_LEN                                   'Store the address of the before table in the thunk data
    z_Sc(IDX_ATABLE) = z_ScMem + CODE_LEN + ((MSG_ENTRIES + 1) * 4)         'Store the address of the after table in the thunk data
    z_Sc(IDX_OWNER) = ObjPtr(oCallback)                                     'Store the callback owner's object address in the thunk data
    z_Sc(IDX_CALLBACK) = nAddr                                              'Store the callback address in the thunk data
    z_Sc(IDX_PARM_USER) = lParamUser                                        'Store the lParamUser callback parameter in the thunk data
    
    nAddr = SetWindowLongA(lng_hWnd, GWL_WNDPROC, z_ScMem + WNDPROC_OFF)    'Set the new WndProc, return the address of the original WndProc
    If nAddr = 0 Then                                                       'Ensure the new WndProc was set correctly
      zError SUB_NAME, "SetWindowLong failed, error #" & Err.LastDllError
      GoTo ReleaseMemory
    End If
        
    z_Sc(IDX_WNDPROC) = nAddr                                               'Store the original WndProc address in the thunk data
    RtlMoveMemory z_ScMem, VarPtr(z_Sc(0)), CODE_LEN                        'Copy the thunk code/data to the allocated memory
    sc_Subclass = True                                                      'Indicate success
  Else
    zError SUB_NAME, "VirtualAlloc failed, error: " & Err.LastDllError
  End If
  
  Exit Function                                                             'Exit sc_Subclass

CatchDoubleSub:
  zError SUB_NAME, "Window handle is already subclassed"
  
ReleaseMemory:
  VirtualFree z_ScMem, 0, MEM_RELEASE                                       'sc_Subclass has failed after memory allocation, so release the memory
End Function

'Terminate all subclassing
Private Sub sc_Terminate()
  Dim i As Long

  If Not (z_Funk Is Nothing) Then                                           'Ensure that subclassing has been started
    With z_Funk
      For i = .Count To 1 Step -1                                           'Loop through the collection of window handles in reverse order
        z_ScMem = .Item(i)                                                  'Get the thunk address
        If IsBadCodePtr(z_ScMem) = 0 Then