outlook vba 插件

最新推荐文章于 2024-10-31 12:07:47 发布

原创最新推荐文章于 2024-10-31 12:07:47 发布 · 2k 阅读

2 ·

CC 4.0 BY-SA版权

文章标签：

#vba #integer #string #application #function #object

vba 专栏收录该内容

4 篇文章

订阅专栏

本文介绍了一个使用VBA编写的Outlook插件，该插件能够自动处理符合特定格式的内部邮件，并将其转发给指定用户或DF支持团队。此外，对于不符合格式要求的邮件，插件会自动发送格式错误通知。

'定義された変数

Dim DelAfterHandle As Boolean

Dim Question, Reply, LogPath, DFMailList, strBody, strSubject, strUser As String

Option Explicit

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)

End Sub

'受信時の動作

Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)

'---------------------------

'自分定義data

'処理完了後で削除falg　デフォルト状態は削除しない（目前は使用しない）

DelAfterHandle = False

'指定ログファイルパス

LogPath = "E:MailRule"

'内部係メールアドレスリスト

DFMailList = ""

'---------------------------

'受信したメール

Dim objMail As Object

'発送や転送の新しいメール

Dim NewMailItem As Outlook.MailItem

'アドレスを追加用の変数

Dim myRecipient As Outlook.Recipient

Dim intBegin, intEnd, intLength As Integer

Dim strEntryID As String

intBegin = 1

intLength = Len(EntryIDCollection)

intEnd = InStr(intBegin, EntryIDCollection, ",")

If intEnd = 0 Then intEnd = intLength + 1

Do While intEnd <> 0

strEntryID = Mid(EntryIDCollection, intBegin, (intEnd - intBegin))

'受信の新しいメールを取得

Set objMail = Application.Session.GetItemFromID(strEntryID)

'送信アドレスによって、受信の新しいメールは内部からメールかどうかを判断

strUser = objMail.SenderEmailAddress

If InStr(1, DFMailList, objMail.SenderEmailAddress) <> 0 Then

'内部アドレス場合、ユーザへ発送

'件名は指定格式を満足かどうかを判断

If GetSubjectAndUser(objMail.Subject) <> False Then

'件名は指定格式を満足すれば

'問題と答え内容を取得できるかどうかを判断

If GetAnswerAndReply(objMail.Body) <> False Then

'問題と答え内容を取得できれば

Set NewMailItem = Application.CreateItem(olMailItem)

strBody = objMail.HTMLBody

With NewMailItem

.BodyFormat = olFormatHTML

.HTMLBody = objMail.HTMLBody

.Subject = strSubject

End With

NewMailItem.Recipients.Add (strUser)

NewMailItem.Send

Open LogPath + "Logs.txt" For Append As #2

Print #2, "[" + Format(Now, "yyyy-mm-dd hh:mm:ss") + "]から" + objMail.SenderEmailAddress + "受信メール " + objMail.Subject + " という件もう代わりました！"

Close #2

Else

'もし問題と答え内容を取得できなければ、「答えメールの格式は指定格式を満足しない」というメールを発送

Call SendFormatErrorMail(objMail, "<HTML><BODY><H2>答えメールの格式は指定した格式と満足しない.</H2>格式は：<H2>Question:</H2><H2>Reply:</H2><H2>このメールは自動返信ですから、返信しないください</H2>")

End If

Else

'件名は指定格式を満足しなければ

Call SendFormatErrorMail(objMail, "<HTML><BODY><H2>件名は指定した格式と満足しない.</H2><H2>格式は：「件名;ユーザのメールアドレス」。</H2><H2>このメールは自動返信ですから、返信しないください.</H2>")

End If

Else

'外部アドレス場合、DFサポート者へ転送

Call SendToDF(objMail)

End If

intBegin = intEnd + 1

intEnd = InStr(intBegin, EntryIDCollection, ",")

Loop

End Sub

'答えメールの件名から新しい件名と対応ユーザのメールアドレスを取得

Private Function GetSubjectAndUser(subjectstr As String) As Boolean

Dim intPos As Integer

intPos = InStr(1, subjectstr, ";")

If intPos <> 0 Then

'件名に「;」前の文字列は新しい件名

strSubject = Mid(subjectstr, 1, intPos - 1)

'件名に「;」後の文字列は対応ユーザのアドレス

strUser = Mid(subjectstr, intPos + 1)

'アドレスが有効かどうかを判断

If InStr(1, strUser, "@") <> 0 Then

GetSubjectAndUser = True

Exit Function

End If

GetSubjectAndUser = False

Exit Function

End Function

'答えメールの内容から問題と答えを取得

Private Function GetAnswerAndReply(bodystr As String) As Boolean

GetAnswerAndReply = True

Exit Function

End Function

Private Sub SendToDF(objMail)

'DFMailListからDFサポート者のメールアドレスを取得して、メールを転送する

Dim intPos As Integer

Dim oldPos As Integer

Dim NewMailItem As Outlook.MailItem

intPos = InStr(1, DFMailList, ";")

Do While intPos <> 0

strUser = Mid(DFMailList, oldPos + 1, intPos - 1 - oldPos)

Set NewMailItem = Application.CreateItem(olMailItem)

With NewMailItem

.Body = objMail.Body

.Subject = objMail.Subject + ";" + objMail.SenderEmailAddress

End With

NewMailItem.Recipients.Add (strUser)

NewMailItem.Send

oldPos = intPos

intPos = InStr(intPos + 1, DFMailList, ";")

Loop

strUser = Mid(DFMailList, oldPos + 1)

Set NewMailItem = Application.CreateItem(olMailItem)

With NewMailItem

.Body = objMail.Body

.Subject = objMail.Subject + ";" + objMail.SenderEmailAddress

End With

NewMailItem.Recipients.Add (strUser)

NewMailItem.Send

'ログファイルに書く込む

Open LogPath + "Logs.txt" For Append As #1

Print #1, "[" + Format(Now, "yyyy-mm-dd hh:mm:ss") + "]から" + objMail.SenderEmailAddress + "受信メール " + objMail.Subject + " という件はDFサポート者へ転送している！"

Close #1

End Sub

Private Sub SendFormatErrorMail(objMail, str)

Dim NewMailItem As Outlook.MailItem

Set NewMailItem = Application.CreateItem(olMailItem)

With NewMailItem

.BodyFormat = olFormatHTML

.HTMLBody = str

.Subject = objMail.Subject

End With

NewMailItem.Recipients.Add (objMail.SenderEmailAddress)

NewMailItem.Send

Open LogPath + "Logs.txt" For Append As #1

Print #1, "[" + Format(Now, "yyyy-mm-dd hh:mm:ss") + "]から" + objMail.SenderEmailAddress + "受信メール " + objMail.Subject + " という件はstr！"

Close #1

End Sub