MrIfOnly
Active Member
- Joined
- Nov 10, 2016
- Messages
- 493
This may not have the same cool factor as the worksheet display, but may be a bit more useful.
You may want to play with the colors:
To generate the display, create a blank userform with no code in its module and name it "Clock", then paste this into a standard module and run from there:
You can delete the above after running.
Now, paste this into a standard module:
You can now run the userform 'Clock' (you can also rename it whatever you want at this point) or call it from a commandbutton or another userform using vbModeless.
Please let me Know if you have questions/issues and also what application you find for this.
Regards,
CJ
You may want to play with the colors:
To generate the display, create a blank userform with no code in its module and name it "Clock", then paste this into a standard module and run from there:
Code:
Option Explicit
Dim NewCtrl As Control
Dim startX As Integer, startY As Integer, i As Integer, j As Integer
Dim WSNew As Worksheet
Dim Newlbl As Control, Newtxtbox As Control
Dim dgtCnt As String
Public InitialstartX As Integer, InitialstartY As Integer
Dim objForm As Object
Dim Line As Long
Sub SETUPUSERFORM()
Do 'input for number of digits
dgtCnt = InputBox("Enter number of digits to be generated.", Default:=3)
If dgtCnt = "" Then Exit Sub
Loop Until dgtCnt > 0 And dgtCnt < 8
InitialstartX = 165 + (60 * (CInt(dgtCnt) - 1))
InitialstartY = 12
Set objForm = ThisWorkbook.VBProject.VBComponents("Clock")
With objForm
With .CodeModule
Line = .CountOfLines + 1
.InsertLines Line, "Dim n As Integer"
.InsertLines Line + 1, "Sub Userform_Initialize()"
.InsertLines Line + 2, "With Me"
.InsertLines Line + 3, vbTab & ".Caption = ""Timer"""
.InsertLines Line + 4, vbTab & ".Width =" & InitialstartX + 56
.InsertLines Line + 5, vbTab & ".Height = 144"
.InsertLines Line + 6, vbTab & ".BackColor = &H80000012"
.InsertLines Line + 7, "End With"
.InsertLines Line + 8, "End Sub" & vbNewLine
.InsertLines Line + 10, "Sub StartBtn_Click()"
.InsertLines Line + 11, vbTab & "runTimer UF:=Me"
.InsertLines Line + 12, "End Sub" & vbNewLine
.InsertLines Line + 14, "Sub StopBtn_Click()"
.InsertLines Line + 15, vbTab & "stpTimer"
.InsertLines Line + 16, "End Sub" & vbNewLine
.InsertLines Line + 18, "Sub LEDOpt_Click()"
.InsertLines Line + 19, vbTab & "Me.BackColor = &H80000012"
.InsertLines Line + 20, vbTab & "For n = 1 To digitCnt 'number of digits"
.InsertLines Line + 21, vbTab & vbTab & "NumberON m:=0, n:=n, UF:=Me"
.InsertLines Line + 22, vbTab & "Next n"
.InsertLines Line + 23, "End Sub" & vbNewLine
.InsertLines Line + 25, "Sub LCDOpt_Click()"
.InsertLines Line + 26, vbTab & "Me.BackColor = &H404040"
.InsertLines Line + 27, vbTab & "For n = 1 To digitCnt 'number of digits"
.InsertLines Line + 28, vbTab & vbTab & "NumberON m:=0, n:=n, UF:=Me"
.InsertLines Line + 29, vbTab & "Next n"
.InsertLines Line + 30, "End Sub"
End With
'Hidden textbox to hold dgtCnt
Set NewCtrl = .Designer.Controls.Add("Forms.TEXTBOX.1", "COUNTHOLDER", False)
NewCtrl.Value = CInt(dgtCnt)
'Start Button
Set NewCtrl = .Designer.Controls.Add("Forms.COMMANDBUTTON.1", "StartBtn")
With NewCtrl
.Caption = "Start"
.BackColor = &HC0FFC0
.Font.Size = 18
.Left = 6
.Top = 6
.Width = 90
.Height = 30
.Accelerator = "S"
End With
'Stop Button
Set NewCtrl = .Designer.Controls.Add("Forms.COMMANDBUTTON.1")
With NewCtrl
.Name = "StopBtn"
.Caption = "Stop"
.BackColor = &H8080FF
.Font.Size = 18
.Left = 6
.Top = 48
.Width = 90
.Height = 30
End With
'LED Option
Set NewCtrl = .Designer.Controls.Add("Forms.OptionButton.1", "LEDOpt")
With NewCtrl
.Name = "LEDOpt"
.Caption = "LED"
.Font.Size = 12
.Left = 6
.Top = 90
.Value = True
.BackStyle = 0
.ForeColor = &H8000000E
End With
'LCD Option
Set NewCtrl = .Designer.Controls.Add("Forms.OptionButton.1")
With NewCtrl
.Name = "LCDOpt"
.Caption = "LCD"
.Font.Size = 12
.Left = 60
.Top = 90
.Value = False
.BackStyle = 0
.ForeColor = &H8000000E
End With
startX = InitialstartX
startY = InitialstartY
For i = 1 To CInt(dgtCnt) 'total number of digits
If i = 2 Then 'POINT
Set Newlbl = .Designer.Controls.Add("Forms.LABEL.1", "POINT")
With Newlbl
.BackColor = &HC0C0FF
.SpecialEffect = 0
.Left = startX + 41
.Top = startY + 85
.Height = 8
.Width = 8
End With
End If
If i = 4 Then 'Minutes Separator
Set Newlbl = .Designer.Controls.Add("Forms.LABEL.1", "TOPSEP1")
With Newlbl
.BackColor = &HC0C0FF
.SpecialEffect = 0
.Left = startX + 41
.Top = startY + 20
.Height = 8
.Width = 8
End With
Set Newlbl = .Designer.Controls.Add("Forms.LABEL.1", "BTMSEP1")
With Newlbl
.BackColor = &HC0C0FF
.SpecialEffect = 0
.Left = startX + 41
.Top = startY + 65
.Height = 8
.Width = 8
End With
End If
If i = 6 Then 'Hours Separator
Set Newlbl = .Designer.Controls.Add("Forms.LABEL.1", "TOPSEP2")
With Newlbl
.BackColor = &HC0C0FF
.SpecialEffect = 0
.Left = startX + 41
.Top = startY + 20
.Height = 8
.Width = 8
End With
Set Newlbl = .Designer.Controls.Add("Forms.LABEL.1", "BTMSEP2")
With Newlbl
.BackColor = &HC0C0FF
.SpecialEffect = 0
.Left = startX + 41
.Top = startY + 65
.Height = 8
.Width = 8
End With
End If
'TOP1
Set Newlbl = .Designer.Controls.Add("Forms.LABEL.1")
With Newlbl
.Name = "ELE_" & i & "_0"
.BackColor = &HC0C0FF
.SpecialEffect = 0
.Left = startX
.Top = startY
.Height = 10
.Width = 22
.BorderStyle = 1
.BorderColor = &HC0C0FF
End With
'MIDDLE1
startX = startX
startY = startY + 42
Set Newlbl = .Designer.Controls.Add("Forms.LABEL.1")
With Newlbl
.Name = "ELE_" & i & "_2"
.BackColor = &HC0C0FF
.SpecialEffect = 0
.Left = startX
.Top = startY
.Height = 10
.Width = 22
.BorderStyle = 1
.BorderColor = &HC0C0FF
End With
'BOTTOM1
startX = startX
startY = startY + 40
Set Newlbl = .Designer.Controls.Add("Forms.LABEL.1")
With Newlbl
.Name = "ELE_" & i & "_1"
.BackColor = &HC0C0FF
.SpecialEffect = 0
.Left = startX
.Top = startY
.Height = 10
.Width = 22
.BorderStyle = 1
.BorderColor = &HC0C0FF
End With
'LEFTTOP1
startX = startX - 13
startY = InitialstartY + 3.95
Set Newlbl = .Designer.Controls.Add("Forms.LABEL.1")
With Newlbl
.Name = "ELE_" & i & "_3"
.BackColor = &HC0C0FF
.SpecialEffect = 0
.Left = startX
.Top = startY
.Height = 40
.Width = 10
.BorderStyle = 1
.BorderColor = &HC0C0FF
End With
'LEFTBOTTOM1
startX = startX
startY = startY + 45
Set Newlbl = .Designer.Controls.Add("Forms.LABEL.1")
With Newlbl
.Name = "ELE_" & i & "_4"
.BackColor = &HC0C0FF
.SpecialEffect = 0
.Left = startX
.Top = startY
.Height = 40
.Width = 10
.BorderStyle = 1
.BorderColor = &HC0C0FF
End With
'RIGHTTOP1
startX = startX + 38
startY = InitialstartY + 3.95
Set Newlbl = .Designer.Controls.Add("Forms.LABEL.1")
With Newlbl
.Name = "ELE_" & i & "_5"
.BackColor = &HC0C0FF
.SpecialEffect = 0
.Left = startX
.Top = startY
.Height = 40
.Width = 10
.BorderStyle = 1
.BorderColor = &HC0C0FF
End With
'RIGHTBOTTOM1
startX = startX
startY = startY + 45
Set Newlbl = .Designer.Controls.Add("Forms.LABEL.1")
With Newlbl
.Name = "ELE_" & i & "_6"
.BackColor = &HC0C0FF
.SpecialEffect = 0
.Left = startX
.Top = startY
.Height = 40
.Width = 10
.BorderStyle = 1
.BorderColor = &HC0C0FF
End With
startX = startX - 93
startY = InitialstartY
Next i
End With
VBA.UserForms.Add(objForm.Name).Show vbModal
End SubYou can delete the above after running.
Now, paste this into a standard module:
Code:
Option Explicit
Dim Start
Dim msec As Integer, sec As Integer, sec2 As Integer, min As Integer, min2 As Integer
Dim hr As Integer, hr2 As Integer, n As Integer, x As Integer
Dim Number As Variant
Public onColor As String, offColor As String
Public stopTimer As Boolean
Public digitCnt As Integer
Public Sub runTimer(UF As UserForm)
UF.LEDOpt.Enabled = False
UF.LCDOpt.Enabled = False
If UF!LEDOpt.Value = True Then
offColor = &HC0C0FF
onColor = &HFF&
Else:
offColor = &H808080
onColor = &H0&
End If
digitCnt = UF!COUNTHOLDER.Value
stopTimer = False
sec = 0
sec2 = 0
min = 0
min2 = 0
hr = 0
hr2 = 0
If digitCnt > 1 Then PointON UF:=UF
If digitCnt > 3 Then SEP1ON UF:=UF
If digitCnt > 5 Then SEP2ON UF:=UF
For n = 1 To digitCnt 'number of digits
NumberON m:=0, n:=n, UF:=UF
Next n
Start = Timer 'Set start time.
Do While Timer < Start + 100
DoEvents ' Yield to other processes.
If stopTimer = True Then Exit Do
msec = ((Timer * 10) Mod (Start * 10))
If digitCnt > 1 And msec = 5 Then PointOFF UF:=UF
If msec = 10 Then '
If digitCnt > 1 Then ''
sec = sec + 1
PointON UF:=UF
If sec = 10 Then '
If digitCnt > 2 Then ''
sec2 = sec2 + 1
If sec2 = 6 Then '
If digitCnt > 3 Then ''
min = min + 1
If min = 10 Then '
If digitCnt > 4 Then ''
min2 = min2 + 1
If min2 = 6 Then '
If digitCnt > 5 Then ''
hr = hr + 1
If hr = 10 Then '
If digitCnt > 6 Then ''
hr2 = hr2 + 1
If hr2 = 2 And hr = 4 Then '
hr2 = 0
hr = 0
End If '
NumberON m:=hr2, n:=7, UF:=UF
End If ''
hr = 0
End If '
NumberON m:=hr, n:=6, UF:=UF
End If ''
min2 = 0
End If '
NumberON m:=min2, n:=5, UF:=UF
End If ''
min = 0
End If '
NumberON m:=min, n:=4, UF:=UF
End If ''
sec2 = 0
End If '
NumberON m:=sec2, n:=3, UF:=UF
End If ''
sec = 0
End If '
NumberON m:=sec, n:=2, UF:=UF
End If ''
Start = Timer
msec = 0
End If '
NumberON m:=msec, n:=1, UF:=UF
Loop
UF.LEDOpt.Enabled = True
UF.LCDOpt.Enabled = True
If digitCnt > 1 Then PointON UF:=UF
End Sub
Public Sub stpTimer()
stopTimer = True
End Sub
Public Sub PointOFF(UF As UserForm)
UF.Controls("POINT").BackColor = offColor
UF.Controls("POINT").BorderColor = offColor
End Sub
Public Sub PointON(UF As UserForm)
UF.Controls("POINT").BackColor = onColor
UF.Controls("POINT").BorderColor = onColor
End Sub
Public Sub SEP1ON(UF As UserForm) 'Minutes Separator
UF.Controls("TOPSEP1").BackColor = onColor
UF.Controls("TOPSEP1").BorderColor = onColor
UF.Controls("BTMSEP1").BackColor = onColor
UF.Controls("BTMSEP1").BorderColor = onColor
End Sub
Public Sub SEP2ON(UF As UserForm) 'Hour Separator
UF.Controls("TOPSEP2").BackColor = onColor
UF.Controls("TOPSEP2").BorderColor = onColor
UF.Controls("BTMSEP2").BackColor = onColor
UF.Controls("BTMSEP2").BorderColor = onColor
End Sub
Sub NumberON(m As Integer, n As Integer, UF As UserForm)
If UF!LEDOpt.Value = True Then
offColor = &HC0C0FF
onColor = &HFF&
Else:
offColor = &H808080
onColor = &H0&
End If
Select Case m
Case 1
Number = Array(0, 0, 0, 0, 0, 1, 1) 'RIGHTTOP & RIGHTBOTTOM
Case 2
Number = Array(1, 1, 1, 0, 1, 1, 0) 'TOP, BOTTOM, MIDDLE, LEFTBOTTOM & RIGHTTOP
Case 3
Number = Array(1, 1, 1, 0, 0, 1, 1) 'TOP, BOTTOM, MIDDLE, RIGHTTOP & RIGHTBOTTOM
Case 4
Number = Array(0, 0, 1, 1, 0, 1, 1) 'MIDDLE, LEFTTOP, RIGHTBOTTOM & RIGHTTOP
Case 5
Number = Array(1, 1, 1, 1, 0, 0, 1) 'TOP, BOTTOM, MIDDLE, LEFTTOP & RIGHTBOTTOM
Case 6
Number = Array(1, 1, 1, 1, 1, 0, 1) 'TOP, BOTTOM, MIDDLE, LEFTTOP, LEFTBOTTOM & RIGHTBOTTOM
Case 7
Number = Array(1, 0, 0, 0, 0, 1, 1) 'TOP, RIGHTTOP & RIGHTBOTTOM
Case 8
Number = Array(1, 1, 1, 1, 1, 1, 1) 'TOP, BOTTOM, MIDDLE, LEFTTOP, LEFTBOTTOM, RIGHTTOP & RIGHTBOTTOM
Case 9
Number = Array(1, 0, 1, 1, 0, 1, 1) 'TOP, MIDDLE, LEFTTOP, RIGHTTOP & RIGHTBOTTOM
Case 0
Number = Array(1, 1, 0, 1, 1, 1, 1) 'TOP, BOTTOM, LEFTTOP, LEFTBOTTOM, RIGHTTOP & RIGHTBOTTOM
End Select
For x = 0 To 6
If Number(x) = 1 Then
UF.Controls("ELE_" & n & "_" & x).BackColor = onColor
UF.Controls("ELE_" & n & "_" & x).BorderColor = offColor
Else:
UF.Controls("ELE_" & n & "_" & x).BackColor = offColor
UF.Controls("ELE_" & n & "_" & x).BorderColor = offColor
End If
Next x
End SubYou can now run the userform 'Clock' (you can also rename it whatever you want at this point) or call it from a commandbutton or another userform using vbModeless.
Please let me Know if you have questions/issues and also what application you find for this.
Regards,
CJ
Last edited:
