下記のコードをVBAエディターに張り付けてください。
※赤字の部分を使用者の名前に変更してください。
以下のルールでメールを書き出します。
- 会議招待メール → 自動で承諾し、削除
- CC に使用者の名前が含まれ、本文の最初の数行にないメール
- 宛先にユーザーの名前がないメール
上記以外のメールは重要度が高いので書き出さない
宛先がユーザーだけの場合は、広告メールの可能性があるので、確認して不要なアドレスは保存しておき削除リストにある場合はメールを削除
Option Explicit
' Main procedure for email organization
Sub メール整理Claud()
Dim objNS As NameSpace
Dim srcFolder As MAPIFolder
Dim destFolder As MAPIFolder
Dim plantFolder As MAPIFolder
Dim saveDataFilename As String
Dim eraseAddressList() As String
Dim npointer As Long
Dim eraseAddressFile As String
Dim nameFilter As String
Dim jsonData As String
On Error GoTo ErrorHandler
' Configuration settings
Const DEBUG_MODE As Boolean = False
nameFilter = "Your Name"
eraseAddressFile = "C:\Users\Public\Taro\Outlook File\er_address.txt"
' Validate that address file exists
If Dir(eraseAddressFile) = "" Then
MsgBox "アドレスファイルが見つかりません: " & eraseAddressFile, vbExclamation
Exit Sub
End If
' Initialize Outlook folders
Set objNS = Application.GetNamespace("MAPI")
Set srcFolder = objNS.GetDefaultFolder(olFolderInbox)
' Get destination folder from user
Set destFolder = objNS.PickFolder
If destFolder Is Nothing Then Exit Sub
If destFolder.EntryID = srcFolder.EntryID Then
MsgBox "送信元と同じフォルダが選択されました。", vbExclamation
Exit Sub
End If
' Get plant management folder
On Error Resume Next
Set plantFolder = srcFolder.Folders("プラント管理メール")
On Error GoTo ErrorHandler
If plantFolder Is Nothing Then
MsgBox "プラント管理メール フォルダが見つかりません。フォルダを作成してください。", vbExclamation
Exit Sub
End If
' Get filename for JSON export
saveDataFilename = GetSaveFilename()
If saveDataFilename = "" Then
MsgBox "終了します。", vbInformation
GoTo Cleanup
End If
' Load the address list for automatic deletion
npointer = LoadAddressList(eraseAddressList, eraseAddressFile)
If npointer < 0 Then GoTo Cleanup
' Process meeting requests
ProcessMeetingRequests srcFolder
' Sort and process mail items
Dim sortedItems() As mailItem
Dim itemCount As Long
itemCount = GetSortedMailItems(srcFolder, sortedItems)
' Process mail items and generate JSON
jsonData = ProcessMailItems(sortedItems, itemCount, nameFilter, destFolder, plantFolder, _
eraseAddressList, npointer, eraseAddressFile, DEBUG_MODE)
' Save JSON data to file
SaveDataAsUTF8 jsonData, saveDataFilename
MsgBox "終了しました。", vbOKOnly, "終了"
Cleanup:
Set objNS = Nothing
Set srcFolder = Nothing
Set destFolder = Nothing
Set plantFolder = Nothing
Exit Sub
ErrorHandler:
MsgBox "エラーが発生しました: " & Err.Description, vbCritical
Resume Cleanup
End Sub
' Process all mail items and generate JSON data
Function ProcessMailItems(items() As mailItem, itemCount As Long, nameFilter As String, _
destFolder As MAPIFolder, plantFolder As MAPIFolder, _
ByRef eraseAddressList() As String, ByRef npointer As Long, _
eraseAddressFile As String, isDebug As Boolean) As String
Dim mailItem As mailItem
Dim recipientType As Integer
Dim senderAddress As String
Dim jsonArray As String
Dim isFirstItem As Boolean
Dim i As Long
Dim result As Integer
jsonArray = "["
isFirstItem = True
For i = 0 To itemCount - 1
Set mailItem = items(i)
recipientType = CheckRecipientType(mailItem, nameFilter)
senderAddress = GetSenderAddress(mailItem)
Select Case recipientType
Case 7, 8 ' Plant management emails
If Not isDebug Then mailItem.Move plantFolder
Case 0 ' No recipients match filter
If Not isDebug Then mailItem.Move destFolder
Case 2 ' CC recipient and not in first 3 lines
If Not CheckNameInFirstLines(mailItem, nameFilter) Then
If Not isFirstItem Then jsonArray = jsonArray & ","
jsonArray = jsonArray & CreateMailItemJSON(mailItem)
isFirstItem = False
If Not isDebug Then mailItem.Move destFolder
End If
Case 9 ' Only recipient and has sender address
If senderAddress <> "" Then
result = HandleSenderAddress(mailItem, eraseAddressList, npointer, eraseAddressFile)
If Not isDebug And result = 1 Then mailItem.Delete
End If
End Select
Next i
jsonArray = jsonArray & "]"
ProcessMailItems = jsonArray
End Function
' Gets mail items from folder and sorts by received time (newest first)
Function GetSortedMailItems(folder As MAPIFolder, ByRef items() As mailItem) As Long
Dim allItems As items
Dim item As Object
Dim mailItem As mailItem
Dim i As Long
Dim count As Long
' First count the actual mail items
count = 0
For Each item In folder.items
If TypeOf item Is mailItem Then count = count + 1
Next
If count = 0 Then
GetSortedMailItems = 0
Exit Function
End If
' Dimension the array to exact size needed
ReDim items(0 To count - 1) As mailItem
' Populate the array with mail items
i = 0
For Each item In folder.items
If TypeOf item Is mailItem Then
Set items(i) = item
i = i + 1
End If
Next
' Use QuickSort on the array
QuickSortMailItems items, 0, count - 1
GetSortedMailItems = count
End Function
' Optimized QuickSort algorithm for mail items (newest first)
Sub QuickSortMailItems(ByRef items() As mailItem, ByVal low As Long, ByVal high As Long)
Dim pivot As Date
Dim i As Long, j As Long
Dim tempItem As mailItem
If low < high Then
' Use middle item as pivot to improve performance on already sorted data
pivot = items((low + high) \ 2).ReceivedTime
i = low
j = high
Do
' Find item on left that should be on right
While items(i).ReceivedTime > pivot And i < high
i = i + 1
Wend
' Find item on right that should be on left
While pivot > items(j).ReceivedTime And j > low
j = j - 1
Wend
' Swap the items
If i <= j Then
Set tempItem = items(i)
Set items(i) = items(j)
Set items(j) = tempItem
i = i + 1
j = j - 1
End If
Loop Until i > j
' Recursively sort the sub-arrays
If low < j Then QuickSortMailItems items, low, j
If i < high Then QuickSortMailItems items, i, high
End If
End Sub
' Check recipient type and return appropriate code
Function CheckRecipientType(mailItem As mailItem, nameFilter As String) As Integer
Dim recipient As recipient
Dim subject As String
Dim sender As String
subject = mailItem.subject
sender = mailItem.senderName
' Check for plant management system emails
If Left(subject, 10) = "プラント管理システム" Then
CheckRecipientType = 8
Exit Function
End If
If sender = "crepf-sys@nacoo.net" And Left(subject, 5) = "エラー発生" Then
CheckRecipientType = 8
Exit Function
End If
If Left(sender, 2) = "CC" And InStr(1, subject, "プラントデータ") <> 0 Then
CheckRecipientType = 7
Exit Function
End If
' Check recipients
For Each recipient In mailItem.recipients
If InStr(recipient.Name, nameFilter) <> 0 Then
If mailItem.recipients.count = 1 Then
CheckRecipientType = 9 ' Only recipient
Else
CheckRecipientType = recipient.Type ' Type: BCC=3, CC=2, TO=1, Originator=0
End If
Exit Function
End If
Next
CheckRecipientType = 0 ' No matching recipients
End Function
' Get sender's email address
Function GetSenderAddress(mailItem As mailItem) As String
If mailItem.SenderEmailType = "EX" Then
GetSenderAddress = ""
Else
GetSenderAddress = mailItem.SenderEmailAddress
End If
End Function
' Check if name appears in first few lines of email body
Function CheckNameInFirstLines(mailItem As mailItem, nameFilter As String) As Boolean
Dim topLines As String
' Get top lines of body (6 rows to account for HTML formatting)
topLines = GetTopLines(mailItem.body, 6, mailItem.BodyFormat)
CheckNameInFirstLines = (InStr(topLines, nameFilter) <> 0)
End Function
' Get the top N lines of text
Function GetTopLines(text As String, lineCount As Integer, format As OlBodyFormat) As String
Dim lineBreak As String
Dim position As Long
Dim nextPosition As Long
Dim i As Integer
Dim result As String
' Determine line break character based on format
If format = olFormatHTML Then
lineBreak = vbCrLf
Else
lineBreak = vbLf
End If
position = 1
result = ""
For i = 1 To lineCount
nextPosition = InStr(position, text, lineBreak, vbBinaryCompare)
If nextPosition = 0 Then
' No more line breaks, include rest of text
result = result & Mid(text, position)
Exit For
Else
' Add current line to result
result = result & Mid(text, position, nextPosition - position + Len(lineBreak))
position = nextPosition + Len(lineBreak)
End If
Next i
GetTopLines = result
End Function
' Process meeting requests automatically
Sub ProcessMeetingRequests(folder As MAPIFolder)
Dim item As Object
Dim meetingItem As meetingItem
Dim appointment As AppointmentItem
On Error Resume Next
For Each item In folder.items
If TypeOf item Is meetingItem Then
Set meetingItem = item
Set appointment = meetingItem.GetAssociatedAppointment(True)
If Not appointment Is Nothing Then
appointment.Respond olResponseAccepted, True
meetingItem.Delete
End If
End If
Next
On Error GoTo 0
End Sub
' Handle sender address processing
Function HandleSenderAddress(mailItem As mailItem, ByRef eraseAddressList() As String, _
ByRef npointer As Long, eraseAddressFile As String) As Integer
Dim result As Integer
Dim senderAddress As String
Dim addressStatus As Integer
senderAddress = mailItem.SenderEmailAddress
addressStatus = CheckAddressInList(senderAddress, eraseAddressList)
Select Case addressStatus
Case 0 ' Delete
HandleSenderAddress = 1
Case 9 ' Not in list, ask user
result = InquireAboutAddress(mailItem)
' Ensure array has enough space
If UBound(eraseAddressList, 2) < npointer Then
ReDim Preserve eraseAddressList(0 To 1, 0 To npointer + 10)
End If
If result = vbYes Then ' Delete
eraseAddressList(0, npointer) = senderAddress
eraseAddressList(1, npointer) = 0
npointer = npointer + 1
SaveAddressToFile senderAddress, 0, eraseAddressFile
HandleSenderAddress = 1
ElseIf result = vbNo Then ' Keep
eraseAddressList(0, npointer) = senderAddress
eraseAddressList(1, npointer) = 1
npointer = npointer + 1
SaveAddressToFile senderAddress, 1, eraseAddressFile
HandleSenderAddress = 0
End If
Case Else ' Keep
HandleSenderAddress = 0
End Select
End Function
' Check if address exists in deletion list
Function CheckAddressInList(address As String, ByRef addressList() As String) As Integer
Dim i As Long
If Not IsArrayInitialized(addressList) Then
CheckAddressInList = 9 ' Not in list
Exit Function
End If
For i = 0 To UBound(addressList, 2)
If addressList(0, i) = address Then
CheckAddressInList = addressList(1, i) ' Return status (0=delete, 1=keep)
Exit Function
End If
Next
CheckAddressInList = 9 ' Not in list
End Function
' Load address list from file
Function LoadAddressList(ByRef addressList() As String, filename As String) As Long
Dim fileNumber As Integer
Dim address As String
Dim flag As String
Dim i As Long
On Error GoTo ErrorHandler
' Initialize array
ReDim addressList(0 To 1, 0 To 10)
' Check if file exists
If Dir(filename) = "" Then
LoadAddressList = 0
Exit Function
End If
' Open file
fileNumber = FreeFile
Open filename For Input As #fileNumber
i = 0
Do Until EOF(fileNumber)
' Read address and flag
Input #fileNumber, address, flag
' Resize array if needed
If i > UBound(addressList, 2) Then
ReDim Preserve addressList(0 To 1, 0 To i + 10)
End If
' Store values
addressList(0, i) = address
addressList(1, i) = Val(flag)
i = i + 1
Loop
Close #fileNumber
LoadAddressList = i
Exit Function
ErrorHandler:
MsgBox "アドレスリストの読み込み中にエラーが発生しました: " & Err.Description, vbCritical
If fileNumber > 0 Then Close #fileNumber
LoadAddressList = -1
End Function
' Save address and flag to file
Sub SaveAddressToFile(address As String, flag As Integer, filename As String)
Dim fileNumber As Integer
On Error Resume Next
fileNumber = FreeFile
Open filename For Append As #fileNumber
Write #fileNumber, address, flag
Close #fileNumber
End Sub
' Show dialog to ask about address
Function InquireAboutAddress(mailItem As mailItem) As Integer
Dim senderName As String
Dim senderAddress As String
Dim subject As String
senderName = mailItem.senderName
senderAddress = mailItem.SenderEmailAddress
subject = mailItem.subject
Load InqDlg
InqDlg.StartUpPosition = 1
InqDlg.Caption = "削除リストに追加しますか？"
InqDlg.Label_sender.Caption = senderName
InqDlg.Label_adress = senderAddress
InqDlg.Label_subject = subject
InqDlg.Show
InquireAboutAddress = InqDlg.DialogResult
End Function
' Create JSON representation of mail item
Function CreateMailItemJSON(mailItem As mailItem) As String
Dim json As String
Dim toRecipients As String
Dim ccRecipients As String
Dim bccRecipients As String
Dim attachments As String
Dim recipient As Outlook.recipient
Dim attachment As Outlook.attachment
Dim bodyText As String
' Process To recipients
toRecipients = "["
For Each recipient In mailItem.recipients
If recipient.Type = olTo Then
If toRecipients <> "[" Then toRecipients = toRecipients & "," & vbCrLf & vbTab & vbTab
toRecipients = toRecipients & """" & recipient.Name & """"
End If
Next recipient
If Len(toRecipients) > 1 Then toRecipients = toRecipients & vbCrLf & vbTab
toRecipients = toRecipients & "]"
' Process CC recipients
ccRecipients = "["
For Each recipient In mailItem.recipients
If recipient.Type = olCC Then
If ccRecipients <> "[" Then ccRecipients = ccRecipients & "," & vbCrLf & vbTab & vbTab
ccRecipients = ccRecipients & """" & recipient.Name & """"
End If
Next recipient
If Len(ccRecipients) > 1 Then ccRecipients = ccRecipients & vbCrLf & vbTab
ccRecipients = ccRecipients & "]"
' Process BCC recipients
bccRecipients = "["
For Each recipient In mailItem.recipients
If recipient.Type = olBCC Then
If bccRecipients <> "[" Then bccRecipients = bccRecipients & "," & vbCrLf & vbTab & vbTab
bccRecipients = bccRecipients & """" & recipient.Name & """"
End If
Next recipient
If Len(bccRecipients) > 1 Then bccRecipients = bccRecipients & vbCrLf & vbTab
bccRecipients = bccRecipients & "]"
' Process attachments
attachments = "["
For Each attachment In mailItem.attachments
If attachments <> "[" Then attachments = attachments & "," & vbCrLf & vbTab & vbTab
attachments = attachments & """" & EscapeJSON(attachment.filename) & """"
Next attachment
If Len(attachments) > 1 Then attachments = attachments & vbCrLf & vbTab
attachments = attachments & "]"
' Process body (truncate if too long)
bodyText = TruncateLongEmail(mailItem.body)
' Build JSON structure
json = "{" & vbCrLf
json = json & vbTab & """ReceivedTime"": """ & format(mailItem.ReceivedTime, "yyyy-mm-dd hh:nn:ss") & """," & vbCrLf
json = json & vbTab & """SenderName"": """ & EscapeJSON(mailItem.senderName) & """," & vbCrLf
json = json & vbTab & """Subject"": """ & EscapeJSON(mailItem.subject) & """," & vbCrLf
json = json & vbTab & """To"": " & toRecipients & "," & vbCrLf
json = json & vbTab & """CC"": " & ccRecipients & "," & vbCrLf
json = json & vbTab & """BCC"": " & bccRecipients & "," & vbCrLf
json = json & vbTab & """Attachments"": " & attachments & "," & vbCrLf
json = json & vbTab & """Body"": """ & EscapeJSON(bodyText) & """" & vbCrLf
json = json & "}"
CreateMailItemJSON = json
End Function
' Truncate long emails to a reasonable size
Function TruncateLongEmail(emailBody As String) As String
Const MAX_LENGTH As Long = 10000
Dim result As String
Dim position As Long
Dim nextMatchPos As Long
' If email is already within limit, return as is
If Len(emailBody) <= MAX_LENGTH Then
TruncateLongEmail = emailBody
Exit Function
End If
' Start building truncated content
result = ""
position = 1
Do While position > 0
' Find next matching line position
nextMatchPos = FindFirstMatchingLine(emailBody, position)
' If no more matching lines are found, append the remaining text
If nextMatchPos = 0 Then
If Len(result & Mid(emailBody, position)) > MAX_LENGTH Then
Exit Do
End If
result = result & Mid(emailBody, position)
Exit Do
End If
' Append text up to the matching position
If Len(result & Mid(emailBody, position, nextMatchPos - position)) > MAX_LENGTH Then
Exit Do
End If
result = result & Mid(emailBody, position, nextMatchPos - position)
' Update position to continue after the match
position = InStr(nextMatchPos, emailBody, vbCrLf)
If position = 0 Then
Exit Do
Else
position = position + 2
End If
Loop
TruncateLongEmail = result
End Function
' Find email format patterns like reply headers
Function FindFirstMatchingLine(text As String, Optional startPos As Long = 1) As Long
Dim regEx As Object
Dim matches As Object
Dim searchText As String
' Adjust starting position
If startPos < 1 Then startPos = 1
If startPos > Len(text) Then
FindFirstMatchingLine = 0
Exit Function
End If
' Create regex object
Set regEx = CreateObject("VBScript.RegExp")
regEx.Pattern = "(\d{4}年\d{1,2}月\d{1,2}日\(.\) \d{1,2}:\d{2} .+ <.+@.+\..+>:" & _
"|差出人: .+ <.+@.+\..+>" & _
"|-+ Original Message -+\nFrom : \"".+\""<.+@.+\..+>)"
regEx.IgnoreCase = True
regEx.Global = False
' Get substring from starting position
searchText = Mid(text, startPos)
' Execute regex
Set matches = regEx.Execute(searchText)
' Return match position if found
If matches.count > 0 Then
FindFirstMatchingLine = startPos + matches(0).FirstIndex - 1
Else
FindFirstMatchingLine = 0
End If
End Function
' Escape special characters for JSON output
Function EscapeJSON(text As String) As String
Dim result As String
result = text
result = Replace(result, "\", "\\")
result = Replace(result, """", "\""")
result = Replace(result, vbCrLf, "\n")
result = Replace(result, vbLf, "\n")
result = Replace(result, vbCr, "\n")
result = Replace(result, vbTab, " ")
' Remove control characters
result = RemoveControlCharacters(result)
EscapeJSON = result
End Function
' Remove control characters from text
Function RemoveControlCharacters(text As String) As String
Dim i As Long
Dim charCode As Integer
Dim result As String
result = ""
For i = 1 To Len(text)
charCode = Asc(Mid(text, i, 1))
' Skip control characters (ASCII 0-31, 127)
If charCode >= 32 And charCode <> 127 Then
result = result & Mid(text, i, 1)
End If
Next i
RemoveControlCharacters = result
End Function
' Get save filename with date-based naming
Function GetSaveFilename() As String
Dim xlApp As Object
Dim fileDialog As Object
Dim selectedFolder As String
' Create Excel application to use FileDialog
Set xlApp = CreateObject("Excel.Application")
Set fileDialog = xlApp.fileDialog(msoFileDialogFolderPicker)
With fileDialog
.Title = "メールデータの保存先フォルダを選択してください"
If .Show = -1 Then
selectedFolder = .SelectedItems(1)
Else
GetSaveFilename = ""
Set fileDialog = Nothing
xlApp.Quit
Set xlApp = Nothing
Exit Function
End If
End With
' Create date-based filename
GetSaveFilename = CreateDatedFilename(selectedFolder, "maildata", "json")
' Clean up
Set fileDialog = Nothing
xlApp.Quit
Set xlApp = Nothing
End Function
' Create dated filename with increment for existing files
Function CreateDatedFilename(folderPath As String, prefix As String, extension As String) As String
Dim filePath As String
Dim i As Long
Dim today As Date
today = Date
i = 0
Do
' Format: prefix + YYMMDD + sequential number + extension
filePath = folderPath & "\" & prefix & format(today, "yymmdd") & format(i, "000") & "." & extension
' Check if file exists
If Dir(filePath) = "" Then
Exit Do
End If
i = i + 1
Loop
CreateDatedFilename = filePath
End Function
' Save data to file with UTF-8 encoding (no BOM)
Sub SaveDataAsUTF8(data As String, filename As String)
Dim stream As Object
On Error GoTo ErrorHandler
' Create ADODB Stream object
Set stream = CreateObject("ADODB.Stream")
With stream
.Charset = "UTF-8"
.Type = 2 ' Text mode
.Open
.WriteText data
' Remove BOM
.position = 0
.Type = 1 ' Binary mode
.position = 3 ' Skip BOM bytes
Dim byteData() As Byte
byteData = .Read
.Close
' Write data without BOM
.Open
.Write byteData
.SaveToFile filename, 2 ' ForOverwrite
.Close
End With
Set stream = Nothing
Exit Sub
ErrorHandler:
MsgBox "ファイル保存中にエラーが発生しました: " & Err.Description, vbCritical
If Not stream Is Nothing Then
On Error Resume Next
stream.Close
Set stream = Nothing
End If
End Sub
' Check if array is initialized
Function IsArrayInitialized(arr As Variant) As Boolean
On Error Resume Next
IsArrayInitialized = IsArray(arr) And Not IsError(LBound(arr, 1))
On Error GoTo 0
End Function