はちまるさん
変数の初期値にもライブラリの前後にもはなにも設定されていませんでした。
スクリプトを貼り付けます。よろしくお願いします。
'--------------------------------------------------------------------
'メイン
'--------------------------------------------------------------------
Const olMSG = 3
Dim oApp
Dim oSelection
Dim oMail
Dim oFS
Dim sBasePath
Dim sMailNumber
Dim sSavePath
Dim fname
Dim absname
Dim folderPath
sBasePath = !ファイル保存先!
If Right(sBasePath, 1) = "\" Then
fname = Left(sBasePath, Len(sBasePath) - 1)
Else
fname = sBasePath
End If
SetUMSVariable "$FILE_PATH_TYPE", "13"
SetUMSVariable "$PARSE_FILE_PATH", fname
sBasePath = GetUMSVariable("$PARSE_FILE_PATH")
sMailNumber = GetUMSVariable($メールの連番$)
Call CheckParameter(sBasePath, sMailNumber )
Set oApp = GetOutlook()
Set oSelection = oApp.ActiveExplorer.Selection
If oSelection.Count > 1 Or oSelection.Count = 0 Then
Err.Raise 1, "", "選択されたメールが1つではありません。"
WScript.Quit()
End If
Set oMail = oSelection.Item(1)
Set oFS = WScript.CreateObject("Scripting.FilesystemObject")
'保存先作成
sSavePath = MakeSavePath(oFS, sBasePath, now, sMailNumber)
'メールと添付ファイル保存
Call SaveMailAndFile(oFS, oMail, sSavePath)
'メールを既読処理
oMail.UnRead = False
SetUMSVariable $格納したフォルダパス$, sSavePath
'--------------------------------------------------------------------
'パラメタの有効性確認
'--------------------------------------------------------------------
Sub CheckParameter(sBasePath, sMailNumber)
If sBasePath = "" Then
Err.Raise 1, "", "ファイル保存先を入力してください。"
WScript.Quit()
End If
If IsNumeric(sMailNumber) = False Then
Err.Raise 1, "", "メールの連番が数字ではありません。"
WScript.Quit()
End If
If Len(sMailNumber) > 8 Then
Err.Raise 1, "", "メールの連番は8桁以下に設定してください。"
WScript.Quit()
End If
End Sub
'--------------------------------------------------------------------
'Outlookの起動確認と取得
'--------------------------------------------------------------------
Function GetOutlook()
Dim oApp
On Error Resume Next
Set oApp = GetObject(, "Outlook.Application")
If oApp Is Nothing Then
On Error GoTo 0
Err.Raise 1, "", "Outlookが起動されていません。"
WScript.Quit()
End If
Set GetOutlook = oApp
End Function
'--------------------------------------------------------------------
'メール保存先フォルダを作成
'--------------------------------------------------------------------
Function MakeSavePath(oFS, sBasePath, dRcvDateTime, sMailNumber)
Dim sRetPath
Dim iDirNum
iDirNum = CLng(sMailNumber)
sMailNumber = String(8 - Len(iDirNum), "0") & iDirNum
sRetPath = sBasePath & "\" & _
Replace(FormatDateTime(dRcvDateTime, vbShortDate), "/", "") & "_" & _
Replace(FormatDateTime(dRcvDateTime, vbLongTime), ":", "") & "_" & _
sMailNumber
If oFS.FolderExists(sRetPath) = False Then
On Error Resume Next
oFS.Createfolder(sRetPath)
If Err.number <> 0 Then
On Error GoTo 0
Err.Raise 1, "", "メール保存先フォルダの作成に失敗しました。" & vbCrLf & "[" & sRetPath & "]"
WScript.Quit()
End If
On Error GoTo 0
Else
Err.Raise 1, "", "既に保存フォルダが存在します。"
WScript.Quit()
End If
MakeSavePath = sRetPath
End Function
'--------------------------------------------------------------------
'メールと添付ファイルを保存
'--------------------------------------------------------------------
Sub SaveMailAndFile(oFS, oMail, sSavePath)
Dim oAttachments
Set oAttachments = oMail.Attachments
sMsgFileName = sSavePath & "\" & ReplaceSubjectToFileName(oMail.Subject) & ".msg"
On Error Resume Next
oMail.SaveAs sMsgFileName, olMSG
If Err.number <> 0 Then
On Error GoTo 0
Err.Raise 1, "", "メールの保存に失敗しました。" & vbCrLf & "[" & sMsgFileName & "]"
WScript.Quit()
End If
On Error GoTo 0
For i = 1 To oAttachments.Count
If oFS.FileExists(sSavePath & "\" & oAttachments(i).FileName) = False Then
On Error Resume Next
oAttachments(i).SaveAsFile(sSavePath & "\" & oAttachments(i).FileName)
If Err.number <> 0 Then
On Error GoTo 0
Err.Raise 1, "", "添付ファイルの保存に失敗しました。" & vbCrLf & "[" & sSavePath & "\" & oAttachments(i).FileName & "]"
WScript.Quit()
End If
On Error GoTo 0
Else
Err.Raise 1, "", "既に同じファイル名の添付ファイルが存在します。"
WScript.Quit()
End If
Next
End Sub
'--------------------------------------------------------------------
'メール件名でファイル名で禁止された文字を削除
'--------------------------------------------------------------------
Function ReplaceSubjectToFileName(sSubject)
Dim sRetName
Dim notAllowFileName
Dim i
sRetName = sSubject
notAllowFileName = Split("/,\,:,*,<,>,?,"",|," & vbTab, ",")
For i = 0 To UBound(notAllowFileName)
sRetName = Replace(sRetName, notAllowFileName(i), "")
Next
If Len(sRetName) > 256 Then
sRetName = Mid(sRetName, 1, 256)
End If
ReplaceSubjectToFileName = sRetName
End Function
