そのため、VBAスクリプトが記述されました（インターネット上で見つかった単一の無料ソリューションが私の機能に合っていなかったため）。これは次のことを行います。
-アドレス帳のすべての連絡先の誕生日と記念日を再保存します（したがって、メインカレンダーのネイティブOutlook機能を使用して、連絡先の誕生日と記念日に関するエントリが作成されます）。
-そのようなイベントに関するすべてのレコードを標準カレンダーからユーザーが指定したものに移動します（すでにレコードでオーバーロードされているメインカレンダーを詰まらせないように）。
-次のように、連絡先「Store as」のレコードを修正します（ご存じのとおり、iOSとAndroidはMicrosoft Exchangeアカウントのこのフィールドでは正しく動作しません）：フィールド「Name」または「Last name」に値が含まれる場合、「Store as」が値を取得します「名姓」、そうでない場合は「組織」（これは、「ピザ配信」などの「名」ではなく、「組織」フィールドにサービスおよびすべての種類のオフィスの名前を保存する場合に特に便利です）。
このようなアルゴリズムが機能するためには、追加のソフトウェアをインストールする必要はありません。
必要な作業は、2つのアクションだけです。未署名のマクロの実行を有効にし、Outlookのクリップボード（CTRL-C、CTRL-V）を介してスクリプト自体をコピーします。
署名されていないマクロを有効にするには、
1. Outlookで、[ファイル]-> [設定]-> [セキュリティセンター]-> [セキュリティセンターの設定]に移動します。
2.マクロオプション->「すべてのマクロの通知」を選択します。
次の手順は、スクリプト自体（マクロ）をOutlookに挿入することです。
これを行うには、OutlookでALT-F11を押します-Microsoft Visual Basic for Applicationsエディターに入ります-> [プロジェクト]セクションで、[ThisOutlookSession]を選択します。
そして、開いたウィンドウで、スクリプトを貼り付けます：
Sub olRobot() ' Outlook VBA script by Sergii Vakula ' Auto generation the Birthdays and Anniversaries appointments of all Contact folders to a specific calendar ' Auto changing Contact's FileAs fields: FullName for humans, CompanyName for companies Dim objOL As Outlook.Application Dim objNS As Outlook.NameSpace Dim objItems As Outlook.Items Dim obj As Object Set objOL = CreateObject("Outlook.Application") Set objNS = objOL.GetNamespace("MAPI") On Error Resume Next ' ***************************************************************************************************** ' *** STAGE 1: Rebuilding Contact's Birthdays and Anniversaries to the main calendar, fixing FileAs *** ' ***************************************************************************************************** Dim Report As String Dim mySession As Outlook.NameSpace Dim myFolder As Outlook.Folder Set mySession = Application.Session ' Method 1: Ask for Contact folder 'MsgBox ("Select Contact folder by next step...") 'Call ContactsFolders(Session.PickFolder, Report) ' Method 2: Use default Contact folder and all subfolders 'Call ContactsFolders(objNS.GetDefaultFolder(olFolderContacts), Report) ' Method 3: Use all Contact folders For Each myFolder In mySession.Folders Call ContactsFolders(myFolder, Report) Next ' *************************************************************************************** ' *** STAGE 2: Moving Birthdays and Anniversaries appointments to a specific calendar *** ' *************************************************************************************** Dim objCalendar As Outlook.AppointmentItem Dim objCalendarFolder As Outlook.MAPIFolder Dim cAppt As AppointmentItem Dim moveCal As AppointmentItem Dim pattern As RecurrencePattern Set objCalendarFolder = objNS.GetDefaultFolder(olFolderCalendar) bodyMessage = "This is autocreated appointment" ' Method 1: Ask for specific calendar folder for birthdays and anniversaries MsgBox ("Select Birthdays and Anniversaries Calendar folder by next step...") Set newCalFolder = Session.PickFolder ' Method 2: Use pre-assigned calendar folder for birthdays and anniversaries 'Set newCalFolder = GetFolderPath("display name in folder list\Calendar\Birthdays and Anniversaries") 'Set newCalFolder = GetFolderPath("\\me@about.com\Calendar\Birthdays and Anniversaries") For i = newCalFolder.Items.Count To 1 Step -1 Set obj = newCalFolder.Items(i) If obj.Class = olAppointment And _ obj.GetRecurrencePattern.RecurrenceType = olRecursYearly And _ obj.AllDayEvent And _ obj.Body = bodyMessage Then Set objCalendar = obj objCalendar.Delete End If Err.Clear Next For i = objCalendarFolder.Items.Count To 1 Step -1 Set obj = objCalendarFolder.Items(i) If obj.Class = olAppointment And _ obj.GetRecurrencePattern.RecurrenceType = olRecursYearly And _ obj.AllDayEvent And _ (Right(obj.Subject, 11) = "'s Birthday" Or Right(obj.Subject, 14) = "'s Anniversary" Or _ Right(obj.Subject, 13) = " " Or Right(obj.Subject, 9) = "") Then Set objCalendar = obj Set cAppt = Application.CreateItem(olAppointmentItem) With cAppt .Subject = objCalendar.Subject .Start = objCalendar.Start .Duration = objCalendar.Duration .AllDayEvent = True .Body = bodyMessage .ReminderSet = False .BusyStatus = olFree End With Set pattern = cAppt.GetRecurrencePattern pattern.RecurrenceType = olRecursYearly cAppt.Save objCalendar.Delete Set moveCal = cAppt.Move(newCalFolder) 'moveCal.Categories = "moved" moveCal.Save End If Err.Clear Next Set objOL = Nothing Set objNS = Nothing Set obj = Nothing Set objContact = Nothing Set objItems = Nothing Set objCalendar = Nothing Set objCalendarFolder = Nothing Set cAppt = Nothing Set moveCal = Nothing Set pattern = Nothing Set mySession = Nothing Set myFolder = Nothing MsgBox ("Completed!" & vbCrLf & vbCrLf & "All Contact's FileAs were fixed." & vbCrLf & "All Birthdays and Anniversaries appointments were re-created." & vbCrLf & vbCrLf & "Contact folders that been processed:" & vbCrLf & Report & vbCrLf & "Calendar for Birhdays and Anniversaries:" & vbCrLf & newCalFolder.FolderPath & vbCrLf & vbCrLf & "Have a nice day!") 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 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 Set GetFolderPath = oFolder Exit Function GetFolderPath_Error: Set GetFolderPath = Nothing Exit Function End Function Private Sub ContactsFolders(CurrentFolder As Outlook.Folder, Report As String) Dim objItems As Outlook.Items Dim obj As Object Dim objContact As Outlook.ContactItem Dim strFileAs As String Dim SubFolder As Outlook.Folder Dim SubFolders As Outlook.Folders Set SubFolders = CurrentFolder.Folders If CurrentFolder.DefaultItemType = 2 Then Report = Report & CurrentFolder.FolderPath & vbCrLf Set objItems = CurrentFolder.Items For Each obj In objItems If obj.Class = olContact Then Set objContact = obj With objContact .Display If .FullName = "" Then strFileAs = .CompanyName Else strFileAs = .FullName End If .FileAs = strFileAs mybirthday = .Birthday myanniversary = .Anniversary .Birthday = Now .Anniversary = Now .Birthday = mybirthday .Anniversary = myanniversary .Save .Close 0 End With End If Err.Clear Next End If For Each SubFolder In SubFolders Call ContactsFolders(SubFolder, Report) Next Set SubFolder = Nothing Set SubFolders = Nothing End Sub
保存し、エディターを閉じてOutlookに戻ります。
残っているのは、このスクリプトを実行することだけです。 これを行うには、ALT-F8を押し、「ThisOutlookSession.olRobot」を選択して、「実行」ボタンをクリックします。
スクリプトのプロセスで、ダイアログボックスが開き、誕生日と連絡先の記念日のエントリを配置するカレンダーを指定するように求められます。
経験豊富なユーザーは、スクリプトの本文で主要な情報を取得するさまざまな方法に注意してください。
メインカレンダーにそのようなイベントに関する誤ったエントリがあった場合-このスクリプトをもう一度実行すると、それらが修正されます。
ALT-F8を押して開始し、カレンダーをキャンディーのように見せます。
お楽しみください！