How would I get a folder that I, as a user, have been added to.
I need to do an addin for work, how would I access an inbox which isn't mine?
So the top one is my personal inbox, I need to access the inbox within 'MIS'.
Private Sub ThisApplication_NewMail() Handles Application.NewMail
Dim myNameSpace = Application.GetNamespace("MAPI")
Dim oParentFolder = myNameSpace.Folders("MIS")
Dim mis = oParentFolder.Folders.Item("Inbox")
Dim moveMail As Outlook.MailItem = Nothing
Dim mItems As Outlook.Items = mis.Items
mItems.Restrict("[Read] = true")
Dim destFolder As Outlook.MAPIFolder = mis.Folders("Test")
Dim SubjName = "TestingAddin123"
Dim sender As String = "michael"
Dim FName As String = "[Some recurring subject]"
Dim tStamp As String = Format(DateTime.Now, "ddMMyy").ToString()
Try
For Each eMail As Object In mItems
moveMail = TryCast(eMail, Outlook.MailItem)
If Not moveMail Is Nothing Then
If InStr(moveMail.SenderEmailAddress, sender) Then
If InStr(moveMail.Subject, SubjName) > 0 Then
Dim rn As New Random
Dim n = rn.Next(1, 9999)
'n()
moveMail.SaveAs("W:\NS\" & FName & "_" & tStamp & n.ToString() + ".html", Outlook.OlSaveAsType.olHTML)
moveMail.Move(destFolder)
End If
End If
End If
Next eMail
Catch ex As Exception
MsgBox(ex.Message)
End Try
End Sub
So I'm using the above code so far but I don't seem to be able to find the MIS Inbox.
How would I achieve this?
Try to use the Namespace.CreateRecipient / Namespace.GetSharedDefaultFolder methods.
Related
I am trying to adapt an outlook vba script that shows if a named meeting series is expiring on that day. I would like to make it look through all my meeting series, and show a reminder message for any when the end date is within the next 30 days.
Here is a start of what I currently have that will work if I supply the one meeting name (TestRecur):
Sub ExtendAppointmentSample()
Dim myApptItem As Outlook.AppointmentItem
Dim myRecurrPatt As Outlook.RecurrencePattern
Dim myNamespace As Outlook.NameSpace
Dim myFolder As Outlook.Folder
Dim myItems As Outlook.Items
Dim QuestionToMessageBox
QuestionToMessageBox = "Appointment is about to expire, would you like to extend it?"
Set myNamespace = Application.GetNamespace("MAPI")
Set myFolder = myNamespace.GetDefaultFolder(olFolderCalendar)
Set myItems = myFolder.Items
' specify the Item Object here but I would like it to cycle through all meeting series and look for those ending within 30 days
Set myApptItem = myItems.Item("TestRecur")
Set myRecurrPatt = myApptItem.GetRecurrencePattern
If myRecurrPatt.PatternEndDate < DateAdd("d", 30, Date) Then
YesOrNoAnswerToMessageBox = MsgBox(QuestionToMessageBox, vbInformation, "Extend")
'Next line does not work; not sure how to get each Meeting Title
'MsgBox (MeetingTitle)
End If
End Sub
show meeting series expiring in the next 30 days
In that case you need to find all meetings that take place during these 30 days in the calendar. Then you can check their PatternEndDate property value when they ends. To get all calendar items for a specific time frame you can use the Find/FindNext or Restrict methods of the Items class. Read more about these methods in the articles that I wrote for the technical blog:
How To: Retrieve Outlook calendar items using Find and FindNext methods
How To: Use Restrict method in Outlook to get calendar items
For example, you may use the following code to find appointments for a specific time frame (VB.NET):
Private Sub FindActiveAppointments(folder As Outlook.MAPIFolder)
Dim dateTimeStart As String = DateTime.Now.ToString("MM/dd/yyyy hh:mm tt")
Dim dt As DateTime = New DateTime(DateTime.Now.Year, DateTime.Now.Month, _
DateTime.Now.Day, 23, 59, 0, 0)
Dim dateTimeEnd As String = dt.ToString("MM/dd/yyyy hh:mm tt")
Dim searchCriteria As String = "[Start]<=""" + dateTimeEnd + """ AND [End]>=""" + _
dateTimeStart + """"
Dim strBuilder As StringBuilder = Nothing
Dim counter As Integer = 0
Dim appItem As Outlook._AppointmentItem = Nothing
Dim folderItems As Outlook.Items = Nothing
Dim resultItem As Object = Nothing
folderItems = folder.Items
folderItems.IncludeRecurrences = True
folderItems.Sort("[Start]")
If (folderItems.Count > 0) Then
resultItem = folderItems.Find(searchCriteria)
If Not IsNothing(resultItem) Then
strBuilder = New StringBuilder()
Do
If (TypeOf (resultItem) Is Outlook._AppointmentItem) Then
counter += 1
appItem = resultItem
strBuilder.AppendLine("#" + counter.ToString() + _
" Subbject: " + appItem.Subject + _
" Organizer: " + appItem.Organizer + _
" Location: " + appItem.Location)
End If
resultItem = folderItems.FindNext()
Loop Until IsNothing(resultItem)
End If
End If
If Not IsNothing(strBuilder) Then
Debug.WriteLine(strBuilder.ToString())
Else
Debug.WriteLine("There is no match in the " + _
folder.Name + " folder.")
End If
End Sub
I am trying to send contents of a crystal report as email body using outlook application.
Here is my code in VB.net
Imports outlook = Microsoft.Office.Interop.Outlook
Dim a As String = something.ConnectionString
Dim cryRpt As ReportDocument
Dim username As String = a.Split("=")(3).Split(";")(0) 'get username
Dim password As String = a.Split("=")(4).Split(";")(0) 'get password
cryRpt = New ReportDocument()
Dim Path As String = Application.StartupPath
Dim svPath As String = Application.StartupPath & "\PDF"
If Not Directory.Exists(svPath) Then
Directory.CreateDirectory(svPath)
End If
cryRpt.Load(Path & "\Reports\dr.rpt")
CrystalReportViewer1.ReportSource = cryRpt
cryRpt.SetDatabaseLogon(username, password)
CrystalReportViewer1.Refresh()
Dim myExportOptions As ExportOptions
myExportOptions = cryRpt.ExportOptions
myExportOptions.ExportDestinationType = ExportDestinationType.DiskFile
myExportOptions.ExportFormatType = ExportFormatType.HTML40 'i tried HTML32 also
Dim html40FormatOptions As HTMLFormatOptions = New HTMLFormatOptions()
html40FormatOptions.HTMLBaseFolderName = svPath
html40FormatOptions.HTMLFileName = "dr.htm"
html40FormatOptions.HTMLEnableSeparatedPages = False
html40FormatOptions.HTMLHasPageNavigator = False
html40FormatOptions.UsePageRange = False
myExportOptions.FormatOptions = html40FormatOptions
cryRpt.Export()
Try
Dim oApp As outlook.Application
oApp = New outlook.Application
Dim oMsg As outlook.MailItem
oMsg = oApp.CreateItem(outlook.OlItemType.olMailItem)
oMsg.Subject = txtSubject.Text
oMsg.BodyFormat = outlook.OlBodyFormat.olFormatHTML
oMsg.HTMLBody = ""
oMsg.HTMLBody = getFileAsString(svPath & "\PoPrt\QuotPrt.html")
oMsg.To = txtEmailId.Text
Dim ccArray As New List(Of String)({txtCC1.Text, txtCC2.Text, txtCC3.Text})
Dim cclis As String = String.Join(",", ccArray.Where(Function(ss) Not String.IsNullOrEmpty(ss)))
oMsg.CC = cclis
oMsg.Display(True)
Catch ex As Exception
MsgBox("Something went wrong", vbExclamation)
End Try
SvFormPanel3.Visible = False
the function
Private Function getFileAsString(ByVal file As String) As String
Dim reader As System.IO.FileStream
Try
reader = New System.IO.FileStream(file, IO.FileMode.Open)
Catch e As Exception
MsgBox("Something went wrong. " + e.Message, vbInformation)
End Try
Dim resultString As String = ""
Dim b(1024) As Byte
Dim temp As UTF8Encoding = New UTF8Encoding(True)
Do While reader.Read(b, 0, b.Length) > 0
resultString = resultString & temp.GetString(b)
Array.Clear(b, 0, b.Length)
Loop
reader.Close()
Return resultString
End Function
The report will get exported to the specified location as html. And when we manually open that html file it displays perfectly with border lines and all.
But when its getting added as html body of outlook application, the formatting will be gone, and looks scattered.
can anyone help
Did you try this?
Open outlook, go to, File>Options>Mail
go to section MessageFormat and untick "Reduce message size by removing format..."
I have solved the issue by exporting it into PDF and then convert to Image and embed in email body.
I am trying to automate sending an email and copy the meeting organizer through an Outlook VBA macro. My company is using Office 365.
I am using the item.GetOrganizer element to get the organizer's name.
Debug.Print oItem.GetOrganizer.Address gives:
/o=ExchangeLabs/ou=Exchange Administrative Group (FYDIBOHF23SPDLT)/cn=Recipients/cn=c035bc5647d64d89aecbc6d3ddb5580b-Name
How do I get the email address?
Example
Option Explicit
Private Function GetMeetingOrganizer( _
ByVal appt As Outlook.AppointmentItem) As Outlook.AddressEntry
If appt Is Nothing Then Exit Function
Dim PR_SENT_REPRESENTING_ENTRYID As String
PR_SENT_REPRESENTING_ENTRYID = _
"http://schemas.microsoft.com/mapi/proptag/0x00410102"
Dim organizerEntryID As String
organizerEntryID = _
appt.PropertyAccessor.BinaryToString( _
appt.PropertyAccessor.GetProperty(PR_SENT_REPRESENTING_ENTRYID))
Dim organizer As Outlook.AddressEntry
Set organizer = Application.Session.GetAddressEntryFromID(organizerEntryID)
If organizer Is Nothing Then
Debug.Print "No organizer" ' Print on Immediate Window
Else
Debug.Print organizer ' Print on Immediate Window
Dim Email_Address As String
If organizer.Type = "SMTP" Then
Email_Address = organizer.Address
Else
If organizer.Type = "EX" Then
Email_Address = organizer.GetExchangeUser.PrimarySmtpAddress
End If
End If
Debug.Print Email_Address ' Print on Immediate Window
End If
End Function
Private Sub Example()
Dim Item As Object
Set Item = ActiveExplorer.Selection.Item(1)
Debug.Print TypeName(Item)
GetMeetingOrganizer Item
End Sub
Function GetOrganizerEmail(ApptItem As Outlook.AppointmentItem) As String
Dim organizer As Outlook.AddressEntry
Set org = ApptItem.GetOrganizer
If org.Type = "SMTP" Then
GetOrganizerEmail = org.Address
ElseIf org.Type = "EX" Then
GetOrganizerEmail = org.GetExchangeUser.PrimarySmtpAddress
End If
End Function
I am creating a solid edge macro that saves a 3D file in solid edge in three different types simultaneously.
owever, I am new to vb.net some I am having some difficulty.
When I run the program, the first pop up says "this file already exists, do you want to overwrite it?".
The next pop up says "cannot access this file" and then the program stops.
Why can vb.net not access the file? It is open in solid edge in the background.
Imports System.Runtime.InteropServices
Public Class Form1
Private Sub saveBtn_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles saveBtn.Click
Dim objApplication As SolidEdgeFramework.Application = Nothing
Dim objDocument As SolidEdgeFramework.SolidEdgeDocument = Nothing
Dim objPropertySets As SolidEdgeFramework.PropertySets = Nothing
Dim objProperties As SolidEdgeFramework.Properties = Nothing
Dim objProperty As SolidEdgeFramework.Property = Nothing
Dim FileName As String
Dim i, j As Integer
Dim NewFileName1 As String
Dim NewFileName2 As String
Dim NewFileName3 As String
Dim Extensions(2) As String
Extensions(0) = ".step"
Extensions(1) = ".x_t"
Extensions(2) = ".igs"
Try
objApplication = Marshal.GetActiveObject("SolidEdge.Application")
objDocument = objApplication.ActiveDocument
objPropertySets = objDocument.Properties
For i = 1 To objPropertySets.Count
objProperties = objPropertySets.Item(i)
For j = 1 To objProperties.Count
objProperty = objProperties.Item(j)
Next
Next
FileName = objProperty.Name
NewFileName1 = FileName & Extensions(0)
NewFileName2 = FileName & Extensions(1)
NewFileName3 = FileName & Extensions(2)
objDocument.SaveAs("C:\Folder", NewFileName1)
objDocument.SaveAs("C:\Folder", NewFileName2)
objDocument.SaveAs("C:\Folder", NewFileName3)
'objDocument.SaveAs(NewFileName1)
'objDocument.SaveAs(NewFileName2)
'objDocument.SaveAs(NewFileName3)
Catch ex As Exception
txt.Text = " Error"
Finally
If Not (objDocument Is Nothing) Then
Marshal.ReleaseComObject(objDocument)
objDocument = Nothing
End If
If Not (objApplication Is Nothing) Then
Marshal.ReleaseComObject(objApplication)
objApplication = Nothing
End If
End Try
End Sub
End Class
As the title says, I'm having issues with enumerating and outputting item in my sent items folder in outlook. Specifically I'm looking for sent tasks. It keeps telling me there's nothing in the folder, when there is. The code is:
Private Sub GetSentTasks(objApp As Microsoft.Office.Interop.Outlook.Application)
Dim objNS As Outlook.NameSpace = objApp.GetNamespace("MAPI")
Dim folder As Outlook.MAPIFolder = _
objNS.GetDefaultFolder( _
Outlook.OlDefaultFolders.olFolderSentMail)
Dim searchCriteria As String = "[MessageClass] = 'IPM.TaskRequest'"
Dim strBuilder As StringBuilder = Nothing
Dim counter As Integer = 0
Dim taskItem As Outlook._TaskItem = Nothing
Dim folderItems As Outlook.Items = Nothing
Dim resultItem As Object = Nothing
Dim TTDcounter As Integer = 0
Try
folderItems = folder.Items
folderItems.IncludeRecurrences = True
If (folderItems.Count > 0) Then
resultItem = folderItems.Find(searchCriteria)
If Not IsNothing(resultItem) Then
strBuilder = New StringBuilder()
Do
If (TypeOf (resultItem) Is Outlook._TaskRequestItem) Then
counter += 1
taskItem = resultItem
'If taskItem.Categories = "TTD" Then
TTDcounter += 1
Dim listarray() As String = {taskItem.Delegator, taskItem.Subject, taskItem.DueDate, stripEstComp(taskItem.Body.ToString())}
taskPaneControl3.ListView1.Items.Add(TTDcounter).SubItems.AddRange(listarray)
'End If
End If
Marshal.ReleaseComObject(resultItem)
resultItem = folderItems.FindNext()
Loop Until IsNothing(resultItem)
End If
End If
If Not IsNothing(strBuilder) Then
Debug.WriteLine(strBuilder.ToString())
Else
Debug.WriteLine("There is no match in the " + _
folder.Name + " folder.")
End If
Catch ex As Exception
System.Windows.Forms.MessageBox.Show(ex.Message)
Finally
If Not IsNothing(folderItems) Then Marshal.ReleaseComObject(folderItems)
End Try
End Sub