I was wondering why the onTime method needs to be preceded by an on Error Resume next Statement. Obviously its because it raises an error and it doesn't seem to affect it's function but I'm just curious.
Can anybody enlighten me?
Code posted as per request!
this is in a worksheet module:
Const scrollRowName = "WindowScrollRow"
Dim ws As DataViewSheetClass
Public nextTime As Double
Public latestTime As Double
Private Sub startDog()
If Me.ProtectContents Then
nextTime = Now + TimeSerial(0, 0, 3)
If Me.ProtectContents Then Application.OnTime nextTime, Me.CodeName & ".kickDog"
End If
End Sub
Private Sub kickDog()
Static prevWsRow As Long
If Me Is ActiveSheet And Me.ProtectContents Then
wsRow = ActiveWindow.scrollRow
If wsRow <> prevWsRow Then
With Application
.screenUpdating = False
.StatusBar = "Calculating Formats"
.EnableEvents = False
scrollRow.Value2 = ActiveWindow.scrollRow
.EnableEvents = True
.StatusBar = False
prevWsRow = wsRow
.screenUpdating = True
End With
End If
Debug.Print timeStamp & ": Woof!" & Chr(9) & wsRow & Chr(9) & scrollRow.Value2
nextTime = Now + TimeSerial(0, 0, 3)
latestTime = nextTime + TimeSerial(0, 0, 10)
Application.OnTime nextTime, Me.CodeName & ".kickDog", latestTime
Else
killDog
End If
End Sub
Private Sub killDog()
On Error GoTo rebootObjects
scrollRow.Value2 = 1
On Error Resume Next
Application.OnTime nextTime, Me.CodeName & ".Worksheet_Deactivate", latestTime, False
On Error GoTo 0
Exit Sub
rebootObjects:
Set scrollRow = Me.Range(scrollRowName)
scrollRow.Value2 = 1
Resume Next
End Sub
Private Sub Worksheet_Activate()
Debug.Print timeStamp & ": " & "Summary Activate Start:" & Chr(9) & MicroTimer - t
t = MicroTimer
On Error GoTo enableAndExit
Set ws = New DataViewSheetClass
Application.EnableEvents = False
With ws
.addedActiveArea = Range("WeeksTable")
.addedActiveArea = Range("SummaryTotals")
.SparkTargetBehaviour = HEAVY
End With
enableAndExit:
Err.Clear
Application.EnableEvents = True
Set scrollRow = Me.Range(scrollRowName)
Set volatileRange = Me.Range(volatileRangeName)
startDog
Debug.Print timeStamp & ": " & "Summary Activated:" & Chr(9) & MicroTimer - t
t = MicroTimer
End Sub
Private Sub Worksheet_Deactivate()
killDog
Set ws = Nothing
End Sub
Its not required and it's a horribly hacky way to write code.
There are very few scenarios where "On Error Resume Next" is acceptable.
Here are two to consider:
Public function Example1() as Boolean
dim blnReturnValue as Boolean
On error goto errHandler
... Do stuff here that might error
... All code can error!
blnReturnValue = True ' Set return flag to success
cleanExit:
On Error Resume Next ' <-- Only Place where "On Error Resume Next" is acceptable
... Finalise things here, close objects etc.
Example1 = blnReturnValue ' Return the result
Exit Function ' Single Exit point
errHandler:
... Handle the error appropriately here
Resume CleanExit ' Ensure the function cleans up after itself
End Function
Or if you expect an error but really must continue:
Public function Example2() as Boolean
dim blnReturnValue as Boolean
On Error Goto errHandler
blnReturnValue = True ' default return flag to success
... Execute error prone code here
... This line will still run after returning from the error handler
Example2 = blnReturnValue ' Will be False if an error occurred, otherwise true
Exit Function 'Single Exit Point
errHandler:
blnReturnValue = False ' Set return flag to Failure
msgbox err.description
Resume Next ' Resume at the next line after the error occurred
End Function
I conducted a series of experiments to try to understand this function better and my results follow. I'm very pleased to confirm that the educated supposition offered by #Jean-François Corbett (here) was absolutely correct.
Yes, you can have more than one timer with the same exact same EarliestTime so this argument is NOT equivalent to "a serial number to register the timer" (contrary to my reading elsewhere).
You can have the same Procedure argument on calls with different EarliestTime arguments and it will also function normally as two separate timers.
Both of these arguments, however, must be the same as the initial call (with Schedule:=True) when killing the timer (with Schedule:=False). Failing to do so will throw ERROR: 1004: Application-defined or object-defined error on trying to execute the OnTime call with Schedule:=False. Also, the timer will not be reset in this case and an ERROR 1004: Object variable or With block variable not set will result if the call-back procedure address can not be resolved when the timer triggers.
The resolution of the timer is 1 second. If you try to start two timers 0.5 seconds apart, they will be registered with the same start time.
I don't think its wise to use the LatestTime argument: I think the timers should always be terminated manually. Omitting it also ensures that the timer will persist if there is a long save or calculate event that exceeds the timer duration and delays the call-back.
Its very important to fully qualify the call-back Procedure to ensure that it is resolvable when the timer fires. Failure to do so may result in the timer not being re-set and the workbook re-opening on attempting to close it, if other workbooks are open at the time.
It is possible to create an OnTimer Class Module with a call-back Procedure referencing a Worksheet Class Module Method. It's a good idea to ensure that the Procedure argument is fully qualified (e.g. Procedure:="'wb Name.xlsm'!Sheet1.methodName").
If you use the Worksheet_Activate and Worksheet_Deactivate events to manage the timer life-cycle and call these procedures from the Workbook_WindowActivate and Workbook_WindowDeactivate events, then the timer will start reliably and the workbook will close and stay closed. You can also use the Workbook_BeforeClose and Workbook_Open events, but they won't cover switching between Workbooks. Because of the sequence in which they fire, the window events, in conjunction with the worksheet events will cover everything.
You need to use some means of transmitting these events to the active worksheet which is hosting the timer. This can be done by creating a Class, based on CallByName to notify the ActiveSheet of the workbook events. You can also do it using a WorkBook, WithEvents Class object declared in the Worksheet, but you still need a CallByName type call to initiate on WorkBook_WindowActivate.
Attempting to kill a timer with OnTime Schedule:=False after the timer has triggered will result in ERROR: 1004: Application-defined or object-defined error.
Preceding the OnTime Schedule:=False call with On Error Resume Next allows for the possibility of killing the timer after it has triggered. I do so but I always trap errors and I have not seen any errors thrown by the OnTime function that weren't genuine and in need of handling.
In response to interest expressed by Mr #Gary's Student I include Example, working code.
In ThisWorkbook Class Module:
Option Explicit
Dim Notify As New cActiveSheetBus
'This is needed to boot the active sheet because the
'Worksheet_Activate event does not fire in the sheet
Private Sub Workbook_WindowActivate(ByVal Wn As Window)
Notify.onWindowActivate ActiveSheet
End Sub
A Class called cActiveSheetBus to provide cross-talk between the WorkBook and Worksheet Class modules:
Option Explicit
Const moduleIndent = 2
'Notify Activesheet of Workbook Events
Sub activeSheetCallBack(ws As Worksheet, cb As String)
On Error GoTo fnCallbackFailed
CallByName ws, cb, VbMethod
On Error GoTo 0
Exit Sub
fnCallbackFailed:
Debug.Print cModuleName & vbTab & myName & vbTab & "****failed****"
Err.Clear
End Sub
Public Sub onOpen(ws As Worksheet)
activeSheetCallBack ws, "onOpen"
End Sub
Public Sub beforeClose(ws As Worksheet)
activeSheetCallBack ws, "beforeClose"
End Sub
Public Sub beforeSave(ws As Worksheet)
activeSheetCallBack ws, "beforeSave"
End Sub
Public Sub afterSave(ws As Worksheet)
activeSheetCallBack ws, "afterSave"
End Sub
Public Sub onWindowActivate(ws As Worksheet)
activeSheetCallBack ws, "onWindowActivate"
End Sub
Public Sub onWindowDEActivate(ws As Worksheet)
activeSheetCallBack ws, "onWindowDEActivate"
End Sub
In the Host Worksheet's Class Module (in this case Sheet2)
Option Explicit
Const cPulseTime As Long = 1
Const cBackgroundPulse As Boolean = False
Dim mOnTime As cOnTime
'Expose custom worksheet properties to configure the timer (optional)
Property Get pulseTime() As Long
' Can put any logic here that interracts with the sheet
' or the user or the application for example
' pulseTime = cPulseTime
pulseTime = Me.Range("pulseTime")
End Property
Property Get enableBackgroundPulse() As Boolean
enableBackgroundPulse = cBackgroundPulse
End Property
Property Get designMode() As Boolean
designMode = Me.ProtectContents
End Property
'****************************************
'ActiveSheet Call-backs
Public Sub onWindowActivate()
Const cMyName As String = "onWindowActivate"
Worksheet_Activate
End Sub
'****************************************
'****************************************
'Timer call-back for cOnTime
Public Sub kickDog()
' Code to execute on timer event
'******************************************
On Error Resume Next
Me.Cells(1, 1) = Not Me.Cells(1, 1)
On Error GoTo 0
'******************************************
Debug.Print "woof!!"
On Error GoTo exitError
mOnTime.kickDog
On Error GoTo 0
Exit Sub
exitError:
End Sub
Private Sub Worksheet_Activate()
Const myName As String = "Sheet2.Worksheet_Activate"
Debug.Print myName
If (mOnTime Is Nothing) Then
Set mOnTime = New cOnTime
Else
mOnTime.kickDog
End If
End Sub
Private Sub Worksheet_Deactivate()
Const pName As String = "Sheet2.Worksheet_Deactivate"
End Sub
This in a Class Module called cOnTime:
Option Explicit
'****************************************
'Encapsulated timer that will sense the active
' sheet and expect to find a callback there
'
'In host sheet
' Const cPulseTime As Long = 1
'
' Dim mOnTime As cOnTime
' Property Get PulseTime() As Long
' PulseTime = cPulseTime
' End Property
' '****************************************
' 'Timer call-back for cOnTime
' Public Sub kickDog()
' ' Code to execute on timer event
' '******************************************
' On Error Resume Next
' Me.Cells(1, 1) = Not Me.Cells(1, 1)
' On Error GoTo 0
' '******************************************
' Debug.Print "woof!!"
' On Error GoTo exitError
' mOnTime.kickDog
' On Error GoTo 0
' Exit Sub
' exitError:
' End Sub
Const DEFDoWhen As String = "kickDog"
Const DEFPulseTime = "PulseTime"
Const DEFearliestTime As Long = 5
Const DEFlatestTime As Long = 15
Private WithEvents wb As Workbook
Private Ws As Worksheet
Private DoWhen As String
Dim KillTimer As String
Private mPulseTime As Long
Private mDesignMode
Private mBackgroundPulse
Private mNextTime As Double
Property Let callBackDoWhen(cb As String)
DoWhen = "'" & wb.Name & "'!" & Ws.CodeName & "." & cb 'e.g. 'wb Name.xlsm'!Sheet1.kickdog
End Property
Property Let callBackPulseTime(csPulseTime As String)
Const cMyName As String = "Let PulseTime"
On Error Resume Next
mPulseTime = CallByName(Ws, csPulseTime, VbGet)
If Err.Number <> 0 Then
mPulseTime = DEFearliestTime
End If
On Error GoTo 0
End Property
Private Function wsGetProperty(prop As String, default)
On Error Resume Next
wsGetProperty = CallByName(Ws, prop, VbGet)
If Err.Number <> 0 Then
wsGetProperty = default
End If
On Error GoTo 0
End Function
Private Function pulseTime() As Long
' This is a live connection to the sheet
pulseTime = wsGetProperty(DEFPulseTime, DEFearliestTime)
End Function
Private Function designMode() As Boolean
' The sheet is only consulted once
If mDesignMode = Empty Then _
mDesignMode = wsGetProperty("designMode", False)
designMode = mDesignMode
End Function
Private Function backgroundPulse() As Boolean
' The sheet is only consulted once
If mBackgroundPulse = Empty Then _
mBackgroundPulse = wsGetProperty("enableBackgroundPulse", False)
backgroundPulse = mBackgroundPulse
End Function
Public Sub kickDog()
Const myName As String = "kickDog"
Dim psMessage As String
If (Ws Is ActiveSheet Or backgroundPulse) _
And Not designMode Then
mNextTime = Now + TimeSerial(0, 0, pulseTime)
On Error Resume Next
Application.OnTime mNextTime, DoWhen
On Error GoTo 0
End If
Exit Sub
End Sub
Public Sub killDog()
If Ws Is Nothing Or mNextTime = 0 Then Exit Sub
On Error Resume Next
Application.OnTime mNextTime, DoWhen, , False
On Error GoTo 0
End Sub
Private Sub Class_Initialize()
Dim errorContext As String
Debug.Print "init conTime"
On Error GoTo enableAndExit
Set wb = ActiveWorkbook
Set Ws = ActiveSheet
On Error GoTo 0
callBackDoWhen = DEFDoWhen
callBackPulseTime = DEFPulseTime
pulseTime
designMode
backgroundPulse
kickDog
Exit Sub
enableAndExit:
If Err <> 0 Then
If Ws Is Nothing Then
errorContext = "ws"
ElseIf wb Is Nothing Then
errorContext = "wb"
End If
End If
End Sub
Private Sub Class_Terminate()
Const myName As String = "Class_Terminate"
On Error Resume Next
killDog
Set Ws = Nothing
Set wb = Nothing
Exit Sub
End Sub
' Manage the timer in response to workbook events
' If the timer is not killed it may cause the workbook
' to reopen after it is closed when the timer calls back.
Private Sub wb_WindowActivate(ByVal Wn As Window)
Const myName As String = "cOnTime.wb_WindowActivate"
Debug.Print myName
' this is handled by ThisWorkbook
End Sub
Private Sub wb_WindowDeactivate(ByVal Wn As Window)
Const myName As String = "cOnTime.wb_WindowDeactivate"
Debug.Print myName
If Not backgroundPulse Then killDog
End Sub
Private Sub wb_BeforeClose(Cancel As Boolean)
Const myName As String = "cOnTime.wb_BeforeClose"
Debug.Print myName
killDog
End Sub
Private Sub wb_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Const myName As String = "cOnTime.wb_BeforeSave"
Debug.Print myName
If SaveAsUI Then killDog
End Sub
(No actual dogs were harmed in the making of this code)
Related
There are ways in stackoverflow that indicate how to:
Refresh all queries asynchronously
Refresh SOME queries one by one(i.e. not asynchronously)
but what I am confusing is how to refresh CERTAIN ranges (for example, given an array of those ranges' name) asynchronously that generated by a query of Power Query in Excel with VBA and execute subsequent sentences in VBA after detecting those asynchronous refreshes are already done.
Anyone who knows how to achieve this? Thx a lot!
Appendix: Ways I've tried which fails to achieve this include:
Sub fail_1()
'This method cannot guarantee showing the msgbox at the end of this sub AFTER the two ranges are refreshed
arrRngName = Array("rng1","rng2")
For Each itm in arrRngName
Range(itm).ListObject.QueryTable.Refresh BackgroundQuery:=True
Next itm
MsgBox "All the refreshes are done asynchronously" 'This is an example of the subsequent sentence
End Sub
Sub fail_2()
'This method cannot guarantee neither that showing the msgbox at the end of this sub AFTER the two ranges are refreshed
arrRngName = Array("rng1","rng2")
For Each itm in arrRngName
With ThisWorkbook.Connections("Query - " & itm).OLEDBConnection
.BackgroundQuery = True
.Refresh
End With
Next itm
MsgBox "All the refreshes are done asynchronously" 'This is an example of the subsequent sentence
End Sub
Sub fail_3()
'This method can guarantee showing the msgbox at the end of this sub AFTER the two ranges are refreshed, but it cannot refresh ALL the ranges at the same time(asynchronously)
arrRngName = Array("rng1","rng2")
For Each itm in arrRngName
With ThisWorkbook.Connections("Query - " & itm).OLEDBConnection
.BackgroundQuery = False
.Refresh
End With
Next itm
MsgBox "All the refreshes are done asynchronously" 'This is an example of the subsequent sentence
End Sub
The following is the Chinese version of this question. Hope to get answers more broadly:
在stackoverflow論壇上有關於刷新Power Query的查詢(Query)的一些回答,但是我想問的是,如何用VBA實現:
祗刷新某幾張特定表,而不是全部的表
異步(asynchronously)刷新(即上述幾張表同時刷新,而不是刷新完一個之後再刷新另外一個)
VBA能夠監測到上述異步刷新的完成,并在刷新完成後執行下一句VBA語句
在stackoverflow论坛上有关于刷新Power Query的查询(Query)的一些回答,但是我想问的是,如何用VBA实现:
只刷新某几张特定的表,而不是全部的表
异步(asynchronously)刷新(即上述几张表同时刷新,而不是刷新完一个之后再刷新另外一个)
VBA能够监测到上述异步刷新的完成,并在刷新完成后执行下一句VBA语句
Unfortunately, there are no events that can be trapped with an OLEDBConnection object, so you will need to devise your own method.
There are two easy options:
1. AfterCalculate
If you have a table on your sheet that is modified by the Query, then you can handle the AfterCalculate event, as shown below:
In ThisWorkbook module
Option Explicit
Private WithEvents mApp As Application
Private mIsManualRefresh As Boolean
Public Sub AwaitManualRefreshComplete()
mIsManualRefresh = True
If mApp Is Nothing Then Set mApp = Application
End Sub
Private Sub mApp_AfterCalculate()
If mIsManualRefresh Then
mIsManualRefresh = False
Debug.Print "Manual refresh complete (after calculate)."
End If
End Sub
and then in a Module:
Public Sub RunMe1()
Dim arrRngName As Variant
Dim itm As Variant
Dim conn As WorkbookConnection
arrRngName = Array("qryAges", "qryGender", "Merge")
ThisWorkbook.AwaitManualRefreshComplete
For Each itm In arrRngName
Set conn = ThisWorkbook.Connections("Query - " & itm)
With conn.OLEDBConnection
.BackgroundQuery = True
.Refresh
End With
Debug.Print "Refresh " & conn.Name
Next
End Sub
2. OnTime
Use a timer to test the Refreshing property on your OLEDBConnection
In a Module:
Public Sub RunMe2()
Dim arrRngName As Variant
Dim itm As Variant
Dim conn As WorkbookConnection
arrRngName = Array("qryAges", "qryGender", "Merge")
For Each itm In arrRngName
Set conn = ThisWorkbook.Connections("Query - " & itm)
With conn.OLEDBConnection
.BackgroundQuery = True
.Refresh
End With
Debug.Print "Refresh " & conn.Name
Next
AwaitManualRefreshComplete arrRngName
End Sub
Public Sub AwaitManualRefreshComplete(Optional arr As Variant)
Static arrRngName As Variant
Dim itm As Variant
Dim conn As WorkbookConnection
Dim isRefreshComplete As Boolean
If Not IsMissing(arr) Then
arrRngName = arr
End If
isRefreshComplete = True
For Each itm In arrRngName
Set conn = ThisWorkbook.Connections("Query - " & itm)
If conn.OLEDBConnection.Refreshing Then
isRefreshComplete = False
End If
Next
If Not isRefreshComplete Then
Application.OnTime _
EarliestTime:=Now + TimeSerial(0, 0, 1), _
Procedure:="AwaitManualRefreshComplete"
Exit Sub
End If
Debug.Print "Manual refresh complete (after time)."
End Sub
I Have a Sub Who opens a new workbook, but this new workbook has its Sub that immediately Activates a user form, and the first Sub never ends, so this is my question How Can I finish the first sub?
first Workbook
Private Sub BotonBalanza_Click()
Workbooks.Open Filename:="C:\Users\proc_221\Desktop\Balanza.xlsm", Password:="genesis1969"
End Sub
Second Workbook
Private Sub Workbook_Open()
Application.Visible = False
Seleccion.Show
End Sub
Thank you
My suggestion would be to deactivate the events when opening the workbook in question
Private Sub BotonBalanza_Click()
Application.EnableEvents=False
Workbooks.Open Filename:="C:\Users\proc_221\Desktop\Balanza.xlsm", Password:="genesis1969"
Application.EnableEvents=True
End Sub
Thanks for all; I fixed the error using a delay time on the code.
Sub Mostrar()
Workbooks.Open Filename:="C:\Users\proc_221\Desktop\Balanza.xlsm", Password:="genesis1969"
End Sub
Private Sub BotonBalanza_Click()
Application.OnTime Now + TimeValue("00:00:03"), "Mostrar"
End Sub
Private Sub Workbook_Open()
Seleccion.Show
End Sub
In Another Instance of Excel
This will run your destination open workbook code only if the application instance is visible.
It will open the destination workbook in another invisible instance and do the job, ensuring the instance gets closed properly and informing of success.
Destination ThisWorkbook Module
Option Explicit
Private Sub Workbook_Open()
If Application.Visible Then
Application.Visible = False
Seleccion.Show
End If
End Sub
Source 'wherever the button is' Sheet Module
Option Explicit
Private Sub BotonBalanza_Click()
Const ProcName As String = "BotonBalanza"
Dim ErrNum As Long
On Error GoTo ClearError
Dim xlApp As Application: Set xlApp = New Application
Dim wb As Workbook: Set wb = xlApp.Workbooks.Open( _
Filename:="C:\Users\proc_221\Desktop\Balanza.xlsm", _
Password:="genesis1969")
' do your stuff, e.g.:
Dim ws As Worksheet: Set ws = wb.Worksheets("Sheet1")
Dim rg As Range: Set rg = ws.Range("A1")
rg.Value = Now
rg.EntireColumn.AutoFit
SafeExit:
On Error Resume Next
If ErrNum = 0 Then
If Not wb Is Nothing Then
wb.Close SaveChanges:=True
End If
xlApp.Quit
MsgBox "Success", vbInformation
Else
If Not wb Is Nothing Then
wb.Close SaveChanges:=False
End If
xlApp.Quit
MsgBox "Failed.", vbCritical
End If
On Error GoTo 0
Exit Sub
ClearError:
ErrNum = Err.Number
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
Resume SafeExit
End Sub
With the use of call statement, I am calling a sub RETURNSEARCHMATCHES that includes UDF FINDCOLLETTEROFNAMEDRANGE(string).
The code where I call the function is below:
Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
On Error Resume Next
Application.EnableEvents = False
If Selection.Count = 1 Then
If Not Intersect(Target, Range("SearchField")) Is Nothing Then
Call OSS_macros.RETURNSEARCHMATCHES
End If
End If
Application.EnableEvents = True
End Sub
I was debugging the code inside RETURNSEARCHMATCHES and I found out that the UDF function FINDCOLLETTEROFNAMEDRANGE(string) is not called by the sub (the code is below):
Public Function FINDCOLLETTEROFNAMEDRANGE(range_name As String) As String
Dim cell_range As Range
Set cell_range = Range(range_name)
If cell_range.Address(0, 0) <> "" Then
FINDCOLLETTEROFNAMEDRANGE = Left(cell_range.Address(0, 0), 1)
Else
FINDCOLLETTEROFNAMEDRANGE = "NONE"
End If
End Function
Sub RETURNSEARCHMATCHES()
Dim cw As Worksheet
Dim is_matchLeft_name As String
Dim is_matchLeft_col As String
Dim last_row As String
Set cw = Sheets("4c.Travel Costs (Search)")
last_row = CStr(cw.Cells(cw.Rows.Count, 2).End(xlUp).Row)
Debug.Print "OK"
is_matchLeft_name = "Is_Match_from_left"
is_matchLeft_col = FINDCOLLETTEROFNAMEDRANGE(is_matchLeft_name)
Debug.Print is_matchLeft_col
End Sub
Do you know why it is like this?
Am I supposed to pass this UDF function somewhere in the call statement?
I'm building a form that can take the values from the clipboard and auto fill itself.
In order to get the values I use application.ontime to run a macro every two seconds and read the clipboard. The start is done in userform initialize.
That works fine.
Sub Userform_Initialize()
On Error Resume Next
fireTime = Now + TimeValue("00:00:02")
Application.OnTime EarliestTime:=fireTime, Procedure:="copy", Schedule:=True
On Error GoTo 0
End Sub
If I close the userform I added a queryclose to make sure the copy macro stops:
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
Application.OnTime EarliestTime:=fireTime, Procedure:="copy", Schedule:=False
End Sub
Works fine also.
The actual macro is this:
Public fireTime As Date
Sub copy()
On Error GoTo ErrHandler
Dim oData As New DataObject
Dim DataObj As MSForms.DataObject
Set DataObj = New MSForms.DataObject
DataObj.GetFromClipboard
strPaste = DataObj.GetText(1)
Row1 = Split(strPaste, vbNewLine)(0)
col = Split(Row1, vbTab)
If UBound(Split(col(14), "-")) = 2 Then
If Len(col(0)) = 7 Then
If Left(col(3), 4) = "4600" Then
oData.SetText Text:=Empty 'Clear
oData.PutInClipboard 'take in the clipboard to empty it
UF_RegistreraVM.TB_LevNr.Text = col(0)
Levnr = col(0)
' ... and so on..
'Line below does not work
Application.OnTime EarliestTime:=fireTime, Procedure:="copy", Schedule:=False
Exit Sub
End If
End If
End If
ErrHandler:
On Error Resume Next
fireTime = Now + TimeValue("00:00:02")
Application.OnTime EarliestTime:=fireTime, Procedure:="copy", Schedule:=True
On Error GoTo 0
End Sub
And the only line that does not work is when I set application.ontime to false in the nested ifs.
That line is the same as the one in queryclose, but it doesn't work here.
When I debug the code errors on that line and due to On Error GoTo ErrHandler it jums down to ErrHandler and sets a new time to run the macro.
What is the issue that with the code, why can't I turn of the ontime inside the ifs?
I'm currently working on a set of code that locks and unlocks a sheet based on the username of the current user, nothing fancy. This code works quite well, except during the after save portion. Intermittently, when saved on the company server, on my computer only (though its only been lightly tested on 3 computers), I get a 50290 error with anything that tries to modify the sheet - even application.wait. Eventually I traced this to the workbook not being ready (application.ready returns false after save, but true if I manually run the code or during the open workbook event). It seems that the standard procedure is to do while loop until application.ready = true, but that locks the computer up with no recovery. I've tried methods of slowing the loop down (sleep, doevent, wait) and none of those seem to fix the issue.
Any ideas?
Sub AuthorizedUser()
- initialize variables here
On Error GoTo errorhandler
Do 'attempt to wait until sheet is ready
DoEvents
Loop Until Application.Ready = True
- Do stuff to protect sheet here -
- If the sheet isn't ready, error state -
- Any change, such as application.wait, coloring cells, or protecting sheet is what the error state occurs on -
errorhandler:
MsgBox "Unlocker broke. Please hit the unlock button"
End Sub
Private Sub Workbook_AfterSave(ByVal Success As Boolean)
Call AuthorizedUser
End Sub
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
- do stuff to protect worksheet -
End Sub
Private Sub Workbook_Open()
Call AuthorizedUser
Application.Run "sheet1.ClearSheet"
End Sub
editted to remove the inner workings of the code. This code works just fine when excel is ready and does things as intended.
Let me know how this one works for you. If it works and you want it, I can make a list of the changes that I made
Option Explicit
Private Const THE_PASSWORD As String = "TDM"
Private Sub Auto_Open()
Call AuthProtect(False)
ThisWorkbook.Sheets(1).Cells.Clear
End Sub
Private Function GetAuth() As Long
With ThisWorkbook.Sheets("Authorized users")
Dim managers As Range
Set managers = .Range("A1").Resize(.Range("A1").End(xlDown).Row)
Dim workers As Range
Set workers = .Range("B1").Resize(.Range("B1").End(xlDown).Row)
End With
On Error GoTo errorhandler
While Not Application.Ready
DoEvents
Wend
On Error GoTo 0
Dim currentUser As String
currentUser = Environ$("username")
Dim auth As Long
Dim cell As Range
For Each cell In Union(managers, workers)
If LCase$(currentUser) = LCase$(cell.Value2) Then
auth = cell.Column
Exit For
End If
Next cell
GetAuth = auth
Exit Function
errorhandler:
GetAuth = -1
End Function
Private Sub AuthProtect(ByVal doProtect As Boolean)
On Error GoTo errorhandler
SpeedUp True
If doProtect Then
With ThisWorkbook
.Unprotect THE_PASSWORD
With .Sheets("Authorized users")
.Unprotect THE_PASSWORD
.Columns("B").Locked = True
.Protect THE_PASSWORD
.Visible = xlVeryHidden
End With
With .Sheets("Part Tracker")
.Unprotect THE_PASSWORD
.Rows("6:" & Rows.Count).Locked = True
.Protect THE_PASSWORD
End With
.Protect THE_PASSWORD
End With
Else
Select Case GetAuth
Case 1
With ThisWorkbook
.Unprotect THE_PASSWORD
With .Sheets("Authorized users")
.Visible = xlSheetVisible
.Unprotect THE_PASSWORD
.Columns("B").Locked = False
.Protect THE_PASSWORD
End With
.Protect THE_PASSWORD
End With
Case 2
With ThisWorkbook.Sheets("Part Tracker")
.Unprotect THE_PASSWORD
.Rows("6:" & Rows.Count).Locked = False
.Protect THE_PASSWORD, _
AllowInsertingRows:=True, _
AllowInsertingHyperlinks:=True, _
AllowDeletingRows:=True, _
AllowFiltering:=True, _
UserInterfaceOnly:=True, _
DrawingObjects:=False
.EnableOutlining = True
End With
Case -1
MsgBox "Error with Application.Ready state"
Case Else
With ThisWorkbook.Sheets("Authorized users")
Dim managers As Range
Set managers = .Range("A1").Resize(.Range("A1").End(xlDown).Row)
End With
Dim managerList As String
Dim cell As Range
For Each cell In managers
managerList = managerList & " " & cell.Value2 & vbCrLf
Next cell
MsgBox "You do not have write access to this file." & vbNewLine & "To request access, please seek out any of the following managers: " & vbCrLf & vbCrLf & managerList
End Select
End If
errorhandler:
SpeedUp False
End Sub
Sub SpeedUp(ByVal toggleOn As Boolean)
With Application
.Calculation = IIf(toggleOn, xlCalculationManual, xlCalculationAutomatic)
.ScreenUpdating = Not toggleOn
.DisplayStatusBar = Not toggleOn
.EnableEvents = Not toggleOn
End With
End Sub
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Call AuthProtect(True)
End Sub
Private Sub Workbook_AfterSave(ByVal Success As Boolean)
Call AuthProtect(False)
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Call AuthProtect(True)
End Sub