I have an Outlook mail Entry ID.
I want details of that Entry Id such as To, Subject ,Body, etc.
Emails are still in Inbox not moved anywhere.
Private Sub CommandButton4_Click()
i = 0
j = 1
Dim path, FileName As String
Set currentExplorer = Application.ActiveExplorer
Set Selection = currentExplorer.Selection
Set currentMail = objNameSpace.GetItemFromID("000000000AB85207D8C3664BA439B3CE1603D186070019BED8705003484BACA686B84F9C6E880000006DE67E000019BED8705003484BACA686B84F9C6E880000428CEF9B0000")
MailTo = currentMail.To
MailSubject = currentMail.Subject
MailBody = currentMail.Body
MailDateTime = currentMail.CreationTime
attcount = currentItem.Attachments.Count
For j = 1 To attcount + 1
'FileName = "\\wipfs01\ES Quality\Personal Folders\Mahesh\Tools\Sorting-Telus\Attachment\" & Atmt.FileName
'Atmt.SaveAsFile FileName
Set chk = UserForm2.Controls("chkn" & j)
If chk.Value = True Then
path = SaveAttachment("\\wipfs01\ES Quality\Personal Folders\Mahesh\Tools\Sorting-Telus\Attachment\PO\")
FileName = path & currentItem.Attachments(j).FileName
currentItem.Attachments(j).SaveAsFile FileName
Set currentMail = currentItem
MailTo = currentMail.To
MailSubject = currentMail.Subject
MailBody = currentMail.Body
MailDateTime = currentMail.CreationTime
chk.Visible = False
End If
Next j
'MsgBox MailTo & vbCrLf & MailSubject & vbCrLf & MailBody & vbCrLf & MailDateTime
End Sub
Use Namespace.GetItemFromID to open the message using its entry id.
Related
I made a code to send some emails, using HCL NOTES and Excel, but I have been stuck.
ERROR 3000 appears when going through the line ".SEND 0, vaRecipient". I think what happens is that the connection with the database is lost, after going through the procedure of attaching an image to the body of the mail. Since if I remove those lines of code, no error arises.
Sub SendQuoteToEmail()
Dim NSession As Object
Dim NDatabase As Object
Dim NUIWorkSpace As Object
Dim NDoc As Object
Dim NUIdoc As Object
Dim NRichTextItem As Object
Dim NrichTextHeader As Object
Dim NMimeImage As Object
Dim strImageType As String
Dim WordApp As Object
Dim EmbedObj As Object
Dim Body As Object
Dim NStream As Object
Dim Subject As String
Dim MailAddress As String
Dim MailAddressCC As String
Dim MailAddressCC2 As String
Dim MailAddressCCO As String
Dim MailAddressCCO2 As String
Dim AttchFiles1, AttchFiles2, AttchFiles3, AttchFiles4 As String
Dim AddImage As String
Dim pf As Integer
Dim Uf As Integer
Dim x As Double
'On Error Resume Next
Set a = ThisWorkbook.Sheets("Base Emails")
pf = 4
Uf = 0
Do While Uf = 0
cuit = Range("a" & pf).Value
If cuit <> Empty Then
Subject = UserForm1.SubjectBox & a.Cells(pf, "D") & " - CUIL N°: " & a.Cells(pf, "A") '
MailAddress = a.Cells(pf, "F")
MailAddressCC = UserForm1.TextBoxCC
MailAddressCC2 = UserForm1.TextBoxCC2
MailAddressCCO = UserForm1.TextBoxCCO
MailAddressCCO2 = UserForm1.TextBoxCCO2
Set NSession = CreateObject("Notes.NotesSession")
Set NUIWorkSpace = CreateObject("Notes.NotesUIWorkspace")
Set NDatabase = NSession.GETDATABASE("", "")
If Not NDatabase.IsOpen Then NDatabase.OPENMAIL
Set NDoc = NDatabase.CREATEDOCUMENT
With NDoc
.SendTo = MailAddress
.CopyTo = MailAddressCC & ", " & MailAddressCC2
.Subject = Subject
.Body = UserForm1.FirstLineBox & vbLf & vbLf & _
UserForm1.FirstParagraphBox & vbLf & vbLf & _
UserForm1.SecondParagraphBox & vbLf & vbLf & _
UserForm1.ThirdParagraphBox & vbLf
.SAVEMESSAGEONSEND = True
End With
AddImage = ThisWorkbook.Path & "\Image\" & Worksheets("Files").Range("A" & 5)
If AddImage <> "" Then
Set NStream = NSession.CREATESTREAM
Call NStream.Open(AddImage)
Set Body = NDoc.CreateMIMEEntity("memo")
Set richTextHeader = Body.CreateHeader("Content-Type")
Call richTextHeader.SetHeaderVal("multipart/mixed")
Set mimeImage = Body.CreateChildEntity()
strImageType = "image/jpeg; image/gif" '" Other formats are "image/gif" "image/bmp" -
Call mimeImage.SetContentFromBytes(NStream, strImageType, ENC_IDENTITY_BINARY)
Call NStream.Close
End If
AttchFiles1 = ThisWorkbook.Path & "\Files\" & Worksheets("Files").Range("A" & 1)
If AttchFiles1 <> "" Then
Set AttachMe = NDoc.CREATERICHTEXTITEM("Attachment1")
Set EmbedObj = AttachMe.EmbedObject(1454, "", AttchFiles1, "Adjunto")
End If
AttchFiles2 = ThisWorkbook.Path & "\Files\" & Worksheets("Files").Range("A" & 2)
If AttchFiles2 <> "" Then
Set AttachMe = NDoc.CREATERICHTEXTITEM("Attachment2")
Set EmbedObj = AttachMe.EmbedObject(1454, "", AttchFiles2, "Adjunto")
End If
AttchFiles3 = ThisWorkbook.Path & "\Files\" & Worksheets("Files").Range("A" & 3)
If AttchFiles3 <> "" Then
Set AttachMe = NDoc.CREATERICHTEXTITEM("Attachment3")
Set EmbedObj = AttachMe.EmbedObject(1454, "", AttchFiles3, "Adjunto")
End If
AttchFiles4 = ThisWorkbook.Path & "\Files\" & Worksheets("Files").Range("A" & 4)
If AttchFiles4 <> "" Then
Set AttachMe = NDoc.CREATERICHTEXTITEM("Attachment4")
Set EmbedObj = AttachMe.EmbedObject(1454, "", AttchFiles4, "Adjunto")
End If
With NDoc
.PostedDate = Now()
.SEND 0, vaRecipient '<--- ERROR 3000
End With
Set NStream = Nothing
Set NDoc = Nothing
Set WordApp = Nothing
Set NSession = Nothing
Set EmbedObj = Nothing
pf = pf + 1
Else
Uf = 1
Exit Do
End If
Loop
VbMessage = "Sent messages"
Call Clean
End Sub
If I remove these lines of code, the procedure works. So I suppose that by manipulating "NSession", something happens, but I don't know what.
AddImage = ThisWorkbook.Path & "\Image\" & Worksheets("Files").Range("A" & 5)
If AddImage <> "" Then
Set NStream = NSession.CREATESTREAM
Call NStream.Open(AddImage)
Set Body = NDoc.CreateMIMEEntity("memo")
Set richTextHeader = Body.CreateHeader("Content-Type")
Call richTextHeader.SetHeaderVal("multipart/mixed")
Set mimeImage = Body.CreateChildEntity()
strImageType = "image/jpeg; image/gif" '" Other formats are "image/gif" "image/bmp" -
Call mimeImage.SetContentFromBytes(NStream, strImageType, ENC_IDENTITY_BINARY)
Call NStream.Close
End If
You've got two pieces of incompatible code here.
.Body = UserForm1.FirstLineBox & vbLf & vbLf & _
UserForm1.FirstParagraphBox & vbLf & vbLf & _
UserForm1.SecondParagraphBox & vbLf & vbLf & _
UserForm1.ThirdParagraphBox & vbLf
And
Set Body = NDoc.CreateMIMEEntity("memo")
Set richTextHeader = Body.CreateHeader("Content-Type")
Call richTextHeader.SetHeaderVal("multipart/mixed")
Set mimeImage = Body.CreateChildEntity()
strImageType = "image/jpeg; image/gif" '" Other formats are "image/gif" "image/bmp" -
Call mimeImage.SetContentFromBytes(NStream, strImageType, ENC_IDENTITY_BINARY)
You can't work with the message body both as Notes rich text (the first piece of code) and as MIME. You need to pick one or the other. I'm guessing you're going to pick MIME, in which case you are going to need to create a text/plain part and populate it with your three paragraphs of text.
Here is my problem:
Duplicate versions
I checked the version history on the Sharepoint site and it doesn't show any duplicates.
Here is the code im using:
Sub versionhistory()
'
' versionhistory Macro
On Error Resume Next
' On Error GoTo message
Dim dlvVersions As Office.DocumentLibraryVersions
Dim dlvVersion As Office.DocumentLibraryVersion
Dim strVersionInfo As String
Set dlvVersions = ThisDocument.DocumentLibraryVersions
'MsgBox ActiveDocument.Bookmarks.Count
Dim tbl As Word.Table
'Set tbl = ActiveDocument.Tables.Item(2)
Set tbl = ActiveDocument.Bookmarks("VersionTable").Range.Tables(1)
If dlvVersions.IsVersioningEnabled Then
strVersionInfo = "This document has " & dlvVersions.Count & " versions: " & vbCrLf
Call InsertVersionHistory(tbl, dlvVersions)
For Each dlvVersion In dlvVersions
strVersionInfo = strVersionInfo & _
" - Version #: " & dlvVersion.Index & vbCrLf & _
" - Modified by: " & dlvVersion.ModifiedBy & vbCrLf & _
" - Modified on: " & dlvVersion.Modified & vbCrLf & _
" - Comments: " & dlvVersion.Comments & vbCrLf
Next
Else
strVersionInfo = "Versioning not enabled for this document."
End If
'MsgBox strVersionInfo, vbInformation + vbOKOnly, "Version Information"
Set dlvVersion = Nothing
Set dlvVersions = Nothing
Call GetUserName
'message:
'MsgBox Err.Description
MsgBox ("Insert Version Number in the Header and type a Title in the [Insert Title here] on the front page. It will be automatically updated in the footer." & vbNewLine & vbNewLine & "Do Not Type in the Review and Version tables.")
End Sub
Private Function InsertVersionHistory(oVerTbl As Word.Table, oVersions As Office.DocumentLibraryVersions)
Dim rowIndex As Integer
Dim oVersion As Office.DocumentLibraryVersion
Dim oNewRow As Row
'test
Dim versionIndex As Integer
For rowIndex = 2 To oVerTbl.Rows.Count
oVerTbl.Rows.Item(2).Delete
Next rowIndex
rowIndex = 1
'test
versionIndex = oVersions.Count
For Each oVersion In oVersions
If (rowIndex > 5) Then
Return
End If
rowIndex = rowIndex + 1
oVerTbl.Rows.Add
Set oNewRow = oVerTbl.Rows(oVerTbl.Rows.Count)
oNewRow.Shading.BackgroundPatternColor = wdColorWhite
oNewRow.Range.Font.TextColor = wdBlack
oNewRow.Range.Font.Name = "Tahoma"
oNewRow.Range.Font.Bold = False
oNewRow.Range.Font.Size = 12
oNewRow.Range.ParagraphFormat.SpaceAfter = 4
With oNewRow.Cells(1)
'.Range.Text = oVersion.Index
.Range.Text = versionIndex
End With
With oNewRow.Cells(2)
.Range.Text = FormUserFullName(GetUserFullName(oVersion.ModifiedBy))
End With
With oNewRow.Cells(3)
.Range.Text = oVersion.Modified
End With
With oNewRow.Cells(4)
.Range.Text = oVersion.Comments
End With
versionIndex = versionIndex - 1
Next
Set oVersion = Nothing
End Function
Function GetUserFullName(userName As String) As String
Dim WSHnet, UserDomain, objUser
Set WSHnet = CreateObject("WScript.Network")
'UserDomain = WSHnet.UserDomain
'Set objUser = GetObject("WinNT://" & UserDomain & "/" & userName & ",user")
userName = Replace(userName, "\", "/")
Set objUser = GetObject("WinNT://" & userName & ",user")
'MsgBox objUser.FullName
GetUserFullName = objUser.FullName
End Function
Function FormUserFullName(userName As String) As String
Dim arrUserName As Variant
Dim changedUserName As String
arrUserName = Split(userName, ",")
Dim length As Integer
length = UBound(arrUserName) - LBound(arrUserName) + 1
If length >= 2 Then
changedUserName = arrUserName(1) & " " & arrUserName(0)
Else
changedUserName = userName
End If
FormUserFullName = changedUserName
End Function
Private Function GetUserName()
Dim userName As String
userName = ActiveDocument.BuiltInDocumentProperties("Author")
ActiveDocument.BuiltInDocumentProperties("Author") = FormUserFullName(userName)
End Function
I know this is old, but I was looking for the same thing and found this article. I'm still trying it out, but wanted to share before I got distracted with my real job.
From: SixSigmaGuy on microsoft.public.sharepoint.development-and-programming.narkive.com/...
Wanted to share my findings, so far. Surprisingly, I could not find
anything in the SharePoint Designer object/class that supported versions,
but the Office, Word, Excel, and PowerPoint objects do support it.. It
wasn't easy to find, but once I found it, it works great, as long as the
file in the document library is one of the Office documents.
Here's some sample code, written in Excel VBA, showing how to get the
version information for a paritcular SharePoint Document Library file
created in Excel:
Public viRow As Long
Function fCheckVersions(stFilename As String) As Boolean
' stFilename is the full URL to a document in a Document Library.
'
Dim wb As Excel.Workbook
Dim dlvVersions As Office.DocumentLibraryVersions
Dim dlvVersion As Office.DocumentLibraryVersion
Dim stExtension As String
Dim iPosExt As Long
ThisWorkbook.Worksheets("Sheet1").Cells(viRow, 1) = stFilename
If Workbooks.CanCheckOut(stFilename) = True Then
Set wb = Workbooks.Open(stFilename, , True)
Set dlvVersions = wb.DocumentLibraryVersions
If dlvVersions.IsVersioningEnabled = True Then
ThisWorkbook.Worksheets("Sheet1").Cells(viRow, 3) = "Num
Versions = " & dlvVersions.Count
For Each dlvVersion In dlvVersions
ThisWorkbook.Worksheets("Sheet1").Cells(viRow, 4) = "Version: " & dlvVersion.Index
ThisWorkbook.Worksheets("Sheet1").Cells(viRow, 5) = "Modified Date: " & dlvVersion.Modified
ThisWorkbook.Worksheets("Sheet1").Cells(viRow, 6) = "Modified by: " & dlvVersion.ModifiedBy
ThisWorkbook.Worksheets("Sheet1").Cells(viRow, 7) = "Comments: " & dlvVersion.Comments
viRow = viRow + 1
Next dlvVersion
End If
wb.Close False
End If
Set wb = Nothing
DoEvents
End Function`
Fortunately, I discovered that Excel can open non-Excel files in most
cases. I.e., I can, for example, open a jpg file in Excel and use the
dlvVersions collection for that file.
I am using the code below to save multiple selected emails in a standard file naming format in a folder, who's path is selected from a text box (textbox1). Depending on whether a checkbox (checkbox1) is selected or not will determine whether the emails are deleted after running the code. If the the checkbox is not selected then the emails are saved to the folder but not deleted from Outlook. If the checkbox is not selected then I want the email subject in Outlook to be changed in order that I know that I have previously saved the email. The code below pretty much does everything I want except changing the email subject. If I select only one email all works fine. However if I select more than one email then only the subject of the first email gets changed. Any help appreciated.
Sub SaveIncoming()
Dim lngC As Long
Dim msgItem As Outlook.MailItem
Dim strPath As String
Dim FiledSubject As String
On Error Resume Next
strPath = UserForm1.TextBox1.Value
On Error GoTo 0
If strPath = "" Then Exit Sub
If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
If TypeName(Application.ActiveWindow) = "Explorer" Then
' save selected messages in Explorer window
If CBool(ActiveExplorer.Selection.Count) Then
With ActiveExplorer
For lngC = 1 To .Selection.Count
If .Selection(lngC).Class = olMail Then
MsgSaver3 strPath, .Selection(lngC)
If UserForm1.CheckBox1.Value = True Then
.Selection(lngC).Delete
End If
If UserForm1.CheckBox1.Value = False Then
FiledSubject = "[Filed" & " " & Date & "]" & " " & .Selection(lngC).Subject
.Selection(lngC).Subject = FiledSubject
End If
End If
Next lngC
End With
End If
ElseIf Inspectors.Count Then
' save active open message
If ActiveInspector.CurrentItem.Class = olMail Then
MsgSaver3 strPath, ActiveInspector.CurrentItem
End If
End If
End Sub
Private Sub MsgSaver3(strPath As String, msgItem As Outlook.MailItem)
Dim intC As Integer
Dim intD As Integer
Dim strMsgSubj As String
Dim strMsgFrom As String
strMsgSubj = msgItem.Subject
strMsgFrom = msgItem.SenderName
' Clean out characters from Subject which are not permitted in a file name
For intC = 1 To Len(strMsgSubj)
If InStr(1, ":<>""", Mid(strMsgSubj, intC, 1)) > 0 Then
Mid(strMsgSubj, intC, 1) = "-"
End If
Next intC
For intC = 1 To Len(strMsgSubj)
If InStr(1, "\/|*?", Mid(strMsgSubj, intC, 1)) > 0 Then
Mid(strMsgSubj, intC, 1) = "_"
End If
Next intC
' Clean out characters from Sender Name which are not permitted in a file name
For intD = 1 To Len(strMsgFrom)
If InStr(1, ":<>""", Mid(strMsgFrom, intD, 1)) > 0 Then
Mid(strMsgFrom, intD, 1) = "-"
End If
Next intD
For intD = 1 To Len(strMsgFrom)
If InStr(1, "\/|*?", Mid(strMsgFrom, intD, 1)) > 0 Then
Mid(strMsgFrom, intD, 1) = "_"
End If
Next intD
' add date to file name
strMsgSubj = Format(msgItem.SentOn, "yyyy-mm-dd Hh.Nn.Ss") & " " & "[From " & strMsgFrom & "]" & " " & strMsgSubj & ".msg"
msgItem.SaveAs strPath & strMsgSubj
Set msgItem = Nothing
UserForm1.Hide
End Sub
When you delete the remaining items move up so 2 becomes 1. You never process the original item 2.
Try replacing
For lngC = 1 To .Selection.count
with
For lngC = .Selection.count to 1 step -1
For the same reason a For Each loop does not work when moving or deleting.
I've set up a button in my Excel Sheet that should be able so save a picture of the sheet to my hard drive and then send an Email to a specific address with the picture attached to it, the saving of the picture works fine, but when I try and send the Email using a piece of code I found at http://www.exceltoolset.com/sending-email-with-vba/ it returns the error: -2147220975
Here is the whole sub:
Sub SendKnap_Klik()
Set Sheet = ActiveSheet
Ret = IIf(Environ$("tmp") <> "", Environ$("tmp"), Environ$("temp"))
Output = Ret & "\SkemaSend.png"
zoom_coef = 100 / Sheet.Parent.Windows(1).Zoom
Set area = Sheet.Range(Sheet.PageSetup.PrintArea)
area.CopyPicture xlPrinter
Set chartobj = Sheet.ChartObjects.Add(0, 0, area.Width * zoom_coef, area.Height * zoom_coef)
chartobj.Chart.Paste
chartobj.Chart.Export Output, "png"
chartobj.Delete
ReturnValue = SendEMail("Subject", "MyMail#gmail.com", Range("J25").Value, "Body", "smtp.gmail.com", "", Output)
If ReturnValue = True Then
MsgBox "Emailen sent to " & Range("J25") & " was successfull!"
Else
MsgBox "Emailen sent to " & Range("J25") & " was not sent" & vbNewLine & "Error: " & Err.Number
End If
End Sub
Function SendEMail(Subject As String, _
FromAddress As String, _
ToAddress As String, _
MailBody As String, _
SMTP_Server As String, _
BodyFileName As String, _
Optional Attachments As Variant = Empty) As Boolean
Dim MailMessage As CDO.Message
Dim N As Long
Dim FNum As Integer
Dim S As String
Dim Body As String
Dim Recips() As String
Dim Recip As String
Dim NRecip As Long
' ensure required parameters are present and valid.
If Len(Trim(Subject)) = 0 Then
SendEMail = False
Exit Function
End If
If Len(Trim(FromAddress)) = 0 Then
SendEMail = False
Exit Function
End If
If Len(Trim(SMTP_Server)) = 0 Then
SendEMail = False
Exit Function
End If
' Clean up the addresses
Recip = Replace(ToAddress, Space(1), vbNullString)
If Right(Recip, 1) = ";" Then
Recip = Left(Recip, Len(Recip) - 1)
End If
Recips = Split(Recip, ";")
For NRecip = LBound(Recips) To UBound(Recips)
On Error Resume Next
' Create a CDO Message object.
Set MailMessage = CreateObject("CDO.Message")
If Err.Number <> 0 Then
SendEMail = False
Exit Function
End If
Err.Clear
On Error GoTo 0
With MailMessage
.Subject = Subject
.From = FromAddress
.To = Recips(NRecip)
If MailBody <> vbNullString Then
.TextBody = MailBody
Else
If BodyFileName <> vbNullString Then
If Dir(BodyFileName, vbNormal) <> vbNullString Then
' import the text of the body from file BodyFileName
FNum = FreeFile
S = vbNullString
Body = vbNullString
Open BodyFileName For Input Access Read As #FNum
Do Until EOF(FNum)
Line Input #FNum, S
Body = Body & vbNewLine & S
Loop
Close #FNum
.TextBody = Body
Else
' BodyFileName not found.
SendEMail = False
Exit Function
End If
End If ' MailBody and BodyFileName are both vbNullString.
End If
If IsArray(Attachments) = True Then
' attach all the files in the array.
For N = LBound(Attachments) To UBound(Attachments)
' ensure the attachment file exists and attach it.
If Attachments(N) <> vbNullString Then
If Dir(Attachments(N), vbNormal) <> vbNullString Then
.AddAttachment Attachments(N)
End If
End If
Next N
Else
' ensure the file exists and if so, attach it to the message.
If Attachments <> vbNullString Then
If Dir(CStr(Attachments), vbNormal) <> vbNullString Then
.AddAttachment Attachments
End If
End If
End If
With .Configuration.Fields
' set up the SMTP configuration
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = SMTP_Server
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 465
.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "mymail#gmail.com"
.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "pass"
.Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
.Update
End With
On Error Resume Next
Err.Clear
' Send the message
.Send
If Err.Number = 0 Then
SendEMail = True
Else
SendEMail = False
Exit Function
End If
End With
Next NRecip
SendEMail = True
End Function
I also changed settings on my Gmail account to allow unsecured programs to access the account
What am I doing wrong, should something be changed?
//
// MessageId: CDO_E_SMTP_SEND_FAILED
//
// MessageText:
//
// The message could not be sent to the SMTP server. The transport error code was %2. The server response was %1
//
#define CDO_E_SMTP_SEND_FAILED 0x80040211L
CDO takes it's default settings from Windows Mail/Outlook Express/Microsoft Internet Mail and News.
This VBA code list your configuration:
Set emailConfig = emailObj.Configuration
On Error Resume Next
For Each fld in emailConfig.Fields
Text = Text & vbcrlf & fld.name & " = " & fld
If err.number <> 0 then
Text = Text & vbcrlf & fld.name & " = Error - probably trying to read password - not allowed"
err.clear
End If
Next
Msgbox Replace(Text, "http://schemas.microsoft.com", "")
I want to run a vba app to find the emails in this mailbox and give me the total number for each date from the last three days. The folder is correct and I can see the next mailitem. The main problem I am having is that I want the for each to end after it gets to the fourth day. I am getting compile errors at the end of the foreach and nested if statements. Do I need to have Next anywhere if it's a for each?
Sub NonTicketEmailsCount()
Dim objOutlook As Object, objnSpace As Object, objFolder As MAPIFolder
Dim EmailCount As Integer
Dim MailItem
Set objOutlook = CreateObject("Outlook.Application")
Set objnSpace = objOutlook.GetNamespace("MAPI")
On Error Resume Next
Set objFolder = objnSpace.Folders("Mailbox - IT Support Center").Folders("Non ticket related emails")
If Err.Number <> 0 Then
Err.Clear
MsgBox "No such folder."
Exit Sub
End If
EmailCount = objFolder.Items.Count
Dim dateStr As String
Dim dict As Object
Dim msg As String
Set dict = CreateObject("Scripting.Dictionary")
' Determine date of each message:
For Each MailItem In objFolder.Items
rt = MailItem.ReceivedTime 'getting received time for each mailitem
nrt = Format(rt, "M/ d/ yyyy") 'formatting the received time to match value of datevalue keyword
If DateValue(nrt) = Empty Then
NonTicket0 = NonTicket0 + 1
ElseIf DateValue(Date - 1) = DateValue(nrt) Then
NonTicket1 = NonTicket1 + 1
ElseIf DateValue(Date - 2) = DateValue(nrt) Then
NonTicket2 = NonTicket2 + 1
ElseIf DateValue(Date - 3) = DateValue(nrt) Then
NonTicket3 = NonTicket3 + 1
ElseIf DateValue(Date - 4) = DateValue(nrt) Then
Exit For
End If
msg = "Total NonTicket emails in the folder: " & EmailCount & vbNewLine _
& NonTicket1 & " = NonTicket Emails on " & Date - 1 & vbNewLine _
& NonTicket2 & " = NonTicket Emails on " & Date - 2 & vbNewLine _
& NonTicket3 & " = NonTicket Emails on " & Date - 3 & vbNewLine _
MsgBox "Number of emails in the folder: " & EmailCount & vbNewLine _
& "NonTicket Emails Yesterday: " & NonTicket1 & vbNewLine _
& "NonTicket Emails Yesterday: " & NonTicket2 & vbNewLine _
& "NonTicket Emails Yesterday: " & NonTicket3
'Send Mail
Set OutApp = CreateObject("outlook.Application")
Set OutMail = OutApp.CreateItem(o)
With OutMail
.Subject = "Non Ticket Emails"
.To = "kylesparmark#glissondo.com; meisnert#glissondo.com"
.Body = msg
.Display
End With
Set OutMail = Nothing
Set OutApp = Nothing
Set objFolder = Nothing
Set objnSpace = Nothing
Set objOutlook = Nothing
End Sub
You're missing the NEXT statement to close your FOR EACH loop:
For Each MailItem In objFolder.Items
rt = MailItem.ReceivedTime 'getting received time for each mailitem
nrt = Format(rt, "M/ d/ yyyy") 'formatting the received time to match value of datevalue keyword
If DateValue(nrt) = Empty Then
NonTicket0 = NonTicket0 + 1
ElseIf DateValue(Date - 1) = DateValue(nrt) Then
NonTicket1 = NonTicket1 + 1
ElseIf DateValue(Date - 2) = DateValue(nrt) Then
NonTicket2 = NonTicket2 + 1
ElseIf DateValue(Date - 3) = DateValue(nrt) Then
NonTicket3 = NonTicket3 + 1
ElseIf DateValue(Date - 4) = DateValue(nrt) Then
Exit For
End If
NEXT ' <--- Add this