I am updating a VBA app which pulls all events from a calendar for a given month and places them in a calendar that is drawn on the word doc. I am getting different results with regards to allday events between my machine (running Microsoft 365) and another machine (running an older version which I can get specifics for, but the .dot it creates is Word 97-2003). The query I'm using to filter is: "[Start] >= """ & start & """ and [Start] <= """ & end & """" where start is say "3/1/2022 12:00 AM" and end is "3/31/2022 11:59 PM".
On my machine, the allday events are pulled as just a single item so when I run through my list of items for the month of March, if an allday event runs from 3/1-3/5, it will only encounter this event once and I insert it into the calendar on 3/1. However, on the other machine, it will place the allday event on each day it takes place, as if it is finding 5 separate calendar items for this allday event. The code is the same between both machines.
Relevant code (modified for brevity):
' get the appointments
Set olns = olap.GetNamespace("MAPI")
Set CurFolder = olap.ActiveExplorer.CurrentFolder
Set olappts = olap.ActiveExplorer.CurrentFolder
Set mycol = olappts.items
mycol.Sort "[Start]"
mycol.IncludeRecurrences = True
Set allAppts = mycol.Restrict(rangequery)
I don't have access to the other machine so I cannot debug, and I am not sure how to reproduce this. Is it possible I need an older version or maybe an older reference to a library?
Thanks!
Related
I have the following snippet of code within my onload function. Checking to see if the date is Monday and if so then check within the log_EmailProductionSchedule to see if todays date is logged. If not the app will automatically send the email and add a log to this table with todays date, preventing the application from sending another email. However, each time I open the application the email is being generated and a new log is being inserted. where have I gone wrong with this code?
If Weekday(Now) = vbMonday Then
If DCount("*", "log_EmailProductionSchedule", "[sentDate] = #" & Format(Now, "mm\/dd\/yyyy") & "#") = 0 Then
'send email
Call SendProductionEmail
CurrentDb.Execute ("INSERT into log_EmailProductionSchedule (sentDate) select date()")
End If
End If
Set a break point on DCount. Your variables are probably not being set to what you think they are.
Instead if messing around with Format just use the date function
If Weekday(Now) = vbMonday Then
If DCount("*", "log_EmailProductionSchedule", "[sentDate] = Date()") = 0 Then
'send email
Call SendProductionEmail
CurrentDb.Execute ("INSERT into log_EmailProductionSchedule (sentDate) select date()")
End If
End If
click here to learn about the peculiarities with VBA and SQL in MS Access. TL:DR; Jet, the database engine that runs your SQL uses whatever your machine regional settings are, but VBA is fixed to mm/dd/yyyy
I built a very complex SeleniumBasic via VBA via Excel Addin setup that interacts with one of the leading ticketing system websites to scrap and populate data. The system interacts with 90+ different fields/clickables with 3 different pages, 6 different tabs, and nested popups...deployed to 120 users who use the automations about 20 times per day.
And it has been working flawlessly for over a year...
We have just provisioned 20 more users on the same system, and their automations refuse to work.
Here is where I am at with my research:
I am able to manually step through code on the new system and have it successfully go through the entire automation, so the issue probably has something to do with the speed VBA/Selenium is trying to interact with the website.
Once the system is unable to find a field or clickable, it refuses to find any other ones after that.
The way the system is built in order to go as fast as possible is via standard VBA error handling. It fails to find something, it goes to the error handler, the error handler says to wait for one second then try again. Again, this system has been working flawlessly for over a year and is currently working on 120 user's systems.
To see if maybe Selenium was refusing to reload the clickable, I broke out the error handling from a Resume to a Resume Next, and then had a do while loop with a boolean flag to keep trying until it was successful, but after the first failure, it refused to find anything else, including different fields
The one thing the 20 new users have in common is that they are all using v66 of Chrome, whereas all of the systems that are working have old copies of Chrome that are at least 9 months old
Thinking this might be an issue, I grabbed all of the ChromeDrivers and systematically went through one by one to test if we got a different performance with a different ChromeDriver, but all of the ChromeDrivers had the same error
So that is where I stand. I'm wondering if there is some key insight I am missing or a workaround that will get newer versions of Chrome to retry the fields. Or...do I need to try a VBA/Selenium tool other than SeleniumBasic to fix this. Or...do I need to roll back these 20 users to older versions of Chrome.
Thanks for sharing your expertise.
''''Check to see if there are any aliases=================================
For AliasCheck = 2 To AliasCounter + 1
If Hash = Sheets("Temp Subjects & Locations").Range("AY" & AliasCheck) Then
AliasName = Sheets("Temp Subjects & Locations").Range("AY" & AliasCheck)
AliasCount = AliasCount + 1
AliasDisplayName = Sheets("Temp Subjects & Locations").Range("AZ" & AliasCheck)
temp1 = ""
temp2 = ""
Call countryDictionary
'drops the country back into Excel to later remove the dupes
temp1 = Sheets("Temp Subjects & Locations").Range("BA" & AliasCheck)
temp2 = dict(temp1)
Sheets("Temp Subjects & Locations").Range("BG" & AliasCount + 1) = temp2
''''Click to add AKA's names
iframeText = "iframe_win_" & AddParty
robot.SwitchToDefaultContent
robot.SwitchToFrame iframeText
iframeTracker = iframeTracker + 1
iframeText = "iframe_win_" & iframeTracker
robot.SwitchToDefaultContent
robot.SwitchToFrame iframeText
robot.FindElementById("X_SUBJECT_ALTERNATE_NM.X_ALTERNATE_NM").SendKeys (AliasDisplayName)
robot.FindElementById("dijit_form_Button_0").Click
End If
Next AliasCheck
The AddParty variable is a way to track the number of the pop-up we came from.
The iFrameTracker variable is a way to track the number of the pop-up we are going to...the system sequentially numbers its pop-ups...instead of legible names...
The newer systems will make it down to the SendKeys and then decide not to work. On a resume next, it will then refuse to find the OK button ("dijit_form_Button_0")
Here is the code I was playing around with to see if I could get it to retry using a "Resume Next" instead of a "Resume"
robot.FindElementById("X_SUBJECT_ALTERNATE_NM.X_ALTERNATE_NM").SendKeys (AliasDisplayName)
Do While FailRetry = True
FailRetry = False
robot.FindElementById("X_SUBJECT_ALTERNATE_NM.X_ALTERNATE_NM").SendKeys (AliasDisplayName)
Loop
errHandler4:
If errorCounter < 21 Then
Application.wait (Now + TimeValue("00:00:01"))
errorCounter = errorCounter + 1
FailRetry = True
Resume Next
Else
MsgBox "Reached 20 second timeout. Stopping processing."
Exit Sub
End If
I have a file with the below macro. And basically I need it to close all the workbooks that opens however one of my files name changes everyweek so for example, for this week it is called Special Services 1503,next week it will be Special Services 1504 etc. Any idea on how to edit the below code so that I can close this file without manually editing the number in vba?
Workbooks("2014 Actuals").Close SaveChanges = True
Workbooks("Special Services Budget 2015").Close SaveChanges = True
The above work because no editing, the below works but I manually have to change week number from 1504 to 1505 etc every week.
Workbooks("Special Services 1504").Close SaveChanges = True
Any ideas guys?
If I understood the logic, you only need to build a dynamic index:
firstWeek2015 = 1500 '<-- starting seed
yearFactor = Year(Now()) - 2015 '<-- we take the current year and we subtract 2015: this year it will be 0, next year 1 etc.
weekFactor = WorksheetFunction.WeekNum(Now()) '<--we just take the current week
newIndex = firstWeek2015 + yearFactor*52 + weekFactor
and replace it into your workbook name:
Workbooks("Special Services " & newIndex).Close SaveChanges = True
Even if I would rather:
1) Use the same logic that you used to open the file;
2) Use a RegEx-based solution (if "Special Services ????" is the only file of that kind).
I'm adding this as a separate answer because it's a completely different approach from the previous one:
If and only if you are sure that only that workbook has a name which looks like Special Services 1054, then you can use the Like operator like this :
For Each objWb In Workbooks
If objWb.Name Like "Special Services *"
objWb.Close SaveChanges = True
End If
Next objWb
As stated in my previous answer, this approach is more reliable than the other one but only if you are 100% sure that there might not be another workbook with a similar name opened.
For reasons beyond my control we are using Access 2010 to update linked SharePoint lists to keep them synchronized to our CMDB. We obtain reports from the CMDB in CSV format, and link them to Access as well. We then use a combination of Access VBA and predefined queryies to add new data, or update or soft delete existing data. One list in particular is causing problems. Specifically, inserts/soft deletes seem to work, but Access exhausts resources and crashes when running the update query. Pulling up the resource monitor shows that memory usage constantly increases as the application runs, and Access finally fails when ~ 1.6 GB or RAM has been allocated to it (on a 4 GB machine with a 6 GB swap file, Windows 7 64 bit, but 32 bit Access).
I use two queries in addition to the VBA code. One query retrieves a result set that allows me to determine which row in the SharePoint list is to be updated (if any), while the other identifies which columns from the report update corresponding columns in the SharePoint list, the join condition between the linked report and the corresponding list, and the row in SP to be updated, identified by by its composite key. Fairly standard stuff, I think.
We have to use this approach (or one substantially similar) due to the fact that the SharePoint list has associated workflows. We found that if we wrote our SQL to perform standard set-type updates, the updates occurred too quickly, overloading Sharepoint's workflow engine and causing the workflows to fail.
I've tried a number of alternate techniques:
Using a recordset edit/update sequence rather than the query/exec
shown below. That consumes memory even more quickly, and spikes the
CPU to 26% vs. 12%.
As shown in the VBA code below, I've tried closing and reopening the queries every
100 rows, as well as using transactions. Neither technique results in
an improvement.
I've tried disabling then re-enabling and extending Access'
SharePoint caching mechanism, with no success.
I've tried using parameterized queries. This technique does not work
as we must update a number of memo fields, and query parameters max
out at 255 characters.
Running a database compact/repair does not release allocated memory.
This is the VBA code to execute the queries:
Private Sub runUpdt()
Dim oQdfUpdt As DAO.QueryDef
Dim oRs As DAO.Recordset
Dim oWrkSpc As DAO.Workspace
Dim strmsg As String
On Error GoTo Handler
logMsg "Entering method runUpdt in class clsAppFsFin"
Debug.Print "Entering method runUpdt in class clsAppFsFin", Now()
Set oRs = CurrentDb.QueryDefs("slctAppFsFinRowsForUpdt").OpenRecordset(dbOpenDynaset, dbReadOnly)
Set oQdfUpdt = CurrentDb.QueryDefs("updtAppFsFin")
Set oWrkSpc = DBEngine.Workspaces(0)
Do While (Not oRs.EOF)
oWrkSpc.BeginTrans
If (isUpdated(oRs)) Then
oQdfUpdt.Parameters("CHGTXT") = "System Change"
oQdfUpdt.Parameters("CID") = oRs.Fields("RYCID")
oQdfUpdt.Execute
' inserts a row into the flg_is_updt table
oFlgUpdt.insFlgIsUpdt oRs.Fields("RYAID")
ElseIf (oRs.Fields("SPCTX") <> "System NoChange") Then
oQdfUpdt.Parameters("CHGTXT") = "System NoChange"
oQdfUpdt.Parameters("CID") = oRs.Fields("RYCID")
oQdfUpdt.Execute
' inserts a row into the flg_is_updt table
oFlgUpdt.insFlgIsUpdt oRs.Fields("RYAID")
End If
oWrkSpc.CommitTrans
If ((oRs.AbsolutePosition Mod 100 = 0) And (oRs.AbsolutePosition > 0)) Then
strmsg = "Updated " & oRs.AbsolutePosition & " rows. Class: clsAppFsFin, Method: runUpdt."
Debug.Print strmsg, Now()
logMsg strmsg
Dim curFSCID As String
curFSCID = oRs.Fields("RYCID")
oRs.Close
Set oRs = Nothing
oQdfUpdt.Close
Set oQdfUpdt = Nothing
Set oRs = CurrentDb.QueryDefs("slctAppFsFinRowsForUpdt").OpenRecordset
Set oQdfUpdt = CurrentDb.QueryDefs("updtAppFsFin")
oRs.FindFirst "RYCID = '" & curFSCID & "'"
End If
' sleep .1 seconds to avoid overloading the upstream workflow
Sleep SLEEPTIMEINMILLIS
oRs.MoveNext
Loop
strmsg = "Final update count: " & oRs.RecordCount & " rows. Class: clsAppFsFin, Method: runUpdt."
logMsg strmsg
Debug.Print strmsg, Now()
oRs.Close
oQdfUpdt.Close
Set oRs = Nothing
Set oQdfUpdt = Nothing
Debug.Print "Exiting method runUpdt in class clsAppFsFin", Now()
logMsg "Exiting method runUpdt in class clsAppFsFin"
Exit Sub
Handler:
oWrkSpc.Rollback
Debug.Print Err.Number, Err.Description
logError Err.Number, Err.Description
End Sub
Here are the select and update queries executed by the VBA code
Select query:
SELECT APFF.[App ID] AS SPAID,
APFF.Server AS SPHST,
APFF.Directory AS SPDIR,
RAppAH.AppID AS RYAID,
RAppAH.Host AS RYHST,
RAppAH.FSCID AS RYCID
<
snip
>
FROM (AppCert
INNER JOIN AppFileSystemFin AS APFF
ON AppCert.[App ID] = APFF.[App ID])
LEFT JOIN RAppAH
ON APFF.FSCID = RAppAH.FSCID
WHERE APFF.FSCID = [RAppAH].[FSCID]
AND AppCert.State = "8 - Complete"
AND RAppAH.FSCID IS NOT NULL
AND APFF.[Change In SoR - Text] <> "System Remove"
ORDER BY APFF.ID;
Update query:
UPDATE AppFileSystemFin
INNER JOIN RAppAH
ON AppFileSystemFin.FSCID = RAppAH.FSCID
SET AppFileSystemFin.Server = [RAppAH].[Host],
AppFileSystemFin.Directory = [RAppAH].[Directory],
<
snip
>
WHERE AppFileSystemFin.ID = [ID];
The issue is now resolved. In the update query shown above, the line:
WHERE AppFileSystemFin.ID = [ID];
does not refer to Sharepoint's system-generated ID column. Instead, it refers to an internally generated key field that we had to use in order to be able to perform SQL join operations between lists.
The query has been updated to use SharePoint's generated ID column instead. This minor update resolves the memory allocation issue and in turn, allows updates to proceed more quickly - now requiring only about a third of the previous runtime to complete execution.
I use Outlook 2007 on Windows 7. I have recently installed iCloud have unfortunately realised that Google Calendar Sync will only sync the default calendar. I was wondering if someone could help me out with a simple VBA macro that would
Empty the default calendar of all appointments
Copy all appointments from the iCloud Calendar to the default calendar
Many thanks!
Health warning
Everything in this answer was discovered by experimentation. I started with VB Help, used F2 to access the object model and experimented until I found what worked. I did buy a highly recommended reference book but it contained nothing important I had not discovered and omitted much that I had discovered.
I suspect that a key feature of the knowledge I have gained is that it is based on many different installations. Some of the problems encountered may have been the result of installation mistakes which would explain why reference book authors did not know of them.
The code below has been tested with Outlook 2003. I have tested similar code with Outlook 2007.
Output selected properties of appointments within default Calendar to Immediate window
You reported that the first version of this routine gave an error: "Runtime error '-2147467259 (80004005)': You must enter a positive duration."
According to the websites I found with Google, error 80004005 means a system file is corrupt.
An appointment has three related items: Start (type Date), End (type Date) and Duration (type Long). I assume either End or Duration is derived at runtime. My guess is that either Duration is negative or End is before Start. I notice in the list of appointments created by this macro on my system that some all day events have property AllDayEvent = False. I seem to recall I once discovered that creating an appointment and later switching AllDayEvent on or off created an inconsistency.
I have added code which attempts to detect this problem but I cannot test it because I have no appointments that give this error on my system. This macro was only intended to get you started with a list of your current appointments so let us not worry to much if you cannot get it working.
Sub ReviewCalendar()
Dim DateTimeEnd As Date
Dim DateTimeStart As Date
Dim Duration As Long
Dim ItemMine As Object
Dim ItemMineClass As Long
Dim FolderTgt As MAPIFolder
Set FolderTgt = CreateObject("Outlook.Application"). _
GetNamespace("MAPI").GetDefaultFolder(olFolderCalendar)
' I use this macro to list selected properties from the test calendar.
' Add a quote to the statement above and remove the quote from the next
' statement to do the same.
'Set FolderTgt = CreateObject("Outlook.Application"). _
GetNamespace("MAPI").Folders("Test Folders"). _
Folders("Calendar")
For Each ItemMine In FolderTgt.Items
With ItemMine
' Occasionally I get syncronisation
' errors. This code avoids them.
ItemMineClass = 0
On Error Resume Next
ItemMineClass = .Class
On Error GoTo 0
If ItemMineClass = olAppointment Then
Debug.Print "** Subject: " & .Subject
Debug.Print " Created: " & _
Format(.CreationTime, "d mmm yy hh:mm:ss")
Debug.Print " Updated: " & _
Format(.LastModificationTime, "d mmm yy hh:mm:ss")
Debug.Print " Time: ";
DateTimeStart = .Start
If .AllDayEvent Then
Debug.Print "All day " & Format(.Start, "d mmm yy")
Else
On Error Resume Next
DateTimeEnd = .End
Duration = .Duration
On Error GoTo 0
If Duration <= 0 Then
Debug.Print " ##### Invalid duration #####"
End If
Debug.Print Format(.Start, "h:mm") & " to " & _
Format(.End, "h:mm") & "(" & .Duration & _
" minutes) on " & Format(.Start, "d mmm yy")
End If
' If you remove the quote from the following statement
' it will delete the appointment.
' .Delete ' Delete appointment
End If
End With
Next
End Sub
Preparing to test copying of appointments
I suggest you create a test folder so you can test macros without effecting anything important.
From the Toolbar, select File, New, Outlook Data File, Office Outlook Personal Folders File (.pst).
A window appears listing your existing PST files. On my system these are: archive.pst, Outlook.pst and Test.pst.
At the bottom the default file name is selected. Enter "Test" or other name of your choice.
Another window appears so you can (1) select the name used for the new personal folder in the Outlook Explorer window and (2) select the level of encryption. Enter "Test" or other name of your choice. (Outlook will add " Folders" to your name.) I do not encrypt or password protect message on my system but that is a choice for you.
From the toolbar, select Go, Folder List. The folder list will appear in place of the Output Explorer window.
Right click folder "Calendar" then select New Folder. The New Folder window appears.
Enter the name as "Calendar" and select Test Folders as its location.
Now, when you select Calendar, you will be offered "Calendar in Test Folders" as an additional choice.
Copy appointments from default Calendar to test Calendar
This macro creates a copy in the test Calendar of every appointment in the default Calendar.
Run it once then select Calandar and tick both the default and the test Calendar. The two calendars should be identical.
Warning: If you run the macro again, you will end with two copies of each appointment.
Sub CopyCalendar()
Dim FolderDest As MAPIFolder
Dim ItemCopy As AppointmentItem
Dim ItemMine As Object
Dim ItemMineClass As Long
Dim NameSpaceMine As NameSpace
Dim FolderSrc As MAPIFolder
Set NameSpaceMine = _
CreateObject("Outlook.Application").GetNamespace("MAPI")
With NameSpaceMine
Set FolderSrc = .GetDefaultFolder(olFolderCalendar)
Set FolderDest = .Folders("Test Folders").Folders("Calendar")
End With
Debug.Print FolderSrc.Items.Count
Debug.Print FolderDest.Items.Count
For Each ItemMine In FolderSrc.Items
With ItemMine
' Occasionally I get syncronisation
' errors. This code avoids them.
ItemMineClass = 0
On Error Resume Next
ItemMineClass = .Class
On Error GoTo 0
' I have never found anything but appointments in
' Calendar but test just in case
If ItemMineClass = olAppointment Then
Set ItemCopy = .Copy
ItemCopy.Move FolderDest
End If
End With
Next
End Sub
Next steps
The Set FolderDest statement shows how to select a partcular folder by working down its hierarchy. There are other, more general, techniques but this should be sufficient for your requirements if you can access the iClound Calendar in this way.
Set NameSpaceMine = _
CreateObject("Outlook.Application").GetNamespace("MAPI")
With NameSpaceMine
Set FolderDest = .Folders("Test Folders").Folders("Calendar")
End With
The first macro includes the code to delete every appointment in a calendar and the second copies appointments from one calendar to another.
Combining and adapting this code would give you a one-way synchronisation. That is, it would make Calendar 2 a copy of Calendar 1. Is this adequate? Would overwriting the iCloud Calendar with the default Calendar be adequate? Two-way synchronisation is more complicated. I have experienced several "enterprise" synchronisation routines and none were fool-proof. If you are of the "enterprise means over priced, poor quality sofware" school, you will not be surprised. Otherwise you may agree that two-way synchronisation is difficult or that both statements are true.
The issues are:
Non-identifying properties in either calendar may be changed.
An appointment may be added to or deleted from either calendar.
Identifying properties in either calendar may be changed. Typically subject and or start time are identifying properties but the subject may be changed and the appointment may be moved.
On my system, CreationTime and LastModificationTime are copied unchanged so there are options around using them as identifiers. I have no means of testing the effect on CreationTime and LastModificationTime of a calendar being updated because of meeting request.
I leave you to consider these issues and decide how you wish to take this matter forward.