I am trying to find an email, by subject starting with specific text, to then download an attachment from that email.
I am using a variable with Restrict function, however issue seems to be because of usage of wildcards.
Sub findemail()
cntofmkts = Range("A" & Rows.Count).End(xlUp).Row
cntofmkts = cntofmkts - 1
ftodaydate = Format(Date, "yyyy-mm-dd")
Do
If i > cntofmkts Then Exit Do
MarketName = Range("A" & j).Value
Findvariable = "XXX_" & MarketName & "_ABC_" & ftodaydate
For Each oOlItm In oOlInb.Items.Restrict("[Subject] = *Findvariable*")
eSender = oOlItm.SenderEmailAddress
dtRecvd = oOlItm.ReceivedTime
dtSent = oOlItm.CreationTime
sSubj = oOlItm.Subject
sMsg = oOlItm.Body
If oOlItm.Attachments.Count <> 0 Then
For Each oOlAtch In oOlItm.Attachments
'~~> Download the attachment
oOlAtch.SaveAsFile NewFileName & oOlAtch.Filename
Exit For
Next
Else
MsgBox "The First item doesn't have an attachment"
End If
Exit For
Next
i = i + 1
j = j + 1
Loop
End sub
The first thing you should mind is that the Restrict() method does not evaluate the variable by it's name. You will have to concatenate the variable to the string.
Another one is, if you look at the example from MSDN site, you will see that there is not support for wildcards, so you will have to use the SQL syntax and the searched text in the filter expression must be between quotes.
' this namespace is for Subject
filterStr = "#SQL=""http://schemas.microsoft.com/mapi/proptag/0x0037001f"" like '%" & Findvariable & "%'"
It seems that urn:schemas:httpmail:subject also works and is easier to understand, but I can't confirm this now:
filterStr = "#SQL=""urn:schemas:httpmail:subject"" like '%" & Findvariable & "%'"
The string comparison that DASL filters support includes equivalence, prefix, phrase, and substring matching.
For Each oOlItm In oOlInb.Items.Restrict("[Subject] = Findvariable")
It looks like you are searching for the exact match. But what you need is to find a substring using the following syntax:
criteria = "#SQL=" & Chr(34) & "urn:schemas:httpmail:subject" & Chr(34) & " like '%question%'"
Note that when you filter on the Subject property, prefixes such as "RE: " and "FW: " are ignored.
See Filtering Items Using a String Comparison for more information.
P.S. The Restrict method is an alternative to using the Find method or FindNext method to iterate over specific items within a collection. The Find or FindNext methods are faster than filtering if there are a small number of items. The Restrict method is significantly faster if there is a large number of items in the collection, especially if only a few items in a large collection are expected to be found.
Related
What is the most efficient way to traverse Outlook.Folders in Excel VBA? I'm somewhat new to Excel VBA and am presently using recursion to traverse folders.
The below code works but is there anything better than what I coded?
Private Function RecursiveEmailItems( _
Optional SubjectContains As String = Empty, _
Optional FolderType As OlDefaultFolders = olFolderInbox, _
Optional StartFolderNm As String = "", _
Optional Folder As Outlook.Folder = Nothing, _
Optional FolderDepth As Long = 1)
Dim Filter As String ' Stores outlook filter
Dim Emails As Outlook.Items ' Stores list of outlook emails
Dim Email As Outlook.MailItem ' Stores an email item
Dim oTest As Object ' Used to test email/folder item
If SubjectContains <> "" Then Filter = "#SQL=urn:schemas:httpmail:subject ci_phrasematch '" _
& SubjectContains & "'"
'-- Check to see if need to initialize folder - First Run --
If Folder Is Nothing Then
If StartFolderNm = "" Then Set Folder = _
Outlook.Application.GetNamespace("MAPI").GetDefaultFolder(FolderType) _
Else Set Folder = _
Outlook.Application.GetNamespace("MAPI").GetDefaultFolder(FolderType).Folders(StartFolderNm)
End If
'-- Get emails from the folder, use filter if not empty
If Filter = "" Then Set Emails = Folder.Items Else Set Emails = Folder.Items.Restrict(Filter)
'-- Process all emails found --
If Emails.Count > 0 Then Debug.Print Indent(FolderDepth, " ") & "-" & Folder.Name
For Each oTest In Emails
If TypeName(oTest) = "MailItem" Then
Set Email = oTest
Debug.Print Indent(FolderDepth, " ") & " |" & Email.Subject
End If
Next oTest
'-- Process all subfolders --
For Each oTest In Folder.Folders
If TypeName(oTest) = "MAPIFolder" Then
Call RecursiveEmailItems(SubjectContains, FolderType, StartFolderNm, oTest, FolderDepth + 1)
End If
Next oTest
End Function
Private Function GetEmailStatus()
'Dim Filter As String: Initialize: Filter = "Timesheet " & Format(EndDt, "mm/dd/yy")
Dim Filter As String: Initialize: Filter = "Timesheet 06"
Call RecursiveEmailItems("Timesheet 06/", olFolderInbox, "Timesheet")
End Function
Private Function Indent(Count As Long, Char As String) As String
Dim idx As Long
For idx = 1 To Count
Indent = Indent + Char
Next
End Function
Thanks in advance for any help!
Running the Restrict method for each folder is not really a good idea. Instead, you may consider using the AdvancedSearch method of the Application class. The key benefits of using the AdvancedSearch method in Outlook are:
The search is performed in another thread. You don’t need to run another thread manually since the AdvancedSearch method runs it automatically in the background.
Possibility to search for any item types: mail, appointment, calendar, notes etc. in any location, i.e. beyond the scope of a certain folder. The Restrict and Find/FindNext methods can be applied to a particular Items collection (see the Items property of the Folder class in Outlook).
Full support for DASL queries (custom properties can be used for searching too). You can read more about this in the Filtering article in MSDN. To improve the search performance, Instant Search keywords can be used if Instant Search is enabled for the store (see the IsInstantSearchEnabled property of the Store class).
You can stop the search process at any moment using the Stop method of the Search class.
Read more about this method in the Advanced search in Outlook programmatically: C#, VB.NET article.
Public m_SearchComplete As Boolean
Private Sub Application_AdvancedSearchComplete(ByVal SearchObject As Search)
If SearchObject.Tag = "MySearch" Then
m_SearchComplete = True
End If
End Sub
Sub TestSearchForMultipleFolders()
Dim Scope As String
Dim Filter As String
Dim MySearch As Outlook.Search
Dim MyTable As Outlook.Table
Dim nextRow As Outlook.Row
m_SearchComplete = False
'Establish scope for multiple folders
Scope = "'" & Application.Session.GetDefaultFolder( _
olFolderInbox).FolderPath _
& "','" & Application.Session.GetDefaultFolder( _
olFolderSentMail).FolderPath & "'"
'Establish filter
If Application.Session.DefaultStore.IsInstantSearchEnabled Then
Filter = Chr(34) & "urn:schemas:httpmail:subject" _
& Chr(34) & " ci_phrasematch 'Office'"
Else
Filter = Chr(34) & "urn:schemas:httpmail:subject" _
& Chr(34) & " like '%Office%'"
End If
Set MySearch = Application.AdvancedSearch( _
Scope, Filter, True, "MySearch")
While m_SearchComplete <> True
DoEvents
Wend
Set MyTable = MySearch.GetTable
Do Until MyTable.EndOfTable
Set nextRow = MyTable.GetNextRow()
Debug.Print nextRow("Subject")
Loop
End Sub
To specify multiple folders for the Scope parameter, use a comma character between each folder path and enclose each folder path in single quotes. For default folders such as Inbox or Sent Items, you can use the simple folder name instead of the full folder path.
That looks fine to me. Is there a particular area you want to improve?
The only line I would remove is the If TypeName(oTest) = "MAPIFolder" Then line. All folders in OOM are MAPIFolder, so the check is superfluous, but it won't do much performance wise either way.
I have a column whose cells have comments via CommentsThreaded and CommentThreaded objects. In another column, I successfully copy the contents of these threads using the function =GetComments(A1), as shown below:
' Returns the concatenated string of parent and child comments for the specified input cell.
Function GetComments(SelectedCell As Range) As String
Set CellComment = SelectedCell.CommentThreaded
Dim Result As String
If Not CellComment Is Nothing Then
Result = CellComment.Author.Name & ": """ & CellComment.Text & """ " & vbNewLine & vbNewLine
Dim ChildCount As Integer
ChildCount = 1
For Each ChildComment In CellComment.Replies
Result = Result & "[Reply #" & ChildCount & "] " & ChildComment.Author.Name & ": """ & ChildComment.Text & """ " & vbNewLine & vbNewLine
ChildCount = ChildCount + 1
Next
Else
Result = "No Comments"
End If
GetComments = Result
End Function
Example output would be: John Doe: "My comment"
However, I've noticed that when a comment is added/edited/deleted, the output cell that uses the GetComments function is not updated. I have to manually re-run the function in the output cell to get its contents to update by selecting it and pressing Enter.
I've tried using all of the typical event handlers, such as Worksheet.Change, SelectionChange, etc. None of the events fire when a comment is modified. Neither does manually forcing Volatile or Calculate. It's almost like the Add/Delete/Edit methods of CommentsThreaded are not included in workbook events at all.
Is this possible? Thanks!
I have some work to complete where I have 9 tabs of data (some of which contain thousands of lines of data). Each tab contains (amongst others) a policy number, a credit and/or a debit number.
Every policy number will have a match somewhere in the tabs containing an equal credit or debit, e.g.
tab 1 will have Policy number 123 and a credit of £100 and
tab 5 will also have policy number 123 with a debit of £100.
What I'm looking to do is, look through each policy number on every tab and find where the opposite amount is located adding the location address to each policy number.
I'm certainly not looking for anyone to create the coding for me, but what I am looking for is advice. I've looked at using loops but feel this may take a very long time to process. I've also looked at Dictionaries but am relatively new to these so am not very confident.
Is what I'm looking for even possible? And if so any ideas where to start or pointers? Any advice is greatly appreciated. Thanks!
Usage Example
#Matt555, You can test the created XML file with the following code to get the sheet names of policy "123" and debit of 100. I tested the code assuming your titles in row A:A contain "policy" and "debit"
#Peh, You are right, xml dom methods aren't used too often within vba. The advantage of using XML in this connex is a great flexibility in searching via XPath as well as performance over huge files. I prefer it even to arrays or dictionaries when filtering unique values. It is possible to return the found item number in node lists without looping through the whole data set ...
Option Explicit
Sub testPolicy()
Dim policy
Dim debit As Double
policy = "123"
debit = "100"
MsgBox "Policy " & policy & " found in " & vbNewLine & _
findSheetName(policy, debit), vbInformation, "Policy " & policy & " in Tabs"
' You can easily split this to an array and analyze the results
End Sub
Function findSheetName(ByVal policy, Optional ByVal debit) As String
' Purpose: Finds Sheet Names where policy AND/OR debit is found
' Note: Assuming your titles in row A:A contain "policy" and "debit"
' You can declare xDoc also after Option Explicit to make it public
Dim xDoc As Object
Dim xNd As Object ' MSXML.IXMDOMNode
Dim xNdList As Object ' MSXML.IXMLDOMNodeList
Dim s As String
' XPath expression
Dim xPth As String
If IsMissing(debit) Then
xPth = "//row[policy=""" & policy & """]"
Else
xPth = "//row[policy=""" & policy & """][debit=""" & debit & """]"
End If
' XML to memory
Set xDoc = CreateObject("MSXML2.Domdocument.6.0")
' allow XPath
xDoc.setProperty "SelectionLanguage", "XPath"
xDoc.validateOnParse = False
' ========
' LOAD XML
' ========
xDoc.Load ThisWorkbook.Path & "\" & "output.xml"
' Loop thru NodeList
Set xNdList = xDoc.DocumentElement.SelectNodes(xPth)
Debug.Print xPth, xNdList.Length
For Each xNd In xNdList
s = s & xNd.ParentNode.NodeName & "|"
Next xNd
Set xDoc = Nothing
findSheetName = s
End Function
You could
a) create an XML file looping through all sheets,
b) open it via load method and
c) perform a simple XPath search (I can give some examples later)
I modified a recent answer (cf. excel-vba-xml-parsing-performance)
to do step "a)" using late binding thus
a) avoiding a reference to the latest MS XML Version Version 6 (msxml6.dll) and
b) getting data over all xheets. XML allows you structured search via XPath over nodes in a logical structure comparable to HTML. The root node in this example is called data, the following nodes are named with the sheets' names and the subsequent nodes get the names in row A:A of each sheet.
A XML file is a simple text file, which you can open by a text editor. Above all you can use VBA XMLDOM methods to analyze or search through the items (nodes). I will give you examples to relating to your question, but give me some time. => see answer "Usage Example", where I explain some Advantages of XML, too (#Peh).
Please pay Attention to the added notes, too.
Option Explicit
Sub xmlExportSheets()
' Zweck: XML Export over all sheets in workbook
' cf. Site: [excel-vba-xml-parsing-performance][1][https://stackoverflow.com/questions/40986395/excel-vba-xml-parsing-performance/40987237#40987237][1]
' Note: pretty printed raw output with line breaks and indentation using an embedded XSLT stylesheet
On Error GoTo ErrHandle
' A. Declarations
' 1 DECLARE XML DOC OBJECT '
' a) Early Binding: VBA REFERENCE MSXML, v6.0 necessary'
' Dim doc As New MSXML2.DOMDocument60, xslDoc As New MSXML2.DOMDocument60, newDoc As New MSXML2.DOMDocument60
' Dim root As IXMLDOMElement, dataNode As IXMLDOMElement, datesNode As IXMLDOMElement, namesNode As IXMLDOMElement
' b) Late Binding XML Files:
Dim doc As Object
Dim xslDoc As Object
Dim newDoc As Object
' c) Late Binding XML Nodes:
Dim root As Object
Dim sh As Object ' xml node containing Sheet Name
Dim dataNode As Object
Dim datesNode As Object
Dim namesnode As Object
' 2 DECLARE other variables
Dim i As Long
Dim j As Long
Dim tmpValue As Variant
Dim tit As String
Dim ws As Worksheet
' B. XML Docs to Memory
Set doc = CreateObject("MSXML2.Domdocument.6.0")
Set xslDoc = CreateObject("MSXML2.Domdocument.6.0")
Set newDoc = CreateObject("MSXML2.Domdocument.6.0")
' C. Set DocumentElement (= root node)'
Set root = doc.createElement("data")
' D. Create Root Node
doc.appendChild root
' ===========================
' ITERATE THROUGH Sheets
' ===========================
For Each ws In ThisWorkbook.Sheets
Set sh = doc.createElement(ws.Name) '
root.appendChild sh
' ===========================
' ITERATE THROUGH ROWS ' A2:NNn
' ===========================
For i = 2 To ws.UsedRange.Rows.Count ' Sheets(1)
' DATA ROW NODE '
Set dataNode = doc.createElement("row") '
sh.appendChild dataNode
' TABLES NODE (orig.: DATES NODE) '
Set datesNode = doc.createElement(ws.Cells(1, 1)) ' Dates
datesNode.Text = ws.Range("A" & i)
dataNode.appendChild datesNode
' NAMES NODE '
For j = 1 To ws.UsedRange.Columns.Count - 1 ' = 12
tit = ws.Cells(1, j + 1)
tmpValue = ws.Cells(i, j + 1)
Set namesnode = doc.createElement(tit)
namesnode.Text = tmpValue
dataNode.appendChild namesnode
Next j
Next i
Next ws
' =============================
' PRETTY PRINT RAW OUTPUT (XSL)
' =============================
xslDoc.LoadXML "<?xml version=" & Chr(34) & "1.0" & Chr(34) & "?>" _
& "<xsl:stylesheet version=" & Chr(34) & "1.0" & Chr(34) _
& " xmlns:xsl=" & Chr(34) & "http://www.w3.org/1999/XSL/Transform" & Chr(34) & ">" _
& "<xsl:strip-space elements=" & Chr(34) & "*" & Chr(34) & " />" _
& "<xsl:output method=" & Chr(34) & "xml" & Chr(34) & " indent=" & Chr(34) & "yes" & Chr(34) & "" _
& " encoding=" & Chr(34) & "UTF-8" & Chr(34) & "/>" _
& " <xsl:template match=" & Chr(34) & "node() | #*" & Chr(34) & ">" _
& " <xsl:copy>" _
& " <xsl:apply-templates select=" & Chr(34) & "node() | #*" & Chr(34) & " />" _
& " </xsl:copy>" _
& " </xsl:template>" _
& "</xsl:stylesheet>"
' XSLT (Transformation)
xslDoc.async = False
doc.transformNodeToObject xslDoc, newDoc
' =================
' Save the XML File
' =================
newDoc.Save ThisWorkbook.Path & "\Output.xml"
MsgBox "Successfully exported Excel data to " & ThisWorkbook.Path & "\Output.XML!", vbInformation
' Regular End of procedure
Exit Sub
ErrHandle:
MsgBox Err.Number & " - " & Err.Description, vbCritical
Exit Sub
End Sub
Note
Sheet names have to be without spaces
Added Note (important hint):
XML Nodes use titles in first row of every sheet. As the modified procedure gets title names via UsedRange it's important not to have any empty cells in row A:A for this example.
Additional remark
I don't know the reason why my prompt answer (marked as "a") was downgraded by someone. I would find it helpful to argue this :-)
I am using dictionaries in Excel VBA via dict As New Dictionary (and adding a reference to the scripting runtime). When I try to monitor those during debugging, I can only see the keys which lie in the dictionary, but not the respective value of each key.
Is there any way to see the value as well? It would make debugging much more easy for me.
EDIT: Based on your answers, there is no easy solution, but I can do the following.
Use a global variable Dim d_obj As Object and monitor it constantly and whenever I need to look up a value of a dictionary, I type into the immediate window Set d_obj(key) = ... and I will be able to see the value in the monitor-window.
What I may do in addition is write a function which takes in a dictionary and returns the values as a list and use this function similarly at the direct window. Thx to all!
I usually type dict.items into the immediate window, select it and go Shift+F9 to insert it into the watch window.
Alternatively, here's a one-liner for the immediate window, to list all items:
for each i in dic.Items: debug.Print i: next
I use a recursive function which can be used to display all simple type variables and the contents of all nested dictionaries in the watch window. This produces output in the form:
Fred:rabbit; Tiddles:cat; Fluffy:cat; Food:[1:lettuce; 2:biscuits; ];
where keys and values are separated by ":", items are separated by "; " and nested dictionaries are shown in square brackets.
Public Function DictionaryContents(ByVal dcDictionary, Optional ByVal boolShowKeyIndex As Boolean = False)
Dim Keys
Keys = dcDictionary.Keys
Dim i As Long
Dim stIndex As String
Dim stOutput As String
stOutput = vbNullString
For i = 0 To dcDictionary.Count - 1
If boolShowKeyIndex Then
stIndex = "(" & i & ")"
End If
stOutput = stOutput & Keys(i) & stIndex & ":"
If IsObject(dcDictionary(Keys(i))) Then
stOutput = stOutput & "[" & DictionaryContents(dcDictionary(Keys(i)), boolShowKeyIndex) & "]"
Else
stOutput = stOutput & dcDictionary(Keys(i))
End If
stOutput = stOutput & "; "
Next i
DictionaryContents = stOutput
End Function
We're managing some system bugs in a web system and setting priority for execs in a spreadsheet.
Each of the tickets has a "FD-" and four numbers as the ID.
The web system has a hyperlink that has that "FD-####" at the end of the link.
The end result would look like this -- http://www.mytickets.com/FD-####
I'd like to run a macro that finds all the FD-#### and inserts a hyperlink on each.
There may be multiple FD-#### in a single cell and there will certainly be other text in there.
I'd go through each and add the link but there are over 150 or so.
Thanks!
As mentioned in a comment, Excel doesn't seem to support multiple hyperlinks in a cell.
The code below will do the replacement from ticket to link:
Option Explicit
Sub loop_over_cells()
Dim a_cell
Dim replaced As String
For Each a_cell In ActiveSheet.UsedRange
Debug.Print "old value " & a_cell.Value
replaced = RegexReplace(a_cell.Value, "(fd-\d{4}\b)", "=hyperlink(" & Chr(34) & "http://cnn.com/$1" & Chr(34) & ")")
a_cell.Value = replaced
Debug.Print "new value " & a_cell.Value
Next
End Sub
Function RegexReplace(search_string, ptrn, rplc)
Dim regEx
Set regEx = CreateObject("VBScript.RegExp")
regEx.Pattern = ptrn
regEx.IgnoreCase = True
regEx.Global = True
RegexReplace = regEx.replace(search_string, rplc)
End Function