This is partial code. Basically I want to run a loop that terminates either when totalHoursNeeded is at 0 or below, or currentDate is at 6/30. The variable totalHoursNeeded is a global variable, and is reduced incrementally in function runReport. During runReport, currentDate, which is also a global variable, is also reassigned.
So lets say currentDate is initialized as 3/1/2016, and totalHoursNeeded is initialized as 234. runReport will be run on the basis of 200 hours, will set current date to be something like 5/5/2016, and then set totalHoursNeeded to be 34 (200 is the max each report can be run). Then, what I want to do is run another report, but instead of it being 200 and 3/1/2016, I want it to be 34 and 5/5/2016.
The issue is that these reports can't go past 6/30/2016; so for instance if I need to run a report based on 200 hours, and the starting date is 6/23/2016, the ending date needs to be 6/30/2016 and the amount of hours in the report needs to be correspondingly reduced.
Anyway, the while loop below is not terminating
Dim currentDate As Date
Dim totalHoursNeeded As Long
Dim totalHoursInExtension As Long
Dim hoursPerDay As Long
While totalHoursNeeded > 0 Or Not (Month(currentDate) = 6 And Day(currentDate) = 30)
'make a new word document object
Dim nWord As New Document
Set nWord = Documents.Open("c:\document\here", Visible:=False)
'run and save the report
On Error GoTo errhandler:
'if the extensions have not been written through 6/30 of any year
If Not (Month(currentDate) = 6) And Not (Day(currentDate) = 30) Then
'run a report based on the current row, two worksheets, and word object
totalHoursNeeded = totalHoursNeeded - runReport(row, summary, oWorksheet, nWord)
saveReport row, totalHoursInExtension, oWorksheet, nWord
Else
End If
' Close things
nWord.Close False
Wend
Related
Turns out my organisation have blocked all Win API calls from MS Office code with their ASR rules and are unwilling to apply any exclusions so any old code I have no longer works. Anyone help with Excel VBA code that can convert local datetime into UTC?GMT while taking into account DST. I tried using the COM object, but wasn't sure what to do with DST offsets. Users are in multiple countries and I'm not sure exactly where since most people work remotely.
Was directed to this answer that uses Outlook which gives exactly what I wanted. Noticeably slower than the Win API calls on large scale repetitive calls, but any complaints can be directed to the company's IT for their security policy change.
https://stackoverflow.com/a/45510712/16578424
Option Explicit
'mTimeZones by Patrick Honorez --- www.idevlop.com
'with the precious help of Julian Hess https://stackoverflow.com/a/45510712/78522
'You can reuse but please let all the original comments including this one.
'This modules uses late binding and therefore should not require an explicit reference to Outlook,
'however Outlook must be properly installed and configured on the machine using this module
'Module works with Excel and Access
Private oOutl As Object 'keep Outlook reference active, to save time in recurring calls
Private oOutlTimeZones As Object 'keep Outlook reference active, to save time in recurring calls
' seems to drop the reference if use previous scheme of returning boolean
' returning the actual object is more correct in any case
Private Function GetOutlookTimeZones() As Object
If oOutl Is Nothing Or oOutlTimeZones Is Nothing Then
Debug.Print "~"
On Error Resume Next
Err.Clear
Set oOutl = GetObject(, "Outlook.Application")
If Err.Number Then
Err.Clear
Set oOutl = CreateObject("Outlook.Application")
End If
Set oOutlTimeZones = oOutl.TimeZones
End If
Set GetOutlookTimeZones = oOutlTimeZones
On Error GoTo 0
End Function
Function ConvertTime(DT As Date, Optional TZfrom As String = "Central Standard Time", _
Optional TZto As String = "W. Europe Standard Time") As Date
'convert datetime with hour from Source time zone to Target time zone
'valid Source & Target time zones can be found in your registry under: HKEY_LOCAL_MACHINE/SOFTWARE/Microsoft/Windows NT/CurrentVersion/Time Zones/
'this version using Outlook, properly handles Dailight Saving Times, including for past and future dates
'it includes a fix for the fact that ConvertTime seems to strip the seconds
'krammy85 2019-01-25 Edit: Outlook rounds minutes when it strips seconds, so modified code to strip seconds (without rounding) prior to running Outlook's ConvertTime.
Dim sourceTZ As Object
Dim destTZ As Object
Dim seconds As Single
Dim DT_SecondsStripped As Date
Dim oOutlTimeZones As Object: Set oOutlTimeZones = GetOutlookTimeZones()
If Not (oOutlTimeZones Is Nothing) Then
'fix for ConvertTime stripping the seconds
seconds = Second(DT) / 86400 'save the seconds as DateTime (86400 = 24*60*60)
DT_SecondsStripped = DT - seconds
Set sourceTZ = oOutlTimeZones.Item(TZfrom)
Set destTZ = oOutlTimeZones.Item(TZto)
ConvertTime = oOutlTimeZones.ConvertTime(DT_SecondsStripped, sourceTZ, destTZ) + seconds 'add the stripped seconds
End If
End Function
' returns number of minutes ahead of UTC (positive number) or behind
Function GetOffsetAt(DT As Date, TZfrom As String) As Long
Dim utc_DT As Date: utc_DT = ConvertTime(DT, TZfrom, "UTC")
GetOffsetAt = DateDiff("n", utc_DT, DT)
End Function
Sub test_ConvertTime()
Dim t As Date: t = #8/23/2017 6:15:05 AM#
Debug.Print t, ConvertTime(t), Format(t - ConvertTime(t), "h")
Debug.Print t, ConvertTime(t, "Central Standard Time", "W. Europe Standard Time"), Format(t - ConvertTime(t), "h")
End Sub
Sub test_DumpTZs()
Dim TZ As Object: For Each TZ In GetOutlookTimeZones()
Debug.Print "TZ:", TZ.Id, TZ.Name
Next TZ
End Sub
Last two Subs are not really necessary.
For example, I can now simply refer to the following to get the user's current timezone, regardless of daylight saving, and return the UTC converted value. This could be wrapped in a Format function to display accordingly.
ConvertTime(Now, oOutlTimeZones.CurrentTimeZone.id, "UTC")
I am trying to find a specific subject in a shared outlook calendar on a specific date. The subject, the date and the shared calendar is passed as arguments. The script below works (I simplified it a bit for readability in this thread). BUT it is extremely slow since the "for" and "if" statement goes through all the schedules in all the dates. I got about 20 shared calendars to go through over 15 days time period; equating to about 300 times that the function is called (300 cells) in excel. This takes a huge amount of time to process, like an hour or or so. I speeded it up a little by exiting the "for" loop as soon as a match is found. But for those dates when there is no match, the for loop has to go through all the calendar item. And some calendar has huge number of schedules. Is there any way to actually only extract the schedules on the specified date, leaving the "for" loop to go through only handful of schedules on that day? Any help would be appreciated.
Function FindAttendance(xDate As Date, xSubject As String, xEmail As String) As Boolean
On Error GoTo ErrHand:
Application.ScreenUpdating = False
Const olFolderCalendar As Byte = 9
Dim olApp As Object: Set olApp = CreateObject("Outlook.Application")
Dim olNS As Object: Set olNS = olApp.GetNamespace("MAPI")
Dim olFolder As Object
Dim olApt As Object
Dim objOwner As Object: Set objOwner = olNS.CreateRecipient(xEmail)
Dim FromDate As Date
Dim ToDate As Date
FindAttendance = False
objOwner.Resolve
If objOwner.Resolved Then
Set olFolder = olNS.GetSharedDefaultFolder(objOwner, olFolderCalendar)
End If
If olFolder.Items.Count = 0 Then Resume cleanExit
On Error Resume Next
For Each olApt In olFolder.Items
If olApt.Start = xDate Then
If (olApt.Subject = xSubject) Then
FindAttendance = True
Exit For
Else
End If
Else
End If
Next
On Error GoTo 0
Application.ScreenUpdating = True
cleanExit:
Application.ScreenUpdating = True
Exit Function
ErrHand:
Resume cleanExit
End Function
First of all, iterating over all items in the folder is not really a good idea. You need to use the Find/FindNext or Restrict methods of the Items class to get only items that correspond to your conditions.
Read more about that in the following articles:
How To: Retrieve Outlook calendar items using Find and FindNext methods
How To: Use Restrict method in Outlook to get calendar items
Second, don't use a straight comparison:
If (olApt.Subject = xSubject) Then
Instead, use the contains search criteria where a subject line may include a substring, not be equal. For example, the following query performs a phrase match query for keyword in the message subject:
filter = "#SQL=" & Chr(34) & "http://schemas.microsoft.com/mapi/proptag/0x0037001E" _
& Chr(34) & " ci_phrasematch " & "'keyword'"
Third, you may combine the following conditions into a single search string:
If olApt.Start = xDate Then
If (olApt.Subject = xSubject) Then
Never loop through all items in a folder, especially if it is an online (non-cached folder), that is what Items.Find/FindNext and Items.Restrict are for. Use a query like
#SQL="http://schemas.microsoft.com/mapi/proptag/0x0E1D001F" = 'TheValue'
Note that the search query above is on the PR_NORMALIZED_SUBJECT_W MAPI property; searches on the OOM property Subject are flaky in OOM.
You can add more conditions with OR or AND connectors. Also note that a check like If olApt.Start = xDate will most likely fail since Date values are floats and the condition will never be satisfied because of the round-off errors - always use a range (e.g. < start + 1 sec and > start - 1 sec)
In general, Excel 2019 is around twice slower than Excel 2010 on the same hardware. That factor is fine because the hardware improvement more than compensates.
However, I noticed that the use of connected objects is around 20 times slower in Excel 2019 than 2010. The problem is not in memory allocation and release, but in the handling of connected objects. In the example shown below, the object has just one member, of the same type. A chained series of such an object takes 4 seconds to build with Excel 2010 and 100 with Excel 2019 (x 25) on my current computer (Dell XPS 5). Hopefully, it is possible to have both versions on the same machine. The memory release is slower by a similar ratio.
Specifically the example has two modules:
A class module "SmallListItem" with this code:
Public NextItem As SmallListItem
And a standard module with the following code:
' measure the time taken to allocate the list and delete it
Public Sub TimeForAllSizes()
Dim r As Range
Dim i As Integer, maxI As Integer
Dim first As SmallListItem
Dim startTime As Single, elapsedTime As Single
Set r = Range("LengthTimeRange")
Let maxI = r.Rows.Count
Call Range(r.Cells(1, 2), r.Cells(maxI, 3)).ClearContents
Let i = 1
Do
' build object
Let startTime = Timer()
Set first = BuildList(r.Cells(i, 1).Value)
Let elapsedTime = Timer() - startTime
Let r.Cells(i, 2).Value = elapsedTime
' release object
Let startTime = Timer()
Call ReleaseList(first)
Let elapsedTime = elapsedTime + Timer() - startTime
Let r.Cells(i, 3).Value = Timer() - startTime
Let i = i + 1
Loop Until i > maxI Or elapsedTime > 100
Call MsgBox("Done!")
End Sub
' build list of SmallListItem
Private Function BuildList(ByVal length As Long) As SmallListItem
Dim j As Long
Dim index As SmallListItem
Set index = New SmallListItem
Set BuildList = index
For j = 1 To length - 1
Set index.NextItem = New SmallListItem
Set index = index.NextItem
Next j
End Function
' deletes memory connected to first
Private Sub ReleaseList(ByRef first As SmallListItem)
Dim index As SmallListItem, prec As SmallListItem
Set index = first
' go to the end and release the preceding item
Do Until index.NextItem Is Nothing
Set prec = index
Set index = index.NextItem
Set prec.NextItem = Nothing
Loop
Set first = Nothing
End Sub
The spreadsheet has just one named range, visible below (the button triggers the macro TimeForAllSizes):
I tried finding workarounds, but wasn't able.
The run time ratio of x25 makes the user experience very different. That macro is several times faster on my previous computer with Excel 2010 than on my current one with Excel 2019.
I have ~150 Queries in a Microsoft Excel file. Clicking "Refresh all" would freeze my PC and resulted in some of the data not being able to load correctly even though network connection is good.
I'm looking to find a way to program "Refresh All" button so that it load maybe 5 to 10 queries at a time then move on the the next. I tried that manually and it loads without any problem. Just 150 queries at a time is too much.
Tks.
I couldn't find any simple way of resolving your query, but I have some thougts of a kind of a workaround. Below you can find two VBA macros that may help you a bit. The first code lists all queries that you have in your workbook in a new tab:
Sub ListQueries()
'Add tab to list all queries
Dim wsQueries As Worksheet
Set wsQueries = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
wsQueries.Name = "Query list"
wsQueries.Range("a1").Value = "Query name"
Dim con As WorkbookConnection
For Each con In ThisWorkbook.Connections
If UCase(Left(con.Name, 8)) = "QUERY - " Then wsQueries.Range("a1048576").End(xlUp).Offset(1, 0).Value = con.Name
Next con
End Sub
When it is finished you can use the second one. This time it will loop through all queries and refresh them but only as many as you will define in this clause If counter = 10 Then Exit For - if you want 15 then feel free to amend it. For each refereshed query it will add 'Yes' in column B. When you run RefreshQueries it at first checks whether a query is marked as 'Yes' and omit it if it's true.
Sub RefreshQueries()
Dim counter As Byte
counter = 0
'Range with query names
Dim rQueries As Range
Dim rQuery As Range
Dim wsQueries As Worksheet
Set wsQueries = ThisWorkbook.Worksheets("Query list")
Set rQueries = wsQueries.Range("a2:a" & wsQueries.Range("a1048576").End(xlUp).Row)
wsQueries.Range("b1") = "Refreshed"
For Each rQuery In rQueries
If counter = 10 Then Exit For 'if more than 10 queries refreshed then exit loop
'If query is refreshed then omit it and go to next
If rQuery.Offset(0, 1) <> "Yes" Then
ThisWorkbook.Connections(rQuery.Value).Refresh
rQuery.Offset(0, 1) = "Yes"
counter = counter + 1
End If
Next rQuery
End Sub
To sum up, you should run ListQueries once and RefreshQueries as many times as required to refresh all of them.
I have made a code using lotusscript that would calculate the time difference between the two fields, now I want to calculate the difference between dates. I've pretty much started lotusscripting and I still got a minimum knowledge about it. Hope you can help me. Here's the code that I've made to calculate time difference:
Sub UpdateDuration()
Dim ws As New NotesUIWorkspace
Dim uidoc As NotesUIDocument
Dim starttime As NotesDateTime
Dim endtime As NotesDateTime
Dim duration As Integer
Set uidoc = ws.CurrentDocument
If uidoc.FieldGetText("StartTime") = "" Then
Exit Sub
Elseif uidoc.FieldGetText("StartTime") = "" Then
Exit Sub
End If
Set starttime = New NotesDateTime( uidoc.FieldGetText("StartTime") )
Set endtime = New NotesDateTime( uidoc.FieldGetText("EndTime") )
duration = endtime.TimeDifference( starttime )
Call uidoc.FieldSetText("Duration", Cstr(duration) )
Call uidoc.Refresh()
End Sub
TimeDifference returns the number of seconds between two NotesDateTimes. There are 60 * 60 * 24 seconds in a day, and that works out to 86400. So just write your code exactly as above and divide the result by 86400. (The only other thing you might want to change is your field and variable names, to reflect the fact that you are working with date input instead of time.)