Outlook内のZipをフォルダに送るスクリプト

質問

Outlookに送られてくるメール内のZipファイルをあるサーバーのフォルダに送りたいのですが、どうもEnd Subエラーが出てうまくいきません。下記のVBスクリプトを見ていただき回答をいただければ助かります。どうぞよろしくお願いいたします。

Public Sub Application_Startup()
Call MailParser
End Sub

Private Sub Application_NewMail()
Call MailParser
End Sub

Public Sub MailParser()
Dim objContactsFolder, objContactItem, intItemCounter
Dim tdystart As Date
Const olFolderContacts = 6 '6 (Inbox) subject line 5 (Sent) uses mail subject line 10 (Contacts) uses full name
Dim MyTempFolderString As String
MyTempFolderString = ""
Dim Mydate
Mydate = DateFix

Set objContactsFolder = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderContacts)
Set SubFolder = objContactsFolder.Folders("Inbox") ' Example ("AAA")
intItemCounter = SubFolder.Items.Count
If intItemCounter = 0 Then Exit Sub
'position counter for the item
Set objContactItem = SubFolder.Items(intItemCounter)
'set to last email
Set mymailitem = SubFolder.Items(intItemCounter)

For I = 1 To intItemCounter Step 1
DoEvents
Dim TempDir As String
TempDir = ""
Set mymailitem = SubFolder.Items(I)

'check for source
If InStr(mymailitem.Subject, "Outlook内のファイル件名が入ります") <> 0 Then
MyTempFolderString = "\\フォルダ名が入ります\"

ElseIf InStr(mymailitem.Subject, "上と同じOutlook内のファイル件名が入ります") <> 0 Then
MyTempFolderString = "\\上と同じフォルダ名が入ります\"
End If
If MyTempFolderString = "" Then GoTo NextI
myAttachCount = mymailitem.Attachments.Count 'set counter for number of attachments

Do Until myAttachCount = 0
DoEvents

Set myAttachments = mymailitem.Attachments
myAttachments.Item(myAttachCount).SaveAsFile MyTempFolderString & Mydate & myAttachments.Item(myAttachCount).DisplayName

Loop
NextI:
Next I

End Function

Function OpenOutlookFolder(StrFolderPath As String) As Outlook.MAPIFolder
Dim arrFolders As Variant, _
varFolder As Variant, _
bolBeyondRoot As Boolean
On Error Resume Next
If StrFolderPath = "" Then
Set OpenOutlookFolder = Nothing
Else
Do While Left(StrFolderPath, 1) = "\"
StrFolderPath = Right(StrFolderPath, Len(StrFolderPath) - 1)
Loop
arrFolders = Split(StrFolderPath, "\")
For Each varFolder In arrFolders
Select Case bolBeyondRoot
Case False
Set OpenOutlookFolder = Outlook.Session.Folders(varFolder)
bolBeyondRoot = True
Case True
Set OpenOutlookFolder = OpenOutlookFolder.Folders(varFolder)
End Select
If Err.Number <> 0 Then
Set OpenOutlookFolder = Nothing
Exit For
End If
Next
End If
On Error GoTo 0
End Function

Function DateFix()
If Len(Month(Now)) < 2 Then
strMM = "0" & Month(Now)
Else
strMM = Month(Now)
End If
If Len(Day(Now)) < 2 Then
strDD = "0" & Day(Now)
Else
strDD = Day(Now)
End If
DateFix = Year(Now) & "_" & strMM & "_" & strDD
End Function

回答No.1

10CubeLeaf

Public Sub MailParser() で始まっているのに End Function で終わっていますね。