VBA.EXCEL STATUS CIRCULARSHAPE PERCENT DISPLAY

Das Script präsentiert in Excel VBA Userform GUI ein parametrisches Statusdisplay / Prozentanzeige in Kreisform like@ Apple Watch [ Windows 7/8/10 x86 ]

The script presented in Excel VBA Userform GUI a parametric Status Display / Display percent in circular shape like @ Apple Watch [Windows x86 7/8/10]

API
VBA
CODE LANGUAGE
VBA Visual Basic for Applications
CODE LINES
<448>

Stay Hungry, Stay Foolish -Steve Jobs Apple
'//// STATUS CIRCULAR DISPLAY
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
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 Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Dim POL As Single, X As Single, Y As Single
Dim I As Long
Const Pi = 3.1415926
Public X_OFFSET As Long
Public Y_OFFSET As Long
Public DIAMETER As Long
Public SLIDE_SIZE As Long
Private M_COL_LABEL As COL_C_LABEL
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
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
    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
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Public ENV_POS As Long
Public NEW_POS As Long
Public M_SNG_LEFT_POS, M_SNG_TOP_POS As Long
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Const LOGPIXELSX = 88
Const LOGPIXELSY = 90
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
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
        .BOTTOM = 1 '//// -1
        .LEFT = 1  '//// -1
        .RIGHT = 1  '//// -1
        .TOP = 1  '//// -1
    End With

    DwmExtendFrameIntoClientArea XWNDFORM, NEWMARGINS '//// DWMAPI
    
    DrawMenuBar HWNDFORM '//// CLEAN MENU BAR
    
    '//// 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
    
    Call START_SETTINGS
    Call DRAW_SLIDEWAY

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 CMD_CLOSE_Click()
    
    Unload Me
    
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Public Sub START_SETTINGS()

    DIAMETER = 50
    SLIDE_SIZE = 12
    X_OFFSET = 150
    Y_OFFSET = 150
 
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Sub CommandButton1_Click()

    Call DRAW_STATUS(TextBox1.Text, TextBox2.Text, TextBox3.Text)
    
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Sub CommandButton2_Click()

    Call DRAW_SLIDEWAY

End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Public Sub DRAW_STATUS(ByVal SLIDE_A As Long, SLIDE_B As Long, SLIDE_C As Long)

    Dim STATUS_A As Long
    Dim STATUS_B As Long
    Dim STATUS_C As Long
    
    STATUS_A = Round(((360 * SLIDE_A) / 100), 0)
    STATUS_B = Round(((360 * SLIDE_B) / 100), 0)
    STATUS_C = Round(((360 * SLIDE_C) / 100), 0)

    S1.Caption = SLIDE_A & " %"
    S2.Caption = SLIDE_B & " %"
    S3.Caption = SLIDE_C & " %"
    
    For I = 0 To 360

        If I < STATUS_A Then Me.Controls("POINT_A" & I).Visible = True
        If I > STATUS_A Then Me.Controls("POINT_A" & I).Visible = False
        'DoEvents
        If I < STATUS_B Then Me.Controls("POINT_B" & I).Visible = True
        If I > STATUS_B Then Me.Controls("POINT_B" & I).Visible = False
        'DoEvents
        If I < STATUS_C Then Me.Controls("POINT_C" & I).Visible = True
        If I > STATUS_C Then Me.Controls("POINT_C" & I).Visible = False
        'DoEvents

    Next I

End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Public Sub DRAW_SLIDEWAY()

    Dim OBJ_LABEL  As MSForms.Label

    Dim sngPosTop As Single
    Dim I As Integer

    Set M_COL_LABEL = New COL_C_LABEL
    Set M_COL_LABEL.Form = Me
   
    Dim OBJ As MSForms.Label
   
    For I = 0 To 360
    
        POL = (135 - I) * Pi / 180
        X = Round(DIAMETER * Cos(POL) + X_OFFSET, 2)
        Y = Round(DIAMETER * Sin(POL) + Y_OFFSET, 2)
               
            Set OBJ_LABEL = Me.Controls.Add("Forms.Label.1", "SLIDE_A" & I, True)
            
            OBJ_LABEL.Move X, Y, SLIDE_SIZE * 2, SLIDE_SIZE * 2
            OBJ_LABEL.Font.Name = "Webdings"
            OBJ_LABEL.Caption = "n"
            OBJ_LABEL.BackStyle = fmBackStyleTransparent
            OBJ_LABEL.ForeColor = &HFCF1E2
            OBJ_LABEL.Font.Size = SLIDE_SIZE
            M_COL_LABEL.Add OBJ_LABEL
            Set OBJ_LABEL = Nothing
            
        POL = (180 - I) * Pi / 180
        X = Round((DIAMETER - 15) * Cos(POL) + X_OFFSET, 2)
        Y = Round((DIAMETER - 15) * Sin(POL) + Y_OFFSET, 2)

            Set OBJ_LABEL = Me.Controls.Add("Forms.Label.1", "SLIDE_B" & I, True)

            OBJ_LABEL.Move X, Y, SLIDE_SIZE * 2, SLIDE_SIZE * 2
            OBJ_LABEL.Font.Name = "Webdings"
            OBJ_LABEL.Caption = "n"
            OBJ_LABEL.BackStyle = fmBackStyleTransparent
            OBJ_LABEL.ForeColor = &HDAFEF5
            OBJ_LABEL.Font.Size = SLIDE_SIZE
            M_COL_LABEL.Add OBJ_LABEL
            Set OBJ_LABEL = Nothing

        POL = (180 - I) * Pi / 180
        X = Round((DIAMETER - 30) * Cos(POL) + X_OFFSET, 2)
        Y = Round((DIAMETER - 30) * Sin(POL) + Y_OFFSET, 2)

            Set OBJ_LABEL = Me.Controls.Add("Forms.Label.1", "SLIDE_C" & I, True)

            OBJ_LABEL.Move X, Y, SLIDE_SIZE * 2, SLIDE_SIZE * 2
            OBJ_LABEL.Font.Name = "Webdings"
            OBJ_LABEL.Caption = "n"
            OBJ_LABEL.BackStyle = fmBackStyleTransparent
            OBJ_LABEL.ForeColor = &HFEE0FC
            OBJ_LABEL.Font.Size = SLIDE_SIZE
            M_COL_LABEL.Add OBJ_LABEL
            Set OBJ_LABEL = Nothing

    Next I

    
    For I = 0 To 360

        POL = (I - 90) * Pi / 180
        X = Round(DIAMETER * Cos(POL) + X_OFFSET, 2)
        Y = Round(DIAMETER * Sin(POL) + Y_OFFSET, 2)

            Set OBJ_LABEL = Me.Controls.Add("Forms.Label.1", "POINT_A" & I, True)

            OBJ_LABEL.Move X, Y, SLIDE_SIZE * 2, SLIDE_SIZE * 2
            OBJ_LABEL.Font.Name = "Webdings"
            OBJ_LABEL.Caption = "n"
            OBJ_LABEL.BackStyle = fmBackStyleTransparent
            OBJ_LABEL.ForeColor = &HEBAA49
            OBJ_LABEL.Font.Size = SLIDE_SIZE
            OBJ_LABEL.Visible = False
            M_COL_LABEL.Add OBJ_LABEL
            Set OBJ_LABEL = Nothing

    Next I

    For I = 0 To 360

        POL = (I - 90) * Pi / 180
        X = Round((DIAMETER - 15) * Cos(POL) + X_OFFSET, 2)
        Y = Round((DIAMETER - 15) * Sin(POL) + Y_OFFSET, 2)

            Set OBJ_LABEL = Me.Controls.Add("Forms.Label.1", "POINT_B" & I, True)

            OBJ_LABEL.Move X, Y, SLIDE_SIZE * 2, SLIDE_SIZE * 2
            OBJ_LABEL.Font.Name = "Webdings"
            OBJ_LABEL.Caption = "n"
            OBJ_LABEL.BackStyle = fmBackStyleTransparent
            OBJ_LABEL.ForeColor = &HD7B7&       '&HB09784
            OBJ_LABEL.Font.Size = SLIDE_SIZE
            OBJ_LABEL.Visible = False
            M_COL_LABEL.Add OBJ_LABEL
            Set OBJ_LABEL = Nothing
            
            
    Next I

    For I = 0 To 360

        POL = (I - 90) * Pi / 180
        X = Round((DIAMETER - 30) * Cos(POL) + X_OFFSET, 2)
        Y = Round((DIAMETER - 30) * Sin(POL) + Y_OFFSET, 2)

            Set OBJ_LABEL = Me.Controls.Add("Forms.Label.1", "POINT_C" & I, True)

            OBJ_LABEL.Move X, Y, SLIDE_SIZE * 2, SLIDE_SIZE * 2
            OBJ_LABEL.Font.Name = "Webdings"
            OBJ_LABEL.Caption = "n"
            OBJ_LABEL.BackStyle = fmBackStyleTransparent
            OBJ_LABEL.ForeColor = &HC000C0          '&HB09784
            OBJ_LABEL.Font.Size = SLIDE_SIZE
            OBJ_LABEL.Visible = False
            M_COL_LABEL.Add OBJ_LABEL
            Set OBJ_LABEL = Nothing
            
    Next I

    Set OBJ = Nothing
    
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Sub Slider1_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As stdole.OLE_XPOS_PIXELS, ByVal Y As stdole.OLE_YPOS_PIXELS)

    Call DRAW_STATUS(Slider1.Value, Slider2.Value, Slider3.Value)
    
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Sub Slider2_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As stdole.OLE_XPOS_PIXELS, ByVal Y As stdole.OLE_YPOS_PIXELS)

    Call DRAW_STATUS(Slider1.Value, Slider2.Value, Slider3.Value)
    
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Sub Slider3_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As stdole.OLE_XPOS_PIXELS, ByVal Y As stdole.OLE_YPOS_PIXELS)

    Call DRAW_STATUS(Slider1.Value, Slider2.Value, Slider3.Value)
    
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Sub Slider1_Scroll()

    S1.Caption = Slider1.Value & " %"
    
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Sub Slider2_Scroll()

    S2.Caption = Slider2.Value & " %"
    
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Sub Slider3_Scroll()

    S3.Caption = Slider3.Value & " %"
    
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Sub LINK_URL_Click()
    
    Dim internet
    Set internet = CreateObject("InternetExplorer.Application")
    
    internet.Visible = True
    
    internet.Navigate ("http://www.paris-studios.de")
    
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
'//// SCRIPT © WWW.PARIS-STUDIOS.DE ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////


'//// CLASS CLASS CLASS CLASS CLASS CLASS CLASS CLASS CLASS CLASS CLASS CLASS CLASS CLASS CLASS CLASS CLASS CLASS CLASS CLASS CLASS CLASS CLASS CLASS
CLASS:C_LABEL

Option Explicit
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private WithEvents MV_LABEL As MSForms.Label
Private M_OBJ_FORM As Object
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Sub Class_Initialize()

End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Sub Class_Terminate()

    Set MV_LABEL = Nothing
    Set M_OBJ_FORM = Nothing
 
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Public Property Set Form(ByRef objForm As Object)

    Set M_OBJ_FORM = objForm
 
End Property
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Public Property Set Label(ByRef OBJ_LABEL As MSForms.Label)

    Set MV_LABEL = OBJ_LABEL

End Property
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
'//// SCRIPT © WWW.PARIS-STUDIOS.DE ////////////////////////////////////////////////////////////////////////////////////////////////////////////////////


'//// CLASS CLASS CLASS CLASS CLASS CLASS CLASS CLASS CLASS CLASS CLASS CLASS CLASS CLASS CLASS CLASS CLASS CLASS CLASS CLASS CLASS CLASS CLASS CLASS
CLASS:COL_C_LABEL

Option Explicit
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private M_COL_LABEL As Collection
Private M_OBJ_FORM As Object
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Sub Class_Initialize()

    Set M_COL_LABEL = New Collection
 
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Private Sub Class_Terminate()

    Set M_COL_LABEL = Nothing
    Set M_OBJ_FORM = Nothing
 
End Sub
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Public Property Set Form(ByRef objForm As Object)

    Set M_OBJ_FORM = objForm
 
End Property
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Public Function Add(ByRef OBJ_LABEL As MSForms.Label) As C_LABEL

  Dim OBJ_C_LABEL As C_LABEL

  Set OBJ_C_LABEL = New C_LABEL

  With OBJ_C_LABEL
    Set .Form = M_OBJ_FORM
    Set .Label = OBJ_LABEL
  End With

  M_COL_LABEL.Add OBJ_C_LABEL, OBJ_LABEL.Name

  Set Add = OBJ_C_LABEL
  Set OBJ_C_LABEL = Nothing

End Function
'///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
'//// SCRIPT © 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