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
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 have a userform (baseUF) that has multiple pages and buttons that all do different things. I have this baseUF being modeless because I want the user to be able to play with the sheet without closing the userform and losing all of the data they input. However, I started having a problem that might be due to the modeless nature of the baseUF.
There are other userforms that can be called from the baseUF. One executes with no issue by double clicking a textbox. However, the other userform is loaded after a button click. Once that button click sub is finished, the baseUF closes after the Exit Sub OR End Sub line. I don't remember this happening in the past and it doesn't happen with any other button click subs.
Does anybody have an idea what the issue could be? I'm pretty lost because I don't have a command to close the baseUF anywhere in that sub. Below is some code to show what is happening:
This sub is connected to a button on the spreadsheet to open the baseUF (the code is in a module).
Sub Button1_Click()
' show the userform
baseUF.Show vbModeless
End Sub
And this is the sub in the baseUF that calls an additional userform (LoadBox) which seems to be the issue.
Private Sub LoadQuery_Click()
' I Dim a bunch of stuff here
' if there are no saved queries, alert the user
If saveSht.Range("B3").Value = "" Then
MsgBox "No saved queries!"
Exit Sub
' if there is only one saved query, add it to the array and pop up the userform that allows for the user to select which save to load
ElseIf saveSht.Range("B4").Value = "" Then
save_names = saveSht.Range("B3").Value
LoadBox.Show
' otherwise, add all of the save names to the array and pop up that userform
Else
save_names = saveSht.Range(saveSht.Range("B3"),saveSht.Range("B3").End(xlDown)).Value
LoadBox.Show
End If
' if the user didn't select a save to load, stop trying to make stuff happen
If load_name = "" Then
' the userform will also close here if this turns out to be true
Exit Sub
End If
' do a bunch of stuff with the selected name here
' and after this line, the userform that contains this code closes
End Sub
EDIT: here is some code showing the two other userforms
This one is the userform with no issue that is called after a textbox is double clicked
Private Sub UserForm_Initialize()
' On start up of this form, populate the listbox with the relevant column names
' Set position
Me.StartUpPosition = 0
Me.Top = baseUF.Top + 0.5 * baseUF.Height - 0.5 * Me.Height
Me.Left = baseUF.Left + 0.5 * baseUF.Width - 0.5 * Me.Width
With FilterSelectionBox
' First grab all of the column names from the main selected table
For i = 0 To baseUF.SelectionBox.ListCount - 1
.AddItem baseUF.SelectionBox.List(i)
Next i
' Then grab all of the column names from the additional tables to be joined
If Not IsVariantEmpty(join_table_cols) Then
For n = 0 To UBound(join_table_cols)
If Not IsEmpty(join_table_cols(n)) Then
For Each col_name In join_table_cols(n)
.AddItem col_name
Next
End If
Next n
End If
End With
End Sub
Private Sub OkButton_Click()
' Initialize the variables
Dim tb As MSForms.TextBox
Dim arr() As String
Dim str As String
' tb is the textbox object that the column names will be pasted in to
Set tb = baseUF.MultiPage1.Pages(baseUF.MultiPage1.Value).Controls(Me.Tag)
' sets the str according to some logic
' This is actually where it gets sent
tb.Value = str
' And close the form
Unload Me
End Sub
And this is the code in the userform with an issue
Private Sub UserForm_Initialize()
' On initialization, populate the combobox with all of the save names present in the spreadsheet
' Set position
Me.StartUpPosition = 0
Me.Top = baseUF.Top + 0.5 * baseUF.Height - 0.5 * Me.Height
Me.Left = baseUF.Left + 0.5 * baseUF.Width - 0.5 * Me.Width
With LoadComb
' If there is more than one save present, go through the array and add each one
If IsArray(save_names) Then
For Each saved_name In save_names
.AddItem saved_name
Next
' Otherwise just add the one
Else
.AddItem save_names
End If
End With
End Sub
Private Sub LoadButton_Click()
' When the user hits the load button, first check if they actually selected anything
If LoadComb.Value = "" Then
' If they didn't, yell at them
MsgBox "No saved query selected!"
Else
' Otherwise, save the name to a global variable
load_name = LoadComb.Value
End If
' Close the form
Unload Me
End Sub
Whenever something unexpected happens with forms, consider writing End in the immediate window and pressing enter. It will kill all the unkilled instances of a form and generally any variable, thus it would be like a cold restart to the VBA program.
After doing this, it is a good idea to consider a cleaner solution, concerning VBA & UserForms, using some OOP. (Disclaimer - the first article is mine):
http://www.vitoshacademy.com/vba-the-perfect-userform-in-vba/
https://rubberduckvba.wordpress.com/2017/10/25/userform1-show/
https://codereview.stackexchange.com/questions/154401/handling-dialog-closure-in-a-vba-user-form
Although it may seem that you are achieving the same results with more code, the benefits of using this approach are quite a lot in the long term.
This is a small example of the OOP model. Imagine you have a user form like this:
It has only the following controls:
btnRun
btnExit
lblInfo
frmMain (the class)
The code withing the form is the following:
Option Explicit
Public Event OnRunReport()
Public Event OnExit()
Public Property Get InformationText() As String
InformationText = lblInfo.Caption
End Property
Public Property Let InformationText(ByVal value As String)
lblInfo.Caption = value
End Property
Public Property Get InformationCaption() As String
InformationCaption = Caption
End Property
Public Property Let InformationCaption(ByVal value As String)
Caption = value
End Property
Private Sub btnRun_Click()
RaiseEvent OnRunReport
End Sub
Private Sub btnExit_Click()
RaiseEvent OnExit
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
If CloseMode = vbFormControlMenu Then
Cancel = True
Hide
End If
End Sub
The form is with two events, getting caught by the clsSummaryPresenter. The clsSummaryPresenter looks like this:
Option Explicit
Private WithEvents objSummaryForm As frmMain
Private Sub Class_Initialize()
Set objSummaryForm = New frmMain
End Sub
Private Sub Class_Terminate()
Set objSummaryForm = Nothing
End Sub
Public Sub Show()
If Not objSummaryForm.Visible Then
objSummaryForm.Show vbModeless
Call ChangeLabelAndCaption("Press Run to Start", "Starting")
End If
With objSummaryForm
.Top = CLng((Application.Height / 2 + Application.Top) - .Height / 2)
.Left = CLng((Application.Width / 2 + Application.Left) - .Width / 2)
End With
End Sub
Private Sub Hide()
If objSummaryForm.Visible Then objSummaryForm.Hide
End Sub
Public Sub ChangeLabelAndCaption(strLabelInfo As String, strCaption As String)
objSummaryForm.InformationText = strLabelInfo
objSummaryForm.InformationCaption = strCaption
objSummaryForm.Repaint
End Sub
Private Sub objSummaryForm_OnRunReport()
MainGenerateReport
Refresh
End Sub
Private Sub objSummaryForm_OnExit()
Hide
End Sub
Public Sub Refresh()
With objSummaryForm
.lblInfo = "Ready"
.Caption = "Task performed"
End With
End Sub
Finally, we have the modMain, which is the so-called business logic of the form:
Option Explicit
Private objPresenter As clsSummaryPresenter
Public Sub MainGenerateReport()
objPresenter.ChangeLabelAndCaption "Starting and running...", "Running..."
GenerateNumbers
End Sub
Public Sub GenerateNumbers()
Dim lngLong As Long
Dim lngLong2 As Long
tblMain.Cells.Clear
For lngLong = 1 To 10
For lngLong2 = 1 To 10
tblMain.Cells(lngLong, lngLong2) = lngLong * lngLong2
Next lngLong2
Next lngLong
End Sub
Public Sub ShowMainForm()
If (objPresenter Is Nothing) Then
Set objPresenter = New clsSummaryPresenter
End If
objPresenter.Show
End Sub
I have a powerpoint presentation that contains animations that show & hide shapes. In addition, there I have VBA scripts that run that will resize some of the same shapes. Whenever the VBA script is running, all of the shapes that were hidden using an animation appear and remain visible until the script finishes.
I could always change all of my animations to use VBA scripts instead to set the .Visible attribute of the shapes but this seems cumbersome and consumes a lot of code.
Is there any way to have VBA script an animations work together?
Thanks in advance
Here is the code:
Private Type MyIntegerPoint
x As Long
y As Long
End Type
Private Type MySinglePoint
x As Single
y As Single
End Type
Private Type MyRect
top As Single
left As Single
bottom As Single
right As Single
End Type
Option Explicit
Private Declare PtrSafe Function GetCursorPos Lib "User32" (lpPoint As MyIntegerPoint) As Long
Private Declare PtrSafe Function GetSystemMetrics Lib "User32" (ByVal nIndex As Long) As Long
Private Declare PtrSafe Function WindowFromPoint Lib "User32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
Private Declare PtrSafe Function GetAsyncKeyState Lib "User32" (ByVal whichButton As Integer) As Integer
Public MousePt As MySinglePoint
Public StartPt As MySinglePoint
Public ShapeOrigCoord As MySinglePoint
Public InDrag As Boolean
Public Sub VerticalDragShape(ByRef sh As Shape)
If Not InDrag Then
InDrag = True
End If
' initialize drag variables
InitDragVars sh
ActivePresentation.SlideShowWindow.View.State = ppSlideShowPaused
While InDrag
GetScaledMousePt
DoEvents
Dim keyState As Integer
keyState = GetAsyncKeyState(1)
If keyState < 0 Then
InDrag = False
Else
With ActivePresentation.Windows(1).View.Slide
.Shapes("Shape1").top = MousePt.y
.Shapes("Shape1").left = MousePt.x
End With
End If
Wend
ActivePresentation.SlideShowWindow.View.State = ppSlideShowRunning
End Sub
Private Sub GetScaledMousePt()
Dim mPt As MyIntegerPoint
'Get the current raw mouse point
GetCursorPos mPt
'Convert it to point coordinates
MousePt.x = MouseXCoordToPoints(mPt.x)
MousePt.y = MouseYCoordToPoints(mPt.y)
End Sub
' converts an x screen coordinate into document window coordinates
' first, convert the screen pixels into slide show window coordinates
' second, convert slide show window coordinates to document window coordinates
Public Function MouseXCoordToPoints(x As Long) As Single
Dim slideWidth As Single
Dim screenWidth As Single
Dim fx As Single
fx = x
slideWidth = ActivePresentation.PageSetup.slideWidth
screenWidth = GetSystemMetrics(0)
MouseXCoordToPoints = fx * slideWidth / screenWidth
End Function
Public Function MouseYCoordToPoints(y As Long) As Single
' TRIAL 3
Dim slideHeight As Single
Dim screenHeight As Single
Dim fy As Single
fy = y
slideHeight = ActivePresentation.PageSetup.slideHeight
screenHeight = GetSystemMetrics(1)
MouseYCoordToPoints = fy * slideHeight / screenHeight
End Function
Private Sub InitDragVars(ByRef sh As Shape)
GetScaledMousePt ' scale current mouse point
StartPt = MousePt ' save start mouse point
ShapeOrigCoord.x = sh.left ' capture left coord of shape
ShapeOrigCoord.y = sh.top ' capture top coord of shape
End Sub
To exhibit the problem, create a single slide presentation that contains two shapes. Name the shapes in the presentation Shape1 & Shape2. Create an animation that hides Shape2 when placed in presentation mode. Insert an action on Shape1 to run VerticalDragShape when clicked on with the mouse. When you run the presentation, Shape2 should be hidden. Clicking (and releasing) the mouse on Shape1 should cause it to move with the mouse until you click again. However, when moving Shape1, Shape2 becomes visible again until the move operation is complete when it becomes hidden.
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.
I have an issue with my Excel window disappearing into the background (or rather, the topmost Z -1 window position) when I run some macros containing a UserForm. This issue seems to be related somehow to the Application.Interactive property being set to True at the start of these macros, i.e. the problem goes away when I comment out that command.
As I can't really remove the Application.Interactive = True command from my subroutines, I've had to put in an BringWindowToTop API call in at the end of every macro to get the window to return to the the top. The problem with this is not just that the screen will flash when the macro finishes running, which is not necessarily a huge issue, but rather that this feels like an inelegant solution because I don't understand what's causing the problem in the first place.
Again, this only occurs when I have a Userform which are called as part of the subroutine but I can't see any problems with how that is written. This issue also occurs with both Excel 2010 and 2013.
Please find below a snippets of code for a Module and UserForm which are similar to how my macros function and which replicate the issue. I've left the API calls in for completeness, but they are commented out.
Does anyone have an idea about what is going on here and how it can be fixed?
Module Code
'Public Declarations
'APIs
Public Declare PtrSafe Function GetActiveWindow Lib "user32.dll" () As Long
Public Declare PtrSafe Function BringWindowToTop Lib "user32.dll" (ByVal hwnd As Long) As Long
Sub Window_To_Background_Test()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.Interactive = False
Application.Calculation = xlCalculationManual
'ThisWorkbooksHandle = GetActiveWindow
With UserForm1
.StartUpPosition = 0
.Left = Application.Left + (0.5 * Application.Width) - (0.5 * .Width)
.Top = Application.Top + (0.5 * Application.Height) - (0.5 * .Height)
.Show
End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.Interactive = True
Application.Calculation = xlCalculationAutomatic
'Call BringWindowToTop(ThisWorkbooksHandle)
End Sub
UserForm Code
Private Sub UserForm_Initialize()
Set Label1 = UserForm1.Controls.Add("Forms.Label.1", "Test", True)
With Label1
.Caption = "Test"
.Left = 10
.Width = 50
.Top = 10
End With
End Sub