'Microsoft Outlook 15.0 Object Library
'Microsoft Scripting Runtime
'Microsoft ActiveX Data Objects 6.1 Library
Private Sub Application_Startup()
End Sub
Set mySync = Application.Session.SyncObjects.Item(1)
mySync.Start
'※ 送受信が思うように動かない場合は sleep と DoEvents を組み合わせて タイムラグを発生させると良いです。
Do
'この DoEvents を入れておくだけで、無限ループをしていても Outlook を閉じたりすることができます。
DoEvents
Loop
Sub Outlook_mail_list()
Dim InboxFolder, i, n, k, attno As Long
Dim sender, mes, path1 As String
Dim outlookObj As Outlook.Application
Dim myNameSpace, objmailItem As Object
Dim fso As FileSystemObject
Set outlookObj = CreateObject("Outlook.Application")
Set myNameSpace = outlookObj.GetNamespace("MAPI")
Set InboxFolder = myNameSpace.GetDefaultFolder(6)
n = 2
path1 = "D:\mail\"
Set fso = CreateObject("Scripting.FileSystemObject")
For i = 1 To InboxFolder.Items.Count
Set objmailItem = InboxFolder.Items(i)
If objmailItem.UnRead = True Then
'メールを開く
objmailItem.Display
NowTimer = Format(Now(), "yyyy/mm/dd hh:mm:ss")
KpArr(0) = objmailItem.ReceivedTime
KpArr(1) = i
KpArr(2) = MjHk(objmailItem.SenderName & ";" & objmailItem.SenderEmailAddress)
KpArr(3) = MjHk(ReceivedOnBehalfOfName & ";" & objmailItem.ReceivedByName)
KpArr(4) = MjHk(objmailItem.CC)
KpArr(5) = MjHk(objmailItem.BCC)
KpArr(6) = MjHk(objmailItem.Subject)
KpArr(7) = MjHk(objmailItem.Body)
KpArr(8) = objmailItem.Attachments.Count
KpArr(9) = Replace(Replace(Replace(objmailItem.ReceivedTime, " ", ""), "/", ""), ":", "") & "_" & Replace(Replace(Replace(NowTimer, " ", ""), "/", ""), ":", "")
’メールをフォルダに保存
Call SaveAsZip
'メールをデータベースに保存
Call DBSaveSry
End If
Exit For
n = n + 1
Next
Set InboxFolder = myNameSpace.GetDefaultFolder(6)
Dim MaxCnt As Integer
Modoru:
MaxCnt = InboxFolder.Items.Count
For i = 1 To MaxCnt
If i > MaxCnt Then Exit For
Set objmailItem = InboxFolder.Items(i)
If objmailItem.UnRead = False Then
objmailItem.Delete
GoTo Modoru
End If
Next
Set InboxFolder2 = myNameSpace.GetDefaultFolder(6)
'''---コード7｜セットした変数を解除
Set outlookObj = Nothing
Set myNameSpace = Nothing
Set InboxFolder = Nothing
'Outlook.Quit
End Sub
Sub SaveAsZip()
On Error GoTo errorEx
Sleep (3000)
Dim openedItem As Outlook.Inspector
Dim targetItem As Object
Set openedItem = Application.ActiveInspector
If Not TypeName(openedItem) = "Nothing" Then
' メールのメタ情報を取得する
Set targetItem = openedItem.CurrentItem
Dim title As String
title = targetItem.Subject
title = Trim(title)
title = Replace(title, "\", "_")
title = Replace(title, "/", "_")
title = Replace(title, "?", "_")
title = Replace(title, ":", "_")
title = Replace(title, "*", "_")
title = Replace(title, """", "_")
title = Replace(title, ">", "_")
title = Replace(title, "<", "_")
title = Replace(title, "|", "_")
Dim senderAddress As String
senderAddress = "[" & targetItem.SenderEmailAddress & "]"
Dim sendDate As Date
sendDate = targetItem.SentOn
Dim sendDateString As String
sendDateString = "[" & Format(sendDate, "YYYYMMDD HHNN") & "]"
Dim mailCategolies As String
mailCategories = targetItem.Categories
mailCategory = Split(mailCategories, ",")
mailCategories = ""
Dim str As Variant
For Each str In mailCategory
mailCategories = mailCategories & "[" & Trim(str) & "]"
Next str
' 保存するフォルダ名を設定する
Dim pathName As String
pathName = "D:\mail\"
' 保存するファイル名を設定する
Dim filename As String
filename = sendDateString & mailCategories & senderAddress & "_" & title
filename = LeftB(filename, 220 - LenB(pathName))
filename = Left(filename, Len(filename))
filename = KpArr(9)
MailFileName = filename
' ファイルアクセス用のオブジェクトの生成
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set app = CreateObject("Shell.Application")
MkDir pathName & MailFileName & "\"
targetItem.SaveAs pathName & MailFileName & "\" & filename & ".msg", olMSG
For i = 1 To targetItem.Attachments.Count
'itemCount = zipFolder.Items().Count
targetItem.Attachments.Item(i).SaveAsFile pathName & MailFileName & "\" & i & "_" & targetItem.Attachments.Item(i).DisplayName
'zipFolder.MoveHere (pathName & i & "_" & targetItem.Attachments.Item(i).DisplayName)
filesName = filesName & i & "_" & targetItem.Attachments.Item(i).DisplayName & "|"
Next
Else
MsgBox "メールを開いてからマクロを実行してください。"
End If
Exit Sub
errorEx:
'MsgBox "エラーが発生しました。"
End Sub
Sub DBSaveSry()
On Error GoTo myError
myError:
Dim myCon As ADODB.Connection
Set myCon = New ADODB.Connection
Dim SQLDT As String
myCon.Open "Provider=MSDASQL; DSN=DB名;DATABASE=DB名;SERVER=IPアドレス;PORT=5432;UID=postgres;PSW=;SSLmode=disable"
SQLDT = "'" & NowTimer & "'" ' "処理日時" timestamp with time zone NOT NULL,
SQLDT = SQLDT & ",'" & KpArr(1) & "'" ' "処理No" integer NOT NULL,
SQLDT = SQLDT & ",'" & KpArr(0) & "'" ' "受信日時" timestamp with time zone NOT NULL,
SQLDT = SQLDT & ",'" & KpArr(2) & "'" ' "From" text,
SQLDT = SQLDT & ",'" & KpArr(3) & "'" ' "To" text,
SQLDT = SQLDT & ",'" & KpArr(4) & "'" ' "Cc" text,
SQLDT = SQLDT & ",'" & KpArr(5) & "'" ' "Bcc" text,
SQLDT = SQLDT & ",'" & KpArr(6) & "'" ' "Subject" text,
SQLDT = SQLDT & ",'" & KpArr(7) & "'" ' "Body" text,
SQLDT = SQLDT & ",'" & KpArr(8) & "'" ' "AttachmentsCount" integer,
SQLDT = SQLDT & ",'" & KpArr(9) & "'" '"SaveFileName" text,
myCon.Execute "INSERT INTO ""Mail"".""受信_post"" VALUES(" & SQLDT & ");"
myCon.Close
Set myCon = Nothing
End Sub
Function MjHk(StrA)
If IsError(StrA) Then
Select Case StrA
Case CVErr(xlErrDiv0)
MjHk = ""
Case CVErr(xlErrNA)
MjHk = ""
Case CVErr(xlErrName)
MjHk = ""
Case CVErr(xlErrNull)
MjHk = ""
Case CVErr(xlErrNum)
MjHk = ""
Case CVErr(xlErrRef)
MjHk = ""
Case CVErr(xlErrValue)
MjHk = ""
Case Else
End Select
Else
'StrA = Replace(StrA, "#N/A", "")
StrA = Replace(StrA, """", """)
StrA = Replace(StrA, "'", "'")
StrA = Replace(StrA, ",", ",")
StrA = Replace(StrA, "Chr(13)", "<br />")
StrA = Replace(StrA, "Chr(10)", "<br />")
StrA = Replace(StrA, vbLf, "<br />")
StrA = Replace(StrA, vbCrLf, "<br />")
MjHk = StrA
End If
End Function