vivre-motion
Excel DropDown Searchable Menu for Windows

SKU: VM-70019
Regular price: € 0,00 EUR
Regular price: ~~€ 3,00 EUR~~
Sale price: € 0,00 EUR
Unit price: per
Tax included. Shipping calculated at checkout.
Product variants
Quantity
Excel Modern DropDown Context Menu

Searchable Selection Menu

The Interactive VBA Selection Menu replaces the standard DropZone with a modern interface.

The Modern Selection Menu also allows a real-time search with Asterisk Wildcards.
Interface Operation

Press Space for * Asterisk Wildcard
Press Arrow Down to select Item
Setup Input Source and Colors

Press ALT+F11, Open CONTEXT_MENU and Change the Input Data Value to yours. Adjust the Theme Colors inside the SELECT_MENU UserForm on Top.
VBA Source Code


'//////////////////////////////////////////////////////////////////////////////////////
Option Explicit
Private Const COLOR_HOVER_ITEM_FONT = &HFFFFFF
Private Const COLOR_HOVER_ITEM_BACK = &HEADE47
Private Const COLOR_DEFAULT_ITEM_FONT = &H412C2B
Private Const COLOR_SEARCH_FIELD_FONT = &H412C2B
Private Const COLOR_PLACEHOLDER_FONT = &H968372
Private Const COLOR_SMILEY_BACK = &H968372
Private Const COLOR_SLIDER_DEFAULT_BACK = &HEADE47
Private Const COLOR_SLIDER_HOVER_BACK = &HCAC0BF
Private Const COLOR_SLIDERAERA_HOVER_BACK = &HCAC0BF
Private Const COLOR_SLIDERAERA_DEFAULT_BACK = &HFAF5F2
Private Const COLOR_COUNTER_FONT = &H968372
Private Const COLOR_SLIDERAERA_PLACEHOLDER_BACK = &HFFFFFF
'//////////////////////////////////////////////////////////////////////////////////////
Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal H_WINDOW As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare PtrSafe Function ReleaseCapture Lib "user32" () As Long
Private Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nshowcmd As Long) As Long
Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal H_WINDOW As Long, ByVal lngWinIdx As Long, ByVal dwNewLong As Long) As Long
Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal H_WINDOW As Long, ByVal lngWinIdx As Long) As Long
Private Declare PtrSafe Function SetLayeredWindowAttributes Lib "user32" (ByVal H_WINDOW As Long, ByVal crKey As Integer, ByVal bAlpha As Integer, ByVal dwFlags As Long) As Long
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Private Declare PtrSafe Function DrawMenuBar Lib "user32" (ByVal H_WINDOW As Long) As Long
Private Declare PtrSafe Function GetWindow Lib "user32" (ByVal hWnd As Long, ByVal wCmd As Long) As Long
Private Declare PtrSafe Function DwmSetWindowAttribute Lib "dwmapi" (ByVal hWnd As Long, ByVal attr As Integer, ByRef attrValue As Integer, ByVal attrSize As Integer) As Long
Private Declare PtrSafe Function DwmExtendFrameIntoClientArea Lib "dwmapi" (ByVal hWnd As Long, ByRef NEWMARGINS As MARGINS) As Long
'//////////////////////////////////////////////////////////////////////////////////////
Private Const GWL_STYLE = (-16)
Private Const WS_CAPTION = &HC00000 '//// WS_BORDER Or WS_DLGFRAME
Private Const WS_BORDER = &H800000
Private Const GWL_EXSTYLE As Long = (-20) '//// OFFSET OF WINDOW EXTENDED STYLE
Private Const WS_EX_DLGMODALFRAME As Long = &H1 '//// CONTROLS IF WINDOW HAS AN ICON
Private Const SC_CLOSE As Long = &HF060
Private Const SW_SHOW As Long = 5
Private Const WS_EX_LAYERED = &H80000
Private Const LWA_COLORKEY = &H1
Private Const LWA_ALPHA = &H2
Private Const WS_EX_TRANSPARENT = &H20&
'//////////////////////////////////////////////////////////////////////////////////////
Private Enum ESetWindowPosStyles
    SWP_SHOWWINDOW = &H40
    SWP_HIDEWINDOW = &H80
    SWP_FRAMECHANGED = &H20 '//// FRAME CHANGED SEND WM_NCCALCSIZE
    SWP_NOACTIVATE = &H10
    SWP_NOCOPYBITS = &H100
    SWP_NOMOVE = &H2
    SWP_NOOWNERZORDER = &H200 '// DONT DO OWNER Z ORDERING
    SWP_NOREDRAW = &H8
    SWP_NOREPOSITION = SWP_NOOWNERZORDER
    SWP_NOSIZE = &H1
    SWP_NOZORDER = &H4
    SWP_DRAWFRAME = SWP_FRAMECHANGED
    HWND_NOTOPMOST = -2
End Enum
'//////////////////////////////////////////////////////////////////////////////////////
Private Type MARGINS
    LEFT As Long
    TOP As Long
    RIGHT As Long
    BOTTOM As Long
End Type
'//////////////////////////////////////////////////////////////////////////////////////
Private Const HTCAPTION = 2
Private XWNDFORM, XWNDFORMEX As Long
Private Const WM_NCLBUTTONDOWN = &HA1
'//////////////////////////////////////////////////////////////////////////////////////
Dim ENV_SLOTS As Long
Dim SLIDE_LEFT_POS As Long
Dim SLIDE_TOP_POS As Long
Dim SELECT_SLIDE_ARRAY
Dim SELECT_SLIDE_ARRAY_MAX As Long
Dim ARROW_SELECT As String
Dim I_SELECT As Integer
'//////////////////////////////////////////////////////////////////////////////////////
Private Sub UserForm_Activate()

    Me.ScrollTop = 700
    
    Call INIT_STAGE
    
    Me.ScrollTop = 0
    
End Sub
'//////////////////////////////////////////////////////////////////////////////////////
Private Sub INIT_STAGE()
'
'    Me.TOP = ActiveCell.TOP + Application.TOP
'    Me.LEFT = ActiveCell.LEFT + Application.LEFT
    
    SMILEY.Visible = False
    
    ENV_SLOTS = 6
    
    I_SELECT = 0
    
    Call RESET_STAGE
    
    SEARCH_FIELD.ForeColor = COLOR_SEARCH_FIELD_FONT
    SMILEY.ForeColor = COLOR_SMILEY_BACK
    SEARCH_FIELD_PLACEHOLDER.ForeColor = COLOR_PLACEHOLDER_FONT
    COUNTER.ForeColor = COLOR_COUNTER_FONT
    SLIDE_AREA_PLACEHOLDER.BackColor = COLOR_SLIDERAERA_PLACEHOLDER_BACK
    
    Dim I As Long
    
    For I = 1 To ENV_SLOTS

        Controls("HOVER_" & I).BorderStyle = fmBorderStyleNone

    Next I
    
    SEARCH_FIELD.Text = ""
    SEARCH_FIELD.SetFocus
    
    Call HYPER_SEARCH(SEARCH_FIELD.Text)
    
    Call REFRESH_SLIDE(0)
    
    SLIDER.TOP = SLIDE_AREA.TOP
    
    Call SLIDER_RESET(Me.SLIDE_AREA, Me.SLIDER)
        
End Sub
'//////////////////////////////////////////////////////////////////////////////////////
Private Sub UserForm_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    
    If Button = 1 Then
   
        ReleaseCapture
        SendMessage XWNDFORM, WM_NCLBUTTONDOWN, HTCAPTION, 0&

    End If
   
End Sub
'//////////////////////////////////////////////////////////////////////////////////////
Private Sub HOVERME(ByVal ITEM As Long)

    Controls("BACK_" & ITEM).BackColor = COLOR_HOVER_ITEM_BACK
    Controls("BACK_" & ITEM).Visible = True
    Controls("ITEM_" & ITEM).ForeColor = COLOR_HOVER_ITEM_FONT

End Sub

Private Sub UserForm_Initialize()

    Dim ISTYLE, HWNDFORM As Long
    Dim btrans As Byte
    btrans = 128
    Dim NEWMARGINS As MARGINS
    
    HWNDFORM = FindWindow(vbNullString, Me.Caption) '//// GET WINDOW

    ISTYLE = GetWindowLong(HWNDFORM, GWL_STYLE) '//// BASIC WINDOW STYLE FLAGS FOR THE FORM
    ISTYLE = ISTYLE And Not WS_CAPTION '//// NO CAPTION AREA
    SetWindowLong HWNDFORM, GWL_STYLE, ISTYLE '//// SET BASIC WINDOW STYLES

    ISTYLE = GetWindowLong(HWNDFORM, GWL_EXSTYLE) '//// BUILD EXTENDED WINDOW STYLE
    ISTYLE = ISTYLE And Not WS_EX_DLGMODALFRAME '//// NO BORDER

    SetWindowLong HWNDFORM, GWL_EXSTYLE, ISTYLE
    
    XWNDFORM = FindWindow("ThunderDFrame", vbNullString) '//// GET NEW WINDOW

    DwmSetWindowAttribute XWNDFORM, 2, 2, 4 '//// DWMAPI

    With NEWMARGINS
        .BOTTOM = 1 '//// -1
        .LEFT = 1  '//// -1
        .RIGHT = 1  '//// -1
        .TOP = 1  '//// -1
    End With

    DwmExtendFrameIntoClientArea XWNDFORM, NEWMARGINS '//// DWMAPI
    
    DrawMenuBar HWNDFORM '//// CLEAN MENU BAR

    Me.Width = Me.Width - 12
    Me.Height = Me.Height - 19
    
End Sub
'//////////////////////////////////////////////////////////////////////////////////////
Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)

    Call RESET_STAGE
    
End Sub
'//////////////////////////////////////////////////////////////////////////////////////
Private Sub SEARCH_FIELD_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)

    If KeyCode = 40 Then SELECT_DOWN
    
    If KeyCode = 38 Then SELECT_UP
        
    If KeyCode = 13 Then
    
        SELECT_NAME = ARROW_SELECT
        Unload Me
    
    End If
    
    If KeyCode = 27 Then

        SELECT_NAME = ""
        Unload Me
    
    End If
    
End Sub
'//////////////////////////////////////////////////////////////////////////////////////
Private Sub SELECT_DOWN()

    If Me.Controls("ITEM_" & 1).Visible = False Then Exit Sub
    
    If I_SELECT <> ENV_SLOTS Then
    
        I_SELECT = I_SELECT + 1
        
        Call RESET_STAGE
        
        If Me.Controls("ITEM_" & I_SELECT).Visible = False Then I_SELECT = I_SELECT - 1

        Call HOVERME(I_SELECT)
        ARROW_SELECT = Me.Controls("ITEM_" & I_SELECT).ControlTipText
    
    End If

End Sub
'//////////////////////////////////////////////////////////////////////////////////////
Private Sub SELECT_UP()

    If Me.Controls("ITEM_" & 1).Visible = False Then Exit Sub
    
    If I_SELECT >= 2 Then
    
        I_SELECT = I_SELECT - 1

        Call RESET_STAGE
        Call HOVERME(I_SELECT)
        ARROW_SELECT = Me.Controls("ITEM_" & I_SELECT).ControlTipText
    
    End If

End Sub
'//////////////////////////////////////////////////////////////////////////////////////
Private Sub SEARCH_FIELD_Change()

    SEARCH_FIELD.Text = Replace(SEARCH_FIELD.Text, " ", "*")
    
    If SEARCH_FIELD.Text = "" Then
        SEARCH_FIELD_PLACEHOLDER.Text = "Suche"
    Else
        SEARCH_FIELD_PLACEHOLDER.Text = ""
    End If
    
    Call HYPER_SEARCH(SEARCH_FIELD.Text)
    
    Call REFRESH_SLIDE(0)
    
    SLIDER.TOP = SLIDE_AREA.TOP
    
    Call RESET_STAGE

    ARROW_SELECT = ""
    
    I_SELECT = 0
    
End Sub
'//////////////////////////////////////////////////////////////////////////////////////
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
 
    If CloseMode = 0 Then SELECT_NAME = ""

End Sub
'//////////////////////////////////////////////////////////////////////////////////////
Private Sub RESET_STAGE()

    Dim I As Long
    
    Call SLIDER_RESET(Me.SLIDE_AREA, Me.SLIDER)
    
    For I = 1 To ENV_SLOTS

        Controls("BACK_" & I).Visible = False
        
        Controls("ITEM_" & I).ForeColor = COLOR_DEFAULT_ITEM_FONT

    Next I
    
End Sub
'//////////////////////////////////////////////////////////////////////////////////////
Private Sub HOVER_1_Click()
    
    SELECT_NAME = ITEM_1.ControlTipText
    Unload Me
    
End Sub
'//////////////////////////////////////////////////////////////////////////////////////
Private Sub HOVER_2_Click()
    
    SELECT_NAME = ITEM_2.ControlTipText
    Unload Me
    
End Sub
'//////////////////////////////////////////////////////////////////////////////////////
Private Sub HOVER_3_Click()
    
    SELECT_NAME = ITEM_3.ControlTipText
    Unload Me
    
End Sub
'//////////////////////////////////////////////////////////////////////////////////////
Private Sub HOVER_4_Click()
    
    SELECT_NAME = ITEM_4.ControlTipText
    Unload Me
    
End Sub
'//////////////////////////////////////////////////////////////////////////////////////
Private Sub HOVER_5_Click()
    
    SELECT_NAME = ITEM_5.ControlTipText
    Unload Me
    
End Sub
'//////////////////////////////////////////////////////////////////////////////////////
Private Sub HOVER_6_Click()
    
    SELECT_NAME = ITEM_6.ControlTipText
    Unload Me
    
End Sub
'//////////////////////////////////////////////////////////////////////////////////////
Private Sub HOVER_1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)

    Call RESET_STAGE
    Call HOVERME(1)
    
End Sub
'//////////////////////////////////////////////////////////////////////////////////////
Private Sub HOVER_2_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)

    Call RESET_STAGE
    Call HOVERME(2)
    
End Sub
'//////////////////////////////////////////////////////////////////////////////////////
Private Sub HOVER_3_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)

    Call RESET_STAGE
    Call HOVERME(3)
    
End Sub
'//////////////////////////////////////////////////////////////////////////////////////
Private Sub HOVER_4_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)

    Call RESET_STAGE
    Call HOVERME(4)
    
End Sub
'//////////////////////////////////////////////////////////////////////////////////////
Private Sub HOVER_5_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)

    Call RESET_STAGE
    Call HOVERME(5)
    
End Sub
'//////////////////////////////////////////////////////////////////////////////////////
Private Sub HOVER_6_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)

    Call RESET_STAGE
    Call HOVERME(6)
    
End Sub
'//////////////////////////////////////////////////////////////////////////////////////
Public Sub SLIDE_AREA_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    
    Call SLIDE_AREA_MOUSE_MOVE(Me.SLIDE_AREA, Me.SLIDER)

End Sub
'//////////////////////////////////////////////////////////////////////////////////////
Private Sub SLIDER_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
   
    Dim SCROLL_POS As Long
    
    SCROLL_POS = Round((((SELECT_SLIDE_ARRAY_MAX - ENV_SLOTS) * CONTROL_SLIDER(Me.SLIDER, Me.SLIDE_AREA, X, Y, Button)) / 100), 0)
    
    Call REFRESH_SLIDE(SCROLL_POS)
    
    Call SLIDER_MOUSE_MOVE(Me.SLIDE_AREA, Me.SLIDER)

End Sub
'//////////////////////////////////////////////////////////////////////////////////////
Private Sub SLIDE_AREA_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
        
    Dim SCROLL_POS As Long
    
    SCROLL_POS = Round((((SELECT_SLIDE_ARRAY_MAX - ENV_SLOTS) * CONTROL_SLIDE_AREA(Me.SLIDER, Me.SLIDE_AREA, X, Y)) / 100), 0)
    
    Call REFRESH_SLIDE(SCROLL_POS)
    
End Sub
'//////////////////////////////////////////////////////////////////////////////////////
Private Sub SLIDER_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    
    If Button = 1 Then SLIDE_LEFT_POS = X
    If Button = 1 Then SLIDE_TOP_POS = Y

End Sub
'//////////////////////////////////////////////////////////////////////////////////////
Private Sub REFRESH_SLIDE(ByVal SCROLL_POS As Long)

    Dim I As Long

    Me.COUNTER.Caption = SELECT_SLIDE_ARRAY_MAX
    
    If SELECT_SLIDE_ARRAY_MAX = 0 Then
        SMILEY.Visible = True
    Else
        SMILEY.Visible = False
    End If
    
    For I = 1 To ENV_SLOTS 'MAX_ITEMS
    
        If I <= SELECT_SLIDE_ARRAY_MAX Then

            If SELECT_SLIDE_ARRAY(SCROLL_POS + I, 1) <> "" Then

                Controls("HOVER_" & I).Visible = True
                Controls("ITEM_" & I).Caption = SELECT_SLIDE_ARRAY(SCROLL_POS + I, 1)
                Controls("ITEM_" & I).ControlTipText = SELECT_SLIDE_ARRAY(SCROLL_POS + I, 1)
                Controls("ITEM_" & I).Visible = True
                
            Else
    
                'Controls("SLOT_" & I).Visible = True
                Controls("HOVER_" & I).Visible = False
                Controls("ITEM_" & I).Visible = False
                
            End If
            
        Else

            Controls("HOVER_" & I).Visible = False
            Controls("ITEM_" & I).Visible = False
                
        End If

    Next I

    If SELECT_SLIDE_ARRAY_MAX < ENV_SLOTS Then

        SLIDER.Visible = False
        SLIDE_AREA.Visible = False

    Else

        SLIDER.Visible = True
        SLIDE_AREA.Visible = True

    End If

End Sub
'//////////////////////////////////////////////////////////////////////////////////////
Private Function CONTROL_SLIDER(ByRef SLIDER As Object, ByRef SLIDE_AREA As Object, ByVal X As Single, ByVal Y As Single, ByVal BUTTON_HOLD As Integer) As Long

    'On Error Resume Next

    Dim SNG_LEFT As Single
    Dim SNG_TOP As Single
    Dim SCROLL_POS As Single
    Dim SCROLL_RANGE As Single

    If BUTTON_HOLD = 1 Then

            '//// LEFT AREA
            SNG_LEFT = (SLIDER.LEFT + X) - SLIDE_LEFT_POS

            If SNG_LEFT < SLIDE_AREA.LEFT Then SNG_LEFT = SLIDE_AREA.LEFT

                If (SNG_LEFT + SLIDER.Width) > (SLIDE_AREA.LEFT + SLIDE_AREA.Width) Then

                    SNG_LEFT = SLIDE_AREA.LEFT + SLIDE_AREA.Width - SLIDER.Width

                End If

            '//// HEIGHT AREA
            SNG_TOP = (SLIDER.TOP + Y) - SLIDE_TOP_POS

            If SNG_TOP < SLIDE_AREA.TOP Then SNG_TOP = SLIDE_AREA.TOP

                If (SNG_TOP + SLIDER.Height) > (SLIDE_AREA.TOP + SLIDE_AREA.Height) Then

                    SNG_TOP = SLIDE_AREA.TOP + SLIDE_AREA.Height - SLIDER.Height

                End If

            SLIDER.Move SNG_LEFT, SNG_TOP

    End If

    '//// SLIDE RANGE
    SCROLL_POS = Round(SLIDER.TOP - SLIDE_AREA.TOP, 0)
    SCROLL_RANGE = SLIDE_AREA.Height - SLIDER.Height
    CONTROL_SLIDER = Round(((100 * SCROLL_POS) / SCROLL_RANGE), 0) 'PERCENT

End Function
'//////////////////////////////////////////////////////////////////////////////////////
Private Function CONTROL_SLIDE_AREA(ByRef SLIDER As Object, ByRef SLIDE_AREA As Object, ByVal X As Single, ByVal Y As Single) As Long

    'On Error Resume Next

    Dim SNG_LEFT As Single
    Dim SNG_TOP As Single
    Dim SCROLL_POS As Single
    Dim SCROLL_RANGE As Single
    Dim SET_POS As Long

    SET_POS = Y - SLIDER.Height + SLIDE_AREA.TOP

    If SET_POS < SLIDE_AREA.TOP Then

        SLIDER.TOP = SLIDE_AREA.TOP

    Else

        SLIDER.TOP = SET_POS

    End If

    If ((SLIDE_AREA.TOP + SLIDE_AREA.Height) - (SLIDER.TOP + SLIDER.Height)) < 30 Then

        SLIDER.TOP = (SLIDE_AREA.TOP + SLIDE_AREA.Height) - SLIDER.Height

    End If

    '//// SLIDE RANGE
    SCROLL_POS = Round(SLIDER.TOP - SLIDE_AREA.TOP, 0)
    SCROLL_RANGE = SLIDE_AREA.Height - SLIDER.Height
    CONTROL_SLIDE_AREA = Round(((100 * SCROLL_POS) / SCROLL_RANGE), 0) 'PERCENT

End Function
'//////////////////////////////////////////////////////////////////////////////////////
Private Sub SLIDE_AREA_MOUSE_MOVE(ByVal SLIDE_AREA_ITEM As Object, ByVal SLIDER_ITEM As Object)

    SLIDE_AREA_ITEM.BackColor = COLOR_SLIDERAERA_HOVER_BACK
    SLIDER_ITEM.BackColor = COLOR_SLIDER_DEFAULT_BACK

End Sub
'//////////////////////////////////////////////////////////////////////////////////////
Private Sub SLIDER_MOUSE_MOVE(ByVal SLIDE_AREA_ITEM As Object, ByVal SLIDER_ITEM As Object)

    SLIDE_AREA_ITEM.BackColor = COLOR_SLIDERAERA_DEFAULT_BACK
    SLIDER_ITEM.BackColor = COLOR_SLIDER_HOVER_BACK

End Sub
'//////////////////////////////////////////////////////////////////////////////////////
Private Sub SLIDER_RESET(ByVal SLIDE_AREA_ITEM As Object, ByVal SLIDER_ITEM As Object)

    SLIDE_AREA_ITEM.BackColor = COLOR_SLIDERAERA_DEFAULT_BACK
    SLIDER_ITEM.BackColor = COLOR_SLIDER_DEFAULT_BACK
    
End Sub
'//////////////////////////////////////////////////////////////////////////////////////
Private Sub HYPER_SEARCH(ByVal SEARCHTEXT As String)

    Dim I As Long
    Dim S As Long
    Dim R As Long
    Dim X As Long
    Dim FUSION_STRING As String
    Dim HYPER_SEARCH(99) As String
    Dim HYPER_SEARCH_MAX As Long
    Dim SPLIT_CACHE
    Dim CONVERSION_CHECK As Boolean
    
    Erase HYPER_SEARCH
    CONVERSION_CHECK = False
    
    '//// CREATE HYPERSEARCH ARRAY
    If InStr(SEARCHTEXT, "*") <> 0 Then
        
        SPLIT_CACHE = Split(SEARCHTEXT, "*")
        
        For R = 0 To UBound(SPLIT_CACHE)
        
            HYPER_SEARCH(R + 1) = SPLIT_CACHE(R)
            HYPER_SEARCH_MAX = R + 1
        
        Next R

    Else
    
        HYPER_SEARCH(1) = SEARCHTEXT
        HYPER_SEARCH_MAX = 1
    
    End If
    '//// CREATE HYPERSEARCH ARRAY
    
    S = 0
    
    If UBound(SELECT_ARRAY) < 6 Then
    
        ReDim SELECT_SLIDE_ARRAY(6, 1)
    
    Else
        
        ReDim SELECT_SLIDE_ARRAY(UBound(SELECT_ARRAY), 1)
        
    End If
    
    
    For I = 1 To UBound(SELECT_ARRAY)

        If SELECT_ARRAY(I, 1) <> "" Then
        
            FUSION_STRING = ""
            FUSION_STRING = FUSION_STRING & SELECT_ARRAY(I, 1) & "|"
        
            For R = 1 To HYPER_SEARCH_MAX
            
                If InStr(LCase(FUSION_STRING), LCase(HYPER_SEARCH(R))) <> 0 Then
                
                    CONVERSION_CHECK = True
                    
                Else
                
                    CONVERSION_CHECK = False
                    Exit For

                End If
                
            Next R
            
            If CONVERSION_CHECK = True Then
                
                S = S + 1
                
                For X = 1 To UBound(SELECT_ARRAY, 2)
                    
                    SELECT_SLIDE_ARRAY(S, X) = SELECT_ARRAY(I, X)
                
                Next X
                
            End If
        
        End If

    Next I
    
    SELECT_SLIDE_ARRAY_MAX = S

End Sub
Item added to your cart
