Extend Outlook

OutlookExtension.bas

Option Explicit

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
    '１．添付ファイルを添付し忘れていないか確認
    Call CheckAttachment(Item, Cancel) 
    
    '2．BCCに指定したアドレス(自分のアドレス)を追加
    Call SetBCC("[email protected]", Item, Cancel) 
    
    '3. メール送信時に、開封確認を要求するか設定
    Call RequireReceiptConfirmation(Item, Cancel) 
End Sub

Private Sub CheckAttachment _
    (ByVal Item As Object, Cancel As Boolean)
    
    Dim strSubject As String: strSubject = Item.Subject
    Dim strBody As String: strBody = Item.Body

    If InStr(strSubject & strBody, "添付") _
        + InStr(strSubject & strBody, "送付") > 0 _
        And Item.Attachments.Count = 0 Then
            If MsgBox("添付ファイルを忘れている可能性があります。本当に送信しますか？", _
                                vbYesNo + vbQuestion) = vbNo Then
                Cancel = True
                Exit Sub
            End If
    End If
End Sub

Private Sub SetBCC _
    (address As String, ByVal Item As Object, Cancel As Boolean)
    
    Dim objMe As Recipient: Set objMe = Item.Recipients.Add(address)
    objMe.Type = olBCC
    objMe.Resolve
End Sub

Private Sub RequireReceiptConfirmation _
    (ByVal Item As Object, Cancel As Boolean)
    
    On Error GoTo ErrorTrap
    Dim Flag As Integer
    Flag = MsgBox("開封確認あり でメールを送信しますか?" & vbCr _
        & vbCr _
        & "はい -> 開封確認あり でメールを送信します" & vbCr _
        & "いいえ -> 開封確認なし でメールを送信します" & vbCr _
        & "キャンセル -> 送信をとりやめます(本文の編集に戻ります)" _
        , vbYesNoCancel + vbQuestion, "開封確認")
        
    If Flag = vbYes Then
        Item.ReadReceiptRequested = True
    ElseIf Flag = vbNo Then
        Item.ReadReceiptRequested = False
    Else
        Cancel = True
    End If
    
    Exit Sub
    
ErrorTrap:
    Cancel = True
End Sub