outlook vba 插件2

来源：互联网发布：mac怎么装linux虚拟机编辑：程序博客网时间：2024/05/15 17:50

ThisOutlookSession文件

VERSION 1.0 CLASS

BEGIN

MultiUse = -1 'True

END

Attribute VB_Name = "ThisOutlookSession"

Attribute VB_GlobalNameSpace = False

Attribute VB_Creatable = False

Attribute VB_PredeclaredId = True

Attribute VB_Exposed = True

'定義された変数

Dim Question, Reply, LogPath, DFMailList As String

Dim MailID As Long

Option Explicit

'受信時の動作

Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)

'受信したメール

Dim objMail As Object

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

Dim NewMailItem As Outlook.MailItem

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

Dim myRecipient As Outlook.Recipient

Dim intBegin, intEnd, intLength As Integer

Dim strEntryID As String

MailID = MailID + 1

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)

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

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

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

Call SendToCustomer(objMail)

Else

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

Call AutoReply(objMail, "<HTML><BODY><H2>メールもう受信しました。</H2><H2>御前の問題を解決後で、すぐ連絡します。</H2>")

Call SaveUnResolveMailInfo(objMail)

Call SendToDF(objMail)

End If

intBegin = intEnd + 1

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

Loop

End Sub

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

Private Function GetSubjectAndUser(subjectstr As String, subject As String, user As String, id As Long) As Boolean

Dim intPos1, intpos2 As Integer

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

If intPos1 <> 0 Then

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

subject = Mid(subjectstr, 1, intPos1 - 1)

intpos2 = InStr(intPos1 + 1, subjectstr, ";")

user = Mid(subjectstr, intPos1 + 1, intpos2 - intPos1 - 1)

id = CLng(Mid(subjectstr, intpos2 + 1))

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

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

GetSubjectAndUser = True

Exit Function

End If

GetSubjectAndUser = False

Exit Function

End Function

'答えメールを客様へ発送

Private Sub SendToCustomer(objMail)

Dim strSubject As String

Dim strUser As String

Dim id As Long

Dim NewMailItem As Outlook.MailItem

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

If GetSubjectAndUser(objMail.subject, strSubject, strUser, id) <> False Then

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

Call ChangeUnResolveMailStatus(objMail, id + 1)

Set NewMailItem = objMail.Forward

NewMailItem.subject = strSubject

NewMailItem.Recipients.Add (strUser)

NewMailItem.Send

Else

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

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

End If

End Sub

Private Sub ChangeUnResolveMailStatus(objMail, id)

Dim xlApp As Excel.Application

Dim xlWb As Excel.Workbook

Dim xlWk As Excel.Worksheet

Dim Rng As Excel.Range

Dim LastRow As Long

Set xlApp = ThisOutlookSession.CreateObject("Excel.Application")

Set xlWb = xlApp.Workbooks.Open(CStr(LogPath & "" & "MailExcel.xls"))

Set xlWk = xlWb.Worksheets(1)

Set Rng = xlWk.Range("A1")

With xlWk

.Cells(id, 9).Value = "解決した"

.Cells(id, 10).Value = Trim(objMail.ReceivedTime)

.Cells(id, 11).Value = Trim(objMail.HTMLBody)

If objMail.Attachments.Count <> 0 Then

Dim i As Integer

Dim oFSO

Dim sPath

Dim nPosition, nItem

sPath = LogPath & "" & "Attachment" & "" & objMail.SenderEmailAddress & ""

nPosition = InStr(1, sPath, "", 0)

Set oFSO = CreateObject("Scripting.FileSystemObject")

While (nPosition <> 0)

If (Not oFSO.FolderExists(Mid(sPath, 1, nPosition))) Then

oFSO.CreateFolder (Mid(sPath, 1, nPosition))

End If

nPosition = InStr(nPosition + 1, sPath, "", 0)

Wend

Set oFSO = Nothing

For i = 1 To objMail.Attachments.Count Step 1

objMail.Attachments.Item(i).SaveAsFile (sPath & "" & objMail.Attachments.Item(i).DisplayName)

.Cells(id, 12).Value = .Cells(id, 12).Value & vbCrLf & sPath & "" & objMail.Attachments.Item(i).DisplayName

Next i

.Hyperlinks.Add .Cells(id, 13), sPath

Else

.Cells(id, 12).Value = "添付ファイルがない"

End If

End With

xlWb.Close (True)

Set xlWk = Nothing

Set xlWb = Nothing

Set xlApp = Nothing

Set Rng = Nothing

End Sub

'サポート者へ転送Proc

Private Sub SendToDF(objMail)

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

Dim intPos As Integer

Dim oldPos As Integer

Dim strUser As String

Dim NewMailItem As Outlook.MailItem

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

Do While intPos <> 0

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

Set NewMailItem = objMail.Forward

NewMailItem.subject = objMail.subject + ";" + objMail.SenderEmailAddress + ";" + CStr(MailID)

NewMailItem.Recipients.Add (strUser)

NewMailItem.Send

oldPos = intPos

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

Loop

strUser = Mid(DFMailList, oldPos + 1)

If strUser <> "" Then

Set NewMailItem = objMail.Forward

NewMailItem.subject = objMail.subject + ";" + objMail.SenderEmailAddress + ";" + CStr(MailID)

NewMailItem.Recipients.Add (strUser)

NewMailItem.Send

End If

End Sub

'サポート者は書いたメールの格式がエラーを含まる時、エラーメールを発送Proc

Private Sub AutoReply(objMail, str)

Dim NewMailItem As Outlook.MailItem

Set NewMailItem = Application.CreateItem(olMailItem)

With NewMailItem

.BodyFormat = olFormatHTML

.HTMLBody = str

.subject = "Re:" + objMail.subject

End With

NewMailItem.Recipients.Add (objMail.SenderEmailAddress)

NewMailItem.Send

End Sub

Private Sub CreatePath(sPath)

Dim oFSO As Object

Dim nPosition As Integer

nPosition = InStr(1, sPath, "", 0)

Set oFSO = CreateObject("Scripting.FileSystemObject")

While (nPosition <> 0)

If (Not oFSO.FolderExists(Mid(sPath, 1, nPosition))) Then

oFSO.CreateFolder (Mid(sPath, 1, nPosition))

End If

nPosition = InStr(nPosition + 1, sPath, "", 0)

Wend

Set oFSO = Nothing

End Sub

Private Sub SaveUnResolveMailInfo(objMail)

Dim xlApp As Excel.Application

Dim xlWb As Excel.Workbook

Dim xlWk As Excel.Worksheet

Dim Rng As Excel.Range

Dim LastRow As Long

Dim sPath As String

sPath = LogPath & "OrinalMail"

CreatePath (sPath)

objMail.SaveAs sPath & Format(objMail.ReceivedTime, "yyyy-mm-dd") & " " & "(" & objMail.SenderEmailAddress & ")" & ".msg", OlSaveAsType.olMSG

Set xlApp = ThisOutlookSession.CreateObject("Excel.Application")

Set xlWb = xlApp.Workbooks.Open(CStr(LogPath & "" & "MailExcel.xls"))

Set xlWk = xlWb.Worksheets(1)

Set Rng = xlWk.Range("A1")

LastRow = Rng.Cells(xlWk.Rows.Count, 1).End(xlUp).Row + 1

With xlWk

.Cells(LastRow, 1).Value = Trim(MailID)

.Cells(LastRow, 2).Value = Trim(objMail.SenderEmailAddress)

.Cells(LastRow, 3).Value = Trim(objMail.ReceivedTime)

.Cells(LastRow, 4).Value = Trim(objMail.subject)

.Cells(LastRow, 5).Value = Trim(objMail.HTMLBody)

If objMail.Attachments.Count <> 0 Then

Dim i As Integer

sPath = LogPath & "" & "Attachment" & "" & objMail.SenderEmailAddress & ""

CreatePath (sPath)

For i = 1 To objMail.Attachments.Count Step 1

objMail.Attachments.Item(i).SaveAsFile (sPath & "" & objMail.Attachments.Item(i).DisplayName)

.Cells(LastRow, 6).Value = .Cells(LastRow, 6).Value & vbCrLf & sPath & "" & objMail.Attachments.Item(i).DisplayName

Next i

.Hyperlinks.Add .Cells(LastRow, 7), sPath

Else

.Cells(LastRow, 6).Value = "添付ファイルがない"

End If

.Cells(LastRow, 8).Value = LogPath & "OrinalMail" & Format(objMail.ReceivedTime, "yyyy-mm-dd") & " " & "(" & objMail.subject & ")" & ".msg"

.Hyperlinks.Add .Cells(LastRow, 8), LogPath & "OrinalMail" & Format(objMail.ReceivedTime, "yyyy-mm-dd") & " " & "(" & objMail.subject & ")" & ".msg"

.Cells(LastRow, 9).Value = "解決していない"

LastRow = LastRow + 1

End With

Set Rng = xlWk.Cells(LastRow, 1)

xlWb.Close (True)

Set xlWk = Nothing

Set xlWb = Nothing

Set xlApp = Nothing

Set Rng = Nothing

End Sub

Private Sub SetMailID()

Dim xlApp As Excel.Application

Dim xlWb As Excel.Workbook

Dim xlWk As Excel.Worksheet

Dim Rng As Excel.Range

Set xlApp = ThisOutlookSession.CreateObject("Excel.Application")

Set xlWb = xlApp.Workbooks.Open(CStr(LogPath & "" & "MailExcel.xls"))

Set xlWk = xlWb.Worksheets(1)

Set Rng = xlWk.Range("A1")

With Rng

.Value = "メールID"

.Font.Bold = True

.Font.Color = vbBlue

.Interior.ColorIndex = 4

.HorizontalAlignment = xlCenter

.WrapText = True

.Offset(0, 1).Value = "発信者"

.Offset(0, 1).Font.Bold = True

.Offset(0, 1).Font.Color = vbBlue

.Offset(0, 1).Interior.ColorIndex = 4

.Offset(0, 1).HorizontalAlignment = xlCenter

.Offset(0, 1).WrapText = True

.Offset(0, 1).ColumnWidth = 22

.Offset(0, 2).Value = "発信時刻"

.Offset(0, 2).Font.Bold = True

.Offset(0, 2).Font.Color = vbBlue

.Offset(0, 2).Interior.ColorIndex = 4

.Offset(0, 2).HorizontalAlignment = xlCenter

.Offset(0, 2).WrapText = True

.Offset(0, 2).ColumnWidth = 22

.Offset(0, 3).Value = "メールの件名"

.Offset(0, 3).Font.Bold = True

.Offset(0, 3).Font.Color = vbBlue

.Offset(0, 3).Interior.ColorIndex = 4

.Offset(0, 3).HorizontalAlignment = xlCenter

.Offset(0, 3).WrapText = True

.Offset(0, 3).ColumnWidth = 22

.Offset(0, 4).Value = "問題内容"

.Offset(0, 4).Font.Bold = True

.Offset(0, 4).Font.Color = vbBlue

.Offset(0, 4).Interior.ColorIndex = 4

.Offset(0, 4).HorizontalAlignment = xlCenter

.Offset(0, 4).WrapText = True

.Offset(0, 4).ColumnWidth = 50

.Offset(0, 5).Value = "添付ファイル"

.Offset(0, 5).Font.Bold = True

.Offset(0, 5).Font.Color = vbBlue

.Offset(0, 5).Interior.ColorIndex = 4

.Offset(0, 5).HorizontalAlignment = xlCenter

.Offset(0, 5).WrapText = True

.Offset(0, 5).ColumnWidth = 22

.Offset(0, 6).Value = "添付ファイルのパス"

.Offset(0, 6).Font.Bold = True

.Offset(0, 6).Font.Color = vbBlue

.Offset(0, 6).Interior.ColorIndex = 4

.Offset(0, 6).HorizontalAlignment = xlCenter

.Offset(0, 6).WrapText = True

.Offset(0, 6).ColumnWidth = 22

.Offset(0, 7).Value = "原始メール"

.Offset(0, 7).Font.Bold = True

.Offset(0, 7).Font.Color = vbBlue

.Offset(0, 7).Interior.ColorIndex = 4

.Offset(0, 7).HorizontalAlignment = xlCenter

.Offset(0, 7).WrapText = True

.Offset(0, 7).ColumnWidth = 22

.Offset(0, 8).Value = "解決状態"

.Offset(0, 8).Font.Bold = True

.Offset(0, 8).Font.Color = vbBlue

.Offset(0, 8).Interior.ColorIndex = 4

.Offset(0, 8).HorizontalAlignment = xlCenter

.Offset(0, 8).WrapText = True

.Offset(0, 8).ColumnWidth = 22

.Offset(0, 9).Value = "解決時刻"

.Offset(0, 9).Font.Bold = True

.Offset(0, 9).Font.Color = vbBlue

.Offset(0, 9).Interior.ColorIndex = 4

.Offset(0, 9).HorizontalAlignment = xlCenter

.Offset(0, 9).WrapText = True

.Offset(0, 9).ColumnWidth = 22

.Offset(0, 10).Value = "答え内容"

.Offset(0, 10).Font.Bold = True

.Offset(0, 10).Font.Color = vbBlue

.Offset(0, 10).Interior.ColorIndex = 4

.Offset(0, 10).HorizontalAlignment = xlCenter

.Offset(0, 10).WrapText = True

.Offset(0, 10).ColumnWidth = 22

.Offset(0, 11).Value = "答え時添付ファイル"

.Offset(0, 11).Font.Bold = True

.Offset(0, 11).Font.Color = vbBlue

.Offset(0, 11).Interior.ColorIndex = 4

.Offset(0, 11).HorizontalAlignment = xlCenter

.Offset(0, 11).WrapText = True

.Offset(0, 11).ColumnWidth = 22

.Offset(0, 12).Value = "答え時添付ファイルのパス"

.Offset(0, 12).Font.Bold = True

.Offset(0, 12).Font.Color = vbBlue

.Offset(0, 12).Interior.ColorIndex = 4

.Offset(0, 12).HorizontalAlignment = xlCenter

.Offset(0, 12).WrapText = True

.Offset(0, 12).ColumnWidth = 22

End With

MailID = Rng.Cells(xlWk.Rows.Count, 1).End(xlUp).Row - 1

xlWb.Close (True)

Set xlWk = Nothing

Set xlWb = Nothing

Set xlApp = Nothing

Set Rng = Nothing

End Sub

Private Sub Application_Quit()

If TimerID <> 0 Then

Call DeactivateTimer

End If

End Sub

Private Sub Application_Startup()

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

'自分定義data

MailID = 0

'指定ログファイルパス

LogPath = ""

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

DFMailList = ""

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

Call SetMailID

Call ActivateTimer(1 * 60 * 6)

Call GetUnResolveMailList

End Sub

文件2

Attribute VB_Name = "Module1"

Option Explicit

Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerfunc As Long) As Long

Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long

Public TimerID As Long 'Need a timer ID to eventually turn off the timer. If the timer ID <> 0 then the timer is running

Public Sub ActivateTimer(ByVal nMinutes As Long)

nMinutes = nMinutes * 1000 * 60 'The SetTimer call accepts milliseconds, so convert to minutes

If TimerID <> 0 Then

Call DeactivateTimer 'Check to see if timer is running before call to SetTimer

End If

TimerID = SetTimer(0, 0, nMinutes, AddressOf TriggerTimer)

End Sub

Public Sub DeactivateTimer()

Dim lSuccess As Long

lSuccess = KillTimer(0, TimerID)

If lSuccess <> 0 Then

TimerID = 0

End If

End Sub

Public Sub TriggerTimer(ByVal hwnd As Long, ByVal uMsg As Long, ByVal idevent As Long, ByVal Systime As Long)

Call GetUnResolveMailList

End Sub

Public Sub GetUnResolveMailList()

Dim xlApp As Excel.Application

Dim xlWb As Excel.Workbook

Dim xlWk As Excel.Worksheet

Dim Rng As Excel.Range

Dim i As Long

Dim strbody As String

Dim NewMailItem As Outlook.MailItem

Dim Sendflag As Boolean

Sendflag = False

Set NewMailItem = Application.CreateItem(olMailItem)

strbody = "解決していないメールリスト:" & vbCrLf

With NewMailItem

.BodyFormat = olFormatHTML

.subject = "三日経って以上まだ解決していないメールリスト"

End With

NewMailItem.Recipients.Add ("")

Set xlApp = ThisOutlookSession.CreateObject("Excel.Application")

Set xlWb = xlApp.Workbooks.Open(CStr("D:DFQA" & "" & "MailExcel.xls"))

Set xlWk = xlWb.Worksheets(1)

Set Rng = xlWk.Range("A1")

For i = 2 To Rng.Cells(xlWk.Rows.Count, 1).End(xlUp).Row Step 1

If xlWk.Cells(i, 9).Value = "三日経って以上まだ解決していない" & DateDiff("d", Time, xlWk.Cells(i, 3).Value) > 3 Then

Sendflag = True

strbody = strbody & "メール" & CStr(i) & " :" & xlWk.Cells(i, 2).Value & "発信件名は" & xlWk.Cells(i, 4).Value & "対応原始メールは添付ファイルの" & xlWk.Cells(i, 8).Value & "です。" & vbCrLf

NewMailItem.Attachments.Add xlWk.Cells(i, 8).Value

End If

Next i

If Sendflag Then

NewMailItem.HTMLBody = "<HTML><BODY><H2>strbody</H2></BODY></HTML>"

NewMailItem.Send

End If

NewMailItem.Delete

xlWb.Close (False)

Set xlWk = Nothing

Set xlWb = Nothing

Set xlApp = Nothing

Set Rng = Nothing

End Sub