ThisOutlookSession文件
VERSION
1.0
Class BEGIN
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()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()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
End If
GetSubjectAndUser = False
Exit Function
End Function
'答えメールを客様へ発送
Private Sub SendToCustomer()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()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()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()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()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()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()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()Sub Application_Quit()
If TimerID <> 0 Then
Call DeactivateTimer
End If
End Sub
Private Sub Application_Startup()Sub Application_Startup()
'---------------------------
'自分定義data
MailID = 0
'指定ログファイルパス
LogPath = ""
'内部係メールアドレスリスト
DFMailList = ""
'---------------------------
Call SetMailID
Call ActivateTimer(1 * 60 * 6)
Call GetUnResolveMailList
End Sub
文件2
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()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()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
End If
GetSubjectAndUser = False
Exit Function
End Function
'答えメールを客様へ発送
Private Sub SendToCustomer()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()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()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()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()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()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()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()Sub Application_Quit()
If TimerID <> 0 Then
Call DeactivateTimer
End If
End Sub
Private Sub Application_Startup()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() 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()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()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()Sub DeactivateTimer()
Dim lSuccess As Long
lSuccess = KillTimer(0, TimerID)
If lSuccess <> 0 Then
TimerID = 0
End If
End Sub
Public Sub TriggerTimer()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()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
Option Explicit
Declare Function SetTimer() 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()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()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()Sub DeactivateTimer()
Dim lSuccess As Long
lSuccess = KillTimer(0, TimerID)
If lSuccess <> 0 Then
TimerID = 0
End If
End Sub
Public Sub TriggerTimer()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()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