I have already read some questions/threads (e.g. this and this) about how to stop the VBA Application.OnTime procedure, but I just can't get it to stop!
I am using it to pull some data every x seconds. I understand that when I call the OnTime() method I need to pass to it the same time value that was used to schedule the event.
I have also tried to introduce multiple commands (that try to cause an error for example) to stop the execution but it still doesn't work! The program just keeps running... This is how my code looks:
In Worksheet code I have:
Public TimerActive As Boolean
Public tick As String
Public idx As Long
Public counter As Long
Public Sub UpdateOff_Click()
TimerActive = False
tick = "Off"
counter = 1
idx = 1
Call StopTimer(idx, counter, tick, TimerActive)
End ' force quit??
End Sub
Public Sub UpdateOn_Click()
TimerActive = True
tick = "live"
counter = 1
idx = 1
Call StartTimer(idx, counter, tick, TimerActive)
End Sub
and in a separate module I have:
Public fireTime As Date
Sub StartTimer(ByVal idx As Long, ByVal counter As Long, ByVal tick As String, ByVal TimerActive As Boolean)
fireTime = Now + TimeValue("00:00:05")
sMacro = " 'pullData " & idx & " , " & counter & ", " & Chr(34) & tick & Chr(34) & ", " & TimerActive & "'"
Application.OnTime EarliestTime:=fireTime, Procedure:=sMacro, Schedule:=True
End Sub
Sub StopTimer(ByVal idx As Long, ByVal counter As Long, ByVal tick As String, ByVal TimerActive As Boolean)
sMacro = "cause error" ' cause an error (by giving false sub name so program stops?
Application.OnTime EarliestTime:=fireTime, Procedure:=sMacro, Schedule:=False
End
End Sub
Public Sub pullData(ByVal idx As Long, ByVal counter As Long, ByVal tick As String, ByVal TimerActive As Boolean)
DoEvents
If TimerActive = True Then
' pull the data do some stuff, print the data, etc...
idx = idx + 1
counter = counter + 1
tick = tick + " ."
If counter = 6 Then
counter = 1
tick = "live"
End If
Call startTimer(idx, counter, tick, TimerActive)
End If
End Sub
I understand that I may have introduced a few extra measures to stop the execution but none seem to work!
It's because your start & stop routines are referring to different macros. Define sMacro as Public, then it will work
Public sMacro As String
Public fireTime As Date
Sub startTimer(ByVal idx As Long, ByVal counter As Long, ByVal tick As String, ByVal TimerActive As Boolean)
fireTime = Now + TimeValue("00:00:05")
sMacro = " 'pullData " & idx & " , " & counter & ", " & Chr(34) & tick & Chr(34) & ", " & TimerActive & "'"
Application.OnTime EarliestTime:=fireTime, Procedure:=sMacro, Schedule:=True
End Sub
Sub StopTimer(ByVal idx As Long, ByVal counter As Long, ByVal tick As String, ByVal TimerActive As Boolean)
Application.OnTime EarliestTime:=fireTime, Procedure:=sMacro, Schedule:=False
End Sub
Related
I have a VBA script that needs to run upon application startup, but after client rules are processed.
I did what was suggested here:
How can I tell when Rules have finished processing?
I added the executing of all rules in Outlook before the rest of the script runs. It did not solve my issue. My script only can process new emails that are in the inbox, not ones that have a rule applied to them. The AdvancedSearch method does not pick them up, even after adding the rule execution lines before.
Option Explicit
Public blnSearchComp As Boolean
Private Sub Application_AdvancedSearchComplete(ByVal SearchObject As Search)
Debug.Print "The AdvancedSearchComplete Event fired"
If SearchObject.Tag = "Process_New_Items" Then
'm_SearchComplete = True` ' Use Option Explicit.
blnSearchComp = True
End If
End Sub
Private Sub Application_Startup()
Dim dmi As MailItem
Dim timeFol As Folder
Dim timeFilter As String
Dim lastclose As String
Dim utcdate As Date
Dim strFilter As String
Dim i As Object
Dim strScope As String
Dim SearchObject As Search
'----------------------------------------------------------------------
Dim olRules As Outlook.Rules
Dim myRule As Outlook.Rule
Set olRules = Application.Session.DefaultStore.GetRules()
For Each myRule In olRules
' Rules we want to run
myRule.Execute
Next
'----------------------------------------------------------------------
Set dmi = CreateItem(olMailItem)
Set timeFol = Session.GetDefaultFolder(olFolderNotes)
timeFilter = "[Subject] = 'App Close Time'"
For Each i In timeFol.Items.Restrict(timeFilter)
lastclose = i.CreationTime
Next i
Debug.Print lastclose
utcdate = dmi.PropertyAccessor.LocalTimeToUTC(lastclose)
'strFilter = "#SQL=""urn:schemas:httpmail:datereceived"" >= '" & Format(utcdate, "dd mmm yyyy hh:mm") & "'"
strFilter = "urn:schemas:httpmail:datereceived >= " & "'" & utcdate & "'"
Debug.Print strFilter
'strScope = "'" & Session.Folders(1).Folders("Inbox") & "'"
Debug.Print strScope
'strScope = "'" & Session.GetDefaultFolder(olFolderInbox) & "'"
Debug.Print strScope
strScope = "'Inbox'"
Debug.Print strScope
'strScope = "'" & Application.Session.GetDefaultFolder(olFolderInbox).FolderPath & "'"
'Sleep (20)
Set SearchObject = AdvancedSearch(Scope:=strScope, Filter:=strFilter, SearchSubFolders:=True, Tag:="Process_New_Items")
blnSearchComp = False
' Otherwise remains True.
' Search would work once until Outlook restarted.
While blnSearchComp = False
DoEvents
' Code should be in a class module such as ThisOutlookSession
Debug.Print "Wait a few seconds. Ctrl + Break if needed."
Wend
Debug.Print "SearchObject.results.count: " & SearchObject.Results.Count
For Each i In SearchObject.Results
If TypeName(i) = "MailItem" Then
Process_MailItem i
Debug.Print i.ReceivedTime, i.Subject
Else: End If
Next i
End Sub
You can use built-in Windows mechanisms via Windows API functions like SetTimer to set up a timer in VBA, see How to make safe API Timers in VBA? and Outlook VBA - Run a code every half an hour for more information. For example:
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 'Need a timer ID to eventually turn off the timer. If the timer ID <> 0 then the timer is running
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
Public Sub DeactivateTimer()
Dim lSuccess As Long
lSuccess = KillTimer(0, TimerID)
If lSuccess = 0 Then
MsgBox "The timer failed to deactivate."
Else
TimerID = 0
End If
End Sub
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
I have a function that logs when users run a report. It is set to run "on open". Is there a way to change the on open for all reports and forms at once?
This code loops through all forms:
Public Sub DoChangeModules()
Dim dstApp As Application
Dim dstDB As Database
Dim AO As Document
Set dstApp = Application
Set dstDB = dstApp.CurrentDb
' iterate forms's modules and insert code
Dim f As Form
Dim M As Module
Debug.Print "Modifying Modules:"
Debug.Print "Forms:"
For Each AO In dstDB.Containers("Forms").Documents
dstApp.DoCmd.OpenForm AO.Name, acViewDesign
Set f = dstApp.Forms(AO.Name)
Set M = f.Module
ProccessModule M
Set f = Nothing
dstApp.DoCmd.Close acForm, AO.Name, acSaveYes
Next AO
End Sub
Public Sub ProccessModule(M As Module)
Dim numLine As Long
Dim StartLine As Long, StartColumn As Long, EndLine As Long, EndColumn As Long
Debug.Print , , M.Name
' insert variable declaration
M.AddFromString "Private testVar As variant ' test addition of module-level variable"
' locate or create Load event procedure
StartLine = 0
StartColumn = 0
EndLine = 0
EndColumn = 0
If Not M.Find(" Form_Open(", StartLine, StartColumn, EndLine, EndColumn) Then
numLine = M.CreateEventProc("Open", "Form")
End If
numLine = M.ProcBodyLine("Form_Open", 0) ' 0 here is vbext_pk_Proc
M.InsertLines numLine + 1, "" & _
" ' Call of global function that logs user" & vbNewLine & _
" doLogUser testVar " & vbNewLine & _
" ' that function called with local module variable "
End Sub
I want to create a pie chart with linked sheet but when I am clicking on the graph I am getting some error, "Compile error Argument not optional" on the "WorkSheetFunction.Index" line of the code.
I am beginner in VBA coding.. Please help
this is my code
xl page
ThisWorkbook module
Dim ChartObjectClass As New Class1
Dim ChartObjectClass2 As New Class2
Private Sub Workbook_Open()
Set ChartObjectClass.ChartObject = Worksheets(1).ChartObjects(1).Chart
Set ChartObjectClass2.ChartObject = Worksheets(1).ChartObjects(2).Chart
End Sub
Class module
Option Explicit
Public WithEvents ChartObject As Chart
Private Sub ChartObject_MouseUp(ByVal Button As Long, ByVal Shift As Long, _
ByVal x As Long, ByVal y As Long)
Dim ElementID As Long, Arg1 As Long, Arg2 As Long
Dim myX As Variant, myY As Double
With ActiveChart
.GetChartElement x, y, ElementID, Arg1, Arg2
If ElementID = xlSeries Or ElementID = xlDataLabel Then
If Arg2 > 0 Then
myX=WorksheetFunction.Index(.SeriesCollection(Arg1).XValues.Arg2)
myY=WorksheetFunction.Index(.SeriesCollection(Arg1).Values.Arg2)
MsgBox "Series" & Arg1 & vbCrLf & """" & .SeriesCollection(Arg1)_
.Name & """" & vbCrLf & "Point" & Arg2 & vbCrLf & _
"x= " & myX & vbCrLf & "y= " & myY
Range("A1").Select
On Error Resume Next
Sheets("Series" & myX & "Detail").Select
Range("A1").Select
On Error GoTo 0
End If
End If
End With
End Sub
In your case, Index requires two arguments. The first argument specifies the array of values from which to return a value. The second argument specifies the nth element from the array to return.
myX = WorksheetFunction.Index(.SeriesCollection(Arg1).XValues, Arg2)
myY = WorksheetFunction.Index(.SeriesCollection(Arg1).Values, Arg2)
By the way, you can also dispense with the use of WorksheetFunction.Index...
myX = .SeriesCollection(Arg1).XValues()(Arg2)
myY = .SeriesCollection(Arg1).Values()(Arg2)
Hello can you help me please with code in VBA ? I would like create a log file from text in cells ("C2" and "C3 " + date and time ) when I press button "zadat" Thank you
My code for implementation is:
Module 1
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Sub zadat()
Dim reg, check As String
Dim i, j, done As Integer
reg = Cells(2, 3).Value
check = Cells(4, 3).Value
If check = "True" Then
i = 2
j = 1
done = 0
Do While Sheets("data").Cells(i, j) <> ""
If Sheets("data").Cells(i, j) = reg Then
vytisteno = ZkontrolovatAVytiskoutSoubor()
done = Sheets("data").Cells(i, j + 3)
done = done + 1
Sheets("data").Cells(i, j + 3) = done
Exit Do
End If
i = i + 1
Loop
Else
MsgBox ("Opravit, špatný štítek!!!")
End If
Cells(3, 3) = ""
Cells(3, 3).Select
ActiveWindow.ScrollRow = Cells(1, 1).row
End Sub
Module 2:
Option Explicit
Public Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" ( _
ByVal hwnd As Long, _
ByVal lpOperation As String, _
ByVal lpFile As String, _
ByVal lpParameters As String, _
ByVal lpDirectory As String, _
ByVal nShowCmd As Long) As Long
Public Function PrintThisDoc(formname As Long, FileName As String)
On Error Resume Next
Dim x As Long
x = ShellExecute(formname, "Print", FileName, 0&, 0&, 3)
End Function
Public Function ZkontrolovatAVytiskoutSoubor() As Boolean
Dim printThis
Dim strDir As String
Dim strFile As String
strDir = "W:\Etikety\Štítky\Krabice\Testy"
strFile = Range("C2").Value & ".lbe"
If Not FileExists(strDir & "\" & strFile) Then
MsgBox "soubor neexistuje!"
ZkontrolovatAVytiskoutSoubor = False
Else
printThis = PrintThisDoc(0, strDir & "\" & strFile)
ZkontrolovatAVytiskoutSoubor = True
End If
End Function
Private Function FileExists(fname) As Boolean
'Returns TRUE if the file exists
Dim x As String
x = Dir(fname)
If x <> "" Then FileExists = True _
Else FileExists = False
End Function
If you don't want to use FSO, there is a simple solution using only VBA statements: Open, Print # and Close:
Sub Log2File(Filename As String, Cell1, Cell2)
Dim f As Integer
f = FreeFile
Open Filename For Append Access Write Lock Write As #f
Print #f, Now, Cell1, Cell2
Close #f
End Sub
I've put the filename and the cells refs as arguments of the sub for re-usability purpose. I also use default (local) formatting, but this can be easily changed.
Note that you don't have to check for existence of the file, it will be created if it doesn't exist.
Try this. Below code will create a new log file every time
Public Function LogDetails()
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Dim logFile As Object
Dim logFilePath As String
Dim logFileName As String
'Replace 'TestLog' with your desired file name
logFileName = "TestLog" & ".txt"
myFilePath = "C:\Users\..\Desktop\" & logFileName 'Modify the path here
If fso.FileExists(myFilePath) Then
Set logFile = fso.OpenTextFile(myFilePath, 8)
Else
' create the file instead
Set logFile = fso.CreateTextFile(myFilePath, True)
End If
logFile.WriteLine "[" & Date & " " & Time & "] " & Worksheet("yoursheetnamehere").Cells(2, 3) & " " & Worksheet("yoursheetnamehere").Cells(3, 3)
logFile.Close ' close the file
End Function
In VBA, I have a function that opens a text file. This allows me to place a button on a form and have it show a file when clicked.
The function works fine, however the aforementioned button is clicked multiple times, it will open the same document over and over, rather than just the once.
How can I make it so that a file is only opened once?
Sub OpenTextFile(ByVal filePath As String)
If Len(Dir(filePath)) = 0 Then Exit Sub ' Ensure that the file to open actaully exists
Dim txtFile As Variant
txtFile = Shell("C:\WINDOWS\notepad.exe " & filePath, 1)
End Sub
First check if a Shell ID has previously been assigned to the Workbooks .CustomDocumentProperties property. If it has, then we need to check if that Shell ID instance is still open. We can do that by using the Shell ID and passing it into the WHERE clause of a query against Win32_Process.
If there is no Shell ID assigned to the property, we can go straight to opening the text file. Once we open the text file, we update the .CustomDocumentProperties Property with the new text file Shell ID.
Option Explicit
Sub OpenTextFile()
Dim filePath As String
Dim txtFile As Long
Dim txtOpenCount As Integer
Dim wb As Workbook
Dim wmiService As Object, winQry As Object
Set wb = ThisWorkbook
On Error Resume Next
txtFile = CLng(wb.CustomDocumentProperties("txtFileNum"))
If Err.Number = 0 Then '' If CustomDocumentProperty returned _
without an error then use this to close txt file.
Set wmiService = GetObject("winmgmts:" _
& "{impersonationLevel=impersonate}!\\" _
& ".\root\cimv2")
Set winQry = wmiService.ExecQuery _
("SELECT * from Win32_Process WHERE ProcessID = " & txtFile)
txtOpenCount = winQry.Count
End If
On Error GoTo 0
If txtOpenCount = 0 Then '' If the txtFile is not found, then open.
filePath = "F:\test.txt"
If txtFile > 0 Then
wb.CustomDocumentProperties("txtFileNum").Delete
End If
txtFile = Shell("C:\WINDOWS\notepad.exe " & filePath, vbNormalFocus)
'' Update CustomDocumentProperty with the new txtFile number.
wb.CustomDocumentProperties.Add Name:="txtFileNum", _
Value:=txtFile, _
LinkToContent:=False, _
Type:=msoPropertyTypeString
End If
End Sub
If you are in Access, you can take advantage of the .CreateProperty method, and then the .Properties.Append method. You have to pass the property created from .CreateProperty into the .Properties.Append method. Updated code below.
Option Explicit
Sub OpenTextFile()
Dim filePath As String
Dim txtFile As Long, oTxt As Object
Dim txtOpenCount As Integer
Dim db As Database
Dim wmiService As Object, winQry As Object
Set db = CurrentDb
On Error Resume Next
txtFile = db.Properties("txtFileNum").Value
If Err.Number = 0 Then '' If CustomDocumentProperty returned _
without an error then use this to close txt file.
Set wmiService = GetObject("winmgmts:" _
& "{impersonationLevel=impersonate}!\\" _
& ".\root\cimv2")
Set winQry = wmiService.ExecQuery _
("SELECT * from Win32_Process WHERE ProcessID = " & txtFile)
txtOpenCount = winQry.Count
End If
On Error GoTo 0
If txtOpenCount = 0 Then '' If the txtFile is not found, then open.
filePath = "F:\test.txt"
If txtFile > 0 Then
db.Properties.Delete "txtFileNum"
End If
txtFile = Shell("C:\WINDOWS\notepad.exe " & filePath, vbNormalFocus)
'' Update db Properties with the new txtFile number.
Set oTxt = db.CreateProperty("txtFileNum", dbLong, txtFile, False)
db.Properties.Append oTxt
End If
End Sub
If you need it. Here is a function to see if notepad is running.
Declare these up top.
Private Declare Function OpenProcess Lib "kernel32" ( _
ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" ( _
ByVal hObject As Long) As Long
Private Declare Function EnumProcesses Lib "PSAPI.DLL" ( _
lpidProcess As Long, ByVal cb As Long, cbNeeded As Long) As Long
Private Declare Function EnumProcessModules Lib "PSAPI.DLL" ( _
ByVal hProcess As Long, lphModule As Long, ByVal cb As Long, lpcbNeeded As Long) As Long
Private Declare Function GetModuleBaseName Lib "PSAPI.DLL" Alias "GetModuleBaseNameA" ( _
ByVal hProcess As Long, ByVal hModule As Long, ByVal lpFileName As String, ByVal nSize As Long) As Long
Private Const PROCESS_VM_READ = &H10
Private Const PROCESS_QUERY_INFORMATION = &H400
Then send this the process name. b = IsProcessRunning("notepad.exe")
Private Function IsProcessRunning(ByVal sProcess As String) As Boolean
'Check to see if a process is currently running
Const MAX_PATH As Long = 260
Dim lProcesses() As Long
Dim lModules() As Long
Dim N As Long
Dim lRet As Long
Dim hProcess As Long
Dim sName As String
sProcess = UCase$(sProcess)
ReDim lProcesses(1023) As Long
If EnumProcesses(lProcesses(0), 1024 * 4, lRet) Then
For N = 0 To (lRet \ 4) - 1
hProcess = OpenProcess(PROCESS_QUERY_INFORMATION Or PROCESS_VM_READ, 0, lProcesses(N))
If hProcess Then
ReDim lModules(1023)
If EnumProcessModules(hProcess, lModules(0), 1024 * 4, lRet) Then
sName = String$(MAX_PATH, vbNullChar)
GetModuleBaseName hProcess, lModules(0), sName, MAX_PATH
sName = Left$(sName, InStr(sName, vbNullChar) - 1)
If sProcess = UCase$(sName) Then
IsProcessRunning = True
Exit Function
End If
End If
End If
CloseHandle hProcess
Next N
End If
End Function