Sending outlook mail using VB.NET in Visual Studio 2015 - excel

I am trying to make a birthday application to read data from CSV, match today's date with DOB in the CSV file and send email to the corresponding Outlook email Id in the CSV file. We will be sending mail to Outlook Email Id's only.
I have written the code to get email addresses to which I need to send the email and I have stored them in a list. The list is iterated through and Outlook despatches an email to each. When the code reaches OutlookMessage.Send() the application doesn't do anything. Any code above OutlookMessage.Send() including Console.WriteLine() statement works properly.
arrName stores the names of the people mentioned in the CSV, arrValue is an array to store the date of birth of person mentioned, and arrEmail stores the email address.
matchName is a list, storing names of matching people according to their DOB mentioned in the CSV. matchDOB is a list to store their DOBs, and matchEmail stores email addresses.
The CSV file contains 3 columns: Name, DOB, Email ID.
The last Console.WriteLine() statement after the OutlookMessage.Send() is not working, but the one before it is fine.
Imports System.IO
Imports Microsoft.VisualBasic.FileIO.TextFieldParser
Imports outlook = Microsoft.Office.Interop.Outlook
Module Module1
Sub Main()
Dim File1 As String = File.ReadAllText("C:\Users\Music\Excel1.csv")
Dim arrName() As String
Dim arrValue() As String
Dim arrEmail() As String
Dim matchName As New List(Of String)
Dim matchDOB As New List(Of String)
Dim matchEmail As New List(Of String)
Using ioReader As New FileIO.TextFieldParser("C:\Users\Music\Excel1.csv")
ioReader.TextFieldType = FileIO.FieldType.Delimited
ioReader.SetDelimiters(",")
While Not ioReader.EndOfData
Dim arrCurrentRow As String() = ioReader.ReadFields()
If arrName Is Nothing Then
ReDim Preserve arrName(0)
ReDim Preserve arrValue(0)
ReDim Preserve arrEmail(0)
arrName(0) = arrCurrentRow(0)
arrValue(0) = arrCurrentRow(1)
arrEmail(0) = arrCurrentRow(2)
Else
ReDim Preserve arrName(arrName.Length)
ReDim Preserve arrValue(arrValue.Length)
ReDim Preserve arrEmail(arrEmail.Length)
arrName((arrName.Length - 1)) = arrCurrentRow(0)
arrValue((arrValue.Length - 1)) = arrCurrentRow(1)
arrEmail((arrEmail.Length - 1)) = arrCurrentRow(2)
End If
End While
Dim regDate As Date = Date.Now()
Dim strDate As String = regDate.ToString("dd/MMM/yyyy")
Dim index As Integer = 0
For Each element As String In arrValue
Dim compCond As Integer = String.Compare(strDate, element)
If compCond = 0 Then
matchDOB.Add(element)
matchName.Add(arrName(index))
matchEmail.Add(arrEmail(index))
End If
index = index + 1
Next
End Using
Dim OutlookMessage As outlook.MailItem
Dim AppOutlook As New outlook.Application
Dim ind As Integer = 0
For Each matchDOB1 As String In matchDOB
Try
Console.WriteLine("Starting 1")
OutlookMessage = AppOutlook.CreateItem(outlook.OlItemType.olMailItem)
Dim Recipents As outlook.Recipients = OutlookMessage.Recipients
Recipents.Add(matchEmail(ind))
OutlookMessage.Subject = matchName(ind)
OutlookMessage.Body = matchDOB1
OutlookMessage.BodyFormat = outlook.OlBodyFormat.olFormatHTML
Console.WriteLine("Before Send")
OutlookMessage.Send()
Console.WriteLine("Email Sent For " + matchName(ind))
Catch ex As Exception
Console.WriteLine("Email Not Sent")
'MessageBox.Show("Mail could not be sent") 'if you dont want this message, simply delete this line
Finally
OutlookMessage = Nothing
AppOutlook = Nothing
ind = ind + 1
End Try
Next
Console.Read()
End Sub
End Module
If I replace OutlookMessage.Send() with OutlookMessage.Display() then the Console.WriteLine("Email Not Sent") gets printed.
Just the sending mail part is left.

The last Console.WriteLine does not work because you catch an exception and do not display it
Catch ex As Exception
'MessageBox.Show("Mail could not be sent") 'if you dont want this message, simply delete this line
So first, take a look at the exception raised.
My guess is: your Visual Studio is running as administrator and not your Outlook. Both must run as the same. So restart your Outlook as administrator, or run your VS without administrator privilege

Related

Vba vba runtime error -1802485755(94904005) [duplicate]

This question already has answers here:
MailItem.GetInspector.WordEditor in Office 2016 generates Application-defined or object defined error
(4 answers)
Closed 3 months ago.
i have a strange problem, vba return me the error vba runtime error -1802485755(94904005) and i searched on internet and i found nothing, so i am tring to ask here if someone can help me
here is the code
Private Sub CommandButton3_Click()
Dim str As New Classe1
Dim ricerca As String
Dim dmi As outlook.MailItem
Dim UTCdate As Date, UTCdate2 As Date
Dim out As outlook.Application
Dim DATA1 As Date
Dim DATA2 As Date
Dim errorN As Long
On Error GoTo FormatoErrato:
DATA1 = DateAdd("h", 1, Res.DataStart.Value)
DATA2 = DateAdd("h", 23, Res.DataEnd.Value)
On Error GoTo 0
Set out = New outlook.Application
Set dmi = out.CreateItem(olMailItem)
UTCdate = dmi.PropertyAccessor.LocalTimeToUTC(DATA1)
UTCdate2 = dmi.PropertyAccessor.LocalTimeToUTC(DATA2)
ricerca = "#SQL=""urn:schemas:httpmail:subject"" LIKE '%sometext%'" & _
" AND ""urn:schemas:httpmail:datereceived"" <= '" & UTCdate2 & "'" & _
" AND ""urn:schemas:httpmail:datereceived"" >= '" & UTCdate & "'"
str.prova (ricerca)
FormatoErrato:
errorN = Err.Number
If errorN = 13 Then
MsgBox "invalid format", vbCritical
End If
End Sub
this code (in a class module) is on a userform button where you set two dates and then the following code search the emails that strike the requirments
Sub prova(val As String)
Res.Mezzi.Clear
Dim fol As outlook.Folder
Dim arr, arr2
Dim ricerca As String, txt As String
Dim n As Long, s As Long, tot As Long, l As Long
Dim mi As outlook.MailItem
Dim i As Object
Dim doc As Word.Document
Set fol = 'outlook folder path'
s = 0
n = 1
ReDim Preserve arr2(0 To s)
For Each i In fol.Items.Restrict(val)
If i.Class = olMail Then
Set mi = i
Set doc = mi.GetInspector.WordEditor
If doc.Tables.Count > 0 Then
For tot = 1 To doc.Tables.Count
arr2(s) = Application.WorksheetFunction.Clean(doc.Tables(tot).Cell(2, 2).Range.Text)
s = s + 1
ReDim Preserve arr2(0 To s)
Next tot
End If
End If
Next i
For s = 0 To UBound(arr2)
If IsEmpty(arr2(s)) = False And arr2(s) <> "" Then
Res.Mezzi.AddItem arr2(s)
End If
Next s
End Sub
the email that i'm looking for has a table, one or more in it so i used getinspector.wordeditor to check if the table exist and then take the data that i need from it.
the sub works fine if the difference between the dates is just few days if i put a week give that error
coudl you help me to solve the problem or work around it?
thanks in advance
I didn't find any information which Office version is installed on the system. So, if you have a pretty old version of MS Office installed the following case makes sense - the WordEditor property is only valid if the IsWordMail method returns True and the EditorType property is olEditorWord.
The most-likely possible reason for such errors at runtime is security settings when dealing with the Outlook object model. The message body is a protected property in the Outlook object model which can generate errors when Outlook is automated from an external application. You can find the list of protected properties described on the Protected Properties and Methods page.
So, the Object Model Guard warns users and prompts users for confirmation when untrusted applications attempt to use the object model to obtain email address information, store data outside of Outlook, execute certain actions, and send email messages. If, for any reason, the warning is not appropriate or can't be displayed, the Outlook object model may generate errors when accessing protected properties.
In your scenario you can:
Use a low-level API which doesn't trigger security issues in the Outlook object model - Extended MAPI or any other third-party wrapper around that API.
Create a COM add-in which has access to the trusted Application object and which doesn't trigger security issues.
Install any AV with the latest updates.
Use group policy settings to setup security settings to not trigger security issues.
after many trials i think i solved
to avoid to raise the error i should close the inspector.
in this way:
If i.Class = olMail Then
Set mi = i
Set insp = mi.GetInspector
Set doc = insp.WordEditor
If doc.Tables.Count > 0 Then
For tot = 1 To doc.Tables.Count
arr2(s) = Application.WorksheetFunction.Clean(doc.Tables(tot).Cell(2, 2).Range.Text)
s = s + 1
ReDim Preserve arr2(0 To s)
Next tot
End If
End If
insp.Close olSave
now all seems to work fine even with range of 10 days of emails

validate strings in an excel in vb.net

I have a question, in vb.net, how can i validate that 2 values are the same in an excel in vb.net
for example i have defined 3 list
Public NSPS As New List(Of String)
Public CONTAINER As New List(Of String)
Public CONTAINER2 As New List(Of String)
I have 2 excel files where CONTAINER and CONTAINER2 are id's
So i need to create a third excel file that filters only the id's that repeat themselves in the 2 excel
meaning if i have an id: CARU9891569 in the 2 files, only then it transfers to the generated excel
and the 2 excel's have some extra information, for example: excel 1 has the variables: DELIVERY, CONTAINER, VOLUME.
the second excel has the variables: NSPS, NPOS, PACKAGES, CONTAINER2
SO the generated excel needs to have all of the variables: DELIVERY, CONTAINER, VOLUME, NSPS, NPOS, PACKAGES. using CONTAINER as the filter
to just fill information in a new excel i use this code
i use a function like this to extract the information from the excel files
Function extraer_valores_planilla(ByRef ruta As String) As Boolean
ExcelPackage.LicenseContext = LicenseContext.NonCommercial
Try
Dim stream = System.IO.File.OpenRead(ruta)
Dim package = New OfficeOpenXml.ExcelPackage(stream)
'// Libro
Dim Workbook = package.Workbook
'// Hojas
Dim hojas = Workbook.Worksheets
' While (Workbook.Worksheets.Count >= aux)
Dim hojaUsuarios = Workbook.Worksheets(Workbook.Worksheets.Item(0).ToString)
Dim indice As Integer = 2
While (indice < 5000)
'Numero entrega'
If (IsNothing(hojaUsuarios.Cells("A" & indice).Value) = False) Then
NSPS.Add(hojaUsuarios.Cells("A" & indice).Value)
End If
indice += 1
End While
indice += 1
Catch EX As Exception
MsgBox(EX.ToString)
Return False
End Try
Return True
and then i fill the third excel like this
Private Sub Button5_Click(sender As Object, e As EventArgs) Handles Button5.Click
ExcelPackage.LicenseContext = LicenseContext.NonCommercial
Dim path As String = seleccionardirectorio("Excel|.xlsx")
If (String.IsNullOrWhiteSpace(path) = False) Then
Dim excel = New ExcelPackage(New FileInfo(path))
excel.Workbook.Worksheets.Add("Hoja1")
Dim aux As Integer = 1
Dim Workbook = excel.Workbook
Dim hojas = Workbook.Worksheets
Dim dict As New Dictionary(Of String, String)
Dim hoja1 = Workbook.Worksheets("Hoja1")
'DAMOS NOMBRE A LAS COLUMNAS
INICIALIZAR_PLANILLA(hoja1)
While (aux <= CONTAINER.Count)
hoja1.Cells("C" & aux + 1).Value = ENTREGA.Item(aux - 1)
aux += 1
End While
this is the same for all variables i just resume for you guys and this works just fine.
should i use 2 cicles to filter the excel, maybe a for each, sorry i am new to programing and i am stuck in this part
any ideas would be helpfull
Thanks in advance!
yes, use 2 for each loops.
for each item in list
for each otheritem in list2
if item = otheritem then
' These items match
end if
next
next
Replace the dummy variables with yours

Retrieving Outlook email data using Excel VBA

I am trying to grab the following details from the sent items folder with subject "Index Coverage".
Sent by
Sent to
Subject
Sent on (date)
email body
I am using formulas in the sheet with code in the ThisOutlookSession module
Index: =TRIM(MID(G2,SEARCH("Code",G2)+(8+LEN("Code")),20))
Our client: =LEFT(I2,FIND("on",I2)-1)
End client: =LEFT(K2,FIND(".",K2)-1)
Const strFilePath As String = "C:\Users\Public\Documents\Excel\OutlookMailItemsDB.xlsx"
Const strSubjectLineStartWith As String = ""
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
Dim varArray As Variant
Dim strSub As String
Dim strBody As String
Dim strArray() As String
Dim lngLoop As Long
Dim objItem As Object
Dim lngMailCounter As Long
Dim objMItem As MailItem
strArray = Split(EntryIDCollection, ",")
For lngMailCounter = LBound(strArray) To UBound(strArray)
Set objItem = Session.GetItemFromID(strArray(lngMailCounter))
If TypeName(objItem) = "MailItem" And InStr(1, objItem.Subject, strSubjectLineStartWith) And InStr(1, objItem.Body, "") Then
Set objMItem = objItem
With CreateObject("Excel.Application").workbooks.Open(strFilePath)
With .sheets(1)
With .cells(.rows.Count, 1).End(-4162)(2).resize(1, 7)
.Value = Array(objMItem.SenderEmailAddress, objMItem.To, objMItem.CC, objMItem.BCC, objMItem.Subject, objMItem.ReceivedTime, objMItem.Body)
End With
End With
.Close 1
End With
Set objItem = Nothing
End If
Next lngMailCounter
If Not IsEmpty(strArray) Then
Erase strArray
End If
End Sub
I am able to grab:
sent by
subject
sent on
Body
Index
Our client
End client
I am not able to grab the recipient contact details.
Also the Excel sheet placed on the desktop needs to be saved and closed on its own so that next time it doesn't throw an error that Excel is not closed.
Also it should consider the sent items folder with the following subject line: "Index Coverage".
Also to grab the details for Index, Our client and End client I am using Excel formulas. Is it possible to achieve this via VBA?
First of all, creating a new Excel instance in the NewMailEx event handler each time a new email is received is not really a good idea. I'd suggest keeping a reference when the add-in works (like a singleton) to prevent any additional workload when receiving a new item.
Try to use the Recipients property of the MailItem class instead of using the To, Cc or Bcc fields. The Recipients collection returns a Recipients collection that represents all the recipients for the Outlook item. Use Recipients(index) where index is the name or index number, to return a single Recipient object. The name can be a string representing the display name, the alias, or the full SMTP email address of the recipient.
Finally, to process items added to the sent items folder you need to handle ItemAdd event which is fired when one or more items are added to the specified collection.
Public WithEvents myOlItems As Outlook.Items
Public Sub Initialize_handler()
Set myOlItems = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderSentItems).Items
End Sub
Private Sub myOlItems_ItemAdd(ByVal Item As Object)
' your code for processing the Item object goes there
End Sub

Get the Nth index of an array in VBA

I am a noob in VBA and can't find a way to get the element of an array at a given index... It might be easy for you, though.
I have an excel file with 2 columns, "Emails" and "Categories", and I want to filter out all emails for a given category.
I ended up so far with the following code:
Sub filterEmails()
Dim tbl As ListObject
Dim emails As Variant
Dim email As String
Dim categories As Variant
Dim category As String
Dim i As Integer
Set tbl = ActiveWorkbook.Worksheets("Feuil1").ListObjects("Tableau1")
emails = tbl.ListColumns("EMAILS").DataBodyRange.Value
categories = tbl.ListColumns("SERVICES").DataBodyRange.Value
i = 1
For Each email In emails
category = ???
If category = "some service" Then
MsgBox email
End If
i = i + 1
Next email
End Sub
I tried many ways to get the ith item from the categories array, like categories(i) but didn't succeed. It might be because I wasn't able to initialize variables with the right type.
I would do it this way:
Sub filterEmails()
Dim tbl As ListObject
Dim emails As Variant
Dim email As String
Dim categories As Variant
Dim category As String
Dim i As Long '<< always best to prefer Long over Integer
Set tbl = ActiveWorkbook.Worksheets("Feuil1").ListObjects("Tableau1")
'Both "emails" and "categories" will be 2-D arrays
emails = tbl.ListColumns("EMAILS").DataBodyRange.Value
categories = tbl.ListColumns("SERVICES").DataBodyRange.Value
For i = lbound(emails,1) to ubound(emails, 1)
category = categories(i, 1)
If category = "some service" Then
MsgBox email
End If
Next i
End Sub
Here's your code, changed it a little, It should work now:
Option Explicit
Sub filterEmails()
Dim tbl As ListObject
Dim emails As Variant
Dim email As Variant
Dim categories As Variant
Dim category As String
Dim i As Integer
Set tbl = ActiveWorkbook.Worksheets("Feuil1").ListObjects("Tableau1")
emails = tbl.ListColumns("EMAILS").DataBodyRange.Value
categories = Application.Transpose(tbl.ListColumns("SERVICES").DataBodyRange.Value)
i = 1
For Each email In emails
category = categories(i)
If category = "some service" Then
MsgBox email
End If
i = i + 1
Next email
End Sub
Comments:
categories(i)
That command wont work because categories is a 2 dimension array, I store it as 1 dimensional array using Application.transpose command.

Collate tables from outlook mails into an Excel sheet using Excel VBA

I have an Excel file which will be used as a tool collate tables from mails. One mail will have only one table and one record in it. I need to collate the records in all such tables (from different mails) into One Excel table. I have the following code to do it. This code when run, copies the entire text in body of mail to Excel (So the code works only if the mail has Table with no other text in the body of mail). But I need to copy only the Table present in the mail to Excel. Please help me modify the code to do this. Please note that I do not want to write any code in outlook. Also the copied table is pasted as text. I want them to get pasted in table format. The part of the code which will need modification is shown below.
Public Sub ExportToExcel1()
Application.ScreenUpdating = False
'Variable declaration
Dim i As Integer
Dim ns As Namespace
Dim Inbox As Outlook.MAPIFolder
Dim item As Object
Dim doClip As MSForms.DataObject
Dim d As String
'Set values for variables
i = 2
d = ActiveSheet.Range("subject").Value
Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
Set doClip = New MSForms.DataObject
'Loop to check mails and pull data
For Each item In Inbox.Items
If TypeName(item) = "MailItem" And item.Subject = d Then
doClip.SetText item.Body
doClip.PutInClipboard
ActiveSheet.Cells(1, 1).PasteSpecial "Text"
EndSub
There are two mistakes in your code:
You access item.Body which is the text body when you need the Html body.
You paste the entire body into the worksheet when you only want the table.
You need some extra variables:
Dim Html As String
Dim LcHtml As String
Dim PosEnd As Long
Dim PosStart As Long
Replace the If statement with:
If TypeName(item) = "MailItem" And item.Subject = d Then
Html = item.HTMLBody
LcHtml = LCase(Html)
PosStart = InStr(1, LcHtml, "<table")
If PosStart > 0 Then
PosEnd = InStr(PosStart, LcHtml, "</table>")
If PosEnd > 0 Then
Debug.Print "[" & Mid(Html, PosStart, PosEnd + 8 - PosStart) & "]"
doClip.SetText Mid(Html, PosStart, PosEnd + 8 - PosStart)
doClip.PutInClipboard
ActiveSheet.Cells(1, 1).PasteSpecial "Text"
End If
End If
End If

Resources