copy an email and paste to another folder (1 Viewer)

Gasman

Enthusiastic Amateur
Local time
Today, 00:18
Joined
Sep 21, 2011
Messages
14,048
Sneuberg,

I hope the O/P appreciates all the hard work you have done on this,especially as it was new to you.

Well done.
 

smiler44

Registered User.
Local time
Today, 00:18
Joined
Jul 15, 2008
Messages
641
OP abserlotly appreciates what snueberg has done and what you all do. I just wish I was clever enough to understand it. I will do my best to try your code tomorrow.

thank you very much

smiler44
 

smiler44

Registered User.
Local time
Today, 00:18
Joined
Jul 15, 2008
Messages
641
insert lots of naughty words. wrote a long reply only for something to time out and i lose the lot

smiler44
 

smiler44

Registered User.
Local time
Today, 00:18
Joined
Jul 15, 2008
Messages
641
Lets try again
Snueberg,
Thank you for the code. I ran it from excel and it made a copy and placed a copy of the email into the other folders.
I will see if i can get some of my code below in with your code as there are 2 things

1. I don’t want to copy and move all emails. Only those that have a certain word in the subject line
2. Any email copied/placed into the other folders needs to be removed/deleted from the source folder.

This is how i work out if the subject line contains the magic word to beome an email i am interested in

Code:
Option Explicit
Dim moveToFolder As Outlook.MAPIFolder
Dim searchItems As Items
Dim msg As MailItem
Dim foundFlag As Boolean
Dim i As Long

Dim c As Long
Dim z As Long
Dim unreadmessagesininbox As String
Dim totalmessagesininbox As String
Dim NS As Outlook.Namespace
Dim searchFolder As Outlook.MAPIFolder

Dim pos As Integer 'used to help get job number from subject line
Dim jnum As String ' is the job number
Dim jcq As String  ' is the  controllers queue
Dim counter1
Dim counter2 ' used to help deal with email were there is no controller ‘  added 14.01.15
Dim tarrget As String
Dim subj As String
Dim re As Object
Dim match As Variant




Sub moveemail()

' In the Visual Basic Editor (VBE)
'  Tools menu | References...
'  Tick the entry for
'   Microsoft VBScript Regular Expressions 5.5
' &
' microsoft outlook 12.0 object libary

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

counter1 = 0 'used if the subject line does not contain a job number

Set NS = CreateObject("Outlook.Application").GetNamespace("MAPI")

On Error Resume Next    ' To bypass the error when the source folder is not found.
                        ' searchFolder will be Nothing

' Enter the exact names of the folders
' No slashes. Walk the path one folder at a time.

Set searchFolder = NS.Folders("mouth  G").Folders("Inbox")

On Error GoTo 0

If searchFolder Is Nothing Then
   MsgBox "Source folder not found!", vbOKOnly + vbExclamation, "searchSubject error"
   GoTo ExitRoutine
Else
   Debug.Print vbCr & "searchFolder: " & searchFolder
End If


'unreadmessagesininbox = searchFolder.UnReadItemCount 'counts the number of unread emails in inbox
    'MsgBox ("unread messages = " & unreadMessagesInInbox)

'totalmessagesininbox = searchFolder.Items.Count ' counts total number of emails in inbox
    'MsgBox (" total messages = " & TotalmessagesInInbox)

'''''''''''''''''''''''''''''''''''''
'For Each oMail In searchFolder.Items
'If oMail.UnRead Then
'oUnread = oUnread + 1 ' this gets number of unread emails
'Else
'oread = oread + 1 ' this gets number of read emails
'End If
'Next

'MsgBox ("read messages = " & oread)

'''''''''''''''''''''''''''''''''''''''
Set searchItems = searchFolder.Items

For i = searchItems.Count To 1 Step -1
    If searchItems(i).Class = olMail Then
        Set msg = searchItems(i)
        patternabcd123456 msg, foundFlag

        If foundFlag = True Then
                
            Debug.Print " Move this mail: " & searchItems(i)
           If searchItems(i).UnRead = False Then
           searchItems(i).UnRead = True ' if email has been read changes it to unread
            End If
            
            Call whattodonow
            
            If counter2 = 1 Then
            GoTo nextemail
            End If
            ''''''''''''''''''''''''''''''''
                      
            searchItems(i).Move moveToFolder: ScrnChk
           
        End If
    End If
    
nextemail:
Next

ExitRoutine:

totalmessagesininbox = searchFolder.Items.Count ' counts total number of emails in inbox
MsgBox (totalmessagesininbox & " E-mails remain in the inbox, please check manually")

    Set msg = Nothing
    Set searchItems = Nothing
    Set searchFolder = Nothing
    Set NS = Nothing
    Call quitexcel

End Sub


Sub patternabcd123456(MyMail As MailItem, fndFlag)


    fndFlag = False
    subj = MyMail.Subject
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'If subj = "*** Important - Please Read - Daily Tracker Reports and Systems Issues ***" Or subj = "Auto Response" Then

pos = InStrRev(subj, "ONE"): ScrnChk  'can "ONE" be removed

If pos = "0" Then ' not found
pos = InStrRev(subj, "OSA")
End If

If pos = "0" Then
pos = InStrRev(subj, "TBA")
End If

If pos = "0" Then
pos = InStrRev(subj, "TWE")
End If

If pos = "0" Then
pos = InStrRev(subj, "TSA")
End If

If pos > 0 Then
GoTo jobnumber

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'added 27.01.16
If pos = "0" Then 'job number etc not found
pos = InStrRev(subj, "*** Important - Please Read - Daily  Reports and Systems Issues ***"): ScrnChk
End If

If pos = "0" Then 'onea etc not found
pos = InStrRev(subj, "Auto Response"): ScrnChk
'pos = InStrRev(subj, "Auto Response")
'pos = 0
End If
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

If pos > 0 Then
'If pos > 0 And subj = "*** Important - Please Read - Tracker Reports and Systems Issues ***" Or subj = "Auto Response" Then
'move to deleted folder

End If


jobnumber:
jnum = Mid(subj, pos, 10): ScrnChk

Else
If pos = 0 Then

counter2 = 1
Exit Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''
End If
End If

Set re = CreateObject("vbscript.regexp")

re.Pattern = jnum
  
    For Each match In re.Execute(subj)
        fndFlag = True
        Debug.Print vbCr & subj
        Debug.Print " *** Pattern found: " & match
    Next
    Set re = Nothing

End Sub
 

sneuberg

AWF VIP
Local time
Yesterday, 17:18
Joined
Oct 17, 2014
Messages
3,506
1. I don’t want to copy and move all emails. Only those that have a certain word in the subject line


I'm trying to understand your code so that I can help you integrate it with the code I've come up with but the code seems to be missing the ScrnChk, whattodonow, and quitexcel procedures. Could you post these or explain what they are? As an aside I googled "ScrnChk" thinking it was some built in function I was not familiar with and came up with this post of yours from 2008. I guess you been using this code for a while now. :)


2. Any email copied/placed into the other folders needs to be removed/deleted from the source folder.


Would want that moved to the Delete folder, some other folder, or permanently deleted?

Why are you running this macro from excel? Is it just that you have Excel open most of the time or does your code use excel somehow?
 

smiler44

Registered User.
Local time
Today, 00:18
Joined
Jul 15, 2008
Messages
641
soory
ScrnChk:- this just makes sure my screen is ready for my macro to send information to the creen and also slows the macro down. there has been a system issue with my macros running to quickly

whattodonow:- once the subject line has been chekced for the magic word, I have to decide what to do. If the magic word is there, do something ( in this case move/copy to 3 othe folders, if not there, leave email alone.

quitexcel :- once the macro has run this shuts down this instance of excel.

why run from excel : - eaiser to distiibute the macro. I can give people the excel file but also i create a vbs file that they can double click its icon to run the excel macro hidden.

Delete the email:- good question. either moving to deleted folder or permently deleting will do.

Re other post. I never solved the problem, someone else has I think solved it. I was never able to work out the problem but i think is had something to do with a previous email not the one the macro was looking at


smiler404
 

sneuberg

AWF VIP
Local time
Yesterday, 17:18
Joined
Oct 17, 2014
Messages
3,506
Thanks for the info. Since you use an excel file would you like to have it used for some the the information that is hard coded? For example folder names and the "magic" key words. I think it would make the program more flexible.
 

smiler44

Registered User.
Local time
Today, 00:18
Joined
Jul 15, 2008
Messages
641
hi sneuberg. I'm not sure I fully understand. The folder names will be hard coded and so is the wrrd magic. The source folder is = NS.Folders("Personal Folders").Folders("inbox").Folders("testin").Folders("testout")

and the destination folder is = NS.Folders("Personal Folders").Folders("Drafts").Folders("testing").Folders("steve")

and

= NS.Folders("Personal Folders").Folders("Drafts").Folders("testing").Folders("steve2")


and

= NS.Folders("Personal Folders").Folders("Drafts").Folders("testing").Folders("phil")


the word to be found in the subject is Deemed. if it is there copy/move the email tot he 3 folders. If it is not in the subjext, leave it where it is.

one other twist. no matter f te email is read or unread it needs to go into the 3 folders as unread. my code in a previous post shold move it and put it in the destination folder as unread. i really appreciate your help as I have run out of ideas

smiler44
 

sneuberg

AWF VIP
Local time
Yesterday, 17:18
Joined
Oct 17, 2014
Messages
3,506
Could you zip and upload the excel spreadsheet you have the code in? When I read this code I would just like to make sure I'm not missing something. For example in the code you posted I can't find the word "Deemed" nor where something is assigned to moveToFolder.
 

sneuberg

AWF VIP
Local time
Yesterday, 17:18
Joined
Oct 17, 2014
Messages
3,506
I analysed the code you posted in post 24. This is what I found.

For each item in the Inbox the code searches the subject for the strings “ONE”, “OSA”, TBA”, “TWE”, or “TSA” and if any one of these is found it changes the email to read, calls whattodonow and moves it to moveToFolder, an Output MAPIFolder object not assigned in this code. This is all is appears to do albeit in a strange way so maybe I am missing something.

To determine if the subject contains one of the strings mentioned the code searches for them with InStrRev. You would think that a return from this greater than zero would be sufficient but the code takes the position returned by InStrRev and extracts a string 10 characters long starting at the position with this line of code

Code:
jnum = Mid(subj, pos, 10)

Then it then uses regular expressions to search through the subject for the pattern it extracted from the subject. What’s the point of this? When would this search fail to find the pattern?

Also I can’t understand how this could work for you as the line
Code:
    Debug.Print " Move this mail: " & searchItems(i)
Gives me a Run time error 428 Object doesn’t support this property or method. I change it to
Code:
Debug.Print " Move this mail: " & searchItems(i).Subject
To get the code to work.

Do I need to consider what this code does or should I just give you code that does what you described in post #28?
 

sneuberg

AWF VIP
Local time
Yesterday, 17:18
Joined
Oct 17, 2014
Messages
3,506
The code that follows (also attached) does what you asked for in post 28. At least I think it does. You just need to change the source and destination folders in the code to your folders. This code adds a category named "Needs Distribution". It doesn't use the one in the previous version named "Email Copied" so you can delete that on your system if it's still there. The code only looks for the word :"Deemed". You can add more words just by adding them comma separated for example

Code:
MarkForDistribution SourceFolder, "Deemed", "DEEMED"

would mark emails for distribution with either "Deemed" or "DEEMED"

Code:
#Const LateBinding = True

'this subroutine marks the items in the Folder that have any of the KeyWords in the subject
#If LateBinding Then
    Private Sub MarkForDistribution(ByRef Folder As Object, ParamArray KeyWords())
    Dim Item As Object
#Else
    Private Sub MarkForDistribution(ByRef Folder As Outlook.MAPIFolder, ParamArray KeyWords())
    Dim Item As Outlook.MailItem
#End If
Dim word As Variant
For Each Item In Folder.Items
    For Each word In KeyWords
        If InStr(1, Item.Subject, word) > 0 Then
            Item.Categories = "Needs Distribution"
            Item.Save
        End If
    Next word
Next Item

End Sub
'this subroutine deletes (moves to the Delete folder)the items in the Folder that have the category ""Needs Distribution"
#If LateBinding Then
    Private Sub DeleteItems(ByRef Folder As Object)
    Dim Item As Object
#Else
    Private Sub DeleteItems(ByRef Folder As Outlook.MAPIFolder)
    Dim Item As Outlook.MailItem
#End If
For Each Item In Folder.Items
   If Item.Categories = "Needs Distribution" Then
        Item.Delete
   End If
Next Item

End Sub
'this function determines where a category with the name CategoryName exist in the name space NS
#If LateBinding Then
    Private Function CategoryExists(ByRef NS As Object, CategoryName As String) As Boolean
    Dim cat As Object
#Else
    Private Function CategoryExists(ByRef NS As Outlook.NameSpace, CategoryName As String) As Boolean
    Dim cat As Outlook.Category
#End If

CategoryExists = False
If NS.Categories.Count = 0 Then
    Exit Function
End If

' Enumerate the Categories collection.
For Each cat In NS.Categories
    If cat.Name = CategoryName Then
        CategoryExists = True
    End If
Next
Set cat = Nothing

End Function
'this subroutine copies the items in the SourceFolder to the DestinationFolder if the item in the SourceFolder
'do have the category "Needs Distribtion".  The items are change to unread
#If LateBinding Then
    Private Sub CopyMarkedItems(ByRef SourceFolder As Object, ByRef DestinationFolder As Object)
    Dim Item As Object
    Dim Copy As Object

#Else
    Private Sub CopyMarkedItems(ByRef SourceFolder As Outlook.MAPIFolder, ByRef DestinationFolder As Outlook.MAPIFolder)
    Dim Item As Outlook.MailItem
    Dim Copy As Outlook.MailItem
#End If

For Each Item In SourceFolder.Items
    If Item.Categories = "Needs Distribution" Then
        Set Copy = Item.Copy
        Copy.Move DestinationFolder
        If Copy.UnRead = False Then
            Copy.UnRead = True
        End If
    End If
Next Item
Set Copy = Nothing

End Sub
'main program to copy email from the Inbox folder to other folders
Public Sub DistributeEmails()

#If LateBinding Then
    Dim OutLookApp As Object
    Dim NS As Object
    Dim SourceFolder As Object
    Dim DestFolder As Object
    Const olCategoryColorTeal = 6
#Else
    Dim OutLookApp As Outlook.Application
    Dim NS As Outlook.NameSpace
    Dim SourceFolder As Outlook.MAPIFolder
    Dim DestFolder As Outlook.MAPIFolder
#End If
Dim TotalMessagesInInbox As Long

Set OutLookApp = CreateObject("Outlook.Application")
Set NS = OutLookApp.GetNamespace("MAPI")

'this ensures the name space has the category "Needs Distribution"
If Not CategoryExists(NS, "Needs Distribution") Then
    'see https://msdn.microsoft.com/en-us/library/office/ff860420.aspx for possible colors
    NS.Categories.Add "Needs Distribution", olCategoryColorTeal
End If

'add source folder here
Set SourceFolder = NS.Folders("Personal Folders").Folders("Inbox")

'assigns the category "Needs Distribution" to the items in the Source folder
'if and of the keywords are found in the subject
'any number of keywords can be added to this procedure call
MarkForDistribution SourceFolder, "Deemed"

'add destination folders here
Set DestFolder = NS.Folders("Personal Folders").Folders("paul")
CopyMarkedItems SourceFolder, DestFolder
Set DestFolder = NS.Folders("Personal Folders").Folders("james")
CopyMarkedItems SourceFolder, DestFolder
Set DestFolder = NS.Folders("Personal Folders").Folders("john")
CopyMarkedItems SourceFolder, DestFolder

'delete the distributed items in the SourceFolder
DeleteItems SourceFolder

TotalMessagesInInbox = SourceFolder.Items.Count ' counts total number of emails in inbox
MsgBox (TotalMessagesInInbox & " E-mails remain in the inbox, please check manually")

Set NS = Nothing
Set SourceFolder = Nothing
Set DestFolder = Nothing

End Sub
 

Attachments

  • CopyEmail_V2.txt
    4.5 KB · Views: 105

smiler44

Registered User.
Local time
Today, 00:18
Joined
Jul 15, 2008
Messages
641
snueberg,
thank you very much. forgive me if I dont try the code for a few days, my head and heart is not in it at the moment. Best friend of over 20 years is going through a cancer scare.
smiler44....not smiling at the moment
 

sneuberg

AWF VIP
Local time
Yesterday, 17:18
Joined
Oct 17, 2014
Messages
3,506
Sorry to hear about your friend. The code will still be there when you are ready for it.
 

smiler44

Registered User.
Local time
Today, 00:18
Joined
Jul 15, 2008
Messages
641
Sneuberg,
what can I say? Thank you, this just does not seem to do it! What you have done is fantastic. I managed to have a play and it did just what I wanted, thank you very much for taking the time to do this for me.

I will incorporate it into the macro for work later this week I hope but using it on my own pc did just what I wanted, magic :)

thank you again
smiler44
 

Users who are viewing this thread

Top Bottom