I am trying to make a countdown in VBA, that displays the seconds in a textbox1. I am using this code below, but nothing happens and the textbox doesn't increment each second. I have tried doing Endtick / 1000 too because it's ms, but to still now avail. Is this the right method I should be using?
Other stuff is happening in the app as the timer is running, so I can't use the WAIT function.
Private Sub CommandButton2_Click()
timer (10)
End Sub
Sub timer(Finish As Long)
Dim NowTick As Long
Dim EndTick As Long
EndTick = GetTickCount + (Finish * 1000)
Do
NowTick = GetTickCount
DoEvents
UserForm1.TextBox1.Text = GetTickCount
Loop Until NowTick >= EndTick
msgbox("Time is up")
End Sub
Add this to a module, separate from the userform code:
Option Explicit
#If Win64 Then
Public Declare PtrSafe Function GetTickCount Lib "kernel32" () As Long
#Else
Public Declare Function GetTickCount Lib "kernel32" () As Long
#End If
Sub timer(Finish As Long)
Dim EndTick As Long
EndTick = GetTickCount + (Finish * 1000)
Do
DoEvents
UserForm1.TextBox1.Text = (EndTick - GetTickCount) / 1000
Loop Until GetTickCount >= EndTick
UserForm1.TextBox1.Text = 0
MsgBox ("Time is up")
End Sub
Related
I have the below code for Outlook 365 which will run a macro after sending an email.
How do I modify this to delay the macro 10 seconds after clicking send, and how do I limit this code to my exchange account email which is the default email account?
Option Explicit
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
With Item
Call BatchResendEmailsMacro
End With
End Sub
Outlook doesn't have a timer function but you can use Appointment or Task Reminders to trigger macros. Set up an Application_Reminder macro that will do something when a reminder fires. To limit it to running when specific reminders fire, use an If statement to look for words in the subject or a specific category.
If you want the macro to fire a specified time after you restart Outlook, use an Application_Startup macro to create the appointment. Read more about that in the Running Outlook Macros on a Schedule article.
Also you may consider using Windows API functions such as SetTimer and KillTimer. Outlook VBA - Run a code every half an hour page provides a sample code (for example, that is for Windows x64):
Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As LongLong, ByVal nIDEvent As LongLong, ByVal uElapse As LongLong, ByVal lpTimerfunc As LongLong) As LongLong
Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongLong, ByVal nIDEvent As LongLong) As LongLong
Public TimerID As LongLong 'Need a timer ID to eventually turn off the timer. If the timer ID <> 0 then the timer is running
Public Sub TriggerTimer(ByVal hwnd As Long, ByVal uMsg As Long, ByVal idevent As Long, ByVal Systime As Long)
MsgBox "The TriggerTimer function has been automatically called!"
End Sub
Public Sub DeactivateTimer()
Dim lSuccess As LongLong
lSuccess = KillTimer(0, TimerID)
If lSuccess = 0 Then
MsgBox "The timer failed to deactivate."
Else
TimerID = 0
End If
End Sub
Public Sub ActivateTimer(ByVal nMinutes As Long)
nMinutes = nMinutes * 1000 * 60
'The SetTimer call accepts milliseconds, so convert to minutes
If TimerID <> 0 Then Call DeactivateTimer
'Check to see if timer is running before call to SetTimer
TimerID = SetTimer(0, 0, nMinutes, AddressOf TriggerTimer)
If TimerID = 0 Then
MsgBox "The timer failed to activate."
End If
End Sub
You could trigger the code with the ItemAdd event on the Sent Items folder.
Option Explicit
' In the ThisOutlookSession module
Private WithEvents sentItems As Items
Private Sub Application_Startup()
Dim sentItemsFolder As Folder
' default Sent Items folder
Set sentItemsFolder = Session.GetDefaultFolder(olFolderSentMail)
Set sentItems = sentItemsFolder.Items
End Sub
Private Sub sentItems_ItemAdd(ByVal item As Object)
Dim waitTime As Long
Dim waitDiff As Long
Dim delay As Date
Dim waitStart As Date
waitTime = 10 ' in seconds
Debug.Print vbCr & "Wait start: " & Now
waitStart = Now
delay = DateAdd("s", waitTime, waitStart)
Debug.Print "Wait until: " & delay
Do Until Now >= delay
DoEvents
Loop
Debug.Print "Wait end..: " & Now
waitDiff = DateDiff("s", waitStart, Now)
Debug.Print waitDiff & " seconds delay."
Debug.Print "Call BatchResendEmailsMacro"
'Call BatchResendEmailsMacro
Debug.Print "Done."
End Sub
Private Sub test()
sentItems_ItemAdd ActiveInspector.currentItem
End Sub
I set up my own library with functions and subs for VBA (Word) and wanted to create a new class module. But I can't figure out how to use this new class with other files.
StopWatch Example (Normal.dotm, Class module: Global_StopWatch)
Private mlngStart As Long
Private Declare PtrSafe Function GetTickCount Lib "kernel32" () As Long
Public Sub StartTimer()
mlngStart = GetTickCount
End Sub
Public Function EndTimer() As Long
EndTimer = (GetTickCount - mlngStart)
End Function
StopWatch call (Document.dotm, module: Test)
Sub swTest()
Dim gSW As Global_StopWatch
Set gSW = New Global_StopWatch
gSW.StartTimer
Debug.Print "That took " & gSW.EndTimer & " ms."
End Sub
Can someone help with this?
Normal.dotm - clsStopWatch (Instancing = PublicNotCreatable)
Option Explicit
Private mlngStart As Long
Private Declare PtrSafe Function GetTickCount Lib "kernel32" () As Long
Public Sub StartTimer()
mlngStart = GetTickCount
End Sub
Public Function EndTimer() As Long
EndTimer = (GetTickCount - mlngStart)
End Function
Normal.dotm - Module1
Public Function StopWatch() As clsStopWatch
Set StopWatch = New clsStopWatch
End Function
Document1 - Module1
Sub Tester()
Dim sw As normal.clsStopWatch, i As Long
Set sw = normal.stopwatch
sw.StartTimer
For i = 1 To 10000000#
'
Next i
Debug.Print sw.endtimer
End Sub
I want that my excel xml always display in full screen view.
For this I code the next:
Private Sub Workbook_Open()
Application.WindowState = xlMaximized
ActiveWindow.WindowState = xlMaximized
Application.DisplayFullScreen = True
End Sub
It is working fine until I minimize excel, once I maximize again It shows in normal view mode, how to proceed? Any suggestion? The main idea is to remove the tool bars as I don't want user to interact with them.
Paste this into the workbook module. It will maximize the windows whenever it gets resized:
Private Sub Workbook_WindowResize(ByVal Wn As Window)
ActiveWindow.WindowState = xlMaximized
End Sub
There is an event that you can trap I'd try adding this to your ThisWorkbook module
Option Explicit
Private mbToggle As Boolean
Private mlPriorState(-1 To 0) As XlWindowState
Private Sub Workbook_WindowResize(ByVal Wn As Window)
mlPriorState(mbToggle) = Wn.WindowState
mbToggle = Not mbToggle
If Wn.WindowState = xlNormal And mlPriorState(mbToggle) <> xlMaximized Then
ActiveWindow.WindowState = xlMaximized
End If
End Sub
Though this may only work on windows that represent the worksheet/workbook. I'd try this first; other solutions involving Windows API are way more complicated.
Folded in some feedback. This code works for me.
Workbook_Activate will bring full screen mode while other will bring back normal mode.
Private Sub Workbook_Activate()
On Error Resume Next
With Application
.DisplayFullScreen = True
.CommandBars("Worksheet Menu Bar").Enabled = False
End With
End Sub
Private Sub Workbook_Deactivate()
On Error Resume Next
With Application
.DisplayFullScreen = False
.CommandBars("Worksheet Menu Bar").Enabled = True
End With
End Sub
EDIT
you shouldn't 'modify' the way Windows works at a system level. However, if you really, really must; add the following to a new module and call the SetStyle procedure.
That code is offered UNTESTED'as is' - the API is a way to modify Windows at a system level and can be dangerous (sudden crashes, data file corruption...) if you do not know what you are doing.
VB:
Option Explicit
'Related Windows API functions
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function GetSystemMenu Lib "user32" (ByVal hWnd As Long, ByVal bRevert As Long) As Long
Private Declare Function DeleteMenu Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long
Private Declare Function DrawMenuBar Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function SetFocus Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function LockWindowUpdate Lib "user32" (ByVal hWndLock As Long) As Long
'Window style constants
Private Const GWL_STYLE As Long = (-16) '// The offset of a window's style
Private Const GWL_EXSTYLE As Long = (-20) '// The offset of a window's extended style
Private Const WS_CAPTION As Long = &HC00000 '// Title bar bit
Private Const WS_SYSMENU As Long = &H80000 '// System menu bit
Private Const WS_THICKFRAME As Long = &H40000 '// Sizable frame bit
Private Const WS_MINIMIZEBOX As Long = &H20000 '// Minimize box bit
Private Const WS_MAXIMIZEBOX As Long = &H10000 '// Maximize box bit
Private Const WS_EX_TOOLWINDOW As Long = &H80 '// Tool Window: small titlebar bit
'Constant to identify the Close menu item
Private Const SC_CLOSE As Long = &HF060
Public Sub SetStyle()
Dim lStyle As Long, hMenu As Long
'Get the basic window style
lStyle = GetWindowLong(Application.hWnd, GWL_STYLE)
If lStyle = 0 Then
MsgBox "Unable to determine application window handle...", vbExclamation, "Error"
Exit Sub
End If
'// Build up the basic window style flags for the form
'// Uncomment the features you want...
'// Set it True to enable, FALSE to disable
'// The first 2 are obvious, ThickFrame controls if the Window is sizable or not.
'// SetBit lStyle, WS_CAPTION, True
'// SetBit lStyle, WS_SYSMENU, False
'// SetBit lStyle, WS_THICKFRAME, False
SetBit lStyle, WS_MINIMIZEBOX, False
SetBit lStyle, WS_MAXIMIZEBOX, False
'Set the basic window styles
SetWindowLong Application.hWnd, GWL_STYLE, lStyle
'Get the extended window style
lStyle = GetWindowLong(Application.hWnd, GWL_EXSTYLE)
'// Handle the close button differently
'// If Close button is wanted
'// hMenu = GetSystemMenu(Application.hWnd, 1)
'// Not wanted - delete it from the control menu
hMenu = GetSystemMenu(Application.hWnd, 0)
DeleteMenu hMenu, SC_CLOSE, 0&
'Update the window with the changes
DrawMenuBar Application.hWnd
SetFocus Application.hWnd
End Sub
'// Set or clear a bit from a style flag
Private Sub SetBit(ByRef lStyle As Long, ByVal lBit As Long, ByVal bOn As Boolean)
If bOn Then
lStyle = lStyle Or lBit
Else
lStyle = lStyle And Not lBit
End If
End Sub
Is there any way to check until file exists in VBA.
what I am trying to do is, making vba call asynch.
Now after I run
wshShell.Run """" & SFilename & """" & s
I want to check until file exists like this
Wait until fso.fileexists("file")
Msgbox "file is now available"
End wait!!!
is there any way in vba?
I am using word vba.
You can do it like this:
Do
If fso.FileExists("file") Then
Exit Do
End If
DoEvents 'Prevents Excel from being unresponsive
Application.Wait Now + TimeValue("0:00:01") 'wait for one second
Loop
MsgBox "file available", vbOKOnly, ""
Although this is surely not the best method
Instead of using Application.Wait, you can use sleep:
Sleep 1000 '1 Second
but you need to add this to your code to be able to use it:
#If VBA7 Then
Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr) 'For 64 Bit Systems
#Else
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds as Long) 'For 32 Bit Systems
#End If
You need a timeout to avoid an endless loop. This function returns true if it found the file and false if timeout was reached.
Option Explicit
Const timeoutSeconds As Long = 128
Private localFSO As Object
Public Function FSO() As Object
If localFSO Is Nothing Then Set localFSO = CreateObject("Scripting.FileSystemObject")
Set FSO = localFSO
End Function
Public Function WaitForFileToExist(ByVal theFileName As String) As Boolean
Dim timeElapsed As Single
Dim startTime As Single
startTime = Timer
Do
If FSO.FileExists(theFileName) Then
WaitForFileToExist = True
Exit Do
End If
DoEvents
Application.Wait Now + TimeValue("0:00:01")
timeElapsed = Timer - startTime
Loop Until timeElapsed > timeoutSeconds
End Function
I'm trying to run Outlook code 10 seconds after an email is received.
I tried using application.wait but it appears that you cannot do this with Outlook.
How do I pause Outlook for a given amount of time?
You can create a Sub that will mimic the Application.Wait, something like.
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
'For 64-Bit
'Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public Sub Pause(intSeconds As Variant)
' Comments: Waits for a specified number of seconds
' Params : intSeconds Number of seconds to wait
' Source : Total Visual SourceBook
On Error GoTo PROC_ERR
Dim datTime As Date
datTime = DateAdd("s", intSeconds, Now)
Do
' Yield to other programs (better than using DoEvents which eats up all the CPU cycles)
Sleep 100
DoEvents
Loop Until Now >= datTime
PROC_EXIT:
Exit Sub
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , "Pause Method"
Resume PROC_EXIT
End Sub
To call this you could use Pause 3
Here's a simple way:
T0 = Now + TimeValue("0:00:10")
Do Until Now > T0
Loop
Throw a DoEvents in this and it'll be okay
T0 = Now + TimeValue("00:00:10")
Do Until Now > 10
DoEvents
Loop
I'm not sure the need for complicated function..
Try This:
#If VBA7 Then
'Code is running VBA7 (2010 or later).
#If Win64 Then
'Code is running in 64-bit version of Microsoft Office.
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#Else
'Code is running in 32-bit version of Microsoft Office.
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If
#Else
'Code is running VBA6 (2007 or earlier).
#End If
Sub Test()
Debug.Print Now
Sleep 10000
Debug.Print Now
End Sub