Xueying
New Member
- Outlook version
- Outlook 2010 64 bit
- Email Account
- Exchange Server
Hi,
I am working on a script that enables Outlook to automatically saves attachments.
Here's my codes:
Ps: I have set the trust center to allow running script.
Is there anyone who can lend me a hand?
Thanks!
I am working on a script that enables Outlook to automatically saves attachments.
Here's my codes:
Public Sub SaveAttach(Item As Outlook.MailItem)
Dim RootPath
RootPath = "D:\Monthly Update Report\Generate Sum Rep\"
SaveAttachment Item, RootPath, "*.*"
End Sub
Private Sub SaveAttachment(ByVal Item As Object, ByVal path As String, Optional condition = "*")
Dim olAtt As Attachment
Dim i As Integer
Dim fso, f
Dim NewFolder
Set fso = CreateObject("Scripting.FileSystemObject")
If Item.Attachments.Count > 0 Then
For i = 1 To Item.Attachments.Count
Set olAtt = Item.Attachments(i)
If olAtt.FileName Like condition Then
NewFolder = Mid(olAtt.FileName, 13, 6)
path = path & NewFolder & "\"
If fso.FolderExists(path) <> True Then
fso.CreateFolder (path)
End If
olAtt.SaveAsFile path & olAtt.FileName
End If
Next
End If
MsgBox "Saved " & Item.Attachments.Count & " items."
Set olAtt = Nothing
End Sub
'This function works to complete "0"s before a month.
Private Function RLeft(sval)
RLeft = Right("00" & CStr(sval), 2)
End Function
This works at the first time I set the rule and run the script. But it doesnt seem to work after the one-time success...Dim RootPath
RootPath = "D:\Monthly Update Report\Generate Sum Rep\"
SaveAttachment Item, RootPath, "*.*"
End Sub
Private Sub SaveAttachment(ByVal Item As Object, ByVal path As String, Optional condition = "*")
Dim olAtt As Attachment
Dim i As Integer
Dim fso, f
Dim NewFolder
Set fso = CreateObject("Scripting.FileSystemObject")
If Item.Attachments.Count > 0 Then
For i = 1 To Item.Attachments.Count
Set olAtt = Item.Attachments(i)
If olAtt.FileName Like condition Then
NewFolder = Mid(olAtt.FileName, 13, 6)
path = path & NewFolder & "\"
If fso.FolderExists(path) <> True Then
fso.CreateFolder (path)
End If
olAtt.SaveAsFile path & olAtt.FileName
End If
Next
End If
MsgBox "Saved " & Item.Attachments.Count & " items."
Set olAtt = Nothing
End Sub
'This function works to complete "0"s before a month.
Private Function RLeft(sval)
RLeft = Right("00" & CStr(sval), 2)
End Function
Ps: I have set the trust center to allow running script.
Is there anyone who can lend me a hand?
Thanks!