Menu com Slider no VBA

Private Declare PtrSafe Function LoadCursor Lib "user32" Alias "LoadCursorA" (ByVal hInstance As Long, ByVal lpCursorName As Any) As Long
Private Declare PtrSafe Function SetCursor Lib "user32" (ByVal hCursor As Long) As Long

'ColorDestaq

Const ColorDestaq = 16730978

Public WithEvents mForm             As MSForms.UserForm
Public WithEvents mPage             As MSForms.MultiPage

Public WithEvents TabLabel          As MSForms.Label
Public WithEvents TabIcon           As MSForms.Label
Public WithEvents ActiveTab         As MSForms.Label
Public WithEvents TabLine           As MSForms.Label

Public LabelTop                    As Integer
Public LabelLeft                   As Long
Public LineLeft                     As Integer

Const IDC_HAND As Long = 32649

Sub MouseMoveIcon()
    Dim hCursor As Long
    hCursor = LoadCursor(0, ByVal IDC_HAND)
    SetCursor hCursor
End Sub
Sub CreateTabMenu(form As MSForms.UserForm, muPage As MSForms.MultiPage)
    Dim Ctrl                As Control
    Dim mPageName           As String
    Dim tempCol             As New Collection
    Dim IconCode            As String
    
    Set mForm = form
    Set mPage = muPage
    
    i = 1
    '//Önce labellar kontrol edilir ve sýrasýna gore collactiona eklenir
    '//First, the labels are checked and added to the collection in order.
    
head:
    For Each Ctrl In mForm.Controls
        TagValue = GetValue(Ctrl, 0)
        mPageName = GetValue(Ctrl, 1)
        If TagValue = "TabMenu" And mPageName = mPage.Name Then
            
            If CInt(GetValue(Ctrl, 2)) = i Then
                tempCol.Add Ctrl
                i = i + 1
                
                GoTo head:
            End If
        End If
    Next
    
    '//Form yüksekliðinden tabmenu eleman sayýsý ve aralarýndaki
    '//boþluk kadar çýkarýp ikiye bölerek yukarýdan ve aþaðýdan eþit boþluk býrakýyoruz
    
    '//Number of tabmenu elements from form height and between them
    '//We remove as much as the space and divide it into two, leaving equal space from above and below.
    LabelTop = (mForm.InsideHeight - ((tempCol.Count + tempCol.Count) * 20)) / 2
    
    Index = 1
    
    '//Yukarýda tempcol isimli Koleksiyona eklemiþ olduðumuz elemanlarýn dizaynýný yapýyoruz
    '//We are designing the elements we have added to the Collection named tempcol above.
    For i = 1 To tempCol.Count
        
        Set Ctrl = tempCol(i)
        LabelDesign Ctrl
        LineLeft = Ctrl.Left + Ctrl.Width + 15
        
        If GetValue(Ctrl, 2) = 1 Then
            '//Eðer ctrl ilk Tablabel ise activeTab oluþturulur
            '//If ctrl is the first Tablabel, activeTab is created
            
            Set ActiveTab = mForm.Controls.Add("Forms.Label.1", "ActiveTab")
            With ActiveTab
                .Height = 40
                .Width = 4
                .BackColor = ColorDestaq
                .BackStyle = fmBackStyleOpaque
                .Top = LabelTop - 10
                .Left = LineLeft - 1
            End With
            
            '//Ayný þekilde birinci elemana göre yan taraftaki çizgi ayarlanýr
            '//In the same way, the line on the side is adjusted according to the first element.
            Set TabLine = mForm.Controls.Add("Forms.Label.1", "TabLine")
            With TabLine
                .BackColor = RGB(212, 212, 212)
                .Width = 1.4
                .Left = LineLeft
                .BackStyle = fmBackStyleOpaque
                .ZOrder 1
            End With
            Ctrl.ForeColor = ColorDestaq
            Ctrl.Font.Name = "Poppins"
            Ctrl.Font.Bold = True
            
            LabelLeft = Ctrl.Left
        Else
            
        End If
        Ctrl.Left = LabelLeft
        
        IconCode = tempCol(i).ControlTipText
        '//Kontrolün ControlTiptex'i dolu ise icon oluþturulur
        '//if the ControlTiptex of the control is full, the icon is created
        If IconCode <> "" Then
            Set TabIcon = mForm.Controls.Add("Forms.Label.1", "TabIcon" & tempCol(i))
            With TabIcon
                .Font.Name = "Segoe MDL2 Assets"
                .Font.size = 14
                .ForeColor = RGB(51, 51, 51)
                .BackStyle = fmBackStyleTransparent
                .Caption = ChrW("&H" & tempCol(i).ControlTipText)
                .Left = Ctrl.Left - 35
                .Top = LabelTop
                .ZOrder 1
            End With
        End If
        
        LabelTop = LabelTop + Ctrl.Height + 20
        
        Set tb = New clsTabMenu
        Set tb.TabLabel = Ctrl
        Set tb.ActiveTab = ActiveTab
        Set tb.mForm = mForm
        Set tb.mPage = mPage
        tbCol.Add tb
        
        '                    Set TabLabel = Nothing
    Next
    
    With TabLine
        .Height = LabelTop + 20
        .Top = (mForm.InsideHeight - .Height) / 2
    End With
    
    '//Multipage stil ayarlarý yaparak her sayfaya transition effect ayarlýyoruz
    '//We set the transition effect on each page by making multipage style settings
    With mPage
        .Style = fmTabStyleNone
        .Top = 0
        .Value = 0
        .Left = TabLine.Left + 8
        
        For i = 0 To .Pages.Count - 1
            With .Pages(i)
                .TransitionEffect = 7        '2 '3
                .TransitionPeriod = 300
            End With
        Next i
        
    End With
    
End Sub
Sub LabelDesign(Ctrl As MSForms.Label)
    With Ctrl
        .Font.Name = "Poppins"
        .Font.Bold = True
        .Font.size = 11
        .ForeColor = vbGrayText
        .Top = LabelTop
        .Width = 110
        .Height = 20
        .Left = .Left + 25
        .Caption = WorksheetFunction.Proper(.Caption)
        .BackStyle = fmBackStyleTransparent
        '        .BorderStyle = fmBorderStyleSingle
        .TextAlign = fmTextAlignLeft
        
    End With
End Sub
Function GetValue(Ctrl As Control, cIndex As Integer)
    On Error Resume Next
    GetValue = Split(Ctrl.Tag, "-")(cIndex)
End Function

Private Sub TabLabel_Click()
    Dim mPageName As String
    Dim iTag As Integer
    Dim speed As Integer
    
    On Error GoTo err:
    
    '//Label'ýn sýrasý alýnýr
    '//Label's order is taken
    iTag = GetValue(TabLabel, 2) - 1
    
    '//Hangi multipage için çalýþacaðý alýnýr
    mPageName = GetValue(TabLabel, 1)
    
    '//Once tum TabLabellar standart hale getirilir
    '//For which multipage it will work
    TabLabelOut TabLabel
    
    '//aktif olan label iþaretlenir
    '//the active label is marked
    With TabLabel
        .ForeColor = ColorDestaq
        .Font.Name = "Poppins"
        .Font.Bold = True
    End With
    
    If TabLabel = "Logout" Then Unload mForm
    
    '//Multipage'in þu anki deðeri ile atanacak deðeri arasýndaki fark alýnýr ve hýz ayarlanýr
    '//The difference between the current value of Multipage and the value to be assigned is taken and the speed is adjusted
    speed = Abs(iTag - mForm.Controls(mPageName).Value)
    
    With ActiveTab
        Do While .Top < TabLabel.Top - 10
            DoEvents
            .Top = .Top + (0.05 * speed)
        Loop
        
        Do While .Top > TabLabel.Top - 10
            DoEvents
            .Top = .Top - (0.05 * speed)
        Loop
    End With
    '//Multipage value atanýr
    '//Multipage value is assigned
    mForm.Controls(mPageName).Value = iTag
    
err:
    If err.Number = 380 Then
        MsgBox "You need To add a New page"
    End If
End Sub
Sub TabLabelOut(Ctrl As MSForms.Label)
    Dim mPageName As String
    
    '//Formdaki diðer labellarý etkilememesi için sadece MultiPage ismi alýnýr
    '//Only MultiPage name is taken so that it does not affect other labels in the form.
    mPageName = GetValue(Ctrl, 1)
    
    Dim ctr As Control
    For Each ctr In mForm.Controls
        
        If TypeName(Ctrl) = "Label" Then
            '//eðer tag'i Multipage name içerirse, standart hale getirilir
            '//if tag contains Multipage name, it is standardized
            If InStr(1, ctr.Tag, mPageName) <> 0 Then
                ctr.ForeColor = vbGrayText
                ctr.Font.Name = "Poppins"
                ctr.Font.Bold = True
            End If
        End If
    Next
    
End Sub

Private Sub TabLabel_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    MouseMoveIcon
End Sub