VB、VBS和VBA中使用outlook学习（二）

最新推荐文章于 2023-08-23 00:17:25 发布

寒炫

最新推荐文章于 2023-08-23 00:17:25 发布

阅读量2.5k

点赞数

分类专栏： VB 文章标签： vba vb integer application function string

VB 专栏收录该内容

3 篇文章 0 订阅

订阅专栏

一、初识「Outlook.MailItem」对象的使用

转⇒outlook vba 插件

' 定義された変数

Dim DelAfterHandle As Boolean

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

Option Explicit

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

End Sub

' 受信時の動作

Private Sub Application_NewMailEx() 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() 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() Function GetAnswerAndReply(bodystr As String ) As Boolean

GetAnswerAndReply = True

Exit Function

End Function

Private Sub SendToDF() 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() 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

寒炫

关注

0
点赞
踩
3

收藏

觉得还不错? 一键收藏
0
评论
VB、VBS和VBA中使用outlook学习（二）

一、初识「Outlook.MailItem」对象的使用转⇒outlook vba 插件定義された変数Dim DelAfterHandle As BooleanDim Question, Reply, LogPath, DFMailList, strBody, strSubject, strUser As StringOption ExplicitPrivate Sub Applica
复制链接

扫一扫