Automatic Category assignment for received email + File name attachment - VBA Macro Outlook - vba

I made a script to assign a category to all selected email based on some initials in the subject, some words in the body, the sender, ...
Public Sub autocategories()
Dim olItem As Object
For Each olItem In Application.ActiveExplorer.Selection
If InStr(1, olItem.Subject, "=SUB1=", vbTextCompare) > 0 Then
olItem.Categories = "SUB1"
ElseIf InStr(1, olItem.Subject, "=SUB2=", vbTextCompare) > 0 Then
olItem.Categories = "SUB2"
ElseIf InStr(1, olItem.Sender, "SEN1", vbTextCompare) > 0 Then
olItem.Categories = "SEN1"
ElseIf InStr(1, olItem.Sender, "SEN2", vbTextCompare) > 0 Then
olItem.Categories = "SEN2"
ElseIf InStr(1, olItem.Body, "BOD1", vbTextCompare) > 0 Then
olItem.Categories = "BOD1"
ElseIf InStr(1, olItem.Body, "BOD2", vbTextCompare) > 0 Then
olItem.Categories = "BOD2"
End If
olItem.Save
Next olItem
Set olItem = Nothing
End Sub
I made a second script to assign a category automatically to all the emails sent.
Private Sub Application_ItemSend(ByVal olItem As Object, Cancel As Boolean)
With olItem
If InStr(1, olItem.Subject, "=SUB1=", vbTextCompare) > 0 Then
olItem.Categories = "SUB1"
olItem.Save
ElseIf InStr(1, olItem.Subject, "=SUB2=", vbTextCompare) > 0 Then
olItem.Categories = "SUB2"
olItem.Save
ElseIf InStr(1, olItem.Body, "BOD1", vbTextCompare) > 0 Then
olItem.Categories = "BOD1"
olItem.Save
ElseIf InStr(1, olItem.Body, "BOD2", vbTextCompare) > 0 Then
olItem.Categories = "BOD2"
olItem.Save
Else: End If
End With
lbl_Exit:
Exit Sub
End Sub
For the emails received:
- I would like the assignment made automatically instead of having to select the emails and click on the macro button
- Using the Rules is not an option as it requires an update of the key registry which is forbidden by my company.
For the email received and sent:
- I would like to recognize the file name of an attachment
- I tried this:
ElseIf InStr(1, olItem.Attachemnts, "[NAME1]", vbTextCompare) > 0 Then
olItem.Categories = "[NAME1]"
olItem.Save

Something like that
Option Explicit
Private WithEvents inboxItems As Outlook.Items
Private WithEvents colSentItems As Outlook.Items
Private Sub Application_Startup()
Dim outlookApp As Outlook.Application
Dim objectNS As Outlook.NameSpace
Set outlookApp = Outlook.Application
Set objectNS = outlookApp.GetNamespace("MAPI")
Set inboxItems = objectNS.GetDefaultFolder(olFolderInbox).Items
Set colSentItems = objectNS.GetDefaultFolder(olFolderSentMail).Items
End Sub
Private Sub inboxItems_ItemAdd(ByVal Item As Object)
On Error GoTo ErrorHandler
Dim Msg As Outlook.MailItem
Dim MessageInfo
Dim Result
Dim objAtt As Outlook.Attachment
If TypeName(Item) = "MailItem" Then
'MessageInfo = "" & _
"Sender : " & Item.SenderEmailAddress & vbCrLf & _
"Sent : " & Item.SentOn & vbCrLf & _
"Received : " & Item.ReceivedTime & vbCrLf & _
"Subject : " & Item.Subject & vbCrLf & _
"Size : " & Item.Size & vbCrLf & _
"Message Body : " & vbCrLf & Item.Body
'Result = MsgBox(MessageInfo, vbOKOnly, "New Message Received")
If InStr(1, Item.Subject, "=SUB1=", vbTextCompare) > 0 Then
Item.Categories = "SUB1"
ElseIf InStr(1, Item.Subject, "=SUB2=", vbTextCompare) > 0 Then
Item.Categories = "SUB2"
ElseIf InStr(1, Item.Sender, "SEN1", vbTextCompare) > 0 Then
Item.Categories = "SEN1"
ElseIf InStr(1, Item.Sender, "SEN2", vbTextCompare) > 0 Then
Item.Categories = "SEN2"
ElseIf InStr(1, Item.Body, "BOD1", vbTextCompare) > 0 Then
Item.Categories = "BOD1"
ElseIf InStr(1, Item.Body, "BOD2", vbTextCompare) > 0 Then
Item.Categories = "BOD2"
End If
For Each objAtt In Item.Attachments
'objAtt.SaveAsFile saveFolder & "\" & Item.Parent & "\" & objAtt.DisplayName
If InStr(1, objAtt.DisplayName, "[NAME1]", vbTextCompare) > 0 Then
Item.Categories = "[NAME1]"
Item.Save
End If
Set objAtt = Nothing
Next
Item.Save
End If
ExitNewItem:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ExitNewItem
End Sub
Private Sub colSentItems_ItemAdd(ByVal Item As Object)
If Item.Class = olMail Then
'Item.ShowCategoriesDialog
If InStr(1, Item.Subject, "=SUB1=", vbTextCompare) > 0 Then
Item.Categories = "SUB1"
ElseIf InStr(1, Item.Subject, "=SUB2=", vbTextCompare) > 0 Then
Item.Categories = "SUB2"
ElseIf InStr(1, Item.Body, "BOD1", vbTextCompare) > 0 Then
Item.Categories = "BOD1"
ElseIf InStr(1, Item.Body, "BOD2", vbTextCompare) > 0 Then
Item.Categories = "BOD2"
End If
Item.Save
End If
End Sub

Related

Range in Middle of the email body

I am working on a Code which can get the range/selection in the middle of the email body. The below code works a bit fine for me it does not captures the desired range in the middle of the email body. This will save my time to work manually.
Sub Selection_email()
Dim bStarted As Boolean
Dim olApp As Object: Set olApp = CreateObject("Outlook.Application")
Dim olMailItm As Object: Set olMailItm = olApp.CreateItem(0)
Dim rngTo As Range
Dim rngSubject As Range
Set oOutlookApp = GetObject(, "Outlook.Application")
If Err <> 0 Then
Set oOutlookApp = CreateObject("Outlook.Application")
bStarted = True
End If
Set oItem = oOutlookApp.CreateItem(olMailItem)
With Active Sheet
Set rngTo = .Rng("E3")
Last = ActiveSheet.Cells(2, 4).Value
End With
With oItem
.SentOnBehalfOfName = ""
.To = rngTo.Value
.Cc = ""
.Subject = "" & Last & ""
.body = "Hello," & vbNewLine & vbNewLine & _
"Welcome to My World"& vbNewLine & vbNewLine & _
**HERE I NEED THE CODE TO PASTE THE RANGE FROM THE EXCEL FILE IT SHOULD BE FROM "A1:D6"**
"Thank you for your cooperation."
.Display.
If bStarted Then
oOutlookApp.Quit
End If
Set oOutlookApp = Nothing
End Sub
Option Explicit
Sub Selection_email()
Dim bStarted As Boolean
Dim olApp As Object
Dim oItem As Outlook.MailItem
Dim olMailItm As Object
Dim rngTo As Range
Dim rngSubject As Range
Dim Last As Variant
Dim htmlString As String
Dim beginBody, endBody As String
Dim oOutlookApp As Outlook.Application
Set olApp = CreateObject("Outlook.Application")
Set olMailItm = olApp.CreateItem(0)
Set oOutlookApp = GetObject(, "Outlook.Application")
If Err <> 0 Then
Set oOutlookApp = CreateObject("Outlook.Application")
bStarted = True
End If
Set oItem = oOutlookApp.CreateItem(olMailItem)
With ActiveSheet
Set rngTo = .Range("E3")
Last = ActiveSheet.Cells(2, 4).Value
End With
'create the HTML table first --
' this builds a string with proper HTML header info
htmlString = RangetoHTML(ActiveSheet.Range("A1:D6"))
'now add the email greeting to the body information
beginBody = Left(htmlString, InStr(1, htmlString, "<body>", vbTextCompare) + 6)
endBody = Right(htmlString, Len(htmlString) - InStr(1, htmlString, "<body>", vbTextCompare) + 5)
htmlString = beginBody & _
"Hello,<br><br>Welcome to My World<br><br>" & _
endBody
'now find the end of the table and add the signoff message
beginBody = Left(htmlString, InStr(1, htmlString, "</div>", vbTextCompare) + 6)
endBody = Right(htmlString, Len(htmlString) - InStr(1, htmlString, "</div>", vbTextCompare) + 5)
htmlString = beginBody & _
"<br><br>Thank you for your cooperation." & _
endBody
With oItem
.SentOnBehalfOfName = ""
.To = rngTo.Value
.CC = ""
.Subject = "" & Last & ""
.HTMLBody = htmlString
.Display
End With
If bStarted Then
oOutlookApp.Quit
End If
Set oOutlookApp = Nothing
End Sub
Function RangetoHTML(rng As Range)
' By Ron de Bruin.
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
'Copy the range and create a new workbook to past the data in
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With
'Publish the sheet to a htm file
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
'Read all data from the htm file into RangetoHTML
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.ReadAll
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")
'Close TempWB
TempWB.Close savechanges:=False
'Delete the htm file we used in this function
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
I'm assuming "A1:D6" is one merged ranged. You only want the top left cell in that case. If I've made an incorrect assumption let me know.
.body = "Hello," & vbNewLine & vbNewLine & _
"Welcome to My World"& vbNewLine & vbNewLine & _
Activesheet.range("A1").value & _
"Thank you for your cooperation."Replacing Activesheet with something more specific would also be a good idea but depends on your worksheets.
Edit
Using the RangeToHTML function found here: Paste specific excel range in outlook
Then change
.body = "Hello," & vbNewLine & vbNewLine & _
"Welcome to My World"& vbNewLine & vbNewLine & _
**HERE I NEED THE CODE TO PASTE THE RANGE FROM THE EXCEL FILE IT SHOULD BE FROM "A1:D6"**
"Thank you for your cooperation."
to
.HTMLBody = "Hello," & vbNewLine & vbNewLine & _
"Welcome to My World"& vbNewLine & vbNewLine & _
RangeToHTML(activesheet.range("A1:D6")) & _
"Thank you for your cooperation."

using backslash or hashtag in textbox in macro enabled word doc

I have a Word macro-enabled document that has a number of set text boxes that have to be completed prior to the document being able to be sent to a number of email addresses. The issue I have is that the workers here like to shortcut everything eg left hand = L/H etc. the document I have in progress doesn't recognize / or #, The text box is a free text box that is required to be completed. When they put a / or \ or # in one of the text boxes that are required, the document doesn't know what to do - its like it cant process them
{ `If ActiveDocument.ProtectionType <> wdNoProtection Then
ActiveDocument.Unprotect "Pass1"
End If
strTempFolder = GetTempFolder()
strDate = ActiveDocument.SelectContentControlsByTag("EventDate").Item(1).Range.Text
If IsDate(strDate) Then
strDate = Format(strDate, "yyyy-mm-dd")
Else
MsgBox "Please select an event date.", vbExclamation, "Date Error"
Exit Sub
End If
strNoti = ActiveDocument.SelectContentControlsByTag("NotificationNumber").Item(1).Range.Text
If Not IsNumeric(strNoti) Or Len(strNoti) <> 9 Then
MsgBox "Please enter a valid notification number.", vbExclamation, "Notification Error"
Exit Sub
End If
strShortText = ActiveDocument.SelectContentControlsByTag("ShortText").Item(1).Range.Text
If Left(strShortText, 5) = "Enter" Then
MsgBox "Please enter short text.", vbExclamation, "Title Not Entered"
Exit Sub
End If
response = MsgBox("Confirm you have completed the data entry and wish to now send this document? WAIT FOR EMAILS TO PROCESS!", vbExclamation + vbYesNo, "Document Send Confirmation")
If response = vbNo Then
MsgBox "Document not sent", vbInformation, "Document Not sent"
Exit Sub
End If
strTitle = strDate & " " & strNoti & " " & strShortText
strFilename = strDate & " " & strNoti & " " & strShortText & ".docm"
strFullFileNameDocm = strTempFolder & "\" & strFilename
ActiveDocument.SaveAs FileName:=strFullFileNameDocm
strFilename = strDate & " " & strNoti & " " & strShortText & ".docx"
strFullFileNameDocx = strTempFolder & "\" & strFilename
Application.Documents.Add ActiveDocument.Fullname
'Remove button
ActiveDocument.Shapes("Control 3").Select
Selection.ShapeRange.Delete
'Save copy
ActiveDocument.SaveAs strFullFileNameDocx
'Old file location for doc save.. "\\necmacfil01 \bcc_data\Transfer\Events\"
' strTo = "Sue.Jones1#ton.com"
strTo = "nswec.mac.mre#ton.com"
Call SendDocumentAsAttachment(strFullFileNameDocx, strTitle, strTo)
Call RemoveSection2ToEnd
strPDFSharePointFolder = "https://spo.ton.com/sites/COLMTAmacdata/Event%20Notifications/"
strFilename = strDate & " " & strNoti & " " & strShortText & ".pdf"
strFullFileNamePDF = strPDFSharePointFolder & strFilename
ActiveDocument.SaveAs FileName:=strFullFileNamePDF, FileFormat:=wdFormatPDF
' strTo = "Sue.Jones1#ton.com"
strTo = "DL-COL-NEC-MACEventNotification#ton.com"
Call SendDocumentAsAttachment(strFullFileNamePDF, strTitle, strTo)
'Close copy
Application.DisplayAlerts = False
ActiveDocument.Close SaveChanges:=wdDoNotSaveChanges
Application.DisplayAlerts = True
MsgBox "Document sent as required, this document will now be closed.", vbInformation, "Document Sent"
Application.DisplayAlerts = False
ActiveDocument.Close SaveChanges:=wdDoNotSaveChanges
Application.DisplayAlerts = True
End Sub
Sub SendDocumentAsAttachment(strFullFileName As String, strTitle As String, strTo As String)
Dim oOutlookApp As Outlook.Application
Dim strBody As String
'You'll need to add the Outlook Object Library to VBA Tools References
Dim oItem As Outlook.MailItem
On Error Resume Next
If Len(ActiveDocument.Path) = 0 Then 'Document has not been saved
'so save it
' ActiveDocument.Save
End If
'see if Outlook is running and if so turn your attention there
Set oOutlookApp = GetObject(, "Outlook.Application")
If Err <> 0 Then 'Outlook isn't running
'So fire it up
Set oOutlookApp = CreateObject("Outlook.Application")
End If
'Open a new e-mail message
Set oItem = oOutlookApp.CreateItem(olMailItem)
.Display
.To = strTo 'send to this address
.CC = ""
.BCC = ""
strBody = "<p>All</p>" & vbCr & vbCr & _
"<p>Please find attached event notification.</p>"
.HTMLBody = strBody & .HTMLBody
.Subject = strTitle 'This is the message subject
.Attachments.Add Source:=strFullFileName
.Send
End With
Set oItem = Nothing
Set oOutlookApp = Nothing
End Sub
Sub RemoveSection2ToEnd()
Selection.HomeKey Unit:=wdStory
Selection.GoTo What:=wdGoToSection, Which:=wdGoToFirst, Count:=2, Name:=""
With Selection.PageSetup
.LineNumbering.Active = False
.Orientation = wdOrientLandscape
.TopMargin = CentimetersToPoints(0)
.BottomMargin = CentimetersToPoints(0)
.LeftMargin = CentimetersToPoints(1.27)
.RightMargin = CentimetersToPoints(1.27)
.Gutter = CentimetersToPoints(0)
.HeaderDistance = CentimetersToPoints(0.75)
.FooterDistance = CentimetersToPoints(0.18)
.PageWidth = CentimetersToPoints(29.7)
.PageHeight = CentimetersToPoints(21)
.FirstPageTray = wdPrinterDefaultBin
.OtherPagesTray = wdPrinterDefaultBin
.SectionStart = wdSectionNewPage
.OddAndEvenPagesHeaderFooter = False
.DifferentFirstPageHeaderFooter = False
.VerticalAlignment = wdAlignVerticalTop
.SuppressEndnotes = False
.MirrorMargins = False
.TwoPagesOnOne = False
.BookFoldPrinting = False
.BookFoldRevPrinting = False
.BookFoldPrintingSheets = 1
.GutterPos = wdGutterPosLeft
End With
Selection.GoTo What:=wdGoToSection, Which:=wdGoToFirst, Count:=2, Name:=""
Selection.EndKey Unit:=wdStory, Extend:=wdExtend
Selection.Delete
Selection.MoveLeft Unit:=wdCharacter, Count:=1
Selection.Delete Unit:=wdCharacter, Count:=2
End Sub}

How to Search Outlook mails with in the inbox and sub folders

I have created a macro which takes the latest mail and send the reply all.
Now how do I search Inbox and sub folders and pick the latest one.
My code picks the mail only from Inbox.
Option Explicit
Public Sub TESTRUN()
Dim olApp As Outlook.Application
Set olApp = New Outlook.Application
Dim olNs As Outlook.Namespace
Set olNs = olApp.GetNamespace("MAPI")
Dim Inbox As Outlook.MAPIFolder
Set Inbox = olNs.GetDefaultFolder(olFolderInbox)
Dim Subject As String
Subject = ThisWorkbook.Sheets("SendMail").Range("B5").Text
Debug.Print Subject
Dim fpath As String
fpath = ThisWorkbook.Sheets("SendMail").Range("A8").Value
Dim i As Long
Dim Filter As String
Filter = "#SQL=" & Chr(34) & "urn:schemas:httpmail:datereceived" & _
Chr(34) & " >= '01/01/1900' And " & _
Chr(34) & "urn:schemas:httpmail:datereceived" & _
Chr(34) & " < '12/31/2100' And " & _
Chr(34) & "urn:schemas:httpmail:subject" & _
Chr(34) & "Like '%" & Subject & "%'"
Dim Items As Outlook.Items
Set Items = Inbox.Items.Restrict(Filter)
Items.Sort "[ReceivedTime]", False
For i = Items.Count To 1 Step -1
DoEvents
If TypeOf Items(i) Is MailItem Then
Dim Item As Object
Set Item = Items(i)
Debug.Print Item.Subject ' Print on Immediate Window
Debug.Print Item.ReceivedTime ' Print on Immediate Window
Dim ReplyAll As Outlook.MailItem
Set ReplyAll = Item.ReplyAll
With ReplyAll
.Subject = Left(ActiveWorkbook.Name, InStr(ActiveWorkbook.Name, ".") - 1)
.HTMLBody = "<font size=""3"" face=""Calibri"">" & _
"Hi Veronica, <br><br>" & _
"The " & Left(ActiveWorkbook.Name, _
InStr(ActiveWorkbook.Name, ".") - 1) & _
"</B> has been prepared and ready for your review.<br>" & _
"</B> <br>" & _
"" & fpath & "" & .HTMLBody
.Display
Exit For
End With
End If
Next
End Sub
You could convert your code recursive function start from Inbox :Example
Option Explicit
Public Sub Example()
Dim olNs As Outlook.NameSpace
Dim Inbox As Outlook.MAPIFolder
Set olNs = Application.GetNamespace("MAPI")
Set Inbox = olNs.GetDefaultFolder(olFolderInbox)
' // Process Current Folder
LoopFolders Inbox
Set Inbox = Nothing
End Sub
Private Function LoopFolders(ByVal ParentFldr As Outlook.MAPIFolder)
Dim Subject As String
Subject = ThisWorkbook.Sheets("SendMail").Range("B5").Text
Dim FPath As String
FPath = ThisWorkbook.Sheets("SendMail").Range("A8").Value
Dim Filter As String
Filter = "#SQL=" & Chr(34) & "urn:schemas:httpmail:datereceived" & _
Chr(34) & " >= '01/01/1900' And " & _
Chr(34) & "urn:schemas:httpmail:datereceived" & _
Chr(34) & " < '12/31/2100' And " & _
Chr(34) & "urn:schemas:httpmail:subject" & _
Chr(34) & "Like '%" & Subject & "%'"
Dim Items As Outlook.Items
Set Items = ParentFldr.Items.Restrict(Filter)
Items.Sort "[ReceivedTime]", False
Dim i As Long
For i = Items.Count To 1 Step -1
DoEvents
If TypeOf Items(i) Is MailItem Then
Dim Item As Object
Set Item = Items(i)
Debug.Print Item.Subject & " " & Item.ReceivedTime
Dim ReplyAll As Outlook.MailItem
Set ReplyAll = Item.ReplyAll
With ReplyAll
.Subject = ""
.HTMLBody = "" '
.Display
End With
Exit Function
End If
Next
Dim SubFldr As Outlook.MAPIFolder
' // Recurse through SubFldrs
If ParentFldr.Folders.Count > 0 Then
For Each SubFldr In ParentFldr.Folders
LoopFolders SubFldr
Debug.Print SubFldr.Name
Next
End If
End Function

Sync outlook messages with vbscript

I have a vbscript that copy's Outlook 2003 messages into a folder in msg format.
The problems are:
I am getting "path too long" errors for some *.msg . I wish to avoid these erros and I don't know how. ' On Error Resume Next is already on the script.
I am getting only inbox messages, but I want all subfolders too;
How can I extract this in *.txt and not in *.msg, in order to become lighter?
Here is my atual script. Thanks for the help!
On Error Resume Next
Dim myNameSpace
Dim ofChosenFolder
Dim myOlApp
Dim myItem
Dim objItem
Dim myFolder
Dim strSubject
Dim strName
Dim strFile
Dim strReceived
Dim strSavePath
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set myOlApp = CreateObject("Outlook.Application")
Set myNameSpace = myOlApp.GetNamespace("MAPI")
Const olFolderInbox = 6
Set ofChosenFolder = myNameSpace.GetDefaultFolder(olFolderInbox)
strSavePath = "c:\test\" 'OBS! use a \ at the end of the path
i = 1
For each Item in ofChosenFolder.Items
Set myItem = ofChosenFolder.Items(i)
strReceived = ArrangedDate(myitem.ReceivedTime)
' strSubject = myItem.Subject
strSubject = myitem.SenderName & "_" & myitem.Subject
strName = StripIllegalChar(strSubject)
strFile = strSavePath & strReceived & "_" & strName & ".msg"
If Not Len(strfile) > 256 then
myItem.SaveAs strfile, 3
Else
wscript.echo strfile & vbcrlf & "Path and filename too long."
End If
i = i + 1
next
Function StripIllegalChar(strInput)
'***************************************************
'Simple function that removes illegal file system
'characters.
'***************************************************
Set RegX = New RegExp
RegX.pattern = "[\" & chr(34) & "\!\#\#\$\%\^\&\*\(\)\=\+\|\[\]\{\}\`\'\;\:\<\>\?\/\,]"
RegX.IgnoreCase = True
RegX.Global = True
StripIllegalChar = RegX.Replace(strInput, "")
Set RegX = nothing
End Function
Function ArrangedDate(strDateInput)
'***************************************************
'This function re-arranges the date data in order
'for it to display in chronilogical order in a
'sorted list in the file system. It also removes
'illegal file system characters and replaces them
'with dashes.
'Example:
'Input: 2/26/2004 7:07:33 AM
'Output: 2004-02-26_AM-07-07-33
'***************************************************
Dim strFullDate
Dim strFullTime
Dim strAMPM
Dim strTime
Dim strYear
Dim strMonthDay
Dim strMonth
Dim strDay
Dim strDate
Dim strDateTime
Dim RegX
If not Left(strDateInput, 2) = "10" Then
If not Left(strDateInput, 2) = "11" Then
If not Left(strDateInput, 2) = "12" Then
strDateInput = "0" & strDateInput
End If
End If
End If
strFullDate = Left(strDateInput, 10)
If Right(strFullDate, 1) = " " Then
strFullDate = Left(strDateInput, 9)
End If
strFullTime = Replace(strDateInput,strFullDate & " ","")
If Len(strFullTime) = 10 Then
strFullTime = "0" & strFullTime
End If
strAMPM = Right(strFullTime, 2)
strTime = strAMPM & "-" & Left(strFullTime, 8)
strYear = Right(strFullDate,4)
strMonthDay = Replace(strFullDate,"/" & strYear,"")
strMonth = Left(strMonthDay, 2)
strDay = Right(strMonthDay,len(strMonthDay)-3)
If len(strDay) = 1 Then
strDay = "0" & strDay
End If
strDate = strYear & "-" & strMonth & "-" & strDay
'strDateTime = strDate & "_" & strTime
strDateTime = strDate
Set RegX = New RegExp
RegX.pattern = "[\:\/\ ]"
RegX.IgnoreCase = True
RegX.Global = True
ArrangedDate = RegX.Replace(strDateTime, "-")
Set RegX = nothing
End Function
You need to truncate the file name appropriately (strName)
Move your code that processes a folder into a sub that take fodler that takes folder as parameter and call it for ofChosenFolder as well as all of its child fodlers in the ofChosenFolder.Folders collection.
You are calling SaveAs..., 3 - 3 here is olMsg. Specify olTxt (= 0).
Off the top of my head:
Const olFolderInbox = 6
Set ofChosenFolder = myNameSpace.GetDefaultFolder(olFolderInbox)
trSavePath = "c:\test\"
ProcessFolder ofChosenFolder, trSavePath
sub ProcessFolder(folder, path)
For each Item in folder.Items
strReceived = ArrangedDate(Item.ReceivedTime)
strSubject = Item.SenderName & "_" &Item .Subject
strName = StripIllegalChar(strSubject)
strFile = strSavePath & strReceived & "_" & strName & ".msg"
If Not Len(strfile) > 256 then
Item.SaveAs strfile, 3
Else
wscript.echo strfile & vbcrlf & "Path and filename too long."
End If
next
for each subfolder in folder.Folders
ProcessFolder(subfolder, trSavePath & subfolder.Name & "\"
next
end sub

vba for each loop with multiple if

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

Resources