VBA Outlook编程

Question

这是我想要实现的。

我的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 

Answer 1

我觉得你是想有这样的事情....

Dim WithEvents mainCal As Items 
Dim CallLogCal As Folder 

Private Sub Application_Startup() 

    Dim NS As Outlook.NameSpace 
    Set NS = Application.GetNamespace("MAPI") 
    Set mainCal = NS.GetDefaultFolder(olFolderCalendar).Items 
    Set CallLogCal = NS.GetDefaultFolder(olFolderCalendar).Folders("Call Log") 
    Set NS = Nothing 

End Sub 


Private Sub mainCal_ItemAdd(ByVal Item As Object) 

    MsgBox "You added a new item into the calendar" 

    If Mid(Item.Subject, 1, 2) = "C." Then 

     MsgBox "Event started with a C." 

     Item.Subject = Mid(Item.Subject, 4, Len(Item.Subject) - 4) 

     If Item.Location = "Missed Call " Then 
      Item.Categories = "S. CALL MISSED." 
      MsgBox "Call Missed Added" 

     ElseIf Item.Location = "Incoming Call " Then 
      Item.Categories = "S. CALL RECEIVED." 
      MsgBox "Call Received Added" 

     Else 
      Item.Categories = "S. CALL MADE." 
      MsgBox "Call Made Added" 

     End If 

     Item.Save 

     Item.Move CallLogCal 

    End If 

End Sub 

你会明显要删除所有MSGBOX的最终版本，但是这将帮助你看到发生了什么。

保重，

马克。