Macro to move emails in folder to dropbox

[FUSESvc]

I have a macro that will copy emails in a certain folder "DBTransfer" in outlook to a Dropbox folder shared with my accountant. It works very well but it only transfers emails with attachments & only runs when I use Alt F8.

Outlook rules will drop content into this folder ready to copy to Dropbox.

I would like the macro modifying so that all content within this folder is moved not copied, and an automated method of running the macro, so that perhaps once a day the folder is purged to Dropbox.

The purpose is to get invoices straight to the accountant without losing them!


Can anyone help?

[gmayor]

You cannot move messages from an Outlook folder to a Windows folder. You can COPY a message, which is essentially what copying to Dropbox is all about. You could delete the messages after copying to Dropbox, or move them to another Outlook folder. I am less enthusiastic about having the only copies of anything on a cloud based service, though to be fair DropBox does work well.

You haven't posted your macro code, so we cannot advise on what needs to be changed, but there will undoubtedly be a statement that checks for the attachments and restricts the process to such messages. Remove that restriction.

Automation of the process may be possible, e.g. by using the Outlook Startup or Quit events to trigger the process, but for that to happen you have to close and or start Outlook at least once a day. A button on the ribbon to run the macro might be more reliable, if you can remember to click it occasionally.

[FUSESvc]

Thank You Graham,

Much appreciated.

So as you will see in the code when I send it to you, the invoices in DBTransfer email folder are moved to a windows folder, that then gets copied out to the cloud, so there is a windows based back up of the receipts I believe, but if not, could we also copy to a local folder and then empty the DBTransfer folder. My accountant has already complained about getting the same invoice 4 times!!


Here's the code.

Sub Test()
'Arg 1 = Folder name of folder inside your Inbox
'Arg 2 = File extension, "" is every file
'Arg 3 = Save folder, "C:\Users\Ron\test" or ""
' If you use "" it will create a date/time stamped folder for you in your "Documents" folder
' Note: If you use this "C:\Users\Ron\test" the folder must exist.


SaveEmailAttachmentsToFolder "DBTransfer", "", "C:\Users\Kev\Dropbox\Accountant stuff\Online Purchases\General"

End Sub










Sub SaveEmailAttachmentsToFolder(OutlookFolderInInbox As String, _
ExtString As String, DestFolder As String)
Dim ns As NameSpace
Dim Inbox As MAPIFolder
Dim SubFolder As MAPIFolder
Dim Item As Object
Dim Atmt As Attachment
Dim FileName As String
Dim MyDocPath As String
Dim I As Integer
Dim wsh As Object
Dim fs As Object


On Error GoTo ThisMacro_err


Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
Set SubFolder = Inbox.Folders(OutlookFolderInInbox)


I = 0
' Check subfolder for messages and exit of none found
If SubFolder.Items.Count = 0 Then
MsgBox "There are no messages in this folder : " & OutlookFolderInInbox, _
vbInformation, "Nothing Found"
Set SubFolder = Nothing
Set Inbox = Nothing
Set ns = Nothing
Exit Sub
End If


'Create DestFolder if DestFolder = ""
If DestFolder = "" Then
Set wsh = CreateObject("WScript.Shell")
Set fs = CreateObject("Scripting.FileSystemObject")
MyDocPath = wsh.SpecialFolders.Item("mydocuments")
DestFolder = MyDocPath & "\" & Format(Now, "dd-mmm-yyyy hh-mm-ss")
If Not fs.FolderExists(DestFolder) Then
fs.CreateFolder DestFolder
End If
End If


If Right(DestFolder, 1) <> "\" Then
DestFolder = DestFolder & "\"
End If


' Check each message for attachments and extensions
For Each Item In SubFolder.Items
For Each Atmt In Item.Attachments
If LCase(Right(Atmt.FileName, Len(ExtString))) = LCase(ExtString) Then
FileName = DestFolder & Item.SenderName & " " & Atmt.FileName
Atmt.SaveAsFile FileName
I = I + 1
End If
Next Atmt
Next Item


' Show this message when Finished
If I > 0 Then
MsgBox "You can find the files here : " _
& DestFolder, vbInformation, "Finished!"
Else
MsgBox "No attached files in your mail.", vbInformation, "Finished!"
End If


' Clear memory
ThisMacro_exit:
Set SubFolder = Nothing
Set Inbox = Nothing
Set ns = Nothing
Set fs = Nothing
Set wsh = Nothing
Exit Sub


' Error information
ThisMacro_err:
MsgBox "An unexpected error has occurred." _
& vbCrLf & "Please note and report the following information." _
& vbCrLf & "Macro Name: SaveEmailAttachmentsToFolder" _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
Resume ThisMacro_exit


End Sub

[FUSESvc]

Oh, and this!




Private Sub Application_Startup()


Test


End Sub


Sub myRuleMacro(Item As Outlook.MailItem)


End Sub


Sub Test()
'Arg 1 = Folder name of folder inside your Inbox
'Arg 2 = File extension, "" is every file
'Arg 3 = Save folder, "C:\Users\Ron\test" or ""
' If you use "" it will create a date/time stamped folder for you in your "Documents" folder
' Note: If you use this "C:\Users\Ron\test" the folder must exist.


SaveEmailAttachmentsToFolder "DBTransfer", "", "C:\Users\Kev\Dropbox\Accountant stuff\Online Purchases\General"
End Sub






Sub SaveEmailAttachmentsToFolder(OutlookFolderInInbox As String, _
ExtString As String, DestFolder As String)
Dim ns As NameSpace
Dim Inbox As MAPIFolder
Dim SubFolder As MAPIFolder
Dim Item As Object
Dim Atmt As Attachment
Dim FileName As String
Dim MyDocPath As String
Dim I As Integer
Dim wsh As Object
Dim fs As Object


On Error GoTo ThisMacro_err


Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
Set SubFolder = Inbox.Folders(OutlookFolderInInbox)


I = 0
' Check subfolder for messages and exit of none found
If SubFolder.Items.Count = 0 Then
MsgBox "There are no messages in this folder : " & OutlookFolderInInbox, _
vbInformation, "Nothing Found"
Set SubFolder = Nothing
Set Inbox = Nothing
Set ns = Nothing
Exit Sub
End If


'Create DestFolder if DestFolder = ""
If DestFolder = "" Then
Set wsh = CreateObject("WScript.Shell")
Set fs = CreateObject("Scripting.FileSystemObject")
MyDocPath = wsh.SpecialFolders.Item("mydocuments")
DestFolder = MyDocPath & "\" & Format(Now, "dd-mmm-yyyy hh-mm-ss")
If Not fs.FolderExists(DestFolder) Then
fs.CreateFolder DestFolder
End If
End If


If Right(DestFolder, 1) <> "\" Then
DestFolder = DestFolder & "\"
End If


' Check each message for attachments and extensions
For Each Item In SubFolder.Items
For Each Atmt In Item.Attachments
If LCase(Right(Atmt.FileName, Len(ExtString))) = LCase(ExtString) Then
FileName = DestFolder & Item.SenderName & " " & Atmt.FileName
Atmt.SaveAsFile FileName
I = I + 1
End If
Next Atmt
Next Item


' Show this message when Finished
' If I > 0 Then
'MsgBox "You can find the files here : " _
' & DestFolder, vbInformation, "Finished!"
'Else
' MsgBox "No attached files in your mail.", vbInformation, "Finished!"
'End If


' Clear memory
ThisMacro_exit:
Set SubFolder = Nothing
Set Inbox = Nothing
Set ns = Nothing
Set fs = Nothing
Set wsh = Nothing
Exit Sub


' Error information
ThisMacro_err:
MsgBox "An unexpected error has occurred." _
& vbCrLf & "Please note and report the following information." _
& vbCrLf & "Macro Name: SaveEmailAttachmentsToFolder" _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
Resume ThisMacro_exit


End Sub


Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)


End Sub

[gmayor]

The following should prevent the messages being processed twice


' Check each message for attachments and extensions
For Each Item In SubFolder.Items
If Not Item.Categories Like "*Processed*" Then
For Each Atmt In Item.Attachments
If LCase(Right(Atmt.FileName, Len(ExtString))) = LCase(ExtString) Then
FileName = DestFolder & Item.SenderName & " " & Atmt.FileName
Atmt.SaveAsFile FileName
I = I + 1
End If
Next Atmt
End If
Item.Categories = "Processed"
Item.Save
Next Item

[Charlize]

Instead of using the application start up location you can use the new mail location.

Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
'************************************************************************** *
'Paste in ThisOutlookSession
'************************************************************************** *
SaveAttachmentRule Application.Session.GetItemFromID(EntryIDCollection)
End Sub

The macro saveattachmentrule will run for every new mail received.

The macro will use the unique id of the received item to refer to it.

Their is a KB that uses this technique.

Charlize

[Charlize]

Another way is monitoring a folder in your outlook session. Whenever the folder contents changes, a macro could be activated.

In this case you use the application startup location.

Charlize

[FUSESvc]

Thank you all.

I used to be really good with basic on the old Commodore 64K. used the three "voices" and "Sprites" could do almost anything. I had a 5" floppy drive and a dot matrix printer. The only thing stopping me was that it was connected to my mum's television and I had to book a slot to use it as we only had one TV in our house when I was young.

I got into 6502 machine code too!

Sadly I never followed up on a programming career and became a service engineer, and now an electrician.


Although I understand "some" of the code, it's well beyond me. I hope to strip out all the macros I have in outlook and re-insert a fully working version, in the right way, in the right location. Can anyone compile a fully working script for me that I can copy and paste?

Much appreciated.