My goal is to increase the font size of a textbox in Excel using VBA. While that's easy, what makes this problem a bit more interesting is that I need a smooth transition from font size x to font size y--an animation.
I am currently using the following code:
Option Explicit
Sub AnimateHit()
Dim i As Integer
For i = 1 To 25
ActiveSheet.Shapes.Range(Array("textEnemyHit")).Select
Selection.ShapeRange.TextFrame2.TextRange.Font.Size = i * 10
'Waits for 50ms
Call DelayMs(550)
Application.ScreenUpdating = True
Next
End Sub
'Code from http://stackoverflow.com/questions/18602979/how-to-give-a-time-delay-of-less-than-one-second-in-excel-vba
Private Sub DelayMs(ms As Long)
Debug.Print TimeValue(Now)
Application.Wait (Now + (ms * 0.00000001))
Debug.Print TimeValue(Now)
End Sub
This code works if the delay is 600ms or more. However, under 600ms, the code does not work. There is a jump from the minimum font size to the maximum without a smooth transition.
Any ideas on how I can achieve a smooth transition at a faster frame rate?
Thanks!
I had your very same problem testing your macro
So I changed into this and it worked
Private Declare Function GetTickCount Lib "kernel32" () As Long
Option Explicit
Sub AnimateHit()
Dim i As Integer
ActiveSheet.Shapes.Range(Array("textEnemyHit")).Select
For i = 1 To 25
Selection.ShapeRange.TextFrame2.TextRange.Font.Size = i * 10
WasteTime (50)
Next
End Sub
Sub WasteTime(Finish As Long)
' from http://www.myonlinetraininghub.com/pausing-or-delaying-vba-using-wait-sleep-or-a-loop
Dim NowTick As Long
Dim EndTick As Long
EndTick = GetTickCount + Finish
Do
NowTick = GetTickCount
DoEvents
Loop Until NowTick >= EndTick
End Sub
Probably the problem is in your hardware. I have tried it like this and it works awesome - it animates really smooth.
Sub AnimateHit()
Dim i As Integer
For i = 1 To 25
[set_fehler_tab2].Font.Size = i * 10
Call DelayMs(50)
Application.ScreenUpdating = True
Next
End Sub
Private Sub DelayMs(ms As Long)
Debug.Print TimeValue(Now)
Application.Wait (Now + (ms * 0.00000001))
Debug.Print TimeValue(Now)
End Sub
I am with i7, Windows7, Office 2010.
Related
I am working on a VBA Module for an interactive PowerPoint. Specifically, I would like a text box to display the current time and update every second (like a live clock) using VBA. I have created and implemented the clock just fine except the clock does not exit its loop when the presentation ends and will continue to update the text box while editing the PowerPoint outside of the presentation mode. I have tried using the sub App_SlideShowEnd(ByVal Pres As Presentation) ( https://learn.microsoft.com/en-us/office/vba/api/powerpoint.application.slideshowend), sub App_SlideShowNextSlide(ByVal Wn As SlideShowWindow) (https://learn.microsoft.com/en-us/office/vba/api/powerpoint.application.slideshownextslide), and even an add-in called AutoEvents (usage shown here http://www.mvps.org/skp/autoevents.htm#Use) to catch the end of the slide show, but to no avail.
So my question to you is: Is there a way to check if the current PowerPoint is actively presenting? If so, I could use it to check if the PowerPoint is presenting instead of checking my boolean variable clockstate that allows the clock to count or not. Here is the implementation of just the clock sub:
Sub clock()
Do Until clockstate = False
MsgBox ActivePresentation.SlideShowWindow.View
Injury.TextFrame.TextRange.text = (Date - entryA) & ":" & Mid(CStr(Time()), 1, Len(Time()) - 3)
Defect.TextFrame.TextRange.text = (Date - entryB) & ":" & Mid(CStr(Time()), 1, Len(Time()) - 3)
Call Wait(1)
Loop
End Sub
Sub Wait(sec As Integer)
Dim temp_time As Variant
temp_time = Timer
Do While Timer < temp_time + sec
DoEvents 'this allows for events to continue while waiting for sec seconds
Loop
End Sub
Here is the implementation of just the App_SlideShowEnd event:
Sub App_SlideShowEnd(ByVal Pres As Presentation)
clockstate = False
End Sub
And here is all of my code all together if you want to see it in one piece:
Option Explicit
Dim indexA As Integer 'this variable contains the slide that Injury_Time is found on for use in the auto next slide event
Dim indexB As Integer 'this varaible contains the slide that Defect_Time is found on for use in the auto next slide event
Dim clockstate As Boolean 'this varaible dictates wether or not the clock is on and counting to save memory/processing resources.
Dim Injury As Shape 'this variable is used to reference the textbox that gets changed by the macro
Dim Defect As Shape 'this varaible is used to reference the other textbox that gets changed by the macro
Dim entryA As Date 'this holds the contents of the first entrybox on the config form so the form can be unloaded without losing the entries
Dim entryB As Date 'this holds the contents of the second entrybox on the config form so the form can be unloaded without losing the entries
Dim daysA As String 'this holds the number of days since last injury for auto-setting the textboxes in the config form
Dim daysB As String 'this holds the number of days since last defect for auto-setting the textboxes in the config form
Sub Auto_Open() 'runs on startup from AutoEvents add-in. runs the find function to locate the Macro-edited slides, then opens the config form
'declare clockstate as false until it is true and turned on
clockstate = False
'assign values the global Injury and Defect variables
Call Find
'try calling the name fields (need to assign it to a variable to try it). If Injury and Defect were found, then nothing happens. Otherwise it moves the the Not_Found label
On Error GoTo Not_Found
'setup daysA and daysB
daysA = Left(Injury.TextFrame.TextRange.text, Len(Injury.TextFrame.TextRange.text) - 8)
daysB = Left(Defect.TextFrame.TextRange.text, Len(Defect.TextFrame.TextRange.text) - 8)
'assign default values to the Config boxes
Config.TextBox1.Value = Date - daysA
Config.TextBox2.Value = Date - daysB
'show config
Config.Show
Exit Sub
'error messaging for if the textbox assignments were not found
Not_Found:
MsgBox "Error: The Macro-edited textbox(es) were not found! This is likely due to the most recent editing preformed on this Powerpoint. Please revert the changes, create a new textbox with the name """"Injury_Time"""" or """"Defect_time"""" (whichever is missing), contact your local VBA expert, or read the Documentation for help."
End Sub
Sub Find() 'locates the textbox that the global variables Injury and Defect are supposed to represent
'use a 2D for loop to iterate through each slide and it's shapes
Dim i As Integer
Dim j As Integer
For i = 1 To ActivePresentation.Slides.Count
For j = 1 To ActivePresentation.Slides(i).Shapes.Count
If StrComp(ActivePresentation.Slides(i).Shapes(j).Name, "Injury_Time") = 0 Then
Set Injury = ActivePresentation.Slides(i).Shapes(j)
indexA = i
End If
If StrComp(ActivePresentation.Slides(i).Shapes(j).Name, "Defect_Time") = 0 Then
Set Defect = ActivePresentation.Slides(i).Shapes(j)
indexB = i
End If
Next j
Next i
End Sub
Sub Save() 'saves the contents of the config form to the global varaibles entryA and entry B then unloads the form to save memory
'save the contents of the config form so we can unload it to save memory
entryA = Config.TextBox1.Value
entryB = Config.TextBox2.Value
'unload the form to save memory
Unload Config
End Sub
Sub Auto_ShowBegin() 'starts the clock for the timers when the show starts
'start clock
clockstate = True
Call clock
End Sub
Sub clock()
Do Until clockstate = False
MsgBox ActivePresentation.SlideShowWindow.View
Injury.TextFrame.TextRange.text = (Date - entryA) & ":" & Mid(CStr(Time()), 1, Len(Time()) - 3)
Defect.TextFrame.TextRange.text = (Date - entryB) & ":" & Mid(CStr(Time()), 1, Len(Time()) - 3)
Call Wait(1)
Loop
End Sub
Sub Wait(sec As Integer)
Dim temp_time As Variant
temp_time = Timer
Do While Timer < temp_time + sec
DoEvents 'this allows for events to continue while waiting for sec seconds
Loop
End Sub
Sub App_SlideShowEnd(ByVal Pres As Presentation)
clockstate = False
End Sub
Sub Auto_Close() 'this is run by the AutoEvents add-in. It displays an informative message when the powerpoint is closed with instructions for the next time the powerpoint is opened
'prevent clock from running after program is closed
clockstate = False
'message to configure the powerpoint when it is opened again
MsgBox "Thank you for using this Macro-Enabled PowerPoint!" & vbCrLf & vbCrLf & "Next time the PowerPoint is opened, you will be asked to re-enter the dates of the most recent injury and quality defect."
End Sub
Thank you for your help and May the 4th be with you!
I think your 'Wait' function is not reliable. The 'for' loop may not end in some case.
To control the clock ticking event, you can make use of Windows 'Timer' API. Though the Timer API is not that reliable or easy to use, it can be controlled and tailored.
The sample code goes like this:
Option Explicit
#If VBA7 Then
Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, _
ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
Public TimerID As LongPtr
#Else
Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, _
ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
Public TimerID As Long
#End If
Const Default As Integer = 1 'the target slide where the 'Clock' textbox exists
Dim Pause As Boolean
Sub StartNow()
StartTimer
End Sub
Sub StopNow()
StopTimer
End Sub
'main timer process : this sub-routine CANNOT be interrupted by any error or itself
Sub myTimer()
On Error Resume Next
If Pause Then Exit Sub
'the Default slide should have a textbox called 'Clock'
ActivePresentation.Slides(Default). _
Shapes("Clock").TextFrame.TextRange.Text = Format(Time, "hh:mm:ss")
End Sub
Function StartTimer()
If TimerID = 0& Then
TimerID = SetTimer(0&, 0&, 1000&, AddressOf myTimer) ' 1000 = 1sec
End If
End Function
Function StopTimer()
On Error Resume Next
KillTimer 0&, TimerID
TimerID = 0&
End Function
'the timer can be paused, if this macro is added to the 'Clock' textbox as an action trigger
Sub PauseTimer()
Pause = Not Pause
End Sub
'the timer must be stopped after finishing the show
Public Sub OnSlideShowTerminate(SSW As SlideShowWindow)
StopTimer
End Sub
'To start the clock automactically
Sub OnSlideShowPageChange(ByVal SSW As SlideShowWindow)
If SSW.View.CurrentShowPosition = Default Then
StartTimer
Else
StopTimer
End If
End Sub
Requirement: A Textbox called 'Clock' should exist on Slide #1.
Warning:
The Timer must be stopped after closing the show. Otherwise, Powerpoint application might crash!
'myTimer' should not contain any error or call itself recursively.
I've tried multiple methods to hide specific workbook behind userform!
Last code I've used is here:
Private Sub UserForm_Layout()
Application.Left = MainWindow.Left
Application.Top = MainWindow.Top
End Sub
Private Sub UserForm_Activate()
Application.Left = Me.Left
Application.Top = Me.Top
Application.Width = Me.Width * 0.85
Application.Height = Me.Height * 0.85
End sub
It will hide application window behind userform, but if there is multiple workbooks open and I activate one of them, when I click on userform afterwards, it will move only active workbook within userform!
How to instruct to always affect only specific workbook with this function?
Also, by jumping from one UF to another same code will be executed each time!
Basically, I need to have specific workbook hidden behind userform ALWAYS and not accessible by users, but all other already opened workbooks or workbooks I intend to open must not be affected by this! Other workbooks must be accessible, and visible and shouldn't dissappear, or move if I use this or similar function!
I also tried application.visible = false but, it is dangerous as it also affects other workbooks and application is OFC not visible on taskbar, and any error may cause application to left open in background and not visible by user!
If you suggest any other method to achieve above mentioned requirement I would be happy to try it!
Thnx
Try hiding the form's parent window
Private Sub UserForm_Initialize()
ThisWorkbook.Windows(1).Visible = False
End Sub
Private Sub UserForm_Terminate()
ThisWorkbook.Windows(1).Visible = True
End Sub
Or determine screen coordinates of the form and apply them the parent
Private Sub UserForm_Initialize()
With ThisWorkbook.Windows(1)
.WindowState = xlNormal
.Left = Me.Left + Application.Left 'Calculate exact Screen.Left coordinate
.Top = Me.Top + Application.Top 'Calculate exact Screen.Top coordinate
.Width = Me.Width * 0.85
.Height = Me.Height * 0.85
End With
End Sub
.
To get screen resolution use GetSystemMetrics function:
#If VBA7 Then
Declare PtrSafe Function GetSystemMetrics32 Lib "user32" Alias "GetSystemMetrics" _
(ByVal nIndex As Long) As Long
#Else
Declare Function GetSystemMetrics32 Lib "user32" Alias "GetSystemMetrics" _
(ByVal nIndex As Long) As Long
#End If
Public Const SM_CXSCREEN = 0
Public Const SM_CYSCREEN = 1
Private Sub setMonitors()
celTotalMonitors = GetSystemMetrics32(80)
End Sub
Private Sub setResolution()
'The width of the virtual screen, in pixels
celScreenResolutionX = Format(GetSystemMetrics32(78), "#,##0")
'The height of the virtual screen, in pixels
celScreenResolutionY = Format(GetSystemMetrics32(79), "#,##0")
'celScreenResolutionY = celScreenResolutionY.Value \ celTotalMonitors
End Sub
Recently I've managed to find some code regarding a timer on a userform, my problem is that I need to keep the timer running even if the userform or excel file is closed... can someone take a look at the code and provide some feedback? My userform is: optionsForm
Dim dteStart As Date, dteFinish As Date
Dim dteStopped As Date, dteElapsed As Date
Dim boolStopPressed As Boolean, boolResetPressed As Boolean
Private Sub Reset_Timer_Click()
dteStopped = 0
dteStart = 0
dteElapsed = 0
Tech_Timer = "00:00:00"
boolResetPressed = True
End Sub
Private Sub Start_Timer_Click()
Start_Timer:
dteStart = Time
boolStopPressed = False
boolResetPressed = False
Timer_Loop:
DoEvents
dteFinish = Time
dteElapsed = dteFinish - dteStart + dteStopped
If Not boolStopPressed = True Then
Tech_Timer = dteElapsed
If boolResetPressed = True Then GoTo Start_Timer
GoTo Timer_Loop
Else
Exit Sub
End If
End Sub
Private Sub Stop_Timer_Click()
boolStopPressed = True
dteStopped = dteElapsed
End Sub
Private Sub optionsForm_Initialize()
Tech_Timer = "00:00:00"
End Sub
The idea of the timer is not that it runs, but that it remembers a point in time and can give you a difference between this point and the current moment. If you ask for this difference every second, then it would look like it is running like a watch.
Something like this would be a good start. In the xl_main write the following:
Option Explicit
Dim dtime As Date
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Cells(1, 1).Value = dtime
End Sub
Private Sub Workbook_Open()
If Cells(1, 1).Value = 0 Then
dtime = Now
Else
dtime = CDate(Cells(1, 1))
End If
End Sub
You may play around it and make it better as you wish. E.g. you may find a way to reset dtime or anything similar.
"Something" needs to be running to handle the timer procedure so if you want to use VBA then Excel can't be "closed" per se, however you could make it appear closed.
An obvious option is to minimize the Excel window (before showing the userform) with the WindowState property:
Application.WindowState = xlMinimized
...or, hide the Excel window completely with the Visible property:
Application.Visible = False
...or if the issue is that you need a "fresh" copy of Excel to work in, you could do so in a new instance by holding Alt while starting Excel.
I have posted code and a downloadable example of a countdown timer that displays the time remaining on a userform semi-independent of the Excel window, using the Windows Timer API (instead of Excel's procedure), in another answer here.
That's not possible if the form is unloaded Unload optionsForm. But you can try to 'close' the form with optionsForm.hide() this only hides the form, the timer should keep running then.
The only way I see to calculate the time passed from a start time even if Excel is closed is to not save the start time in a variable dteStart but in an Excel cell.
Actually you can use a code that is placed in a module. The code is:
Option Explicit
Dim T
Sub stopTimer()
On Error Resume Next
Application.OnTime (T), Procedure:="Update", Schedule:=False
End Sub
Sub StartTimer()
T = Now + TimeValue("00:00:01")
Application.OnTime T, "Update"
End Sub
Sub Update()
UserForm1.TextBox1.Value = Format(Now - Sheets("Sheet1").Range("E11").Value,
"hh:mm:ss")
UserForm1.TextBox2.Value = Format(TimeValue("1:00:00") - (Now -
Sheets("Sheet1").Range("E11").Value), "hh:mm:ss")
Call StartTimer
End Sub
Thereafter, you can now reference it in the userform by calling it. Here is a typical example. It is
Private Sub Userform_Activate()
Sheet1.Activate
Sheets("Sheet1").Range("E11").Value = Now
Application.Run "StartTimer"
If Sheets("Sheet1").Range("K27").Value = "K29" Then
Me.CommandButton4.Caption = "Start"
Me.CommandButton2.Visible = False
End If
End Sub
I'm working on a macro that displays cell info on the statusbar on each selection change within the excel application. It has grown with the addition of new features thanks to help from members in here. So now sometimes the focus sticks to a cell and I cant move on with the arrow keys to nearby cell before the cell info to be displayed has been calculated. But I do want the selection to move on for a smooth user experience. How should I interrupt the calculation?
It goes something like this in a class module:
Private Sub Appl_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
Dim InfoAboutTarget
InfoAboutTarget = GetInfoAbout(Target)
WriteInfoToStatusbar(InfoAboutTarget)
End Sub
Is any of the following two options any good?
Have an application_onkey event raising an error flag with a user-defined error code and an error handler in the above sub that exits on this particular error
Measure the time elapsed since the above sub started at interesting points in the code and exit after a time large enough to threaten the user experience?
As Dirk says, you should use DoEvents to allow excel to process user input, and detect if you long running code is interrupted and if so, cancel the interrupted execution, while allowing the most recent call to complete.
Here's an example to demonstrate (coded in ThisWorkbook)
Option Explicit
Dim abort As Boolean
Dim CallCount As Long
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
test Target
End Sub
Sub test(r As Range)
Dim i As Long, n As Long, b As Long
CallCount = CallCount + 1
n = 100
' simulate long running code
For i = 1 To n
DoEvents
If abort Then
GoTo AbortSub
End If
Application.StatusBar = CallCount & " " & r.Address & " " & i
Next
AbortSub:
' Abort all interrupted calls
If CallCount > 1 Then
abort = True
Else
abort = False
End If
CallCount = CallCount - 1
End Sub
Not sure if it will work, but maybe something like this
Dim globalCounter As Long ' 0 by defaul
Private Sub Appl_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
globalCounter = globalCounter + 1
WriteInfoToStatusbar GetInfoAbout(Target)
End Sub
Function GetInfoAbout(Target As Range)
Dim localCounter As Long
localCounter = globalCounter
' .. some code
DoEvents
If localCounter <> globalCounter Then Exit Function
' .. some code
End Function
I'm using visual basic as I will be studying it soon in college and I was wondering how could I run a sub a certain amount of times a second I have tried using Do Loop whilst calling the function inside the Loop
Do
GameLoop()
Loop Until running = false
I've also tried using a while loop, any help would be great :D
If getting the loop into hundredths of a second is acceptable, then the following would work.
Dim Start As Variant
Do
Start = Timer
GameLoop
Do While (Timer - Start < 0.01)
DoEvents
Loop
Loop Until running = False
If more precision is needed then replace the timer with: How to get time elapsed in milliseconds
If the GameLoop is too slow, then it will run full-speed; otherwise it will run at the desired Loops per second.
DoEvents could be removed if not needed, or you don't like it's event jumbling side effects.
Note this is VB6 code, for the VB.Net millisecond timer check out: How do you get the current time in milliseconds (long), in VB.Net?
Place another loop inside your loop.
In this inner loop you wait for the remaining time, and if there is no time left you continue.
I used the GetTickCount API for this which uses milliseconds as its input althought its accuracy depends on the resolution of the cpu clock
Option Explicit
Private Declare Function GetTickCount Lib "kernel32" () As Long
Private mblnRun As Boolean
Private Sub Command1_Click()
StartLoop
End Sub
Private Sub Command2_Click()
StopLoop
End Sub
Private Sub StartLoop()
Dim lngStart As Long
mblnRun = True
Do While mblnRun
'store start time
lngStart = GetTickCount
'do your actions
DoSomething
'wait for the remaining time
Do While GetTickCount < lngStart + 2000
'wait until 2 seconds are passed since the start of this loop cycle
DoEvents
Loop
Loop
End Sub
Private Sub StopLoop()
mblnRun = False
Caption = "Stopped : " & CStr(Now)
End Sub
Private Sub DoSomething()
Caption = "Running : " & CStr(Now)
End Sub
As long as mblnRun is True the loop keeps running