0

これが私が達成しようとしていることです。

My BlackBerry は予定をダイアリーに自動的に追加します。

次に、カレンダー アイテムの作成時に自動的に次のようにします。

1) 接頭辞「C」が付いている予定をピックアップします。

2) 予定の場所に基づいて予定を分類します。「着信」および「発信」 = カテゴリ「通話」、「不在着信」 = カテゴリ「不在着信」

3) 予定の名前を「C.」プレフィックスを削除して変更します

4) 「通話」カテゴリにあるすべての予定を「通話ログ」というサブカレンダーに移動します

5) 新しい予定が追加されたときに、手動でマクロやリマインダーを使用するのではなく、このプロセスを自動的に開始したい。

Web 上の他の場所にある以下のプロセスを修正しようとしましたが、うまくいきませんでした。

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
4

1 に答える 1

0

こんなものが欲しいと思います…。

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を削除する必要がありますが、これは何が起こっているかを確認するのに役立ちます。

気をつけて、

マーク。

于 2013-03-20T15:02:04.917 に答える