I have some undeliverable emails in a folder. I am trying to go through each email in the folder and pull out the intended recipients email address by searching the message.
I have some VBA code that works on regular emails, but since undeliverable's aren't Outlook "Mail Items", they are Outlook "Report Items", I am having issues searching the message. The search function is coming back empty and after a lot of research, it seems that maybe "Report Items" do not actually have a "body" that can be searched.
The email in all the error reports are in the following format in the report.
(xxxxxx#xxxxxx.com)
Here is the code I am using, which works on normal Mail Items.
Sub Undeliver()
On Error Resume Next
Set myOlApp = Outlook.Application
Set mynamespace = myOlApp.GetNamespace("MAPI")
'Selects the current active folder to use
Set myfolder = myOlApp.ActiveExplorer.CurrentFolder
'creates excel spreadsheet where data will go
Set xlobj = CreateObject("excel.application")
xlobj.Visible = True
xlobj.Workbooks.Add
'names column a row 1 "email" and column b row 1 "else"
xlobj.Range("a" & 1).Value = "Email"
xlobj.Range("b" & 1).Value = "Else"
'loops through all the items in the current folder selected
For I = 1 To myfolder.Items.Count
Set myitem = myfolder.Items(I)
'selects the body of the current email being searched
msgtext = myitem.Body
'searches the body for the first open parentheses and first close
'parentheses and copies the value in between into an array
delimtedMessage = Replace(msgtext, "(", "###")
delimtedMessage = Replace(delimtedMessage, ")", "###")
'splits the array up into two pieces
messageArray = Split(delimitedMessage, "###")
'this inputs the values of the array into my excel spreadsheet
xlobj.Range("a" & I + 1).Value = messageArray(1)
xlobj.Range("b" & I + 1).Value = messageArray(2)
Next I
End Sub
Does anyone know how I can access the message part of the report for searching purposes?
The solution I ended up going with involved converting the body of the message back to Unicode and then searching for what I needed. This ended up being very simple to implement.
Here is my finished, working code for future reference. I ended up adding a progress bar to monitor where it was in the code. It unfortunately runs fairly slow but it gets the job done.
Hopefully this helps someone in the future!
On Error Resume Next
Set myOlApp = Outlook.Application
Set mynamespace = myOlApp.GetNamespace("MAPI")
Set xlobj = CreateObject("excel.application")
xlobj.Visible = True
xlobj.Workbooks.Add
xlobj.Range("a" & 1).Value = "Email"
xlobj.Application.displayStatusBar = True
For I = 1 To myOlApp.ActiveExplorer.CurrentFolder.Items.Count
Set myitem = myOlApp.ActiveExplorer.CurrentFolder.Items(I)
msgtext = StrConv(myitem.Body, vbUnicode)
delimtedMessage = Replace(msgtext, "mailto:", "###")
delimtedMessage = Replace(delimtedMessage, "</a><br>", "###")
messageArray = Split(delimtedMessage, "###")
xlobj.Range("a" & I + 1).Value = Split(messageArray(1), """")(0)
xlobj.Application.StatusBar = "Progress: " & I & " of " & myOlApp.ActiveExplorer.CurrentFolder.Items.Count & Format(I / myOlApp.ActiveExplorer.CurrentFolder.Items.Count, " 0%")
Next I
xlobj.Application.displayStatusBar = False
Well, there is always this solution.
The gist is that ReportItem.Body returns an unreadable string, so this solution saves the ReportItem as a text file, then parses the text file. Its not exactly elegant, but it should work.
Hope this helps!
Related
I have a workbook that is essentially an automated test, marking and feedback tool for end of topic tests for students. On the '701Test' sheetThey input their teaching group via a drop down list and the select their from subsequent list. They answer the multiple choice questions and press a button when finished. The button takes them to a 'results' page which gives their marks for each question, give feedback for incorrect answers and gives a total score. They then hit the finish button which generates a PDF copy of the mark sheet in their my documents folder and then emails a copy to themselves and the Schools email account. At this point I also wanted to post the final score to the students record on a central registry using a loop through the student list to find the name and offset to post the Score value from the 'Results' page and finally return to the test page. This last bit I wrote the code for in a module and it executes perfectly, but when added to the main code and run from the button the loop part fails to execute but the return to the test page does work, but no error is recorded for the loop failure.
Here is the 'Results' page code in full the 'With Central reg' bit at the bottom is the problem, any help is greatly appreciated.
Private Sub CommandButton1_Click()
Dim IsCreated As Boolean
Dim PdfFile As String, Title As String
Dim OutlApp As Object
Dim cell As Range
Dim Students As Range
Title = Range("D1").Value
sname = Range("B2").Value
PdfFile = CreateObject("WScript.Shell").SpecialFolders("MyDocuments") & "\" & sname & Title & ".pdf"
With ActiveSheet
.ExportAsFixedFormat Type:=xlTypePDF, Filename:=PdfFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
End With
On Error Resume Next
Set OutlApp = GetObject(, "Outlook.Application")
If Err Then
Set OutlApp = CreateObject("Outlook.Application")
IsCreated = True
End If
OutlApp.Visible = True
On Error GoTo 0
With OutlApp.CreateItem(0)
.Subject = Title
.to = Range("B2").Value ' <-- Put email of the recipient here"
.CC = "" ' <-- Put email of 'copy to' recipient here
.Body = "Hi," & vbLf & vbLf _
& "Yr 7 701 EOT test attached in PDF format." & vbLf & vbLf _
& "Regards," & vbLf _
& "KDS ICT Dept" & vbLf & vbLf
.Attachments.Add PdfFile
Application.Visible = True
.Display
End With
If IsCreated Then OutlApp.Quit
Set OutlApp = Nothing
With CentralReg
For Each cell In Range("A2:A250")
If cell = Range("Results!B2").Value Then
cell.Offset(0, 4).Activate
ActiveCell.Value = Range("Results!B27").Value
End If
Next
End With
End Sub
I believe you are trying to refer to CentralReg which is a worksheet, which means you should qualify it as such.
Also, you should not dim variables that are similar to defined objects/properties in VBE. Try MyCell instead of cell (good practice, not required).
I am assuming you want to see if the value on sheet CentralReg in Column A is equal to sheet Result B2. If this condition is met, your MyCell will take on the value equal sheet Result B27
Dim MyCell As Range
Dim Result, NewValue as Variant
Result = ThisWorkbook.Sheets("Result").Range("B2")
NewValue = ThisWorkbook.Sheets("Result").Range("B27")
With ThisWorkbook.Sheets("CentralReg")
For Each MyCell In .Range("A2:A250")
If MyCell = Result Then MyCell.Offset(, 4) = NewValue
Next MyCell
End With
That with statement is useless as nothing actually uses it within the construct.
Delete with CentralReg and End with and it will work.
alternatively if CentralReg IS something like a sheet then you need to precede your code with a . so this: Range("A2:A250") becomes this: .Range("A2:A250") and so on, the . tells the code that it is related to whatever your with construct surrounds
I'm not a programmer so I apologize in advance.
I have three different worksheets in a workbook. Each sheet has a specific macro so that after numbers are entered, shift supervisors can press a button with the assigned macro and metrics from that sheet will be copied and pasted to a different worksheet in a format with filter-able/pivot-able columns. It then saves and closes the data, goes back to the shift report worksheet, copies the pertinent cells, then opens lotus and formats a new message with a subject line stating the correct shift number and date and pastes the shift report data into the body of the e-mail.
Since there is a different button to press on 3 worksheets, and I can't count on supervisors to enter numbers in any specific order, I need to be able to tell if Lotus has already opened and created an e-mail with that specific subject line to see if it needs to be created or if it exists with some information already in the body. Does anyone know if this is possible?
Dim NSession As Object
Dim NDatabase As Object
Dim NUIWorkSpace As Object
Dim NDoc As Object
Dim NUIdoc As Object
Dim WordApp As Object
Dim WordDoc As Object
Dim msg As String
msg = "Leads Report " & Now() & vbNewLine & vbNewLine & _
"Finishing:" & vbNewLine & _
"**PASTE Leadsheet CELLS HERE**" & vbNewLine & vbNewLine
Sheets("Leadsheet").Select
Set newRange = Range("e4")
mystring = RangeToString(newRange)
Set NSession = CreateObject("Notes.NotesSession")
Set NUIWorkSpace = CreateObject("Notes.NotesUIWorkspace")
Set NDatabase = NSession.GetDatabase("", "")
If Not NDatabase.IsOpen Then
NDatabase.OPENMAIL
End If
'Create a new document
'******************************(if statement to see
'if a document with specific subject line has already been
'created....'subject = doc.GetItemValue("subject")(0)???????
'****************************************
Set NDoc = NDatabase.createdocument
With NDoc
.SendTo = "email#email.com" 'CHANGE THIS
.CopyTo = ""
.Subject = Format(Date, "mm-dd-yyyy") & " Lead Report Shift " & mystring
'Email body text, including marker text which will be replaced by the Excel cells
.Body = msg
.Save True, False
End With
'Edit the just-created document to copy and paste the Excel cells into it
Set NUIdoc = NUIWorkSpace.editdocument(True, NDoc)
'Find the marker text in the Body item
'Replace it with the Excel cell
With NUIdoc
'leadsheet
Workbooks("Master Shift Report Sheet.xlsm").Activate
Sheets("LeadSheet").Select
Range("B2:o62").Select
ActiveWindow.zoom = 86
Selection.copy
Set WordApp = CreateObject("Word.Application")
Set WordDoc = WordApp.Documents.Add
With WordApp.Selection
.PasteSpecial DataType:=4 & vbNewLine
.wholestory
.copy
End With
.gotofield ("Body")
.findstring "**PASTE Leadsheet CELLS HERE**"
.Paste
'Application.CutCopyMode = False
'.Send
'.Close
End With
Set NSession = Nothing
anything else looks wonky don't hesitate to point it out! I'm learning.
I am attempting to run through sheet 2 of an Excel workbook to email ranges to customers.
The ranges would be A1:B30,C1:D30,E1:F30 and so on with their account number in A1 & email in B1 and information below.
Every time I try to run the email it comes up with:
Run Time Error 1004
and then goes on to error
Object has been moved or deleted
Is there another way of emailing ranges or a way to amend this code?
Sub EmailRanges()
Dim cr As Range
Set cr = [b1]
ActiveWorkbook.EnvelopeVisible = True
Do While cr <> ""
cr.Offset(, -1).Resize(30, 2).Select
With ActiveSheet.MailEnvelope
.Introduction = " Good Morning"
.Item.To = cr
.Item.Subject = "Just testing, sorry for filling you inbox ^_^ "
.item.Send ' to send
.Item.Display ' to test
End With
MsgBox cr & " receives " & Selection.Address
Set cr = cr.Offset(, 2)
Loop
Application.ScreenUpdating = True
MsgBox "The Customers Have Been Notified"
End Sub
You need to be more explicit about your references (workbook, sheet, ...).
Thx to #Ralph :
A range can be only selected if the sheet is activated first. Otherwise, you'll get an error.
This run smoothly on my computer :
Sub Email_Ranges()
Dim rG As Range
Dim RangeToSend As Range
Dim CustomerMail As String
Set rG = ActiveWorkbook.ActiveSheet.[b1]
ActiveWorkbook.EnvelopeVisible = True
Do While rG.Value <> vbNullString
CustomerMail = rG.Value
Set RangeToSend = rG.Offset(, -1).Resize(30, 2)
'With RangeToSend.Parent.MailEnvelope
''Uncomment below if you get an error
rG.Parent.Activate
RangeToSend.Select
With Selection.Parent.MailEnvelope
.Introduction = "Good Morning"
With .Item
.To = CustomerMail
.Subject = "Just testing, sorry for filling your inbox ^_^ "
.display 'to test
.Send 'to send
End With
End With
Debug.Print CustomerMail & " receives " & RangeToSend.Address
Set rG = rG.Offset(, 2)
Loop
ActiveWorkbook.EnvelopeVisible = False
End Sub
I have a worksheet that tracks invoices and I am trying to generate an auto-emailer that if a cell in column 12 contains AUTOEMAIL it will combine all of the rows with a similar email address which I've generated using a TRIM function. It will pull all of the like rows (Email Addresses based on column 15) into a LotusNotes Email. Ron De Bruin has some fantastic examples on his site. I attempted to write a loop which attempts to loop through and copy all rows based on an email address. When I go to run, the code does nothing but no errors are presented. There are instances online of this done in Outlook, but they don't apply to LotusNotes as the issue is late vs early binding. I'm newer to VBA automation as well.
Sub Send_Data()
Dim noSession As Object, noDatabase As Object, noDocument As Object
Dim vaRecipient As Variant
Dim rnBody As Range
Dim Data As DataObject
Const stSubject As String = "TEST"
Const stMsg As String = "TEST"
Const stPrompt As String = "Please select the range:"
lastrow = Range("N" & Rows.Count).End(xlUp).row
For Each Cell In Range("N8:N" & lastrow)
If WorksheetFunction.CountIf(Range("N8:N" & Cell.row), Cell) = 1 Then
If Cells(Cell.row, 11) = "AUTOEMAIL" Then
rnBody = "Hello" & vbNewLine & vbNewLine & _
ActiveCell.EntireRow.Select
On Error Resume Next
'The user canceled the operation.
If rnBody Is Nothing Then Exit Sub
On Error GoTo 0
'Instantiate Lotus Notes COM's objects.
Set noSession = CreateObject("Notes.NotesSession")
Set noDatabase = noSession.GETDATABASE("", "")
'Make sure Lotus Notes is open and available.
If noDatabase.IsOpen = False Then noDatabase.OPENMAIL
'Create the document for the e-mail.
Set noDocument = noDatabase.CreateDocument
'Copy the selected range into memory.
rnBody.Copy
'Retrieve the data from then copied range.
Set Data = New DataObject
Data.GetFromClipboard
'Add data to the mainproperties of the e-mail's document.
With noDocument
.Form = "Memo"
.SendTo = vaRecipient
.Subject = stSubject
'Retrieve the data from the clipboard.
.Body = stMsg & " " & Data.GetText
.SaveMessageOnSend = True
End With
' SEND EMAIL
With noDocument
.PostedDate = Now()
.Send 0, vaRecipient
End With
' REMOVE FROM MEMORY
Set noDocument = Nothing
Set noDatabase = Nothing
Set noSession = Nothing
'SWITCH BACK TO EXCEL
AppActivate "Microsoft Excel"
'EMPTY COPY-PAST CLIPBOARD
Application.CutCopyMode = False
' DISPLAYS TO USER IF SUCCESSFUL
MsgBox "Complete!", vbInformation
End If
End If
Next Cell
End Sub
I set the email body range as a Prompt Box where the user could highlight the cells and then another prompt box in which it asked for the email that was created using a TRIM() function. I realized that the way the code was set-up would not allow for what I wanted to do. The new method works quite well
Treevar
I am a bit new to Outlook forms, but not to VBA overall - nor HTML/Web design of forms. However, my problem is finding a way to combine the two.
I am trying to design a form for users to fill out, and based on what they fill out in drop-down box's, it will then tell them what we want them to attach in the email. Currently we have this done in Excel, based on dropbox's it then VLOOKUPS to the 2nd Spreadsheet that contains the forms required.
Is there anyway I can bring in the Excel with the VLOOKUP behind the scenes in my VBA Outlook Form so that it can look-up what attachments we want the user to do? Otherwise, it would be a TON of SELECT CASE statements in VBA =/
This seems to the do the trick for me.
Some of it I have cobbled together from sites like this, the rest has been created by myself from scratch.
When I click my button:
An input box appears, which is the value that will be looked up in the spreadsheet.
it looks in the range (specified in the code), for a match
returns the value, two columns to the left of it.
when it finds a match it puts it in the Subject line in Outlook.
Dim jobno As String
Dim Proj As String
Sub Test()
jobno = InputBox("Job Number?", "Test")
GetNameFromXL
If jobno <> "" Then
Set myItem = Application.CreateItem(0)
If Proj <> "" Then
myItem.Subject = jobno & " - " & Proj & " - " & Format(Date, "dd.mm.yy")
Else
myItem.Subject = jobno & " - " & Format(Date, "dd.mm.yy")
End If
myItem.Display
Else
Exit Sub
End If
End Sub
Sub GetNameFromXL()
'Late binding. No reference to Excel Object required.
Dim xlApp As Object
Dim xlWB As Object
Dim xlWS As Object
Set xlApp = CreateObject("Excel.Application")
'Open the spreadsheet to get data
Set xlWB = xlApp.Workbooks.Open("X:\...\FILENAME.xlsx") ' <-- Put your file path and name here
Set xlWS = xlWB.Worksheets(1) ' <-- Looks in the 1st Worksheet
Debug.Print "-----Start of 'For Each' loop"
For Each c In xlWS.Range("A6:A100") 'Change range to value you want to 'VLookUp'
Proj = c.Offset(0, 2).Value 'This looks at the 2nd column after the range above
Debug.Print c & Proj
If jobno = c Then
Debug.Print "-----Match Found: " & jobno & " = " & Proj
GoTo lbl_Exit
Else
End If
Next c
Debug.Print "-----End of For Each loop"
MsgBox jobno & " not found in WorkBook."
'Clean up
Set xlWS = Nothing
Set xlWB = Nothing
Set c = Nothing
Proj = ""
xlApp.Quit
Set xlApp = Nothing
lbl_Exit:
Exit Sub
End Sub