Outlook上にて、
開いている(選択している)mailに対して、
規定の宛先・本文を追記(先頭に)します。

Sub Create_DHL_Mail()

	Dim objItem As MailItem
	Dim mTitle As String
	Dim mTo As String
	Dim mCc As String
	Dim mBody As String
	
	'付与する情報
	mTo = "xxxx@xxx.com"
	mCc = "xxxx@xxx.com"
	mBody = "既存mailの先頭に文章を追加する" & vbCrLf & "二行目です。"
	
	'現在開いているmail
	Set objItem = ActiveInspector.CurrentItem
	mTitle = objItem.Subject
	
	'開いているmailを書き換える
	objItem.To = mTo
	objItem.CC = mCc
	objItem.Body = mBody & vbCrLf & vbvrlf & objItem.Body
	
End Sub

Google CalenderのデータをOutlookに取り込んだ後に印刷を行うという運用を想定。
毎回フィルタするのが面倒なので、自動化。

Sub auto_enabler_calender()
    Dim myCal As String
    Dim navModCal As CalendarModule
    
    myCal = "Google"
    
    Dim ContactsFolder As Folder
    Set ContactsFolder = Session.GetDefaultFolder(olFolderCalendar)
    Session.SendAndReceive (True)
    ContactsFolder.Display

    Set navModCal = ActiveExplorer.NavigationPane.Modules.GetNavigationModule(olModuleCalendar)
    'show myCal calender
    For Each navGroup In navModCal.NavigationGroups
        For Each navFolder In navGroup.NavigationFolders
            Debug.Print navFolder.DisplayName
            If navFolder.DisplayName = myCal Then
                navFolder.IsSelected = True
            End If
        Next
    Next
    'hide other calender
    For Each navGroup In navModCal.NavigationGroups
        For Each navFolder In navGroup.NavigationFolders
            Debug.Print navFolder.DisplayName
            If navFolder.DisplayName <> myCal Then
                navFolder.IsSelected = False
            End If
        Next
    Next
End Sub

説明:
指定のOutlookフォルダ”mailfolder”を開く
mailを後方から順番に開いて、
mailタイトルが”TEST:”で始まるかチェック
添付ファイルを指定のフォルダ”BASE_PATH”に保管してmailを削除

Const BASE_PATH As String = "c:\temp\mail\"
    
Sub export_attached_file()
    Dim myOlApp As Object, myNameSpace As Object, myFolder As Object
    Dim MAX_MAIL As Long
    Dim myItem As Object, myAttachments As Object
    Dim Title As String
        
    Title = "TEST:"
    
    Set myOlApp = CreateObject("Outlook.Application")
    Set myNameSpace = myOlApp.GetNamespace("MAPI")
    'Set myFolder = myNameSpace.PickFolder　'毎回フォルダを選択させたい場合
    Set myFolder = myNameSpace.Folders("mailfolder") 'mailのフォルダ指定
    
    MAX_MAIL = myFolder.Items.Count
    Open BASE_PATH & "index_ZIP.txt" For Output As #1
        
    For j = MAX_MAIL To 1 Step -1
        'Debug.Print J
        Set myItem = myFolder.Items(j)
        Set myAttachments = myItem.Attachments
        
        '添付フアィルの数をカウント
        cu = myAttachments.Count
        
        If Left(myItem.Subject, Len(Title)) = Title Then
        
            'ファイルを保存
            For i = 1 To cu
                FN = BASE_PATH & myAttachments.Item(i).DisplayName
                myAttachments.Item(i).SaveAsFile FN
                Print #1, FN
            Next i
            myItem.Delete 'mail delete
        
        End If
        Debug.Print j
        DoEvents
    Next
    Close
    
    MsgBox "done!"

End Sub