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的最終版本，但是這將幫助你看到發生了什麼。

保重，

馬克。