コメントにて以下のご要望をいただきました。
いつも参考にさせて頂き、
要望にも対応頂きありがとうございます
Outlook365
Windows10(64bit)
2台の端末で1つのアカウントでログイン(設定)し
1週間の内、端末Aと端末Bを使用します。
例えば、月曜に端末Aで送受信等ををし、
残りの火曜～金曜は端末Bで送受信等とする場合
送受信メール、連絡先(追加などした場合)の
各データを同期させたいのです。
過去の相当古いデータも残しておきたいため
IMAP等では無理だと判断しています。
単純にデータ(pst)のエクスポートとインポートを
日時指定(作成日時、更新日時)で対応しようと考えています。
マクロ作成可能でしょうか?
日時指定(作成日時、更新日時)はダイアログで指定ができると有難いです。
メールの受信トレイ(階層1として)や送信トレイの下層に
サブフォルダを階層3迄で作成しています。
送受信後、返信や解答があったものは手動で移動しています。
サブフォルダを追加した場合もそのフォルダ等も
エクスポートとインポートの対象になりますよね?
よろしくお願いします。
—-
お返事ありがとうございます。
>Outlook のインポート、エクスポートの機能をマクロで呼び出すことはできないため、マクロ
>ですべて実装する必要があります。
≫≫
以前CSVのエクスポートするマクロを参考にさせて頂きましたが
単純にデータ(pst)のエクスポートとインポートを
日時指定(作成日時、更新日時)で対応はできないでしょうか?
>インポート先に同じアイテムがあった場合に単純な上書きとするのかや、
>そもそも同じアイテムと判断する基準はどうするかなどを考慮する必要があります。
≫≫
手動でデータ(pst)のエクスポートとインポートの時の
ダイアログの条件(下記3種)
・重複した場合、インポートするアイテムと置き換える(E)
・重複してもインポートする(A)
・重複したらインポートしない(D)
このうちの
・重複してもインポートする(A)で良いと考えています。
Outlook 365 を使われているというのは、Office 365 の Outlook を使われているということなのでしょうか?
≫≫
はいそうです。
MicrosoftR OutlookR for Office 365 MSO (16.0.12228.20100) 32 ビット です。
その場合、サーバーは Exchange を使用しているはずで、連絡先などの情報もメールボックスに保存されているので、PST で同期する必要はないはずです。
≫≫
アプリ自体はOffice 365 の Outlookですが
エクスポートしたいアカウント(主にメール)の種類は
POP/SMTP(送信で使用する既定のアカウント)となっています。
もうひとつ 予定表の管理用として
利用している@outlook.comのアカウントは 種類はMicrosoft Exchangeとなっています。
アイテムのエクスポートやインポートの際に「重複してもインポートする」で構わないということであれば、単純にフォルダーのアイテムをコピーするというようなマクロとなります。
ただし、サブ フォルダーもコピーするとなると、エクスポート先にそのフォルダーがないという可能性もあるため、フォルダーがなければ作成するというロジックが必要になります。
また、日付の指定については InputBox で入力を行い、その日付でフィルターを作成して Items コレクションの Restrict メソッドにより日付の絞り込みを行います。
マクロは以下の通りになります。
なお、エクスポート、インポートする PST ファイルはあらかじめプロファイルに追加して置き、その名前を GetPSTRoot 内の PST_NAME で指定してください。
' ここをトリプルクリックでマクロ全体を選択できます。
'
' PST にエクスポートするプロシージャ
Public Sub ExportToPST()
Dim fldSrc As Folder
Dim fldDst As Folder
Dim strFilter As String
' コピー元はメールボックス
Set fldSrc = Session.DefaultStore.GetRootFolder
' コピー先は PST
Set fldDst = GetPSTRoot()
If fldDst Is Nothing Then Exit Sub
' フィルターを初期化
strFilter = ""
' コピー処理をフォルダーごとに呼び出し
CopyItems fldSrc, fldDst, "受信トレイ", strFilter
CopyItems fldSrc, fldDst, "送信トレイ", strFilter
CopyItems fldSrc, fldDst, "送信済みアイテム", strFilter
CopyItems fldSrc, fldDst, "下書き", strFilter
CopyItems fldSrc, fldDst, "連絡先", strFilter
End Sub
'
' PST からインポートするプロシージャ
Public Sub ImportFromPST()
Dim fldSrc As Folder
Dim fldDst As Folder
Dim strFilter As String
' コピー元は PST
Set fldSrc = GetPSTRoot()
' コピー先はメールボックス
Set fldDst = Session.DefaultStore.GetRootFolder
If fldDst Is Nothing Then Exit Sub
' フィルターを初期化
strFilter = ""
' コピー処理をフォルダーごとに呼び出し
CopyItems fldSrc, fldDst, "受信トレイ", strFilter
CopyItems fldSrc, fldDst, "送信トレイ", strFilter
CopyItems fldSrc, fldDst, "送信済みアイテム", strFilter
CopyItems fldSrc, fldDst, "下書き", strFilter
CopyItems fldSrc, fldDst, "連絡先", strFilter
End Sub
'
' PST のルートフォルダーを取得する関数
Private Function GetPSTRoot() As Folder
Const PST_NAME = "個人用 Outlook データ ファイル"
Dim fldRoot As Folder
' プロファイル
For Each fldRoot In Session.Folders
If fldRoot.Name = PST_NAME Then
Set GetPSTRoot = fldRoot
Exit Function
End If
Next
MsgBox PST_NAME & "が見つかりません。", vbCritical
Set GetPSTRoot = Nothing
End Function
'
' フォルダごとにアイテムをコピーするプロシージャ
Private Sub CopyItems(fldSrcRoot As Folder, fldDstRoot As Folder, strName As String, strFilter As String)
On Error Resume Next
Const PR_ATTR_HIDDEN = "http:" & "//schemas.microsoft.com/mapi/proptag/0x10F4000B"
Dim fldSrc As Folder
Dim dfType As OlDefaultFolders
Dim fldDst As Folder
Dim colItems As Items
Dim objItem As Object
Dim objCopy As Object
Dim fldSub As Folder
' フィルターが設定されていなければ基準日を入力してフィルターを作成
If strFilter = "" Then
Dim strDate As String
strDate = FormatDateTime(CDate(InputBox("基準日")), vbShortDate)
' 更新日時が基準日以降であるアイテムを取得するフィルター
strFilter = "[更新日時] >= '" & strDate & "'"
' 作成日時が基準日以降であるアイテムを取得する場合は以下のフィルターを使用
'strFilter = "[作成日時] >= '" & strDate & "'"
End If
' コピー元フォルダーの取得
Set fldSrc = fldSrcRoot.Folders(strName)
' コピー元フォルダーが隠しフォルダーならコピーせず終了
If fldSrc.PropertyAccessor.GetProperty(PR_ATTR_HIDDEN) = True Then
Exit Sub
End If
' コピー先フォルダーの取得
Set fldDst = fldDstRoot.Folders(strName)
' コピー先フォルダーが見つからなければ作成
If fldDst Is Nothing Then
' フォルダーに格納されるアイテムの種別からフォルダー種別を設定
dfType = GetFolderType(fldSrc)
' 新規にフォルダーを作成
Set fldDst = fldDstRoot.Folders.Add(strName, dfType)
End If
' フィルターによりアイテムを抽出
Set colItems = fldSrc.Items.Restrict(strFilter)
' 抽出したアイテムのすべてについて処理
For Each objItem In colItems
' アイテムのコピーを作成
Set objCopy = objItem.Copy
' アイテムのコピーをコピー先フォルダーに移動
objCopy.Move fldDst
Next
' サブフォルダーについてもコピー処理
For Each fldSub In fldSrc.Folders
CopyItems fldSrc, fldDst, fldSub.Name, strFilter
Next
End Sub
'
' フォルダーに保存するアイテム種別をもとにフォルダー種別を返す関数
Private Function GetFolderType(fldToCheck As Folder) As OlDefaultFolders
Select Case fldToCheck.DefaultItemType
Case olMailItem
GetFolderType = olFolderInbox
Case olAppointmentItem
GetFolderType = olFolderCalendar
Case olContactItem
GetFolderType = olFolderContacts
Case olTaskItem
GetFolderType = olFolderTasks
Case Else
GetFolderType = olFolderInbox
End Select
End Function
Outlook 研究所 