I am having an issue implementing VB code I found on this site. I want to use VB to access the Calendar folder in a PST file and change all appointments so that reminders are set to false. I have pasted the following code in the ThisOutlookSession section:
Function GetFolderPath(ByVal FolderPath As String) As Outlook.folder
Dim oFolder As Outlook.folder
Dim FoldersArray As Variant
Dim i As Integer
On Error GoTo GetFolderPath_Error
If Left(FolderPath, 2) = "\\" Then
FolderPath = Right(FolderPath, Len(FolderPath) - 2)
End If
'Convert folderpath to array
FoldersArray = Split(FolderPath, "\")
Set oFolder = Application.Session.Folders.Item(FoldersArray(0))
If Not oFolder Is Nothing Then
For i = 1 To UBound(FoldersArray, 1)
Dim SubFolders As Outlook.Folders
Set SubFolders = oFolder.Folders
Set oFolder = SubFolders.Item(FoldersArray(i))
If oFolder Is Nothing Then
Set GetFolderPath = Nothing
End If
Next
End If
'Return the oFolder
Set GetFolderPath = oFolder
Exit Function
GetFolderPath_Error:
Set GetFolderPath = Nothing
Exit Function
End Function
End Function
After that I used the following code in the Module section:
Private Sub Application_Startup()
Dim Ns As Outlook.NameSpace
Set Ns = Application.GetNamespace("MAPI")
Set Items = GetFolderPath("\\zakin\Calendar").Items
End Sub
Private Sub Items_ItemAdd(ByVal Item As Object)
On Error Resume Next
Dim Appt As Outlook.AppointmentItem
If TypeOf Item Is Outlook.AppointmentItem Then
Set Appt = Item
'Checks to see if all day and if it has a reminder set to true
If Appt.Start < Now Then
'appt.reminderset block - 2 lines
Appt.ReminderSet = False
Appt.Save
End If
End If
End Sub
When I run the module, it returns an error about an unknown sub for function being GetFolderPath. Sorry if this is an easy fix but I am new to VB so any help provided is appreciated.
Thanks,
Michael
Function GetFolderPath(ByVal FolderPath As String) As Outlook.folder
Dim oFolder As Outlook.folder
Dim FoldersArray As Variant
Dim i As Integer
On Error GoTo GetFolderPath_Error
If Left(FolderPath, 2) = "\\" Then
FolderPath = Right(FolderPath, Len(FolderPath) - 2)
End If
'Convert folderpath to array
FoldersArray = Split(FolderPath, "\")
Set oFolder = Application.Session.Folders.Item(FoldersArray(0))
If Not oFolder Is Nothing Then
For i = 1 To UBound(FoldersArray, 1)
Dim SubFolders As Outlook.Folders
Set SubFolders = oFolder.Folders
Set oFolder = SubFolders.Item(FoldersArray(i))
If oFolder Is Nothing Then
Set GetFolderPath = Nothing
End If
Next
End If
'Return the oFolder
Set GetFolderPath = oFolder
Exit Function
GetFolderPath_Error:
Set GetFolderPath = Nothing
Exit Function
End Function
End Function
After that I used the following code in the Module section:
Private Sub Application_Startup()
Dim Ns As Outlook.NameSpace
Set Ns = Application.GetNamespace("MAPI")
Set Items = GetFolderPath("\\zakin\Calendar").Items
End Sub
Private Sub Items_ItemAdd(ByVal Item As Object)
On Error Resume Next
Dim Appt As Outlook.AppointmentItem
If TypeOf Item Is Outlook.AppointmentItem Then
Set Appt = Item
'Checks to see if all day and if it has a reminder set to true
If Appt.Start < Now Then
'appt.reminderset block - 2 lines
Appt.ReminderSet = False
Appt.Save
End If
End If
End Sub
When I run the module, it returns an error about an unknown sub for function being GetFolderPath. Sorry if this is an easy fix but I am new to VB so any help provided is appreciated.
Thanks,
Michael
