Results 1 to 8 of 8

Thread: Custom Spin Button Based On Values Passed From Array

Hybrid View

Previous Post Previous Post   Next Post Next Post
  1. #1
    Junior Member Preeti Verma's Avatar
    Join Date
    May 2012
    Posts
    5
    Rep Power
    0

    Question Custom Spin Button Based On Values Passed From Array

    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.

  2. #2
    Administrator Excel Fox's Avatar
    Join Date
    Mar 2011
    Posts
    1,402
    Rep Power
    10

    Spin Button Based On Values Passed From Array

    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
    Attached Files Attached Files
    A dream is not something you see when you are asleep, but something you strive for when you are awake.

    It's usually a bad idea to say that something can't be done.

    The difference between dream and aim, is that one requires soundless sleep to see and the other requires sleepless efforts to achieve

    Join us at Facebook

  3. #3
    Junior Member
    Join Date
    May 2012
    Posts
    4
    Rep Power
    0
    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

  4. #4
    Administrator Excel Fox's Avatar
    Join Date
    Mar 2011
    Posts
    1,402
    Rep Power
    10
    Welcome to ExcelFox Zack. Nice to have someone of your expertise with us.

    And nice alternative too. Mine also requires two buttons (shapes) Zack.


    https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA
    https://www.youtube.com/watch?v=QjEWAJ3d-jw
    https://www.youtube.com/watch?v=QjEWAJ3d-jw&lc=UgwCGCesYkcmCcv7tzx4AaABAg
    https://www.youtube.com/watch?v=QjEWAJ3d-jw&lc=UgwCGCesYkcmCcv7tzx4AaABAg.9wbCfWMaaLa9wbLcU jbPCV 3
    https://www.youtube.com/watch?v=QjEWAJ3d-jw&lc=UgwCGCesYkcmCcv7tzx4AaABAg.9wbCfWMaaLa9wbLma sNyaX 1
    https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA
    https://www.youtube.com/watch?v=QjEWAJ3d-jw&lc=UgzxkJD1jksXet8AZYB4AaABAg.9p3jaxCq0AG9wbF__ jtm9w 2
    https://www.youtube.com/watch?v=QjEWAJ3d-jw&lc=UgxePNoJ9lMOZZIxSI54AaABAg.9n_K6OLzSGt9wbFsa Pa2ym 1
    https://www.youtube.com/watch?v=QjEWAJ3d-jw&lc=UgwUIM7LhCvJkBpHL4N4AaABAg.9j-vSfzAHrw9wbFzCwVRUo 1
    https://www.youtube.com/watch?v=QjEWAJ3d-jw&lc=UgwQ_hGXSa1PNKbT-r94AaABAg.9hmiz-Qc-bq9wbG1qa8wKO 1
    https://www.youtube.com/watch?v=QjEWAJ3d-jw&lc=UgwqWxGrYGjtUAJG6aF4AaABAg.9hI9sgAhykQ9wbG4K JfN91 1
    https://www.youtube.com/watch?v=QjEWAJ3d-jw&lc=UgxJL5BeSLbJ-m7BWW54AaABAg.9euWbYmFb169wbG8eMb5Wb 1
    https://www.youtube.com/watch?v=QjEWAJ3d-jw&lc=UgwaEHwTeazYGD7xHmN4AaABAg.9eWJC0jtPrJ9wbGCR m3IO6 1
    https://www.youtube.com/watch?v=QjEWAJ3d-jw&lc=UgySibJeWUXeEn3qez14AaABAg.9dj9CcZAzcq9wbGH5 FhlqO
    https://www.youtube.com/watch?v=QjEWAJ3d-jw&lc=UgyrMrxE5-AP81sgU8V4AaABAg.9aoKBx9yaE89wbGOGcNnKy 1
    https://www.youtube.com/watch?v=QjEWAJ3d-jw&lc=Ugw5b6kCEckEbGTccxp4AaABAg.9_Sbwexq-co9wbGW8LbhKp 1
    https://www.youtube.com/watch?v=QjEWAJ3d-jw&lc=UgyCQp_ShaVxQui5hJh4AaABAg.9ZBRfgBVmcd9wbGdP 0tnCi 2
    https://www.youtube.com/watch?v=QjEWAJ3d-jw&lc=Ugz_lKW2DNBax4Aemst4AaABAg.9Xjhb-fv4pt9wbGgysEibx
    https://www.youtube.com/watch?v=QjEWAJ3d-jw&lc=UgxguKtw3d8jE8bkGTB4AaABAg.9UuGKC386629wbGl3 2wvjC 1
    https://www.youtube.com/watch?v=QjEWAJ3d-jw&lc=UgwLt2hK6AcHVnVlaUl4AaABAg.9HKd-ioHqxM9wbH2o6HYsJ 1
    https://www.youtube.com/watch?v=QjEWAJ3d-jw&lc=Ugw-IPT7RwxyRo4cbqd4AaABAg.9GqtD5j30Wp9wbH6q7RTJa 1
    https://www.youtube.com/watch?v=QjEWAJ3d-jw&lc=UgzLnQG1_LQtmvLQoot4AaABAg.9FvawuMTb-k9wbHFrsug5Z 1
    https://www.youtube.com/watch?v=QjEWAJ3d-jw&lc=Ugys6Ur7BNsRFbH_f_B4AaABAg.9DhZy5EEpKY9wbHfy JkVMG 3
    https://www.youtube.com/watch?v=QjEWAJ3d-jw&lc=UgxJLVpwY8fIla7G-pN4AaABAg.9BLeCWVhxdG9wbILDvziWr 2
    https://www.youtube.com/watch?v=QjEWAJ3d-jw&lc=UgwgzeOLschepoIO3gx4AaABAg.97v7ND4_6p298-gyUz3MY7 2
    https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA
    Last edited by DocAElstein; 11-02-2023 at 05:21 PM.
    A dream is not something you see when you are asleep, but something you strive for when you are awake.

    It's usually a bad idea to say that something can't be done.

    The difference between dream and aim, is that one requires soundless sleep to see and the other requires sleepless efforts to achieve

    Join us at Facebook

  5. #5
    Junior Member
    Join Date
    May 2012
    Posts
    4
    Rep Power
    0
    Thanks very much!




    https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA
    https://www.youtube.com/watch?v=oVb1RfcSHLM&lc=UgwTq-jZlZLnLQ5VB8Z4AaABAg.9Hroz-OyWog9tYjSMc1qjA
    https://www.youtube.com/watch?v=0pbsf6sox34&lc=Ugxp9JFvvejnqA68W1t4AaABAg
    https://www.youtube.com/watch?v=kfQC-sQxMcw&lc=UgyCxQWypNIhG2nUn794AaABAg.9q1p6q7ah839t UQl_92mvg
    https://www.youtube.com/watch?v=vXyMScSbhk4&lc=UgyOh-eR43LvlIJLG5p4AaABAg.9isnKJoRfbL9itPC-4uckb
    https://www.youtube.com/watch?v=vXyMScSbhk4&lc=Ugy1B1aQnHq2WbbucmR4AaABAg. 9isY3Ezhx4j9itQLuif26T
    https://www.youtube.com/watch?v=vXyMScSbhk4&lc=UgxxajSt03TX1wxh3IJ4AaABAg. 9irSL7x4Moh9itTRqL7dQh
    https://www.youtube.com/watch?v=vXyMScSbhk4&lc=Ugxa2VYHMWJWXA6QI294AaABAg. 9irLgSdeU3r9itU7zdnWHw
    https://www.youtube.com/watch?v=vXyMScSbhk4&lc=UgwJAAPbp8dhkW2X1Uh4AaABAg. 9iraombnLDb9itV80HDpXc
    https://www.youtube.com/watch?v=vXyMScSbhk4&lc=UgzIzQ6MQ5kTpuLbIuB4AaABAg. 9is0FSoF2Wi9itWKEvGSSq
    https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=UgykemWTw-fGoPwu8E14AaABAg.9iECYNx-n4U9iK75iCEaGN
    https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=UgykemWTw-fGoPwu8E14AaABAg.9iECYNx-n4U9iK7XF33njy
    https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=Ugy_1xkcndYdzUapw-J4AaABAg.9iGOq_leF_E9iKCSgpAqA1
    https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=Ugy_1xkcndYdzUapw-J4AaABAg.9iGOq_leF_E9iKCy--3x8E
    https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=UgwNaJiNATXshvJ0Zz94AaABAg. 9iEktVkTAHk9iF9_pdshr6
    https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=UgykemWTw-fGoPwu8E14AaABAg.9iECYNx-n4U9iFAZq-JEZ-
    https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=UgxV2r7KQnuAyZVLHH54AaABAg. 9iDVgy6wzct9iFBxma9zXI
    https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=Ugx12mI-a39T41NaZ8F4AaABAg.9iDQqIP56NV9iFD0AkeeJG
    https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=UgwnYuSngiuYaUhEMWN4AaABAg. 9iDQN7TORHv9iFGQQ5z_3f
    https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=UgwJ3yzdk_EE98dndmt4AaABAg. 9iDLC2uEPRW9iFGvgk11nH
    https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=UgyDWAVqCa4yMot463x4AaABAg. 9iH3wvUZj3n9iHnpOxOeXa
    https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=UgwvLFdMEAba5rLHIz94AaABAg. 9iGReNGzP4v9iHoeaCpTG8
    https://www.youtube.com/watch?v=ITI1HaFeq_g&lc=Ugy_1xkcndYdzUapw-J4AaABAg.9iGOq_leF_E9iHpsWCdJ5I
    https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA
    Last edited by DocAElstein; 09-13-2023 at 10:28 AM.

  6. #6
    Junior Member Preeti Verma's Avatar
    Join Date
    May 2012
    Posts
    5
    Rep Power
    0
    @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.
    Last edited by Preeti Verma; 05-22-2012 at 04:05 PM. Reason: Added functionality to alternative II.

  7. #7
    Junior Member Preeti Verma's Avatar
    Join Date
    May 2012
    Posts
    5
    Rep Power
    0

    CustomSpinControlVBA

    Quote Originally Posted by Preeti Verma View Post
    @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!
    Attached Files Attached Files
    PreetiVerma@xlfox

  8. #8
    Administrator Excel Fox's Avatar
    Join Date
    Mar 2011
    Posts
    1,402
    Rep Power
    10
    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.
    Attached Files Attached Files
    A dream is not something you see when you are asleep, but something you strive for when you are awake.

    It's usually a bad idea to say that something can't be done.

    The difference between dream and aim, is that one requires soundless sleep to see and the other requires sleepless efforts to achieve

    Join us at Facebook

Similar Threads

  1. Replies: 14
    Last Post: 01-26-2013, 04:58 AM
  2. Replies: 1
    Last Post: 12-04-2012, 08:56 AM
  3. counting consecutive values in an array
    By 5ko in forum Excel Help
    Replies: 3
    Last Post: 12-04-2012, 03:49 AM
  4. Formula to Display Month and Dates Using Spin Button
    By ayazgreat in forum Excel Help
    Replies: 6
    Last Post: 11-21-2012, 10:19 PM
  5. Subtraction Of Series Of Cells' / Array Values
    By PcMax in forum Excel Help
    Replies: 6
    Last Post: 10-26-2012, 11:55 PM

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •