Custom Spin Button Based On Values Passed From Array

**Preeti Verma** · 05-21-2012, 11:51 AM

I wish to use CUSTOM buttons for my excel worksheet as below:

[< ] [TEXT ALTERING AS PER LEFT RIGHT CLICK] [>]

LeftCellButtonImage ButtonLinkedText RightCellButtonImage

by passing a variant array:

Dim arr As Variant
arr = Array("Txt1","Txt2","Txt3","Txt4","Txt5","Txt6","T xt7","Txt8","Txt9","Txt10","Txt11","Txt12")

It should work like:
InitialText = [Txt1]

FirstLeftClick LeftCellButtonImage arr(11) FirstRightClick LeftCellButtonImage arr(1)
SecondLeftClick LeftCellButtonImage arr(10) SecondRightClick LeftCellButtonImage arr(2)
ThirdLeftClick LeftCellButtonImage arr(9) ThirdRightClick LeftCellButtonImage arr(3)
FourthLeftClick LeftCellButtonImage arr(8) FourthRightClick LeftCellButtonImage arr(4)
-------------------------------------------------------------------------------------
TwelfthLeftClick LeftCellButtonImage arr(1) FirstRightClick LeftCellButtonImage arr(1)
-------------------------------------------------------------------------------------

In a circular manner.

**Excel Fox** · 05-21-2012, 09:42 PM

Code:

Option Explicit
Option Base 1
Private Enum LeftOrRight
    LeftMove = 0
    RightMove = 1
End Enum
Dim arr As Variant
Dim lngCurrentBound As Long
Sub CusSpin()

    If Not IsArray(arr) Then
        arr = Array("Txt1", "Txt2", "Txt3", "Txt4", "Txt5", "Txt6", "Txt7", "Txt8", "Txt9", "Txt10", "Txt11", "Txt12")
        lngCurrentBound = LBound(arr)
    End If
    If Application.Caller = "btnLeft" Then
        Cells(1, 2).Value = MoveValue(LeftMove)
    Else
        Cells(1, 2).Value = MoveValue(RightMove)
    End If
    
End Sub

Private Function MoveValue(lngLeftOrRight As LeftOrRight)

    If lngLeftOrRight Then
        lngCurrentBound = (lngCurrentBound) Mod UBound(arr) + 1
    Else
        lngCurrentBound = (lngCurrentBound - 1) Mod UBound(arr) + (UBound(arr) * Abs((lngCurrentBound - 1) = 0))
    End If
    
    MoveValue = arr(lngCurrentBound)
    
End Function

**Zack Barresse** · 05-21-2012, 10:02 PM

I had a similar set of code, two separate routines, perhaps a little longer though...

Code:

Option Explicit

Dim oBtnClk                     As Shape
Dim WS                          As Worksheet
Dim rCell                       As Range
Dim arr()                       As String
Dim iPos                        As Long

Const sArr                      As String = "Txt1, Txt2, Txt3, Txt4, Txt5, Txt6, Txt7, Txt8, Txt9, Txt10, Txt11, Txt12"
Const sTargetSheet              As String = "Sheet1"
Const sTargetCell               As String = "A1"

Sub Increase()
    Set oBtnClk = Nothing
    Set WS = Worksheets(sTargetSheet)
    Set rCell = WS.Range(sTargetCell)
    On Error Resume Next
    Set oBtnClk = WS.Shapes(Application.Caller)
    arr = Split(sArr, ", ")
    iPos = WorksheetFunction.Match(rCell.Value, arr(), 0)
    On Error GoTo 0
    If oBtnClk Is Nothing Then Exit Sub
    If iPos = 0 Then
        'not set yet
        rCell.Value = arr(LBound(arr))
        Exit Sub
    End If
    If iPos - 1 = UBound(arr) Then Exit Sub
    rCell.Value = arr(iPos)
End Sub

Sub Decrease()
    Set oBtnClk = Nothing
    Set WS = Worksheets(sTargetSheet)
    Set rCell = WS.Range(sTargetCell)
    On Error Resume Next
    Set oBtnClk = WS.Shapes(Application.Caller)
    arr = Split(sArr, ", ")
    iPos = WorksheetFunction.Match(rCell.Value, arr(), 0)
    On Error GoTo 0
    If oBtnClk Is Nothing Then Exit Sub
    If iPos = 0 Then
        'not set yet
        rCell.Value = arr(LBound(arr))
        Exit Sub
    End If
    If iPos - 1 = LBound(arr) Then Exit Sub
    rCell.Value = arr(iPos - 2)
End Sub

This would actually require two buttons. If you don't want to use buttons, and are good with using the worksheet cells, we can utilize click and right click events, but not right clicking on an object. We could perhaps utilize some API's to determine where the mouse clicked, and if it was over the top of a button, but I think it'd be a little more in-depth than workarounds such as these.

HTH

Regards,
Zack Barresse

**Excel Fox** · 05-21-2012, 10:14 PM

**Zack Barresse** · 05-21-2012, 10:17 PM

Thanks very much!

**Preeti Verma** · 05-22-2012, 09:44 AM

@ExcelFox
@Zack Barresse

Thanks for your concise solution & quick response.

I needed two custom shapes for my problem which actually involved Java Swing API simulation on Excel using VBA coding.

**Preeti Verma** · 05-22-2012, 04:03 PM

Originally Posted by Preeti Verma

@ExcelFox
@Zack Barresse

Thanks for your concise solution & quick response.

I needed two custom shapes for my problem which actually involved Java Swing API simulation on Excel using VBA coding.

Thanks again!

@Zack Barresse

I have modified your code a bit to make spin truly circular as under:

Option Explicit
Dim oBtnClk As Shape
Dim WS As Worksheet
Dim rCell As Range
Dim arr() As String
Dim iPos As Long
Const sArr As String = "Txt1, Txt2, Txt3, Txt4, Txt5, Txt6, Txt7, Txt8, Txt9, Txt10, Txt11, Txt12"
Const sTargetSheet As String = "Sheet1"
Const sTargetCell As String = "E4"

Sub Increase()
Set oBtnClk = Nothing
Set WS = Worksheets(sTargetSheet)
Set rCell = WS.Range(sTargetCell)
On Error Resume Next
Set oBtnClk = WS.Shapes(Application.Caller)
arr = Split(sArr, ", ")
iPos = WorksheetFunction.Match(rCell.Value, arr(), 0)
On Error GoTo 0
If oBtnClk Is Nothing Then Exit Sub
If iPos = 0 Then
rCell.Value = arr(LBound(arr))
Exit Sub
End If
'**************************
If iPos - 1 = UBound(arr) Then
iPos = LBound(arr)
End If
rCell.Value = arr(iPos)
'**************************
End Sub

Sub Decrease()
Set oBtnClk = Nothing
Set WS = Worksheets(sTargetSheet)
Set rCell = WS.Range(sTargetCell)
On Error Resume Next
Set oBtnClk = WS.Shapes(Application.Caller)
arr = Split(sArr, ", ")
iPos = WorksheetFunction.Match(rCell.Value, arr(), 0)
On Error GoTo 0
If oBtnClk Is Nothing Then Exit Sub
If iPos = 0 Then
'not set yet
rCell.Value = arr(LBound(arr))
Exit Sub
End If
'*****************************
If iPos - 1 = LBound(arr) Then
iPos = UBound(arr) + 2
End If
'*****************************
rCell.Value = arr(iPos - 2)
End Sub

Now, both code works identically.

Attaching modCustomSpinButton.xlsm file with both functioning!

**Excel Fox** · 05-22-2012, 07:23 PM

Your uploaded version had a slight miss in it. There is a conditional that looks for the name of the button 'btnLeft'. Since you missed to put the name in there for the shape (1st Method), it always moves the array value to the right. Here's the corrected version.