这是我想要实现的目标。
我的 BlackBerry 会自动将约会添加到我的日记中。
然后我想在创建日历项目时自动：
1) 拿起任何带有前缀“C”的约会。
2）根据预约地点对预约进行分类；“来电”和“去电”=类别“通话”，“未接电话”=类别“未接电话”
3) 重命名约会，去掉“C.”前缀
4）现在将“通话”类别中的任何约会移至名为“通话记录”的子日历
5）我希望这个过程在添加新约会时自动启动，而不是手动宏或提醒驱动。
我已尝试修改在网络上其他地方找到的以下流程....但对我不起作用。
Private Sub Application_Reminder(ByVal Item As Object)
If Item.subject = "Process Calls" Then
' Define variables
Dim objCalendar As Outlook.folder
Dim objItems As Outlook.Items
Dim objAppt As Outlook.AppointmentItem
Dim strRestriction As String
Dim objFinalItems As Outlook.Items
Dim myolApp As Outlook.Application
' Set strRestriction to be only calls
strRestriction = "@SQL= (""urn:schemas:httpmail:subject"" LIKE '@Call.%' OR ""urn:schemas:httpmail:subject"" LIKE 'C.%' OR ""urn:schemas:httpmail:subject"" LIKE '@Call in%' OR ""urn:schemas:httpmail:subject"" LIKE '@Call%') AND ""urn:schemas-microsoft-com:office:office#Keywords"" 'Phone call'"
' Set the objCalendar and objItems items
Set objCalendar = Application.Session.GetDefaultFolder(olFolderCalendar)
Set objItems = objCalendar.Items
Set objFinalItems = objItems.Restrict(strRestriction)
Set myolApp = CreateObject("Outlook.Application")
For Each objAppt In objFinalItems
' Debugging
' Debug.Print objAppt.Start, objAppt.Subject, objAppt.Categories
' Assign the category to the appointments
If objAppt.Location = "Missed Call " Then
objAppt.Categories = "S. CALL MISSED."
ElseIf objAppt.Location = "Incoming Call " Then
objAppt.Categories = "S. CALL RECEIVED."
Else
objAppt.Categories = "S. CALL MADE."
End If
objAppt.Save
Next
' Rename Entry
Dim iItemsUpdated As Integer
Dim strTemp As String
iItemsUpdated = 0
For Each aItem In objCalendar.Items
If Mid(aItem.subject, 1, 2) = "C." Then
strTemp = Mid(aItem.subject, 4, Len(aItem.subject) - 4)
aItem.subject = strTemp
iItemsUpdated = iItemsUpdated + 1
End If
aItem.Save
Next aItem
MsgBox iItemsUpdated & " of " & objCalendar.Items.Count & " Meetings Updated"
End If
End Sub
Private Sub Application_Reminder(ByVal Item As Object)
If Item.subject = "Move Calls" Then
Public Sub MoveACallLog()
Dim objOL As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim objAppt As Outlook.Items
Dim objFolder As Outlook.MAPIFolder
On Error Resume Next
Set objOL = CreateObject("Outlook.Application")
Set objNS = objOL.GetNamespace("MAPI")
Set objFolder = objNS.GetDefaultFolder(olFolderCalendar)
Set objAppt = objFolder.Items
' move to a calendar in an archive data file
Set CalFolder = GetFolderPath("\\stephen@gazard.net\Calendar\Call Log")
For i = objAppt.Count To 1 Step -1
If objAppt(i).Categories = "Calls" Then
objAppt(i).Move CalFolder
End If
Next i
Set objAppt = Nothing
Set objFolder = Nothing
Set objOL = Nothing
Set objNS = Nothing
End Sub
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
Function GetCurrentItem() As Object
Dim objApp As Outlook.Application
Set objApp = Application
On Error Resume Next
Select Case TypeName(objApp.ActiveWindow)
Case "Explorer"
Set GetCurrentItem = objApp.ActiveExplorer.Selection.Item(1)
Case "Inspector"
Set GetCurrentItem = objApp.ActiveInspector.CurrentItem
End Select
Set objApp = Nothing
End Function