How to move mail from shared mailbox to a subfolder based on calculated entries in Excel sheet?
Question
I export e-mail details from an Outlook 2007 shared inbox folder into an Excel 2007 sheet (Sender, Subject, Date & time received).
I then use formulas in Excel 2007 to attempt to extract a reference from the subject. Then lookup the reference against some data exported from our computer system.
- If the reference matches with a file reference then set criteria from a formula will populate an answer in column D (so that's Sender, Subject, Date & time received, Yes/No).
- If the reference can't be found or the data from the file doesn't meet the criteria to merit a response column D will then show "Yes" (meaning it needs to be marked as read and moved to the folder "No Response" which is part of the same shared mailbox on the same level as the inbox) otherwise will show "No" (in which case nothing needs to be done to that e-mail). The Yes/No Column formula criteria will be a continuous work in progress.
Exporting the e-mail details into an Excel sheet works and so do all of the formulas.
I've not managed to get Outlook to take the appropriate action from the details in the Excel sheet.
Sub ExportToExcel()
' Fully working, will export Sender, Subject & Date Received from e-mails into spreadsheet *** Except For Non-Mail Items ***
' If getting "spreadsheet user-defined type not defined" go to Visual Basic > Tools > References and tick 'Microsoft Excel 12.0 Object Library'
On Error GoTo ErrHandler
Dim appExcel As Excel.Application
Dim wkb As Excel.Workbook
Dim wks As Excel.Worksheet
Dim rng As Excel.Range
Dim strSheet As String
Dim strPath As String
Dim intRowCounter As Integer
Dim intColumnCounter As Integer
Dim msg As Outlook.MailItem
Dim nms As Outlook.NameSpace
Dim fld As Outlook.MAPIFolder
Dim itm As Object
'Set path for spreadsheet
strSheet = "OE.xlsx"
strPath = "C:\Users\JM\Desktop\"
strSheet = strPath & strSheet
Debug.Print strSheet
'Select export folder
Set nms = Application.GetNamespace("MAPI")
Set fld = nms.PickFolder
'Handle potential errors with Select Folder dialog box.
If fld Is Nothing Then
MsgBox "There are no mail messages to export", vbOKOnly, "Error"
Exit Sub
ElseIf fld.DefaultItemType <> olMailItem Then
MsgBox "There are no mail messages to export", vbOKOnly, "Error"
Exit Sub
ElseIf fld.Items.Count = 0 Then
MsgBox "There are no mail messages to export", vbOKOnly, "Error"
Exit Sub
End If
'Open and activate Excel workbook.
Set appExcel = CreateObject("Excel.Application")
appExcel.Workbooks.Open (strSheet)
Set wkb = appExcel.ActiveWorkbook
Set wks = wkb.Sheets(1)
wks.Activate
appExcel.Application.Visible = True
'Copy field items in mail folder.
For Each itm In fld.Items
intColumnCounter = 1
Set msg = itm
intRowCounter = intRowCounter + 1
Set rng = wks.Cells(intRowCounter, intColumnCounter)
intColumnCounter = intColumnCounter
Set rng = wks.Cells(intRowCounter, intColumnCounter)
'rng.Value = msg.SenderEmailAddress
rng.Value = msg.SenderEmailAddress
intColumnCounter = intColumnCounter + 1
Set rng = wks.Cells(intRowCounter, intColumnCounter)
rng.Value = msg.Subject
intColumnCounter = intColumnCounter
intColumnCounter = intColumnCounter + 1
Set rng = wks.Cells(intRowCounter, intColumnCounter)
rng.Value = msg.ReceivedTime
Next itm
MsgBox "Export Complete", vbOKOnly, "Information"
Set appExcel = Nothing
Set wkb = Nothing
Set wks = Nothing
Set rng = Nothing
Set msg = Nothing
Set nms = Nothing
Set fld = Nothing
Set itm = Nothing
Exit Sub
ErrHandler:
If Err.Number = 1004 Then
MsgBox strSheet & " doesn't exist", vbOKOnly, "Error"
Else
End If
Set appExcel = Nothing
Set wkb = Nothing
Set wks = Nothing
Set rng = Nothing
Set msg = Nothing
Set nms = Nothing
Set fld = Nothing
Set itm = Nothing
MsgBox "Export Completed", vbOKOnly
End Sub
This is what the spreadsheet would look like, I can't show the original because of data protection.
Most of the code has been put together from a few different websites.
The predominant source of the code was this site http://www.vbaexpress.com/forum/showthread.php?52247-Macro-to-send-out-email-based-on-criteria-via-outlook/page3&s=11b5bf88fb5e89d06f7c8b43f6f92d2e
I want the following code to:
- Mark the "Yes" e-mails as read and move them into the shared "No Response" folder in Outlook (in the same shared mailbox as the inbox the e-mail details were exported from).
This is where I am so far. The code will recognise an e-mail, mark it as unread, flag it as complete but it won't move the items into the folder or process the whole folder.
Option Explicit
Const strWorkbook As String = "C:\Users\jmurrey\Desktop\OE.xlsm" 'The path of the workbook
Const strSheet As String = "Sheet1" 'The name of the worksheet
Sub ProcessFolder()
Dim olItem As Object
Dim olFolder As Folder
Set olFolder = Session.PickFolder 'select the folder
For Each olItem In olFolder.Items 'loop through the items
If TypeName(olItem) = "MailItem" Then
MoveToFolder olItem 'run the macro
End If
Exit For
Next olItem
Set olItem = Nothing
lbl_Exit:
Exit Sub
End Sub
Sub MailFilter()
Dim olMsg As MailItem
On Error Resume Next
Set olMsg = ActiveExplorer.Selection.Item(1)
MoveToFolder olMsg
lbl_Exit:
Exit Sub
End Sub
Sub MoveToFolder(olMail As Outlook.MailItem)
Dim olReply As Outlook.MailItem
Dim olInsp As Outlook.Inspector
Dim wdDoc As Object
Dim oRng As Object
Dim Arr() As Variant
Dim iCols As Long
Dim iRows As Long
Dim strName As String
'load the worksheet into an array
Arr = xlFillArray(strWorkbook, strSheet)
With olMail
For iRows = 0 To UBound(Arr, 2) 'Check each row of the array
'If column 2 (starting at column 0) contains the e-mail address of the message
If .SenderEmailAddress = Arr(0, iRows) Then
'If the subject value is in the message subject
If InStr(1, .Subject, Arr(1, iRows)) > 0 Then
If InStr(1, .ReceivedTime, Arr(2, iRows)) > 0 Then
'If the received time is in the message subject
If InStr(1, "Yes", Arr(3, iRows)) > 0 Then
'If The string above matches then mark the email as unread and move to 'No Response' folder
'MsgBox "Match Found", vbOKOnly, "Match"
.FlagStatus = olFlagComplete
.UnRead = False
.Save
.Move Application.Session.Folders("No Response")
Exit For
End If
End If
End If
End If
Next iRows
End With
lbl_Exit:
Set olReply = Nothing
Set olInsp = Nothing
Set wdDoc = Nothing
Set oRng = Nothing
Exit Sub
End Sub
Private Function xlFillArray(strWorkbook As String, _
strWorksheetName As String) As Variant
Dim RS As Object
Dim CN As Object
Dim iRows As Long
strWorksheetName = strWorksheetName & "$]"
Set CN = CreateObject("ADODB.Connection")
CN.Open ConnectionString:="Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & strWorkbook & ";" & _
"Extended Properties=""Excel 12.0 Xml;HDR=YES"";"
Set RS = CreateObject("ADODB.Recordset")
RS.Open "SELECT * FROM [" & strWorksheetName, CN, 2, 1
With RS
.MoveLast
iRows = .RecordCount
.MoveFirst
End With
xlFillArray = RS.GetRows(iRows)
If RS.State = 1 Then RS.Close
Set RS = Nothing
If CN.State = 1 Then CN.Close
Set CN = Nothing
lbl_Exit:
Exit Function
End Function
How do I move e-mails to the folder "No Response" which is in the same shared mailbox as the inbox the data has been exported from and also run through all of the e-mails in the Excel sheet rather than just one.
3 answers
solution1
2 2017-01-28 22:31:40
I have many issues with your code. With some issues, I am sure your code is faulty. With other issues I am not so sure. I will work down your code discussing my issues which I hope will help you address your problem.
Don't use On Error GoTo ErrHandler during development or after release if you can avoid it. Your code will report the non-existence of the workbook but in the event of any other error it will just stop without giving no indication that it has failed to complete its task or the reason.
Try this for the workbook problem and add code for any other problems as they are discovered:
Set wkb = Nothing
On Error Resume Next
Set wkb = appExcel.Workbooks.Open(strSheet)
On Error GoTo 0
If wkb Is Nothing Then
Call MsgBox("I cannot open the workbook", vbOKOnly)
Exit Sub
End If
Dim intRowCounter As Integer . We were told to stop using data type Integer with VBA because it declares a 16-bit variable and such variables required special – slow - processing on 32 and 64-bit computers. When I got around to testing this claim, I was unable to detect any difference in processing speed. My reason for not using Integer for a row number is that its maximum value is 32767. I assume you will not have that many emails per folder but I will still suggest you get into the habit of declaring row numbers as Long .
You do not initialise intRowCounter . The default value is 0 and you add 1 before first use so it starts as 1.
strSheet = "OE.xlsx" . Not very important but I hate anything that might cause confusion in the future. "OE.xlsx" is the name of a workbook and not the name of a worksheet. The term “spreadsheet” dates back to when there was only one sheet per file and I consider it obsolete.
You use PickFolder to select the folder which is fine if you want to be able run this macro against multiple folders. I was concerned you were using PickFolder because you did not know how else to get a folder reference particularly as you are using Explorer in MailFilter() .
Alternatively, since you are playing with Explorer, perhaps this technique will appeal. The user selects the target folder and then starts your macro with this code at the beginning:
Dim Exp As Outlook.Explorer
Dim Fldr As Folder
Set Exp = Outlook.Application.ActiveExplorer
If Exp.Selection.Count = 0 Then
Call MsgBox("No emails selected", vbOKOnly)
Exit Sub
Else
Set Fldr = Exp.Selection(1).Parent
End If
Exp.Selection(1) is the first or only selected email.
Exp.Selection(1).Parent is the folder containing the selected email.
There is no need to activate the worksheet.
I would never identify columns by number unless the nature of the task required it. I would replace your code by:
Const ColEmSenderEmailAddress As Long = 1
Const ColEmSubject As Long = 2
Const ColEmReceivedTime As Long = 3
wks.Cells(intRowCounter, ColEmSenderEmailAddress).Value = msg.SenderEmailAddress
wks.Cells(intRowCounter, ColEmSubject).Value = msg.Subject
wks.Cells(intRowCounter, ColEmReceivedTime).Value = msg.ReceivedTime
I think this is easier to read and, more importantly, if any of the columns move, you only need to update the constants.
In your first macro you use For Each itm In fld.Items to access the mail items. In the second you use Explorer to access the first or only selected email. You must be consistent.
I rarely use For Each itm In fld.Items and have never experimented with the sequence in which items are presented to the macro. In the second macro, you will be removed items from the folder by moving them elsewhere. Again I have never experimented so do not know how this might affect the items returned by For Each itm In fld.Items . I doubt there will be an effect but you will need to check if you want to use For Each itm In fld.Items in both macros.
I would use something like this for the first macro:
Dim InxMi As Long
Dim itm As MailItem
For InxMi = 1 To Fldr.Items.Count
Set itm = Fldr.Items(InxMi)
Output macro to worksheet
Next
Since you start at row 1 in the worksheet, this would mean the item number InxMi and the row number intRowCounter would be the same make matching rows and mail items in the second macro easier. If there is no change to the folder between creating the worksheet and running the second macro, there will be an exact match. If you allow additions and deletion between the two macros, it will be more complicated but rows and the mail items will be in the same sequence so not too complicated.
In the second macro, you need to start at the bottom row of the worksheet and read the folder up from the bottom:
For InxMi = Fldr.Items.Count To 1 Step -1
Set itm = Fldr.Items(InxMi)
If appropriate Move item
Next
Mail items within a folder are like rows within worksheets, if you delete one then all the one below move up. If you move up the worksheet and the folder, the row and mail items will continue to match because the moved mail items will below the current position.
You do not give enough detail for me to be more specific but I hope the above helps you progress.
solution2
1 2017-02-28 05:03:52
Hey why not run it from your Excel file and keep it simple -
Basic Example
Option Explicit
Public Sub Example()
Dim App As Outlook.Application
Dim olNs As Outlook.Namespace
Dim Inbox As Outlook.MAPIFolder
Dim SubFolder As Outlook.MAPIFolder
Dim Items As Outlook.Items
Dim Item As Object
Dim iRow As Long
Dim i As Long
Dim RevdTime As String
Dim Subject As String
Dim Email As String
Set App = New Outlook.Application
Set olNs = App.GetNamespace("MAPI")
Set Inbox = olNs.GetDefaultFolder(olFolderInbox) ' Inbox
Set Items = Inbox.Items
iRow = 1 ' Row Count
With Worksheets("Sheet1") ' Update with Correct Sheet Name
Do Until IsEmpty(.Cells(iRow, 4))
DoEvents
If Cells(iRow, 4).Value = "Yes" Then
RevdTime = .Cells(iRow, 3).Value ' Email ReceivedTime
Subject = .Cells(iRow, 2).Value ' Email Subject
Email = .Cells(iRow, 1).Value ' Email Sender Name
For i = Items.Count To 1 Step -1
Set Item = Items(i)
If Item.Class = olMail And _
Item.Subject = Subject And _
Item.ReceivedTime = RevdTime And _
Item.SenderEmailAddress = Email Then
Debug.Print Item.Subject ' Immediate Window
Debug.Print Item.ReceivedTime ' Immediate Window
Debug.Print Item.SenderEmailAddress ' Immediate Window
Item.UnRead = False
Item.Save
Item.Move olNs.GetDefaultFolder(olFolderInbox) _
.Folders("No Response")
End If
Next
End If
iRow = iRow + 1 ' Go to Next Row
Loop
End With
Set App = Nothing
Set olNs = Nothing
Set Inbox = Nothing
Set SubFolder = Nothing
Set Items = Nothing
Set Item = Nothing
End Sub
for Late Binding see
Option Explicit
Public Sub Example()
Dim App As Object ' Outlook.Application
Dim olNs As Object ' Outlook.Namespace
Dim Inbox As Object ' Outlook.MAPIFolder
Dim SubFolder As Object ' Outlook.MAPIFolder
Dim Items As Object ' Outlook.Items
Dim Item As Object
Dim iRow As Long
Dim i As Long
Dim RevdTime As String
Dim Subject As String
Dim Email As String
Set App = CreateObject("Outlook.Application")
Set olNs = App.GetNamespace("MAPI")
Set Inbox = olNs.GetDefaultFolder(6) ' olFolderInbox = 6
Set Items = Inbox.Items
iRow = 1 ' Row Count
With Worksheets("Sheet1") ' Update with Correct Sheet Name
Do Until IsEmpty(.Cells(iRow, 4))
DoEvents
If Cells(iRow, 4).Value = "Yes" Then
RevdTime = .Cells(iRow, 3).Value ' Email ReceivedTime
Subject = .Cells(iRow, 2).Value ' Email Subject
Email = .Cells(iRow, 1).Value ' Email Sender Name
For i = Items.Count To 1 Step -1
Set Item = Items(i)
' olMail - 43 = A MailItem object.
If Item.Class = 43 And _
Item.Subject = Subject And _
Item.ReceivedTime = RevdTime And _
Item.SenderEmailAddress = Email Then
Debug.Print Item.Subject ' Immediate Window
Debug.Print Item.ReceivedTime ' Immediate Window
Debug.Print Item.SenderEmailAddress ' Immediate Window
Item.UnRead = False
Item.Save
Item.Move olNs.GetDefaultFolder(6) _
.Folders("No Response")
End If
Next
End If
iRow = iRow + 1 ' Go to Next Row
Loop
End With
Set App = Nothing
Set olNs = Nothing
Set Inbox = Nothing
Set SubFolder = Nothing
Set Items = Nothing
Set Item = Nothing
End Sub
If you want to run it from Outlook let me know it shouldn't be hard-
solution3
1 2017-03-10 00:05:27
I did not know where to start with fixing your code so I have started from scratch based on my best guesses regarding your requirement.
I created a file named OE.xlsx with a single worksheet named “Emails” since I avoid using the default worksheet names. I created a header line with values: “Sender”, “Subject”, “Received”, “Yes/No” and “Folder”. I have maintained your sequence although I have added “Folder”.
I have named the main macros as “Part1” and “Part2” so there is no confusion with the other macros. All the other macros are from my library. They are more complicated than you need but I did not want to spend time coding something simpler. I suggest you accept these routines do what the comments say and not worry about how.
You have not said if the source of the emails is always the same shared folder. I added the folder column to allow for multiple shared folders. It means macro “Part2” does not need to ask about the source folder since it gets this information from the workbook although it would need to be told about the destination folder.
You do not say how you create the formulae that sets the value in the “Yes/No” column. I would get macro “Part1” to create them and I have included an example which sets “Yes” or “No” depending on the length of the subject.
In macro “Part1”, I use “For Each FldrSrcNameArr … ” to get details of emails from two folders. If you have fixed source folders, you can use something similar. If your requirement is more complicated, you will need to provide more detail.
Macro “Part1” adds new emails below any existing rows. In macro “Part2”, I clear the rows for emails that are moved and then write the remaining rows back to the worksheet. I know your macros do not work like this but I wanted to show what is possible. You can easily delete the redundant code if you do not require it.
I believe you should find it easy to adjust the following code to your requirements. Come back questions if necessary.
Option Explicit
' Requires references to "Microsoft Excel nn.0 Object Library", "Microsoft Office
' nn.0 Object Library" and "Microsoft Scripting Runtime" Value of "nn" depends
' on version of Office being used.
' Technique for locating desktop from answer by Kyle:
' http://stackoverflow.com/a/17551579/973283
Const ColEmailSender As Long = 1
Const ColEmailSubject As Long = 2
Const ColEmailReceived As Long = 3
Const ColEmailYesNo As Long = 4
Const ColEmailFolderName As Long = 5
Const RowEmailDataFirst As Long = 2
Sub Part1()
Dim ColEmailLast As Long
Dim FldrSrc As Folder
Dim FldrSrcName As String
Dim FldrSrcNameArr As Variant
Dim ItemCrnt As MailItem
Dim ItemsSrc As Items
Dim Path As String
Dim RowEmailCrnt As Long
Dim WbkEmail As Excel.Workbook
Dim WshtEmail As Excel.Worksheet
Dim xlApp As Excel.Application
Path = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\"
Set xlApp = Application.CreateObject("Excel.Application")
xlApp.Visible = True ' This slows your macro but helps during debugging
With xlApp
Set WbkEmail = .Workbooks.Open(Path & "OE.xlsx")
End With
With WbkEmail
Set WshtEmail = .Worksheets("Emails")
End With
Call FindLastRowCol(WshtEmail, RowEmailCrnt, ColEmailLast)
' Output first new row under any existing rows.
RowEmailCrnt = RowEmailCrnt + 1
For Each FldrSrcNameArr In VBA.Array(VBA.Array("test folders", "Test emails 1"), _
VBA.Array("test folders", "Test emails 2"))
Set FldrSrc = GetFldrRef(FldrSrcNameArr)
FldrSrcName = Join(GetFldrNames(FldrSrc), "|")
Set ItemsSrc = FldrSrc.Items
' This shows how to sort the emails by a property should this be helpful.
ItemsSrc.Sort "[ReceivedTime]" ' Ascending sort. Add ", False" for descending
For Each ItemCrnt In ItemsSrc
With ItemCrnt
WshtEmail.Range(WshtEmail.Cells(RowEmailCrnt, 1), _
WshtEmail.Cells(RowEmailCrnt, 5)).Value = _
VBA.Array(.SenderEmailAddress, .Subject, .ReceivedTime, _
"=IF(MOD(LEN(" & ColCode(ColEmailSubject) & RowEmailCrnt & "),2)=0,""Yes"",""No"")", _
FldrSrcName)
End With
RowEmailCrnt = RowEmailCrnt + 1
Next
Set ItemCrnt = Nothing
Set ItemsSrc = Nothing
Set FldrSrc = Nothing
Next
WbkEmail.Close SaveChanges:=True
Set WshtEmail = Nothing
Set WbkEmail = Nothing
xlApp.Quit
Set xlApp = Nothing
End Sub
Sub Part2()
Dim ColEmailCrnt As Long
Dim ColEmailLast As Long
Dim FldrDest As Folder
Dim FldrSrc As Folder
Dim FldrSrcNameCrnt As String
Dim FldrSrcNamePrev As String
Dim InxIS As Long
Dim ItemsSrc As Items
Dim ItemsToMove As New Collection
Dim Path As String
Dim RngSortF As Range
Dim RngSortR As Range
Dim RngWsht As Range
Dim RowEmailCrnt As Long
Dim RowEmailLast As Long
Dim WbkEmail As Excel.Workbook
Dim WshtEmail As Excel.Worksheet
Dim WshtEmailValues As Variant
Dim xlApp As Excel.Application
Path = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\"
Set xlApp = Application.CreateObject("Excel.Application")
xlApp.Visible = True ' This slows your macro but helps during debugging
With xlApp
Set WbkEmail = .Workbooks.Open(Path & "OE.xlsx")
End With
With WbkEmail
Set WshtEmail = .Worksheets("Emails")
End With
Call FindLastRowCol(WshtEmail, RowEmailLast, ColEmailLast)
With WshtEmail
Set RngWsht = .Range(.Cells(1, 1), .Cells(RowEmailLast, ColEmailLast))
Set RngSortF = .Range(.Cells(2, ColEmailFolderName), .Cells(RowEmailLast, ColEmailFolderName))
Set RngSortR = .Range(.Cells(2, ColEmailReceived), .Cells(RowEmailLast, ColEmailReceived))
' Ensure rows are sequecnced by Folder name then Received
' For each folder, the items are sorted by ReceivedTime. THis means the two lists
' are in the same sequence.
With .Sort
.SortFields.Clear
.SortFields.Add Key:=RngSortF, SortOn:=xlSortOnValues, _
Order:=xlAscending, DataOption:=xlSortNormal
.SortFields.Add Key:=RngSortR, SortOn:=xlSortOnValues, _
Order:=xlAscending, DataOption:=xlSortNormal
.SetRange RngWsht
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
WshtEmailValues = RngWsht.Value
End With
FldrSrcNamePrev = ""
Set FldrDest = GetFldrRef("test folders", "No response")
For RowEmailCrnt = RowEmailDataFirst To RowEmailLast
If WshtEmailValues(RowEmailCrnt, ColEmailYesNo) = "Yes" Then
' This row identifies an email that is to be moved
FldrSrcNameCrnt = WshtEmailValues(RowEmailCrnt, ColEmailFolderName)
If FldrSrcNamePrev <> FldrSrcNameCrnt Then
' New source folder
Set FldrSrc = Nothing
Set FldrSrc = GetFldrRef(Split(FldrSrcNameCrnt, "|"))
FldrSrcNamePrev = FldrSrcNameCrnt
Set ItemsSrc = FldrSrc.Items
ItemsSrc.Sort "[ReceivedTime]"
InxIS = 1
End If
' Scan down mail items within sorted folder until reach or are past current email
Do While InxIS <= ItemsSrc.Count
If ItemsSrc(InxIS).ReceivedTime >= WshtEmailValues(RowEmailCrnt, ColEmailReceived) Then
Exit Do
End If
InxIS = InxIS + 1
Loop
If InxIS <= ItemsSrc.Count Then
If ItemsSrc(InxIS).ReceivedTime = WshtEmailValues(RowEmailCrnt, ColEmailReceived) And _
ItemsSrc(InxIS).SenderEmailAddress = WshtEmailValues(RowEmailCrnt, ColEmailSender) And _
ItemsSrc(InxIS).Subject = WshtEmailValues(RowEmailCrnt, ColEmailSubject) Then
' Have found email to be moved
' ItemsSrc is what VBA calls a Collection but most languages call a List.
' Moving a mail item to another folder removes an item from the Collection and
' upsets the index. Better to save a reference to the mail item and move it later.
ItemsToMove.Add ItemsSrc(InxIS)
' Clear row in WshtEmailValues to indicate email moved
For ColEmailCrnt = 1 To ColEmailLast
WshtEmailValues(RowEmailCrnt, ColEmailCrnt) = ""
Next
InxIS = InxIS + 1
' Else there is no mail item matching email row
End If
' Else no more emails in folder
End If
' Else email row marled "No"
End If
Next
' Move mail items marked "Yes"
Do While ItemsToMove.Count > 0
ItemsToMove(1).Move FldrDest
ItemsToMove.Remove 1
Loop
' Upload worksheet values with rows for moved files cleared
RngWsht.Value = WshtEmailValues
' Sort blank lines to bottom
With WshtEmail
With .Sort
.Apply
End With
End With
WbkEmail.Close SaveChanges:=True
Set WshtEmail = Nothing
Set WbkEmail = Nothing
xlApp.Quit
Set xlApp = Nothing
'Set ItemCrnt = Nothing
'Set ItemsSrc = Nothing
'Set FldrSrc = Nothing
End Sub
' =================== Standard Outlook VBA routines ===================
Function GetFldrNames(ByRef Fldr As Folder) As String()
' * Fldr is a folder. It could be a store, the child of a store,
' the grandchild of a store or more deeply nested.
' * Return the name of that folder as a string array in the sequence:
' (0)=StoreName (1)=Level1FolderName (2)=Level2FolderName ...
' 12Oct16 Coded
' 20Oct16 Renamed from GetFldrNameStr and amended to return a string array
' rather than a string
Dim FldrCrnt As Folder
Dim FldrNameCrnt As String
Dim FldrNames() As String
Dim FldrNamesRev() As String
Dim FldrPrnt As Folder
Dim InxFN As Long
Dim InxFnR As Long
Set FldrCrnt = Fldr
FldrNameCrnt = FldrCrnt.Name
ReDim FldrNamesRev(0 To 0)
FldrNamesRev(0) = Fldr.Name
' Loop getting parents until FldrCrnt has no parent.
' Add names of Fldr and all its parents to FldrName as they are found
Do While True
Set FldrPrnt = Nothing
On Error Resume Next
Set FldrPrnt = Nothing ' Ensure value is Nothing if following statement fails
Set FldrPrnt = FldrCrnt.Parent
On Error GoTo 0
If FldrPrnt Is Nothing Then
' FldrCrnt has no parent
Exit Do
End If
ReDim Preserve FldrNamesRev(0 To UBound(FldrNamesRev) + 1)
FldrNamesRev(UBound(FldrNamesRev)) = FldrPrnt.Name
Set FldrCrnt = FldrPrnt
Loop
' Copy names to FldrNames in reverse sequence so they end up in the correct sequence
ReDim FldrNames(0 To UBound(FldrNamesRev))
InxFN = 0
For InxFnR = UBound(FldrNamesRev) To 0 Step -1
FldrNames(InxFN) = FldrNamesRev(InxFnR)
InxFN = InxFN + 1
Next
GetFldrNames = FldrNames
End Function
Function GetFldrRef(ParamArray FolderNames() As Variant) As Folder
' FolderNames can be used as a conventional ParamArray: a list of values. Those
' Values must all be strings.
' Alternatively, its parameter can be a preloaded one-dimensional array of type
' Variant or String. If of type Variant, the values must all be strings.
' The first, compulsory, entry in FolderNames is the name of a Store.
' Each subsequent, optional, entry in FolderNames is the name of a folder
' within the folder identified by the previous names. Example calls:
' 1) Set Fldr = GetFolderRef("outlook data file")
' 2) Set Fldr = GetFolderRef("outlook data file", "Inbox", "Processed")
' 3) MyArray = Array("outlook data file", "Inbox", "Processed")
' Set Fldr = GetFolderRef(MyArray)
' Return a reference to the folder identified by the names or Nothing if it
' does not exist
Dim FolderNamesDenested() As Variant
Dim ErrNum As Long
Dim FldrChld As Folder
Dim FldrCrnt As Folder
Dim InxP As Long
Call DeNestParamArray(FolderNamesDenested, FolderNames)
If LBound(FolderNamesDenested) > UBound(FolderNamesDenested) Then
' No names specified
Set GetFolderRef = Nothing
Exit Function
End If
For InxP = 0 To UBound(FolderNamesDenested)
If VarType(FolderNamesDenested(InxP)) <> vbString Then
' Value is not a string
Debug.Assert False ' Fatal error
Set GetFolderRef = Nothing
Exit Function
End If
Next
Set FldrCrnt = Nothing
On Error Resume Next
Set FldrCrnt = Session.Folders(FolderNamesDenested(0))
On Error GoTo 0
If FldrCrnt Is Nothing Then
' Store name not recognised
Debug.Print FolderNamesDenested(0) & " is not recognised as a store"
Debug.Assert False ' Fatal error
Set GetFldrRef = Nothing
Exit Function
End If
For InxP = 1 To UBound(FolderNamesDenested)
Set FldrChld = Nothing
On Error Resume Next
Set FldrChld = FldrCrnt.Folders(FolderNamesDenested(InxP))
On Error GoTo 0
If FldrChld Is Nothing Then
' Folder name not recognised
Debug.Print FolderNamesDenested(InxP) & " is not recognised as a folder within " & _
Join(GetFldrNames(FldrCrnt), "->")
Debug.Assert False ' Fatal error
Set GetFldrRef = Nothing
Exit Function
End If
Set FldrCrnt = FldrChld
Set FldrChld = Nothing
Next
Set GetFldrRef = FldrCrnt
End Function
' =================== Standard VBA routines ===================
Sub DeNestParamArray(Denested() As Variant, ParamArray Original() As Variant)
' Each time a ParamArray is passed to a sub-routine, it is nested in a one
' element Variant array. This routine finds the bottom level of the nesting and
' sets RetnValue to the values in the original parameter array so that other routines
' need not be concerned with this complication.
' Nov10 Coded
' 6Aug16 Minor correction to documentation
' 6Aug16 The previous version did not correctly handle an empty ParamArray.
' 15Oct16 replaced call of NumDim by call of NumberOfDimensions
' Tested that routine could denest a ParamArray that started as a reloaded
' array rather than a list of values in a call.
Dim Bounds As Collection
Dim Inx1 As Long
Dim Inx2 As Long
Dim DenestedCrnt() As Variant
Dim DenestedTemp() As Variant
DenestedCrnt = Original
' Find bottom level of nesting
Do While True
If VarType(DenestedCrnt) < vbArray Then
' Have found a non-array element so must have reached the bottom level
Debug.Assert False ' Should have exited loop at previous level
Exit Do
End If
Call NumberOfDimensions(Bounds, DenestedCrnt)
' There is one entry in Bounds per dimension in NestedCrnt
' Each entry is an array: Bounds(N)(0) = Lower bound of dimension N
' and Bounds(N)(1) = Upper bound of dimenssion N
If Bounds.Count = 1 Then
If Bounds(1)(0) > Bounds(1)(1) Then
' The original ParamArray was empty
Denested = DenestedCrnt
Exit Sub
ElseIf Bounds(1)(0) = Bounds(1)(1) Then
' This is a one element array
If VarType(DenestedCrnt(Bounds(1)(0))) < vbArray Then
' But it does not contain an array so the user only specified
' one value (a literal or a non-array variable)
' This is a valid exit from this loop
'Debug.Assert False
Exit Do
End If
' The following sometimes crashed Outlook
'DenestedCrnt = DenestedCrnt(Bounds(1)(0))
If VarType(DenestedCrnt(Bounds(1)(0))) = vbArray + vbString Then
' DenestedCrnt(Bounds(1)(0))) is an array of strings.
' This is the array sought but it must be converted to an array
' of variants with lower bound = 0 before it can be returned.
ReDim Denested(0 To UBound(DenestedCrnt(Bounds(1)(0))) - LBound(DenestedCrnt(Bounds(1)(0))))
Inx2 = LBound(DenestedCrnt)
For Inx1 = 0 To UBound(Denested)
Denested(Inx1) = DenestedCrnt(Bounds(1)(0))(Inx2)
Inx2 = Inx2 + 1
Next
Exit Sub
End If
DenestedTemp = DenestedCrnt(Bounds(1)(0))
DenestedCrnt = DenestedTemp
Else
' This is a one-dimensional, non-nested array
' This is the usual exit from this loop
Exit Do
End If
Else
' This is an array but not a one-dimensional array
' There is no code for this situation
Debug.Assert False
Exit Do
End If
Loop
' Have found bottom level array. Save contents in Return array.
If LBound(DenestedCrnt) <> 0 Then
' A ParamArray should have a lower bound of 0. Assume the ParamArray
' was loaded with a 1D array that did not have a lower bound of 0.
' Build Denested so it has standard lbound
ReDim Denested(0 To UBound(DenestedCrnt) - LBound(DenestedCrnt))
Inx2 = LBound(DenestedCrnt)
For Inx1 = 0 To UBound(Denested)
Denested(Inx1) = DenestedCrnt(Inx2)
Inx2 = Inx2 + 1
Next
Else
Denested = DenestedCrnt
End If
End Sub
Function NumberOfDimensions(ByRef Bounds As Collection, _
ParamArray Params() As Variant) As Long
' Example calls of this routine are:
' NumDim = NumberOfDimensions(Bounds, MyArray)
' or NumDim = NumberOfDimensions(Bounds, Worksheets("Sheet1").Range("D4:E20"))
' * Returns the number of dimensions of Params(LBound(Params)). Param is a ParamArray.
' MyArray, in the example call, is held as the first element of array Params. That is
' it is held as Params(LBound(Params)) or Params(LBdP) where LBdP = LBound(Params).
' * If the array to test is a regular array, then, in exit, for each dimension, the lower
' and upper bounds are recorded in Bounds. Entries in Bounds are zero-based arrays
' with two entries: lower bound and upper bound.
' * If the array is a worksheet range, the lower bound values in Bounds are 1 and the
' upper bound values are the number of rows (first entry in Bounds) or columns (second
' entry in Bounds)
' * The collection Bounds is of most value to routines that can be pased an array as
' a parameter but does not know if that array is a regular array or a range. The values
' returned in Bounds means that whether the test array is a regular array or a range,
' its elements can be accessed so:
' For InxDim1 = Bounds(0)(0) to Bounds(0)(1)
' For InxDim2 = Bounds(1)(0) to Bounds(1)(1)
' : : :
' Next
' Next
' If there is an official way of determining the number of dimensions, I cannot find it.
' This routine tests for dimension 1, 2, 3 and so on until it get a failure.
' By trapping that failure it can determine the last test that did not fail.
' * Params() is a ParamArray because it allows the passing of arrays of any type.
' * The array to be tested in not Params but Params(LBound(Params)).
' * The routine does not check for more than one parameter. If the call was
' NumDim(Bounds, MyArray1, MyArray2), it would ignore MyArray2.
' Jun10 Coded
' Jul10 Documentation added
' 13Aug16 Return type changed from Integer
' 14Aug16 Upgraded to handle ranges. VarType reports a worksheet range as an
' array but LBound and UBound do not recognise a range as an array.
' Added Bounds to report bounds of both regular arrays and ranges.
' 14Aug16 Renamed from NumDim.
' 14Aug16 Switched between different approaches as built up understanding of
' bounds of ranges as documented elsewhere in macro.
' 15Aug16 Switched back to use of TestArray.
Dim InxDim As Long
Dim Lbd As Long
Dim LBdC As Long
Dim LBdP As Long
Dim LBdR As Long
Dim NumDim As Long
Dim TestArray As Variant
'Dim TestResult As Long
Dim UBdC As Long
Dim UBdR As Long
Set Bounds = New Collection
If VarType(Params(LBound(Params))) < vbArray Then
' Variable to test is not an array
NumberOfDimensions = 0
Exit Function
End If
On Error Resume Next
LBdP = LBound(Params)
TestArray = Params(LBdP)
NumDim = 1
Do While True
Lbd = LBound(TestArray, NumDim)
'Lbd = LBound(Params(LBdP), NumDim)
If Err.Number <> 0 Then
If NumDim > 1 Then
' Only known reason for failing is because array
' does not have NumDim dimensions
NumberOfDimensions = NumDim - 1
On Error GoTo 0
For InxDim = 1 To NumberOfDimensions
Bounds.Add VBA.Array(LBound(TestArray, InxDim), UBound(TestArray, InxDim))
'Bounds.Add VBA.Array(LBound(Params(LBdP), InxDim), _
UBound(Params(LBdP), InxDim))
Next
Exit Function
Else
Err.Clear
Bounds.Add VBA.Array(TestArray.Row, TestArray.Rows.Count - TestArray.Row + 1)
Bounds.Add VBA.Array(TestArray.Column, TestArray.Columns.Count - TestArray.Column + 1)
If Err.Number <> 0 Then
NumberOfDimensions = 0
Exit Function
End If
On Error GoTo 0
NumberOfDimensions = 2
Exit Function
End If
End If
NumDim = NumDim + 1
Loop
End Function
' =================== Standard Excel routines ===================
Function ColCode(ByVal ColNum As Long) As String
' Convert column number to column code
' For example: 1 -> A, 2 -> B, 26 -> Z and 27 -> AA
Dim PartNum As Long
' 3Feb12 Adapted to handle three character codes.
' 28Oct16 Renamed ColCode to match ColNum.
If ColNum = 0 Then
Debug.Assert False
ColCode = "0"
Else
ColCode = ""
Do While ColNum > 0
PartNum = (ColNum - 1) Mod 26
ColCode = Chr(65 + PartNum) & ColCode
ColNum = (ColNum - PartNum - 1) \ 26
Loop
End If
End Function
Sub FindLastRowCol(ByRef Wsht As Worksheet, ByRef RowLast As Long, _
ByRef ColLast As Long)
' Sets RowLast and ColLast to the last row and column with a value
' in worksheet Wsht
' The motivation for coding this routine was the discovery that Find by
' previous row found a cell formatted as Merge and Center but Find by
' previous column did not.
' I had known the Find would missed merged cells but this was new to me.
' Dec16 Coded
' 31Dec16 Corrected handling of UsedRange
' 15Feb17 SpecialCells was giving a higher row number than Find for
' no reason I could determine. Added code to check for a
' value on rows and columns above those returned by Find
Dim ColCrnt As Long
Dim ColLastFind As Long
Dim ColLastOther As Long
Dim ColLastTemp As Long
Dim ColLeft As Long
Dim ColRight As Long
Dim Rng As Range
Dim RowIncludesMerged As Boolean
Dim RowBot As Long
Dim RowCrnt As Long
Dim RowLastFind As Long
Dim RowLastOther As Long
Dim RowLastTemp As Long
Dim RowTop As Long
With Wsht
Set Rng = .Cells.Find("*", .Range("A1"), xlFormulas, , xlByRows, xlPrevious)
If Rng Is Nothing Then
RowLastFind = 0
ColLastFind = 0
Else
RowLastFind = Rng.Row
ColLastFind = Rng.Column
End If
Set Rng = .Cells.Find("*", .Range("A1"), xlValues, , xlByColumns, xlPrevious)
If not Rng Is Nothing Then
If RowLastFind < Rng.Row Then
RowLastFind = Rng.Row
End If
If ColLastFind < Rng.Column Then
ColLastFind = Rng.Column
End If
End If
Set Rng = .Range("A1").SpecialCells(xlCellTypeLastCell)
If Rng Is Nothing Then
RowLastOther = 0
ColLastOther = 0
Else
RowLastOther = Rng.Row
ColLastOther = Rng.Column
End If
Set Rng = .UsedRange
If not Rng Is Nothing Then
If RowLastOther < Rng.Row + Rng.Rows.Count - 1 Then
RowLastOther = Rng.Row + Rng.Rows.Count - 1
End If
If ColLastOther < Rng.Column + Rng.Columns.Count - 1 Then
ColLastOther = Rng.Column + Rng.Columns.Count - 1
End If
End If
If RowLastFind < RowLastOther Then
' Higher row found by SpecialCells or UserRange
Do While RowLastOther > RowLastFind
ColLastTemp = .Cells(RowLastOther, .Columns.Count).End(xlToLeft).Column
If ColLastTemp > 1 Or .Cells(RowLastOther, 1).Value <> "" Then
' Row after RowLastFind has value
RowLastFind = RowLastOther
Exit Do
End If
RowLastOther = RowLastOther - 1
Loop
ElseIf RowLastFind > RowLastOther Then
Debug.Assert False
' Is this possible
End If
RowLast = RowLastFind
If ColLastFind < ColLastOther Then
' Higher column found by SpecialCells or UserRange
Do While ColLastOther > ColLastFind
RowLastTemp = .Cells(.Rows.Count, ColLastOther).End(xlUp).Row
If RowLastTemp > 1 Or .Cells(1, ColLastOther).Value <> "" Then
Debug.Assert False
' Column after ColLastFind has value
ColLastFind = ColLastOther
Exit Do
End If
ColLastOther = ColLastOther - 1
Loop
ElseIf ColLastFind > ColLastOther Then
Debug.Assert False
' Is this possible
End If
ColLast = ColLastFind
End With
End Sub
The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.