I'm trying to extract information from unread e-mails in a specific folder and paste it in a structured Excel file.
I need the subject, the body, the sender, received time, conversation ID and the attachment names.
Important: it has to be an Outlook macro and not an Excel macro.
I have the following code but it is giving me
"runtime error '9': subscript out of range.
Sub WriteTextFile()
Dim wkb As Workbook
Set wkb = Workbooks.Open("C:\Users\bebxadvypat\Desktop\Test VBA Macros.xlsx")
Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = True
Set Workbook = objExcel.Workbooks.Open("C:\Users\bebxadvypat\Desktop\Test VBA Macros.xlsx")
Dim objNS As Outlook.NameSpace
Dim objFolder As Outlook.MAPIFolder
Dim row As Integer
row = 2
objExcel.Worksheets("Sheet1").Cells(1, 1).Value = "Sender"
objExcel.Worksheets("Sheet1").Cells(1, 2).Value = "Subject"
objExcel.Worksheets("Sheet1").Cells(1, 3).Value = "Date"
objExcel.Worksheets("Sheet1").Cells(1, 4).Value = "ID"
objExcel.Worksheets("Sheet1").Cells(1, 5).Value = "Body"
Set objNS = GetNamespace("MAPI")
Set objFolder = objNS.Folders.GetLast
Set objFolder = objFolder.Folders("Deleted Items")
For Each item In objFolder.Items
objExcel.Worksheets("Sheet1").Cells(row, 1).Value = item.sender
objExcel.Worksheets("Sheet1").Cells(row, 2).Value = item.Subject
objExcel.Worksheets("Sheet1").Cells(row, 3).Value = item.ReceivedTime
objExcel.Worksheets("Sheet1").Cells(row, 4).Value = item.ConversationID
objExcel.Worksheets("Sheet1").Cells(row, 5).Value = item.Body
Next
Workbook.Save
Workbook.Saved = True
Workbook.Close
objExcel.Quit
Set Workbook = Nothing
Set objExcel = Nothing
End Sub
According to test your code, you could try to add row = row+1 and use this method to get Delete Items:
Set olNs = Application.GetNamespace("MAPI")
Set DeletedFolder = olNs.GetDefaultFolder(olFolderDeletedItems)
For Each Item In objFolder.Items
objExcel.Worksheets("Sheet1").Cells(row, 1).Value = Item.Sender
objExcel.Worksheets("Sheet1").Cells(row, 2).Value = Item.Subject
objExcel.Worksheets("Sheet1").Cells(row, 3).Value = Item.ReceivedTime
objExcel.Worksheets("Sheet1").Cells(row, 4).Value = Item.ConversationID
objExcel.Worksheets("Sheet1").Cells(row, 5).Value = Item.Body
row = row + 1
Next
Related
I am using a script to download my Outlook calendar in Excel format to my hard drive. Every time I use it I get a prompt saying that the file already exists as the previously downloaded file is still there.
Is there a way to suppress this prompt? I want to overwrite without having to manually click yes.
Sub calendar_download()
Dim myNameSpace As Outlook.NameSpace
Dim tdystart As Date
Dim tdyend As Date
Dim myAppointments As Outlook.Items
Dim currentAppointment As Outlook.AppointmentItem
Dim xlApp As Object
Dim xlWorkbook As Object
Dim xlWorksheet As Object
Dim i As Long
Set xlApp = CreateObject("Excel.Application")
Set xlWorkbook = xlApp.Workbooks.Add
Set xlWorksheet = xlWorkbook.Worksheets(1)
With xlWorksheet
.Cells(1, 1).Value = "Body"
.Cells(1, 2).Value = "Start"
.Cells(1, 3).Value = "End"
.Cells(1, 4).Value = "Subject"
End With
Set myNameSpace = Application.GetNamespace("MAPI")
tdystart = VBA.Format(Now, "Short Date")
tdyend = VBA.Format(Now + 1, "Short Date")
Set myAppointments = myNameSpace.GetDefaultFolder(olFolderCalendar).Items
myAppointments.Sort "[Start]"
myAppointments.IncludeRecurrences = True
Set currentAppointment = myAppointments.Find("[Start] >= """ & tdystart & """ and [Start] <= """ & tdyend & """")
i = 2
While TypeName(currentAppointment) <> "Nothing"
Debug.Print currentAppointment.Subject
xlWorksheet.Cells(i, 1).Value = currentAppointment.Body
xlWorksheet.Cells(i, 2).Value = currentAppointment.Start
xlWorksheet.Cells(i, 3).Value = currentAppointment.End
xlWorksheet.Cells(i, 4).Value = currentAppointment.Subject
i = i + 1
Set currentAppointment = myAppointments.FindNext
Wend
xlWorksheet.Columns("A:D").EntireColumn.AutoFit
xlWorkbook.SaveAs "C:\calendar\Calendardownload.xlsx" ' <------- Change this Path to the location you want to save the file to
xlWorkbook.Close
End Sub
You can delete the existing file before saving. Insert the following lines before xlWorkbook.SaveAs ...:
If Len(Dir("C:\calendar\Calendardownload.xlsx")) <> 0 Then
Kill "C:\calendar\Calendardownload.xlsx"
End If
It will first test if the file exists.
DisableAlerts, then re-enable Alerts
Application.DisplayAlerts = False
"YOUR CODE WHICH CAUSES THE ALERT"
Application.DisplayAlerts = True
I have an Excel sheet with email addresses, To, CC, Subject etc.
I have file paths to each attachment. These are statements. Some .PDF and some .XLSX depending on the request. Although I have the file path to each, some have multiple Columns E-L but not all rows will have a file path and not always a statement at the end of the path.
I need the VBA code to ignore blanks and missing files only attaching as found. This can be as many as 9 files or as little as one or none by row to recipient.
I cannot get it to run without error, in my Test environment, ignoring blank cells with no path or paths that do not have a file.
Sub SendMail()
Dim objOutlook As Object
Dim objMail As Object
Dim ws As Worksheet
Set objOutlook = CreateObject("Outlook.Application")
Set ws = ActiveSheet
For Each cell In ws.Range("A2:A196")
Set objMail = objOutlook.CreateItem(0)
With objMail
.To = cell.Value
.CC = cell.Offset(0, 1).Value
.Subject = cell.Offset(0, 2).Value
.Body = cell.Offset(0, 3).Value
.Attachments.Add cell.Offset(0, 4).Value
.Attachments.Add cell.Offset(0, 5).Value
.Attachments.Add cell.Offset(0, 6).Value
.Attachments.Add cell.Offset(0, 7).Value
.Attachments.Add cell.Offset(0, 8).Value
.Display
End With
Set objMail = Nothing
Next cell
Set ws = Nothing
Set objOutlook = Nothing
End Sub
This is my first VBA project.
Try it this way, and feel free to modify the code to suit your needs, of course..
Make a list in Sheets("Sheet1") with :
In column A : Names of the people
In column B : E-mail addresses
In column C:Z : Filenames like this C:\Data\Book2.xls (don't have to be Excel files)
The Macro will loop through each row in "Sheet1" and if there is a E-mail address in column B
and file name(s) in column C:Z it will create a mail with this information and send it.
Sub Send_Files()
'Working in Excel 2000-2016
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
Dim OutApp As Object
Dim OutMail As Object
Dim sh As Worksheet
Dim cell As Range
Dim FileCell As Range
Dim rng As Range
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set sh = Sheets("Sheet1")
Set OutApp = CreateObject("Outlook.Application")
For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)
'Enter the path/file names in the C:Z column in each row
Set rng = sh.Cells(cell.Row, 1).Range("C1:Z1")
If cell.Value Like "?*#?*.?*" And _
Application.WorksheetFunction.CountA(rng) > 0 Then
Set OutMail = OutApp.CreateItem(0)
With OutMail
.to = cell.Value
.Subject = "Testfile"
.Body = "Hi " & cell.Offset(0, -1).Value
For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
If Trim(FileCell) <> "" Then
If Dir(FileCell.Value) <> "" Then
.Attachments.Add FileCell.Value
End If
End If
Next FileCell
.Send 'Or use .Display
End With
Set OutMail = Nothing
End If
Next cell
Set OutApp = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
https://www.rondebruin.nl/win/s1/outlook/amail6.htm
This will ignore your blanks cells in your range, assuming the values you want to ignore are in your Range A2 - A196.
Here, ignore really means to skip down to "Else" where your loop will start over. It is being ignored in the sense that the IF statement is telling it to do nothing when blank. The next line is "Next Cell" which will give you the desired result.
Sub SendMail()
Dim objOutlook As Object
Dim objMail As Object
Dim ws As Worksheet
Set objOutlook = CreateObject("Outlook.Application")
Set ws = ActiveSheet
For Each cell In ws.Range("A2:A196")
If cell.value <> "" Then 'If NOT blank, do this (your code)
Set objMail = objOutlook.CreateItem(0)
With objMail
.To = cell.Value
.CC = cell.Offset(0, 1).Value
.Subject = cell.Offset(0, 2).Value
.Body = cell.Offset(0, 3).Value
.Attachments.Add cell.Offset(0, 4).Value
.Attachments.Add cell.Offset(0, 5).Value
.Attachments.Add cell.Offset(0, 6).Value
.Attachments.Add cell.Offset(0, 7).Value
.Attachments.Add cell.Offset(0, 8).Value
.Display
End With
Set objMail = Nothing
Else 'If IS blank, do this (next cell)
End If
Next cell
Set ws = Nothing
Set objOutlook = Nothing
End Sub
I am running a macro for sending mails to multiple recipients via Outlook with one or more attachments through vba excel. I am not well versed in macros and hence took some inputs from various sources and came upon the below final code.
However I have mentioned max. limit of 3 file attachments which is constant for all recipients but have to disable by commenting whenever I have to attach only 1 or 2 files accordingly like e.g in the below code I have disabled the 2nd and 3rd attachment columns for attaching 1 file across.
Is there any way where the macro would automatically take the inputs according to the values entered and left blank e.g If one recipient has 1 attachment and the next recipient has 2 or 3 attachments
Sub SendMail()
Dim objOutlook As Object
Dim objMail As Object
Dim ws As Worksheet
Set objOutlook = CreateObject("Outlook.Application")
Set ws = ActiveSheet
For Each cell In ws.Range("A2:A1000")
Set objMail = objOutlook.CreateItem(0)
With objMail
.To = cell.Value
.Cc = cell.Offset(0, 1).Value
.Bcc = cell.Offset(0, 2).Value
.Subject = cell.Offset(0, 3).Value
.Body = cell.Offset(0, 4).Value
.Attachments.Add cell.Offset(0, 5).Value
'.Attachments.Add cell.Offset(0, 6).Value
'.Attachments.Add cell.Offset(0, 7).Value
.Send
End With
Set objMail = Nothing
Next cell
Set ws = Nothing
Set objOutlook = Nothing
End Sub
Dim i As Long, c As Range
'....
With objMail
.To = cell.Value
.Cc = cell.Offset(0, 1).Value
.Bcc = cell.Offset(0, 2).Value
.Subject = cell.Offset(0, 3).Value
.Body = cell.Offset(0, 4).Value
For i = 5 to 6
Set c = cell.Offset(0, i)
If c.Value <> "" Then .Attachments.Add c.Value
Next i
.Send
End With
'....
I have the below code that I am trying to modify to split a subject line into to six columns to view in Excel.
Sub subject2excel()
On Error Resume Next
Set myOlApp = Outlook.Application
Set mynamespace = myOlApp.GetNamespace("mapi")
Set myfolder = myOlApp.ActiveExplorer.CurrentFolder
Set xlobj = CreateObject("excel.application.14")
xlobj.Visible = True
xlobj.Workbooks.Add
'Set Heading
xlobj.Range("a" & 1).Value = "From"
xlobj.Range("b" & 1).Value = "Subject"
For i = 1 To myfolder.Items.Count
Set myitem = myfolder.Items(i)
msgtext = myitem.Body
xlobj.Range("a" & i + 1).Value = myitem.Sender
xlobj.Range("b" & i + 1).Value = myitem.Subject
Next
End Sub
My data is in the below format
SLWP Moncton | Cable Service Eng. | 21-Jul-15 | Shift End: 0:00 | Leave Time: entire day | SLWP (Unpaid)
So in total 7 columns I plan to leave is below.
Sender
Location
LOB
Date
Shift End Time
Shift Leave Time
Leave Type
In it's current state as you can see it only produces two columns and I do not know how to break the subject line apart.
Any help will be most appreciated.
Thanks
Use Split.
Sub subject2excel()
Dim myOlApp As Outlook.Application
Dim myFolder As folder
Dim xlobj As Object
Dim i As Long
Dim j As Long
Dim myitem As Object
Dim Words() As String
'On Error Resume Next
Set myOlApp = Outlook.Application
'Set myNameSpace = myOlApp.GetNamespace("mapi")
Set myFolder = myOlApp.ActiveExplorer.currentFolder
Set xlobj = CreateObject("excel.application.14")
xlobj.Visible = True
xlobj.Workbooks.Add
'Set Heading
xlobj.Range("a" & 1).Value = "From"
xlobj.Range("b" & 1).Value = "Subject"
For i = 1 To myFolder.Items.count
Set myitem = myFolder.Items(i)
If TypeOf myitem Is MailItem Then
'msgText = myitem.body
xlobj.Range("a" & i + 1).Value = myitem.Sender
'xlobj.Range("b" & i + 1).Value = myitem.Subject
Words = Split(myitem.Subject, " | ")
For j = 0 To UBound(Words)
Debug.Print Words(j)
Next j
End If
Next i
exitRoutine:
Set myOlApp = Nothing
Set myFolder = Nothing
Set xlobj = Nothing
Set myitem = Nothing
End Sub
I was able to solve the issue
Sub subject2excel()
Dim olFolder As Outlook.Folder
Dim olItem As Outlook.MailItem
Dim olNS As Outlook.NameSpace
Dim xlApp As Object
Dim xlWB As Object
Dim i As Long
Dim j As Long
Dim vSubject As Variant
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If Err <> 0 Then
Set xlApp = CreateObject("Excel.Application")
End If
On Error GoTo 0 'err_Handler
xlApp.Visible = True
Set xlWB = xlApp.Workbooks.Add
'Set Heading
With xlWB.Sheets(1)
.Range("A" & 1).Value = "Sender"
.Range("B" & 1).Value = "Location"
.Range("C" & 1).Value = "LOB"
.Range("D" & 1).Value = "Date"
.Range("E" & 1).Value = "Shift End Time"
.Range("F" & 1).Value = "Requested Leave Time"
.Range("G" & 1).Value = "Paid/Unpaid"
End With
'Fill sheet
Set olNS = GetNamespace("MAPI")
Set olFolder = olNS.PickFolder
For i = 1 To olFolder.Items.Count
Set olItem = olFolder.Items(i)
If InStr(1, olItem.Subject, "|") > 0 Then
vSubject = Split(olItem.Subject, "|")
With xlWB.Sheets(1)
.Range("A" & i + 1).Value = olItem.Sender
.Range("B" & i + 1).Value = vSubject(0)
.Range("C" & i + 1).Value = vSubject(1)
.Range("D" & i + 1).Value = vSubject(2)
.Range("E" & i + 1).Value = Trim(Mid(vSubject(3), InStr(1, vSubject(3), Chr(58)) + 1))
.Range("F" & i + 1).Value = Trim(Mid(vSubject(4), InStr(1, vSubject(4), Chr(58)) + 1))
.Range("F" & i + 1).HorizontalAlignment = -4152 'align right
.Range("G" & i + 1).Value = Replace(Trim(Mid(vSubject(5), InStrRev(vSubject(5), Chr(40)) + 1)), Chr(41), "")
End With
End If
Next i
xlWB.Sheets(1).UsedRange.Columns.Autofit
exitRoutine:
Set olFolder = Nothing
Set xlApp = Nothing
Set xlWB = Nothing
Set olItem = Nothing
lbl_Exit:
Exit Sub
err_Handler:
GoTo lbl_Exit
End Sub
My query is , i have below vba code trying to extract the outlook contents of a Particular Date - but my issue is whenever i try to run this code all the emails irrespective of the my required dates are being extracted:-
Sub GetFromInbox()
Dim olApp As Outlook.Application
Dim olNs As Namespace
Dim Fldr As MAPIFolder
Dim olMail As Object
Dim i As Integer
Dim Dstr As Date
Dim itms As Outlook.Items
Dim filteredItms As Outlook.Items
On Error GoTo err
dStart = Application.InputBox("Enter you start date in MM/DD/YYYY")
If dStart = Empty Then
MsgBox "Start date cannot be empty, please run it again"
Exit Sub
End If
Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
Set Fldr = olNs.Application.ActiveExplorer.CurrentFolder
MsgBox Fldr
i = 2
Do
For Each olMail In Fldr.Items
If olMail.Subject = "Test - 153EN" Then
Sheet3.Range(Cells(2, 8), Cells(2, 100)).ClearContents
Sheet3.Cells(i, 1).Value = olMail.Subject
Sheet3.Cells(i, 2).Value = olMail.ReceivedTime
Sheet3.Cells(i, 3).Value = olMail.Sender
i = i + 1
End If
Next olMail
Loop Until (DateValue(olMail.ReceivedTime) = dStart)
err:
'Display the error message in Status bar
If err.Number > 0 Then
Application.StatusBar = err.Description
MsgBox "Err#" & err.Number & " " & err.Description
End If
Set Fldr = Nothing
Set olNs = Nothing
Set olApp = Nothing
End Sub
I have noticed the following code:
Do
For Each olMail In Fldr.Items
If olMail.Subject = "Test - 153EN" Then
Sheet3.Range(Cells(2, 8), Cells(2, 100)).ClearContents
Sheet3.Cells(i, 1).Value = olMail.Subject
Sheet3.Cells(i, 2).Value = olMail.ReceivedTime
Sheet3.Cells(i, 3).Value = olMail.Sender
i = i + 1
End If
Next olMail
Loop Until (DateValue(olMail.ReceivedTime) = dStart)
The fact is that the Do loop is ignored and you iterate over all items in the folder using the following loop inside:
For Each olMail In Fldr.Items
You need to use the Find/FindNext or Restrict methods of the Items class instead. The following articles describe them in depth:
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
Remove the Do Loop and inside the For Loop and another outer If/then statement conditioned to your date specification:
For Each olMail In Fldr.Items
If (DateValue(olMail.ReceivedTime) = dStart) Then
If olMail.Subject = "Test - 153EN" Then
Sheet3.Range(Cells(2, 8), Cells(2, 100)).ClearContents
Sheet3.Cells(i, 1).Value = olMail.Subject
Sheet3.Cells(i, 2).Value = olMail.ReceivedTime
Sheet3.Cells(i, 3).Value = olMail.Sender
i = i + 1
End If
End If
Next olMail