VBA DYNAMIC DESIGNRANGE SLIDER CONTROL

Das Script präsentiert in Excel VBA Userform GUI ein Dynamisches Design Slider Steuerelement, welches zusätzlich die Abtastung an der aktuellen Mausposition verfeinert wenn dies nach unten gezogen wird [ Windows 7/8/10 x86 ]

The script presented in Excel VBA Userform GUI a dynamic design slider control, which addition refines the sampling at the current mouse position when it is pulled down [ Windows 7/8/10 x86 ]

LICENCE
FOR FREE
CODE LANGUAGE
VBA Visual Basic for Applications
CODE LINES
<326>

Die Kinder von heute werden niemals verstehen, wie aufregend es früher war, nach Hause zu kommen ;)

'// AREA RANGE SLIDER
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Option Explicit
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Declare Function GetActiveWindow Lib "user32" () As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal H_WINDOW As Long, ByVal lngWinIdx As Long, ByVal dwNewLong As Long) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal H_WINDOW As Long, ByVal lngWinIdx As Long) As Long
Private Declare 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 Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare 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 Function DrawMenuBar Lib "user32" (ByVal H_WINDOW As Long) As Long
Private Declare 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 Function ReleaseCapture Lib "user32" () As Long
Private Declare Function SetWindowRgn Lib "user32" (ByVal H_WINDOW As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
Private Declare Function ScreenToClient Lib "user32" (ByVal H_WINDOW As Long, lpPoint As POINTAPI) As Long
Private Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, ByVal wCmd As Long) As Long
Private Declare Function GetCursorPos Lib "user32" (p As tCursor) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal HDC As Long, ByVal nIndex As Long) As Long
Private Declare Function DwmSetWindowAttribute Lib "dwmapi" (ByVal hwnd As Long, ByVal attr As Integer, ByRef attrValue As Integer, ByVal attrSize As Integer) As Long
Private Declare Function DwmExtendFrameIntoClientArea Lib "dwmapi" (ByVal hwnd As Long, ByRef NEWMARGINS As MARGINS) As Long
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Type POINTAPI
    X As Long
    Y As Long
End Type
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Type tCursor
    LEFT As Long
    TOP As Long
End Type
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
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
    leftWidth As Long
    rightWidth As Long
    topHeight As Long
    bottomHeight As Long
End Type
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Const HTCAPTION = 2
Private XWNDFORM, XWNDFORMEX As Long
Private Const WM_NCLBUTTONDOWN = &HA1
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Const LOGPIXELSX = 88
Const LOGPIXELSY = 90
Dim SLIDE_POS As Long
Dim SLIDE_LOCK As Boolean
Dim M_SNG_LEFT_POS As Long
Dim M_SNG_TOP_POS As Long

'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
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 CMD_CLOSE_Click()

    Unload Me
    
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Sub SLIDER_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    
    SLIDER_FINE.Visible = False
    FINE_DIRECTION.Visible = False
    SLIDE_AREA.Visible = False
    FINE_LINE.Visible = False
    DYNAMIC_SLIDE_RANGE.Visible = False
    SLIDER.ForeColor = &HFFFFFF
    SLIDER_B.ForeColor = &HBD02CC
        
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

    'ISTYLE = ISTYLE Or WS_EX_LAYERED '//// ADD ONE COLOR TRANSPARENCE
    'ISTYLE = ISTYLE Or WS_EX_TRANSPARENT '//// ADD SEMI-TRANSPARENT WINDOW

    SetWindowLong HWNDFORM, GWL_EXSTYLE, ISTYLE

    'SetLayeredWindowAttributes HWNDFORM, vbCyan, btrans, LWA_ALPHA     '//// SEMI TRANSPARENT WINDOW
    'SetLayeredWindowAttributes HWNDFORM, vbCyan, btrans, LWA_COLORKEY  '//// COLOR SCREEN TRNSPARENCY

    XWNDFORM = FindWindow("ThunderDFrame", vbNullString) '//// GET NEW WINDOW

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

    With NEWMARGINS
        .rightWidth = 1   '//// -1
        .leftWidth = 1   '//// -1
        .topHeight = 1 '//// -1
        .bottomHeight = 1  '//// -1
    End With

    DwmExtendFrameIntoClientArea XWNDFORM, NEWMARGINS '//// DWMAPI
    
    DrawMenuBar HWNDFORM '//// CLEAN MENU BAR
    
    Me.Width = Me.Width - 5 '//// FRAMECUT BALANCE OFFSET
    Me.Height = Me.Height - 24 '//// FRAMECUT BALANCE OFFSET
    
    '//// BORDER LINES
    LINE_LEFT.LEFT = 1
    LINE_LEFT.TOP = 0
    LINE_LEFT.Width = 0.5
    LINE_LEFT.Height = Me.Height

    LINE_RIGHT.TOP = 0
    LINE_RIGHT.LEFT = Me.Width - 1.5
    LINE_RIGHT.Width = 0.5 '1.5
    LINE_RIGHT.Height = Me.Height

    LINE_BOTTOM.LEFT = 0
    LINE_BOTTOM.TOP = Me.Height - 1.5
    LINE_BOTTOM.Width = Me.Width
    LINE_BOTTOM.Height = 0.5

    LINE_TOP.TOP = 1
    LINE_TOP.LEFT = 0
    LINE_TOP.Width = Me.Width
    LINE_TOP.Height = 0.5
    
    '//// STARTUP
    SLIDE_AREA.Visible = False
    SLIDER_FINE.Visible = False
    FINE_DIRECTION.Visible = False
    FINE_LINE.Width = 1
    FINE_LINE.Visible = False
    RANGE_LABEL = L_MIN.Text
    DYNAMIC_SLIDE_RANGE.Visible = False
    
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Public Sub SLIDER_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    
    If Button = 1 Then
        
        M_SNG_LEFT_POS = X
        M_SNG_TOP_POS = Y
        
        SLIDER.ForeColor = &HBD02CC
        SLIDER_B.ForeColor = &HFFFFFF
    
    End If
    
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Public Sub SLIDER_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    
    Dim SNG_LEFT As Long, SNG_TOP As Long, SCROLL_RANGE As Long, SCROLL_POS As Long, SLIDEAERA As Long
    Dim F1 As Double, F2 As Double, P2 As Double, P3 As Double, P4 As Double, VALUE_MIN As Double, VALUE_MAX As Double, MULTI As Double, MULTIPLICATOR As Double
    Dim DECI As Integer
    
    If Button = 1 Then
    
        With SLIDER
        
            '//// LEFT AREA
            SNG_LEFT = (.LEFT + X) - M_SNG_LEFT_POS
                        
            If SNG_LEFT < SLIDE_AREA.LEFT Then SNG_LEFT = SLIDE_AREA.LEFT

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

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

                End If
                
            '//// HEIGHT AREA
            SNG_TOP = (.TOP + Y) - M_SNG_TOP_POS
            
            If SNG_TOP < SLIDE_AREA.TOP Then SNG_TOP = SLIDE_AREA.TOP

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

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

                End If

            .Move SNG_LEFT, SNG_TOP
            
        End With

        '//// SETTINGS
        VALUE_MIN = CDbl(L_MIN.Text)
        VALUE_MAX = CDbl(L_MAX.Text)
        DECI = 1
        MULTI = 1
        '//// SETTINGS
        
        SLIDER_FINE.Visible = True
        'DYNAMIC_SLIDE_RANGE.Visible = True
        
        SLIDER_B.LEFT = SLIDER.LEFT - 3
        SLIDER_FINE.LEFT = SLIDER.LEFT + ((SLIDER.Width - SLIDER_FINE.Width) / 2)
        
        FINE_DIRECTION.LEFT = SLIDER.LEFT
        FINE_DIRECTION.TOP = SLIDER.TOP + 22
        
        FINE_LINE.LEFT = Round(SLIDER.LEFT + ((SLIDER.Width) / 2) - 1)
        FINE_LINE.TOP = DYNAMIC_SLIDE_RANGE.TOP
        FINE_LINE.Height = SLIDER_FINE.TOP - SLIDER.TOP + 2
        
        '//// FINE SLIDER
        If (Y) > ((SLIDER.Height / 2)) Then
            SLIDER_FINE.TOP = Y + SLIDER.TOP - (SLIDER.Height / 2)
        Else
            SLIDER_FINE.TOP = SLIDER.TOP
        End If
        '//// FINE SLIDER
        
        '//// FINE SLIDER MULTIPLICATOR
        MULTIPLICATOR = ((Y - (SLIDER.Height / 2)) / MULTI)
            
        If MULTIPLICATOR > 10 Then
    
            FINE_DIRECTION.Visible = False
            FINE_LINE.Visible = True
        
            If SLIDE_LOCK = False Then
           
                SLIDE_POS = SLIDER.LEFT
                SLIDE_LOCK = True
                    
            End If
    
            P2 = Round(100 * ((SLIDE_POS - SLIDE_AREA.LEFT)) / (SLIDE_AREA.Width - SLIDER.Width)) 'SLIDER POS %
            
            DYNAMIC_SLIDE_RANGE.Width = Round(SLIDE_AREA.Width * MULTIPLICATOR) 'SET WIDTH
            
            P3 = Round((DYNAMIC_SLIDE_RANGE.Width - (SLIDE_AREA.Width)) * (P2) / 100)  'QUOTA % MORE THEN SLIDE_AREA.WIDTH
            
            DYNAMIC_SLIDE_RANGE.LEFT = Round(SLIDE_AREA.LEFT - P3)
            
            
        
                '//// SECOND VISUAL SLIDE LINE ONLY FOR NICE EFFECT
                DYNAMIC_SLIDE_RANGE_VISUAL.Width = Round(SLIDE_AREA.Width * MULTIPLICATOR / 50) 'SET WIDTH
                P4 = Round((DYNAMIC_SLIDE_RANGE_VISUAL.Width - (SLIDE_AREA.Width)) * (P2) / 100)
                DYNAMIC_SLIDE_RANGE_VISUAL.LEFT = Round(SLIDE_AREA.LEFT - P4)
                '//// SECOND VISUAL SLIDE LINE ONLY FOR NICE EFFECT
    
        Else
        
            FINE_DIRECTION.Visible = True
            FINE_LINE.Visible = False
            DYNAMIC_SLIDE_RANGE.Width = SLIDE_AREA.Width
            DYNAMIC_SLIDE_RANGE.LEFT = SLIDE_AREA.LEFT
            SLIDE_LOCK = False
            
        End If
        '//// FINE SLIDER MULTIPLICATOR
      
        '//// SLIDE CALC
        SLIDEAERA = DYNAMIC_SLIDE_RANGE.Width - SLIDER.Width
        F1 = (SLIDEAERA / (VALUE_MAX - VALUE_MIN)) 'OVERSAMPLING
        F2 = (((SLIDER.LEFT - DYNAMIC_SLIDE_RANGE.LEFT) / F1) + VALUE_MIN) 'CONVERSION
        '//// SLIDE CALC
        
        RANGE_LABEL = Round(F2, DECI) '//// PUBLISH VALUE
    
    End If
    
    CONSOLE.Text = ""
    CONSOLE.Text = CONSOLE.Text & "// CONSOLE" & vbCrLf
    CONSOLE.Text = CONSOLE.Text & Round(MULTIPLICATOR, 2) & " MULTIPLICATOR" & vbCrLf
    CONSOLE.Text = CONSOLE.Text & DYNAMIC_SLIDE_RANGE.Width & " DYNAMIC_SLIDE_RANGE.Width" & vbCrLf
    CONSOLE.Text = CONSOLE.Text & P2 & " % SLIDER POS" & vbCrLf
    CONSOLE.Text = CONSOLE.Text & P3 & " % QUOTA MORE" & vbCrLf
    CONSOLE.Text = CONSOLE.Text & DYNAMIC_SLIDE_RANGE.LEFT & " DYNAMIC_SLIDE_RANGE.LEFT" & vbCrLf
    CONSOLE.Text = CONSOLE.Text & Round(F1, 2) & " F1 OVERSAMPLING" & vbCrLf
    CONSOLE.Text = CONSOLE.Text & Round(F2, 6) & " F2 CONVERSION" & vbCrLf
    
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
'//// SCRIPT © REUTLINGER - WWW.PARIS-STUDIOS.DE ///////////////////////////////////////////////////////////////////////////////////////////////////////

Cookies make it easier for us to provide you with our services. With the usage of our services you permit us to use cookies.
More information Ok