I get a 430 error running code on a subfolder of a shared inbox.
Sub GetEmails()
'Add Tools->References->"Microsoft Outlook nn.n Object Library"
'nn.n varies as per our Outlook Installation
Const NUM_DAYS As Long = 34
Dim OutlookApp As Outlook.Application
Dim i As Long
Dim Folder As Outlook.MAPIFolder
Dim itm As Object
Dim iRow As Long, oRow As Long, ws As Worksheet, sBody As String
Dim mailboxName As String, inboxName As String, subfolderName As String
mailboxName = "mailboxname"
inboxName = "Inbox"
subfolderName = "subfoldername"
Set OutlookApp = New Outlook.Application
On Error Resume Next
Set Folder = OutlookApp.Session.Folders(mailboxName) _
.Folders(inboxName).Folders(subfolderName)
On Error GoTo 0
If Folder Is Nothing Then
MsgBox "Source folder not found!", vbExclamation, _
"Problem with export"
Exit Sub
End If
Set ws = ThisWorkbook.Worksheets(1)
'add headers
ws.Range("A1").Resize(1, 4).Value = Array("Sender", "Subject", "Date", "Body")
iRow = 2
Folder.Items.Sort "Received"
For Each itm In Folder.Items
If TypeOf itm Is Outlook.MailItem Then 'check it's a mail item (not appointment, etc)
If Date - itm.ReceivedTime <= NUM_DAYS Then
sBody = Left(Trim(itm.Body), 150) 'first 150 chars of Body
sBody = Replace(sBody, vbCrLf, "; ") 'remove newlines
sBody = Replace(sBody, vbLf, "; ")
ws.Cells(iRow, 1).Resize(1, 4).Value = _
Array(itm.SenderName, itm.Subject, itm.ReceivedTime, sBody)
iRow = iRow + 1
End If
End If
Next itm
MsgBox "Outlook Mails Extracted to Excel"
End Sub
I tried changing "itm" to "item". It works on the regular inbox. The issue happens when I try to pull from a subfolder.
I tried Debug Print. I don't know if I'm putting it in the right place.
The 430 error happens on the line:
If Date - itm.ReceivedTime <= NUM_DAYS Then
If I try to pull 30 days worth of data, it will only pull like the last seven days. So it works but it is limited.
First of all, the Sort method deals with non-existsing property:
Folder.Items.Sort "Received"
You need to use the ReceivedTime property instead.
Second, the sorted collection is lost and you continue dealing with unsorted one.
Folder.Items.Sort "Received"
For Each itm In Folder.Items
Asking each time the Items property returns a new Items instance. So, you need to get an instance once and then re-use in the code. Only by following this way you will preserve the sorting order.
The 430 error happens on the line:
If Date - itm.ReceivedTime <= NUM_DAYS Then
The error code indicates that Class doesn't support Automation (Error 430) which don't tell us anything meaningful.
Anyway, calculating dates that way to get items for specific dates in Outlook is not the best and proper way. Instead, you need to consider using the Find/FindNext or Restrict methods of the Items class which allows getting/dealing with items that correspond to your conditions only. Read more about these methods in the articles I wrote for the technical blog:
How To: Use Find and FindNext methods to retrieve Outlook mail items from a folder (C#, VB.NET)
How To: Use Restrict method to retrieve Outlook mail items from a folder
For example, you could use the following search criteria to get items for a specific timeframe:
'This filter uses urn:schemas:httpmail namespace
strFilter = AddQuotes("urn:schemas:httpmail:datereceived") _
& " > '" & datStartUTC & "' AND " _
& AddQuotes("urn:schemas:httpmail:datereceived") _
& " < '" & datEndUTC & "'"
See Filtering Items Using a Date-time Comparison for more information.
I have a problem updating certain modules. In some modules I can delete and import the modules, but on others what happens is that the module is imported first and the original deleted later which adds a 1 at the end of the module name and messes up the code.
Here's how I do it:
I have the following Excel file which I can track who needs or has updated to the new module version. When I update the module version I just type on the correct username column Not Updated. Once the user opens his MS Project it runs the following code and changes the value to Updated.
Then I run the following on Project.Activate in VBA - MS Project 2016 to check if the module needs to update.
Dim xlapp As Object
Dim xlbook As Object
Dim sHostName As String
Dim modulesList_loc As String
Dim projectVBA_loc As String
Dim modulesVBA_loc As String
projectVBA_loc = "\\sharedNetwork\Project\VBA\"
modulesVBA_loc = projectVBA_loc & "Modules\"
modulesList_loc = projectVBA_loc & "Modules Updates.xlsx"
' Get Host Name / Get Computer Name
sHostName = Environ$("username")
Set xlapp = CreateObject("Excel.Application")
SetAttr modulesList_loc, vbNormal
Set xlbook = xlapp.Workbooks.Open(modulesList_loc)
Dim rng_modules As Range
Dim rng_usernames As Range
Dim username As Range
Dim atualizado As Range
Dim module_name As Range
Dim lastcol As Long
Dim lastcol_letter As String
Dim linha As Integer
Dim len1 As Integer
Dim len2 As Integer
Dim module_name_short As String
Dim actualizar As Integer
'LAST USERNAME COLUMN
With xlbook.Worksheets(1)
'Last Column
lastcol = .Cells(2, .Columns.Count).End(xlToLeft).Column
lastcol_letter = GetColumnLetter(lastcol, xlbook.Worksheets(1))
End With
'Usernames range
Set rng_usernames = xlbook.Worksheets(1).Range("E2:" & lastcol_letter & "2")
'Finds the correct username
Set username = rng_usernames.Find(sHostName)
Set rng_modules = xlbook.Worksheets(1).Range("A3") 'First module
Do While rng_modules.Value <> Empty
'Adds module if necessary
linha = rng_modules.Row
Set atualizado = username.Offset(linha - 2)
Set module_name = rng_modules.Offset(, 1)
If atualizado.Value = "Not Updated" Then
With ThisProject.VBProject
len1 = Len(module_name.Value)
len2 = len1 - 4
module_name_short = Left(module_name.Value, len2)
On Error Resume Next
.VBComponents.Remove .VBComponents(module_name_short)
.VBComponents.import modulesVBA_loc & module_name.Value
End With
atualizado.Value = "Updated"
End If
Set rng_modules = rng_modules.Offset(1)
Loop
xlbook.Close (True)
SetAttr modulesList_loc, vbReadOnly
Add DoEvents after the Remove method is called to give time for the Remove method to complete.
'On Error Resume Next
.VBComponents.Remove .VBComponents(module_name_short)
DoEvents
.VBComponents.import modulesVBA_loc & module_name.Value
If the Remove method is failing, there is likely an error occurring, but the On Error Resume Next line is hiding the error. Comment out the On Error... line and see what the error is and handle it rather than ignore it.
I've made use of Cor_blimey's queue method to write all the folders and subfolders of a drive to an excel sheet, as follows:
Public Sub NonRecursiveMethod()
Dim fso, oFolder, oSubfolder, oFile, queue As Collection
Set fso = CreateObject("Scripting.FileSystemObject")
Set queue = New Collection
queue.Add fso.GetFolder("your folder path variable") 'obviously replace
Do While queue.Count > 0
Set oFolder = queue(queue.count)
queue.Remove(queue.count) 'dequeue
'...insert any folder processing code here...'
'*...(Here I write the name of the folder to the excel sheet)*.
For Each oSubfolder In oFolder.SubFolders
queue.Add oSubfolder 'enqueue
Next oSubfolder
For Each oFile In oFolder.Files
'...insert any file processing code here...
Next oFile
Loop
End Sub
I've tried the "LIFO" version (as above) and the "FIFO" version, but neither of them produces a standard alphabetical listing. The above version lists the drive in exact reverse alphabetical order, and the "FIFO" version produces a list in normal alphabetical order, but it lists only the first-level folders, then starts again and lists all the second-level folders, again in alphabetical order, then the third level of folders, again starting over from "A", etc. As a result, the subfolders are not listed under their parent folder.
Does anyone know what I can do to get a standard tree structure, in alphabetical order by folder and subfolder name?
TIA
Les
Update: for some reason I can't manage to show all the comments on this thread or write a new comment. But I wanted to thank everybody, in particular #Rosenfeld, and say that I'm eager to try the solution using dir but am currently swamped with work. I'll report back in a few days when I get a chance to stumble around.
I'd like for the output to the sheet to look like the results of a tree command
Seems to me the simplest would be to just use the Tree command.
Here is one way, but the details could certainly be changed:
Execute a Tree command on the base folder
Write the output to some text file (location and name specified in the code)
Open the file as a text file in Excel
Split into columns on the vertical bar (Unicode character 9474) that the Tree command uses to differentiate levels
I use the WSH.Run method as that allows the CMD window to be easily hidden
One could use the WSH.Exec method to pipe the output directly to a VBA variable, but it is much harder to hide the CMD window (meaning, in another application, I've not been able to) :-)
One could also Import the text file into the same workbook instead of opening a new file. I will leave that exercise to you if you choose to do it.
Option Explicit
'set referennce to Windows Script Host Object Model
Sub DirTree()
Dim sBaseFolder As String, sTempFile As String
Dim WSH As WshShell
Dim sCMD As String
Dim lErrCode As Long
'Many ways to set starting point
sBaseFolder = Environ("HOMEDRIVE") & "\"
sTempFile = Environ("TEMP") & "\Tree.txt"
'Command line
sCMD = "CMD /c tree """ & sBaseFolder & """ > """ & sTempFile & """"
Set WSH = New WshShell
lErrCode = WSH.Run(sCMD, xlHidden, True)
If Not lErrCode = 0 Then
MsgBox "Error in execution: Code - " & lErrCode
Else
'Open the file
Workbooks.OpenText Filename:=sTempFile, Origin:=xlMSDOS, _
StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=False, Tab:=False, Semicolon:=False, Comma:=False _
, Space:=False, Other:=True, OtherChar:=ChrW(&H2502), _
FieldInfo:=Array(Array(1, 1), Array(2, 1))
End If
End Sub
Here is a screenshot of the beginning of the output when run on my C: drive
EDIT: Since you now mention that you want the links to be clickable, an approach using dir would probably be simpler, especially since you can provide arguments to the dir command that will result in full paths being returned.
I used a class module so as to have a User Defined Object, which would have the necessary information; and a dictionary of these objects after appropriate filtering.
I chose to display merely the folder name in the cell, but the the screen tip will show the full path.
Note the References that need to be set (in the code). Also note that the class module must be renamed: cTree
EDIT 2: The Regular and Class modules were edited to allow for optional listing of the files. Note that the macro now has an argument, so it must be called from another macro or from the immediate window, to include the argument. (The argument could also be obtained from an Input box, user form, etc, but I did it this way for now because it is simpler.
I did not add hyperlinks for the files, thinking it would get confusing as different programs and dialogs (other than the file explorer) would be opening depending on the extension.
Class Module
Option Explicit
'Rename Class Module: cTree
Private pFullPath As String
Private pFolderName As String
Private pLevel As Long
Private pFile As String
Private pFiles As Dictionary
Public Property Get FullPath() As String
FullPath = pFullPath
End Property
Public Property Let FullPath(Value As String)
pFullPath = Value
End Property
Public Property Get FolderName() As String
FolderName = pFolderName
End Property
Public Property Let FolderName(Value As String)
pFolderName = Value
End Property
Public Property Get Level() As Long
Level = pLevel
End Property
Public Property Let Level(Value As Long)
pLevel = Value
End Property
Public Property Get Files() As Dictionary
Set Files = pFiles
End Property
Public Function ADDfile(Value As String)
pFiles.Add Value, Value
End Function
Private Sub Class_Initialize()
Set pFiles = New Dictionary
pFiles.CompareMode = TextCompare
End Sub
Regular Module
Option Explicit
'Set reference to Windows Script Host Object Model
' Microsoft Scripting Runtime
Sub GetDirList(bInclFiles As Boolean)
Const sDIRargs As String = " /A-S-L-H /S"
Dim sBaseFolder As String, sTempFile As String
Dim WSH As WshShell
Dim sCMD As String
Dim lErrCode As Long
Dim FSO As FileSystemObject, TS As TextStream
Dim S As String, sFN As String
Dim V As Variant, W As Variant
Dim I As Long
Dim lMaxLevel As Long
Dim lMinLevel As Long
Dim dctTrees As Dictionary, cT As cTree
Dim wsRes As Worksheet
Dim vRes As Variant, rRes As Range
'Add worksheet if needed
On Error Resume Next
Set wsRes = Worksheets("TreeLink")
If Err.Number = 9 Then
Set wsRes = Worksheets.Add
wsRes.Name = "TreeLink"
End If
On Error GoTo 0
Set rRes = wsRes.Cells(1, 1)
'Many ways to set starting point
sBaseFolder = Environ("HOMEDRIVE") & "\"
sTempFile = Environ("TEMP") & "\DirList.txt"
'CommandLine
sCMD = "CMD /c dir """ & sBaseFolder & """" & sDIRargs & " > " & sTempFile
Set WSH = New WshShell
lErrCode = WSH.Run(sCMD, xlHidden, True)
If Not lErrCode = 0 Then
MsgBox "Error in execution: Code - " & lErrCode
Stop
Else
'Read in the relevant data
Set dctTrees = New Dictionary
Set FSO = New FileSystemObject
Set TS = FSO.OpenTextFile(sTempFile, ForReading, False, TristateUseDefault)
lMaxLevel = 0
V = Split(TS.ReadAll, vbCrLf)
For I = 0 To UBound(V)
Do Until V(I) Like " Directory of *"
If I = UBound(V) Then Exit For
I = I + 1
Loop
Set cT = New cTree
S = Mid(V(I), 15)
'Can exclude certain directories at this point
'To exclude all that start with a dot:
If Not S Like "*\.*" Then
With cT
.FullPath = S
.FolderName = Right(S, Len(S) - InStrRev(S, "\"))
.Level = Len(S) - Len(Replace(S, "\", ""))
lMaxLevel = IIf(lMaxLevel > .Level, lMaxLevel, .Level)
dctTrees.Add Key:=S, Item:=cT
I = I + 1
'Only run for file list
If bInclFiles = True Then
Do
sFN = V(I)
If Not sFN Like "*<DIR>*" _
And sFN <> "" Then
'add the files
dctTrees(S).ADDfile Mid(sFN, 40)
End If
I = I + 1
Loop Until V(I) Like "*# File(s)*"
End If
End With
End If 'End of directory exclusion "if" statement
Next I
lMinLevel = dctTrees(dctTrees.Keys(0)).Level
I = 0
With rRes.Resize(columnsize:=lMaxLevel + 1).EntireColumn
.Clear
.HorizontalAlignment = xlLeft
End With
Application.ScreenUpdating = False
For Each V In dctTrees.Keys
Set cT = dctTrees(V)
With cT
I = I + 1
rRes.Worksheet.Hyperlinks.Add _
Anchor:=rRes(I, .Level - lMinLevel + 1), _
Address:="File:///" & .FullPath, _
ScreenTip:=.FullPath, _
TextToDisplay:=.FolderName
For Each W In .Files.Keys
I = I + 1
rRes(I, .Level - lMinLevel + 2) = W
Next W
End With
Next V
Application.ScreenUpdating = True
End If
End Sub
Results without File Listing
Results with File Listing
I know you are using a non-recursion method, but admittedly I wanted to try my hand at using recursion to solve the task (particularly for anyone who may need this in the future).
Note: I am not certain that the Scripting.FileSystem Folders/Files collections are always alphabetical so I am assuming they are in this case, but I could be mistaken.
From brief tests I am not noticing any kind of performance issue with recursion though, depending on the directory size, there certainly could be one.
Finally, the 'CleanOutput' argument in the main Function is used to determine if hierarchy relationships are displayed in the output.
Method Used to Test/Output
Sub Test()
Dim fso As Scripting.FileSystemObject
Set fso = New Scripting.FileSystemObject
Dim Folder As Scripting.Folder
Set Folder = fso.GetFolder("C:")
Dim Test As Variant
Test = GetDirectoryFromScriptingFolder(Folder, True)
ActiveSheet.Range("A1").Resize(UBound(Test, 1), UBound(Test, 2)).value = Test
End Sub
Main Function
Private Function GetDirectoryFromScriptingFolder(ByVal InputFolder As Scripting.Folder, Optional CleanOutput As Boolean = False) As Variant
' Uses recursion to return an organized hierarchy that represents files/folders in the input directory
Dim CurrentRow As Long
CurrentRow = 1
Dim CurrentColumn As Long
CurrentColumn = 1
Dim OutputDirectory As Variant
ReDim OutputDirectory(1 To GetDirectoryLength(InputFolder), 1 To GetDirectoryDepth(InputFolder))
WriteFolderHierarchy InputFolder, OutputDirectory, CurrentRow, CurrentColumn, CleanOutput
' Adjust current column so that files in the parent directory are properly indented
WriteFileHierarchy InputFolder, OutputDirectory, CurrentRow, CurrentColumn + 1, CleanOutput
GetDirectoryFromScriptingFolder = OutputDirectory
End Function
Functions Used in Recursion
Private Sub WriteFolderHierarchy(ByVal InputFolder As Scripting.Folder, ByRef InputHierarchy As Variant, ByRef CurrentRow As Long, ByVal CurrentColumn As Long, ByVal CleanOutput As Boolean)
If Not IsArray(InputHierarchy) Then Exit Sub
InputHierarchy(CurrentRow, CurrentColumn) = InputFolder.Name
CurrentRow = CurrentRow + 1
Dim StartRow As Long
Dim SubFolder As Folder
For Each SubFolder In InputFolder.SubFolders
' Use recursion to write the files/folders of each subfolder to the directory
StartRow = CurrentRow
WriteFolderHierarchy SubFolder, InputHierarchy, CurrentRow, CurrentColumn + 1, CleanOutput
WriteFileHierarchy SubFolder, InputHierarchy, CurrentRow, CurrentColumn + 2, CleanOutput
If CleanOutput Then
For StartRow = StartRow To CurrentRow
InputHierarchy(StartRow, CurrentColumn) = "||"
Next
End If
Next
End Sub
Private Sub WriteFileHierarchy(ByVal InputFolder As Scripting.Folder, ByRef InputHierarchy As Variant, ByRef CurrentRow As Long, ByVal CurrentColumn As Long, ByVal CleanOutput As Boolean)
If Not IsArray(InputHierarchy) Then Exit Sub
Dim SubFile As File
For Each SubFile In InputFolder.Files
' Write the Files to the Hierarchy
InputHierarchy(CurrentRow, CurrentColumn) = SubFile.Name
If CleanOutput Then InputHierarchy(CurrentRow, CurrentColumn - 1) = "--"
CurrentRow = CurrentRow + 1
Next
End Sub
Helper Functions (Depth and Length)
Private Function GetDirectoryLength(ByVal InputFolder As Scripting.Folder) As Long
Dim TotalLength As Long
' Include a base of 1 to account for the input folder
TotalLength = 1 + InputFolder.Files.Count
Dim SubFolder As Scripting.Folder
For Each SubFolder In InputFolder.SubFolders
' Add 1 to the total to account for the subfolder.
TotalLength = TotalLength + GetDirectoryLength(SubFolder)
Next
GetDirectoryLength = TotalLength
End Function
Private Function GetDirectoryDepth(ByVal InputFolder As Scripting.Folder) As Long
Dim TotalDepth As Long
Dim SubFolder As Scripting.Folder
Dim MaxDepth As Long
Dim NewDepth As Long
For Each SubFolder In InputFolder.SubFolders
NewDepth = GetDirectoryDepth(SubFolder)
If NewDepth > MaxDepth Then
MaxDepth = NewDepth
End If
Next
If MaxDepth = 0 Then MaxDepth = 1
' Add 1 for the Parent Directory
GetDirectoryDepth = MaxDepth + 2
End Function
What is essentially happening is this:
We take an input Folder and determine the dimensions of the hierarchy
for that file
Next, we define an output array using those dimensions.
Using a row counter and column counter, we allow the recursion functions to write their recursive results directly to the hierarchy
This hierarchy is returned, and the main routine puts this straight to the sheet
Next Steps that You Could Take
I noticed a few things doing this
There is no information other than the file name, which, depending on
the application, may make the method useless
All files are included
in the output, not just important ones (non-important files being
temp, hidden, etc.)
Even with the CleanOutput option there isn't an easy way of diagramming the relationships between parents and children.
Overall though this should suffice, depending on your needs. You can make adjustments as needed. If you have questions, just ask :).
I don't think LIFO or FIFO matters, just take a look at this idea.
Sub GetFilesInFolder(SourceFolderName As String)
'--- For Example:Folder Name= "D:\Folder Name\"
Dim FSO As Scripting.FileSystemObject
Dim SourceFolder As Scripting.folder, SubFolder As Scripting.folder
Dim FileItem As Scripting.File
Set FSO = New Scripting.FileSystemObject
Set SourceFolder = FSO.GetFolder(SourceFolderName)
'--- This is for displaying, whereever you want can be configured
r = 14
For Each FileItem In SourceFolder.Files
Cells(r, 2).Formula = r - 13
Cells(r, 3).Formula = FileItem.Name
Cells(r, 4).Formula = FileItem.Path
Cells(r, 5).Formula = FileItem.Size
Cells(r, 6).Formula = FileItem.Type
Cells(r, 7).Formula = FileItem.DateLastModified
Cells(r, 8).Formula = "=HYPERLINK(""" & FileItem.Path & """,""" & "Click Here to Open" & """)"
r = r + 1 ' next row number
Next FileItem
Set FileItem = Nothing
Set SourceFolder = Nothing
Set FSO = Nothing
End Sub
ii) User wants to get the list of all files inside a folder as well as Sub-folders
Copy and Paste the below Code and this will list down the list of all the files inside the folder as well as sub-folders. If there are other files which are there in some other Sub-folders then it will list down all files from each and Every Folders and Sub-folders.
Sub GetFilesInFolder(SourceFolderName As String, Subfolders As Boolean)
'--- For Example:Folder Name= "D:\Folder Name\" and Flag as Yes or No
Dim FSO As Scripting.FileSystemObject
Dim SourceFolder As Scripting.folder, SubFolder As Scripting.folder
Dim FileItem As Scripting.File
'Dim r As Long
Set FSO = New Scripting.FileSystemObject
Set SourceFolder = FSO.GetFolder(SourceFolderName)
'--- This is for displaying, whereever you want can be configured
r = 14
For Each FileItem In SourceFolder.Files
Cells(r, 2).Formula = r - 13
Cells(r, 3).Formula = FileItem.Name
Cells(r, 4).Formula = FileItem.Path
Cells(r, 5).Formula = FileItem.Size
Cells(r, 6).Formula = FileItem.Type
Cells(r, 7).Formula = FileItem.DateLastModified
Cells(r, 8).Formula = "=HYPERLINK(""" & FileItem.Path & """,""" & "Click Here to Open" & """)"
r = r + 1 ' next row number
Next FileItem
'--- This is the Function to go each and Every Folder and get the Files. This is a Nested-Function Calling.
If Subfolders = True Then
For Each SubFolder In SourceFolder.Subfolders
ListFilesInFolder SubFolder.Path, True
Next SubFolder
End If
Set FileItem = Nothing
Set SourceFolder = Nothing
Set FSO = Nothing
End Sub
File Manager using Excel Macro in Excel Workbook
I have created one File Manager using the above Code. It basically fetches the list of Files from Folders and Sub-folders and list them. It fetches other details of the files as well like File Size, Last modified, path of the File, Type of the File and a hyperlink to open the file directly from the excel by clicking on that.
It looks something like below:
Here is the link to download the full Workbook.
http://learnexcelmacro.com/wp/2011/11/how-to-get-list-of-all-files-in-a-folder-and-sub-folders/
Click on the button that is named 'Download Now'.
I need to extract all emails with standard outlook fields (from/to/subject/date, including category and most importantly, ConversationID) into Excel/csv.
I'm using MS Office 2016, no idea about version of Exchange server.
I tried several ways to do so on my mailbox:
1) exported data through standard outlook interface
2) exported data into MS access via standard export master
3) extracted data to MS PowerBI from MS Exchange directly
In all 3 cases I wasn't able to get ConversationID (PowerBI extract had some ID but it was not ConversationID)
Now I understand that it should be extracted through MAPI somehow, but I'm totally illiterate on this topic. Some searches advised to use special software for that, like Transcend, but it's obviously too expensive for one user :)
I also found VBA code to get data into Excel directly but it is not working for me:
http://www.tek-tips.com/viewthread.cfm?qid=1739523
Also found this nice explanation what is ConversationID - might be helpful for others intrested in topic:
https://www.meridiandiscovery.com/how-to/e-mail-conversation-index-metadata-computer-forensics/
Here is some sample code to get you started, I already had something similar to your ask. The code is commented, but feel free to ask questions :)
Option Explicit
Public Sub getEmails()
On Error GoTo errhand:
'Create outlook objects and select a folder
Dim outlook As Object: Set outlook = CreateObject("Outlook.Application")
Dim ns As Object: Set ns = outlook.GetNameSpace("MAPI")
'This option open a new window for you to select which folder you want to work with
Dim olFolder As Object: Set olFolder = ns.pickFolder
Dim emailCount As Long: emailCount = olFolder.Items.Count
Dim i As Long
Dim myArray As Variant
Dim item As Object
ReDim myArray(4, (emailCount - 1))
For i = 1 To emailCount
Set item = olFolder.Items(i)
'43 is olMailItem, only consider this type of email message
'I'm assuming you only want items with a conversationID
'Change the logic here to suite your specific needs
If item.Class = 43 And item.ConversationID <> vbNullString Then
'Using an array to write to excel in one go
myArray(0, i - 1) = item.Subject
myArray(1, i - 1) = item.SenderName
myArray(2, i - 1) = item.To
myArray(3, i - 1) = item.CreationTime
myArray(4, i - 1) = item.ConversationID
End If
Next
'Adding headers, then writing the data to excel
With ActiveSheet
.Range("A1") = "Subject"
.Range("B1") = "From"
.Range("C1") = "To"
.Range("D1") = "Created"
.Range("E1") = "ConversationID"
.Range("A2:E" & (emailCount + 1)).Value = TransposeArray(myArray)
End With
Exit Sub
errhand:
Debug.Print Err.Number, Err.Description
End Sub
'This function is used to bypass the limitation of -
'application.worksheetfunction.transpose
'If you have too much data added to an array you'll get a type mismatch
'Found here - http://bettersolutions.com/vba/arrays/transposing.htm
Public Function TransposeArray(myArray As Variant) As Variant
Dim X As Long
Dim Y As Long
Dim Xupper As Long: Xupper = UBound(myArray, 2)
Dim Yupper As Long: Yupper = UBound(myArray, 1)
Dim tempArray As Variant
ReDim tempArray(Xupper, Yupper)
For X = 0 To Xupper
For Y = 0 To Yupper
tempArray(X, Y) = myArray(Y, X)
Next
Next
TransposeArray = tempArray
End Function
I have a VBA Macro to search through email archives.
When searching through tens of thousands of emails, (or even just a couple hundred on my test machine) it displays the status for a few seconds, then enters a Not Responding state while running through the rest of the emails.
This has led impatient users to close out of the task prematurely, and I would like to rectify this by providing status updates.
I have coded the following solution, and believe that the problem lies in the way the GarbageCollector functions in VBA during the Loop.
Public Sub searchAndMove()
UserForm1.Show
' Send a message to the user indicating
' the program has completed successfully,
' and displaying the number of messages sent during the run.
End Sub
Private Sub UserForm_Activate()
Me.Width = 240
Me.Height = 60
Me.Label1.Width = 230
Me.Label1.Height = 50
Dim oSelectTarget As Outlook.Folder
Dim oMoveTarget As Outlook.Folder
Dim oSearchCriteria As String
' Select the target folder to search and then the folder to
' which the files should be moved
Set oSelectTarget = Application.Session.PickFolder
Set oMoveTarget = Application.Session.PickFolder
oSearchCriteria = InputBox("Input search string: ")
Dim selectedItems As Outlook.Items
Set selectedItems = oSelectTarget.Items
Dim selectedEmail As Outlook.MailItem
Dim StatusBarMsg As String
StatusBarMsg = ""
Dim initialCount As Long
initialCount = selectedItems.count
Dim movedCounter As Long
movedCounter = 0
Dim x As Long
Dim exists As Long
' Function Loop, stepping backwards
' to prevent errors derived from modifying the collection
For x = selectedItems.count To 1 Step -1
Set selectedEmail = selectedItems.Item(x)
' Test to determine if the subject contains the search string
exists = InStr(selectedEmail.Subject, oSearchCriteria)
If Len(selectedEmail.Subject) > 999 Then
selectedEmail.Move oMoveTarget
Else:
If exists <> 0 Then
selectedEmail.Move oMoveTarget
movedCounter = (movedCounter + 1)
Else: End If
End If
Set selectedEmail = Nothing
StatusBarMsg = "Processing " & x & " out of " & initialCount & " messages."
UserForm1.Label1.Caption = StatusBarMsg
UserForm1.Repaint
Next x
Dim Msg As String
Dim Response
Msg = "SearchAndMove has detected and moved " & movedCounter & _
" messages since last run."
Response = MsgBox(Msg, vbOKOnly)
' Close the References to prevent a reference leak
Set oSelectTarget = Nothing
Set oMoveTarget = Nothing
Set selectedItems = Nothing
Set selectedEmail = Nothing
Unload Me
End Sub
Change the line
UserForm1.Repaint
to
DoEvents
Yes this will increase the execution time but in case there are thousands of emails then you don't have much of an option.
TIP:
Also you might want to change
StatusBarMsg = "Processing " & x & " out of " & initialCount & " messages."
to
StatusBarMsg = "Please do not interrupt. Processing " & x & " out of " & initialCount & " messages."
Also it is advisable to inform your user at the beginning of the process that it might take time and hence they can run the process when they are sure they do not want to work on that pc?
Something like this
Sub Sample()
Dim strWarning As String
Dim Ret
strWarning = "This process may take sometime. It is advisable to run this " & _
"when you don't intend to use the pc for sometime. Would you like to Continue?"
Ret = MsgBox(strWarning, vbYesNo, "Information")
If Ret <> vbYes Then Exit Sub
For x = SelectedItems.Count To 1 Step -1
'~~> Rest of the code
End Sub
HTH
Sid