例によってoutlookVBAです。
受信したメールをフォルダを作成して一緒にその中に保存するVBAです。
エクセルファイルも一緒に保存します。そのエクセルファイルの印刷ヘッダーフッターを少し編集もしています。
Sub fold()
dim file_count as string
file_cout = ""
fol_path = "C:\Users"
fol_path = fol_path & "\" & format(date,"yyyymmdd") & "_testBat"
if dir(fol_path,vbdirectory) = "" then
mkdir fol_path
end if
syutoku_fol = fol_path & "\" & "取得ファイル"
file_path = fol_path & "\" & "テストファイル" & format(date,"yyyymmdd")
mkdir syutoku_fol
dim excelapp as object 'Excel.application
dim book as object 'Excel workbook
dim sheet as object 'Excel worksheet
set excelapp = createobject("Excel.application")
set book = excelapp.workbook.ass
set sheet = "test"
'印刷ヘッダーフッターをあらかじめ編集
with sheet.pagesetup
.rightheader = "&D-&T"
.centerheader = "&F"
.rightheader = "&A"
.centerfooter = "&P/&N"
.scalewithdocheaderfooter = false
.centerhorizonally = true
end with
book.saveas file_path
excellapp.quit
dim myitem as outlook.inspector
dim objectitem as object
dim str as string,arr() as variant
set myitem = application.activeinspector
set objitem = myitem currentitem
'受信メールをフォルダに一緒に保存するときに件名から以下の文字列を除去します。増やしても良いですし減らしても良いです。
'もっと増やさないといけないかもしれません。
'左ダブルクオーテーション：Chr(&H8167) 右ダブルクオーテーション：Chr(&H8168).
arr = Array("\","/",":","*","?",""","<",">","|" "," ","!","#","$","%","&","(",")","@","Chr(&H8167)","Chr(&H8168))
for each elm in arr
strname = replace(strname,elm,"")
next elm
objitem.save as fol_path & strname & ".msg"
shell "C:\Users" & fol_path.vbnormalfocus
end sub
