Outlook  VSTO

Ribbon Type (for creating a button in my case)

Click on the top most Ribbon properties and then you'll see it

2019-09-13 14_23_54-Clipboard

Put the Group and buttons on the HOME tab

Change to TabMail (TabHome did not work for me)

2019-09-13 15_00_07-Clipboard


Start a Process

One Off Process

System.Diagnostics.Process.Start("iexplore", "http://www.yoursite.com")

Controlled Process

    Dim myProcess as new System.Diagnostics.Process()


    myProcess.StartInfo = new System.Diagnostics.ProcessStartInfo("iexplore")

    myProcess.Arguments = yourWebsite


'Kill the process when you want to



Color "text" or rather, graphic in Ribbon

** Cannot be larger than the Large Ribbon icon

Imports System.Drawing.Text

Imports System.Drawing

Imports System.Drawing.Drawing2D

Imports System.IO

Imports System.Drawing.Imaging

Button1.Image = Image.FromFile(createTextImage("0", Color.Black))  

    Function createTextImage(text As String, oColor As Color) As String

    'Returns the file path in the temp folder that has the imsage to load

        'Dim text As String = txtText.Text.Trim()

        Dim bitmap As New Bitmap(1, 1)

        Dim font As New Font("Arial", 25, FontStyle.Bold, GraphicsUnit.Pixel)

        Dim graphics As Graphics = Graphics.FromImage(bitmap)

        Dim width As Integer = CInt(graphics.MeasureString(text, font).Width)

        Dim height As Integer = CInt(graphics.MeasureString(text, font).Height)

        bitmap = New Bitmap(bitmap, New Size(width, height))

        graphics = Graphics.FromImage(bitmap)


        graphics.SmoothingMode = SmoothingMode.AntiAlias

        graphics.TextRenderingHint = TextRenderingHint.AntiAlias

        'graphics.DrawString(text, font, New SolidBrush(Color.FromArgb(255, 0, 0)), 0, 0)

        graphics.DrawString(text, font, New SolidBrush(oColor), 0, 0)



        Dim fileName As String = Path.GetFileNameWithoutExtension(Path.GetRandomFileName()) & ".jpg"

        bitmap.Save(Environment.ExpandEnvironmentVariables("%TEMP%") & "\" & fileName, ImageFormat.Jpeg)

        'imgText.ImageUrl = "~/images/" & fileName

        'imgText.Visible = True

        Return Environment.ExpandEnvironmentVariables("%TEMP%") & "\" & fileName

    End Function

Button click to manipulate current/active email

    Private Sub Button1_Click(sender As Object, e As EventArgs) Handles Button1.Click

        'On Error Resume Next

        Dim ThisOutlookSession As Outlook.Application = New Outlook.Application

        Dim NS As Outlook.NameSpace = ThisOutlookSession.Session

        Dim objsel As Outlook.MailItem


        'Check it's Inspector or Explorer Window

        If TypeName(ThisOutlookSession.ActiveWindow) = "Inspector" Then


            objsel = ThisOutlookSession.ActiveInspector.CurrentItem

            'objsel.Subject += vbCrLf






            'Get the selected item for processing

            objsel = ThisOutlookSession.ActiveExplorer.Selection.Item(1)

            'Check the relevant item and process per your logic

            If (TypeOf objsel Is Outlook.MailItem) Then

                Dim mailItem As Outlook.MailItem =

                        TryCast(objsel, Outlook.MailItem)

                'MsgBox("Mail Item's Subject" & mailItem.Subject)

                'Implement your business logic here

            End If

        End If

    End Sub

Ribbon Button click to manipulate current/active email

    Private Sub Button1_Click(sender As Object, e As RibbonControlEventArgs) Handles Button1555.Click

        Dim message As String = "this is not a mail, appointment or task item"

        Dim OutlookApp As Outlook.Application = Globals.ThisAddIn.Application

        'If (Not Globals.ThisAddIn.theCurrentAppointment Is Nothing) Then

        '    '            {

        '    '    //  Our Ribbon control contains a TextBox called "tbSubject"

        '    '    tbSubject.Text = ThisAddIn.theCurrentAppointment.Subject

        '    Button1555.Label = Globals.ThisAddIn.theCurrentAppointment.Subject

        'End If


        Dim inspector As Outlook.Inspector

        If Globals.ThisAddIn.Application.ActiveExplorer.Selection.Count > 0 Then

            Dim mail As Outlook.MailItem = DirectCast(Globals.ThisAddIn.Application.ActiveExplorer.Selection(1), Outlook.MailItem)

            'Button1555.Label = mail.Subject.ToString

            If mail.Sender.Address.ToString = "esp@crouse.org" Then


                'Destination IP:" & vbTab & " " & vbTab


                Dim sOutput As String = ""

                'For x = 1 To Len(mail.HTMLBody)

                '    sOutput = sOutput & Mid(mail.HTMLBody, x, 1)


                WriteFile(mail.HTMLBody, "c:\temp\output.html")

                sOutput = My.Computer.FileSystem.ReadAllText("c:\temp\output.html", Encoding.ASCII)

                'Button1555.Label = funGrabBetween(funRemoveHTML(sOutput), "Source IP:", "</font>")

                Button1555.Label = Trim(funRemoveHTML(funGrabBetween(sOutput, "Source IP:", "</tr>")))

                Dim dict As New Dictionary(Of String, String)

                dict.Add("ip", Button1555.Label)

                dict.Add("cidr", "/32")

                dict.Add("send", "submit")

                dict.Add("requestor_show_to_user", Replace(Environment.UserName, Environment.UserDomainName & "\", ""))

                Dim webform As New WebFormSubmitter

                Dim response As String = webform.submit("http://website/page-dev.asp", dict)

                Dim frmWeb As New Form2

                frmWeb.WebBrowser1.DocumentText = response


                Button1555.Label = "BlockIP"

            End If

        End If

End Sub

MailItem Events with Listeners

Public Class ThisAddIn

    Dim WithEvents myInspectors As Outlook.Inspectors

    'Public theCurrentAppointment As MailItem

    Public WithEvents theCurrentAppointment As Outlook.MailItem

    Private Sub ThisAddIn_Startup() Handles Me.Startup

        'myInspectors = Globals.ThisAddIn.Application.Inspectors

        myInspectors = Application.Inspectors

        'Inspectors.NewInspector += New Outlook.InspectorsEvents_NewInspectorEventHandler(Inspectors_NewInspector)


        'AddHandler Inspectors.NewInspector, InspectorsEvents_NewInspectorEventHandler(Inspectors_NewInspector);

        'myInspectors.Add(New Outlook.InspectorsEvents_NewInspectorEventHandler(AddressOf Inspectors_NewInspector))

        'myInspectors.NewInspector += New Outlook.InspectorsEvents_NewInspectorEventHandler(AddressOf Inspectors_NewInspector)

    End Sub

    Public Sub myinspectors_NewInspector(Inspector As Microsoft.Office.Interop.Outlook.Inspector) Handles myInspectors.NewInspector

        theCurrentAppointment = Nothing

        Dim item As Object = Inspector.CurrentItem

        'If IsNothing(item) Then Return

        If TypeOf (item) Is Outlook.MailItem Then theCurrentAppointment = Inspector.CurrentItem


    End Sub

    Sub theCurrentAppointment_Read(ByVal Item As Object)

        Globals.Ribbons.Ribbon1.Button1555.Label = Item.subject

    End Sub


    Private Sub theCurrentAppointment_Read() Handles theCurrentAppointment.Read

        'Globals.Ribbons.Ribbon1.Button1555.Label = theCurrentAppointment.Subject

        If theCurrentAppointment.SenderEmailAddress.ToString = "esp@crouse.org" Then

            If InStr(theCurrentAppointment.Body, "source ip", CompareMethod.Text) Then

                Globals.Ribbons.Ribbon1.Button1555.Label = Now

            End If

        End If

    End Sub

End Class


Sorting Outlook Emails into Subfolders

Sub MoveEmailToStorageFormatted()

 'On Error Resume Next

    Dim curMail As Outlook.MailItem

 For x = 1 To Application.ActiveExplorer.Selection.count

 Debug.Print x

    Set curMail = GetCurrentItem(x)


    Call MoveAndFormat(curMail)


End Sub

Sub CreateFolders(sPath, level, ByRef oFolder As Folder)

  On Error Resume Next


  sLevel = Split(sPath, "\")(level)

  Debug.Print "sLevel = " & sLevel & vbTab & "Level = " & level

  If Len(sLevel) > 0 Then

   'If IsNull(oFolder.Folders(sLevel)) Then

    Debug.Print "IsNull"

    Debug.Print "Adding: " & sLevel

    oFolder.Folders.Add sLevel

    Set oFolder = oFolder.Folders(sLevel)

     Call CreateFolders(sPath, level + 1, oFolder)

   'End If

 End If



  On Error GoTo 0

End Sub


    Sub CreateFolder(ByVal strPath)

        On Error Resume Next


        If Not objFSO.FolderExists(objFSO.GetParentFolderName(strPath)) Then Call CreateFolder(objFSO.GetParentFolderName(strPath))

        objFSO.CreateFolder (strPath)

        On Error GoTo 0

    End Sub



' From http://www.outlookcode.com/codedetail.aspx?id=50

Function GetCurrentItem(x) As Object

    Dim objApp As New Outlook.Application


    'Set objApp = CreateObject("Outlook.Application")

    On Error Resume Next

    Select Case TypeName(objApp.ActiveWindow)

        Case "Explorer"

            Set GetCurrentItem = objApp.ActiveExplorer.Selection.Item(x)

        Case "Inspector"

            Set GetCurrentItem = objApp.ActiveInspector.CurrentItem

        Case Else

            ' anything else will result in an error, which is

            ' why we have the error handler above

    End Select


    Set objApp = Nothing

End Function

Sub MoveAndFormat(themail As MailItem)

On Error Resume Next

 Dim xFolder As Folder, out As Folder


'Set xFolder = Application.session.Folders.Item("Inbox")

' Item Can be Mailbox - <first> <lastname>

Set xFolder = Application.session.Folders.Item("Mailbox - Rich Lemmermann")



  Debug.Print themail.SenderName

  Debug.Print themail.SentOn & vbTab & Year(themail.SentOn)

  sDestFolder = "Inbox\" & Year(themail.SentOn) & "\" & themail.SenderName

 Call CreateFolders(sDestFolder, 0, xFolder)


 Set out = GetFolder(sDestFolder, 0, xFolder)

 Debug.Print out.Name

 themail.UnRead = False


 themail.Move out


End Sub

Function GetFolder(sPath, level, oFolder)

  On Error Resume Next

  sLevel = Split(sPath, "\")(level)

  Debug.Print "sLevel = " & sLevel & vbTab & "Level = " & level

  If Len(sLevel) > 0 Then


    Set oFolder = oFolder.Folders(sLevel)

    Call GetFolder(sPath, level + 1, oFolder)

  End If


  Set GetFolder = oFolder


  On Error GoTo 0

End Function

Send a fax (example of manipulating To line)

    Sub subSendFax(mail As Outlook.MailItem)

        Dim sNumber As String = ""

        Dim recipients As Outlook.Recipients

        Dim recipient As Outlook.Recipient

        recipients = mail.Recipients

        'sNumber = funWhatever(sToLine.ToString)

        'sNumber = "3156993964"

        Dim sToLine As String

        If Label1.Text = "O365" Then

            sToLine = "/Name=Fax/Fax=" & TextBox2.Text & "/rfax@faxtest.crouse.org"


            sToLine = "[rfax:Fax@/FN=" & TextBox2.Text & "]"

        End If

        mail.To = ""

        recipient = recipients.Add(sToLine.ToString)






    End Sub

Example of going through all Recipients in ItemSend() method

  Private Sub Application_ItemSend(Item As Object, ByRef Cancel As Boolean) Handles Application.ItemSend


        'Dim recipient As Outlook.Recipient = Nothing

        'Dim recipients As Outlook.Recipients = Nothing

        'Dim mail As Outlook.MailItem = TryCast(Item, Outlook.MailItem)

        'If Not IsNothing(mail) Then

        '    Dim addToSubject As String = " !IMPORTANT"

        '    Dim addToBody As String = "Sent from my Outlook 2010"

        '    If Not mail.Subject.Contains(addToSubject) Then

        '        mail.Subject += addToSubject

        '    End If

        '    If Not mail.Body.EndsWith(addToBody) Then

        '        mail.Body += addToBody

        '    End If

        '    recipients = mail.Recipients

        '    recipient = recipients.Add("Eugene Astafiev")

        '    recipient.Type = Outlook.OlMailRecipientType.olBCC

        '    recipient.Resolve()

        '    If Not IsNothing(recipient) Then Marshal.ReleaseComObject(recipient)

        '    If Not IsNothing(recipients) Then Marshal.ReleaseComObject(recipients)

        'End If

        Dim bOnPrem As Boolean = False

        Dim ThisOutlookSession As Outlook.Application = New Outlook.Application

        Dim NS As Outlook.NameSpace = ThisOutlookSession.Session

        If NS.ExchangeMailboxServerName.Contains("vs8cashub") Then

            bOnPrem = True ' = "onPrem"


            bOnPrem = False ' = "O365"

        End If

        'Dim recipient As Outlook.Recipient = Nothing

        Dim recipients As Outlook.Recipients = Nothing

        Dim mail As Outlook.MailItem = TryCast(Item, Outlook.MailItem)

        If Not IsNothing(mail) Then

            recipients = mail.Recipients

            For Each recipient As Outlook.Recipient In recipients

                Console.WriteLine(recipient.Name & " -> " & recipient.Class.ToString)


                    If recipient.AddressEntry.Members IsNot Nothing Then

                        For Each x As Outlook.AddressEntry In recipient.AddressEntry.Members

                            Dim sReturn As String = funGetFaxStringOrReturnSameValue(x.Address.ToString, bOnPrem, x.Type.ToString)






                        Dim sReturn As String = funGetFaxStringOrReturnSameValue(recipient.Address.ToString, bOnPrem, recipient.Type.ToString)




                    End If

                Catch ex As Exception

                    Console.WriteLine("ERROR: " & ex.Message.ToString)

                End Try




            'For Each recipient As Outlook.Recipient In recipients

            '    If TypeOf recipient Is Outlook.ContactItem Then

            '        Dim contactItem As Outlook.ContactItem = TryCast(recipient, Outlook.ContactItem)

            '        For Each x In contactItem.AddressEntries

            '            MsgBox(x.ToString)

            '        Next

            '    End If


            'Dim addToSubject As String = " !IMPORTANT"

            'Dim addToBody As String = "Sent from my Outlook 2010"

            'If Not mail.Subject.Contains(addToSubject) Then

            ' mail.Subject += addToSubject

            'End If

            'If Not mail.Body.EndsWith(addToBody) Then

            'mail.Body += addToBody


            recipients = mail.Recipients

            'ecipient = recipients.Add("Eugene Astafiev")

            'recipient.Type = Outlook.OlMailRecipientType.olBCC


            'If Not IsNothing(recipient) Then Marshal.ReleaseComObject(recipient)

            If Not IsNothing(recipients) Then Marshal.ReleaseComObject(recipients)


            'Cancel = True

        End If

    End Sub


Function funGetFaxStringOrReturnSameValue(sPotentialFaxEmail As String, bOnPrem As Boolean, sType As String) As String

        If LCase(sType) = "fax" Then

            'we know it's a fax. change it to somehitng so that it'll properly get handled.

            sPotentialFaxEmail = "[rfax:FAX@/FN=" & funGrabBetween(sPotentialFaxEmail & vbCrLf, "@", vbCrLf) & "]"

        End If

        'handle what should work in an ideal solution

        If InStr(LCase(sPotentialFaxEmail), "rfax@faxtest.crouse.org") > 0 Then

            If Not bOnPrem Then

                Return sPotentialFaxEmail 'Already in corerct format


                'sToLine = "[rfax:Fax@/FN=" & TextBox2.Text & "]"

                Return Regex.Replace("[rfax:FAX@/FN=" & funGrabBetween(sPotentialFaxEmail, "Fax=", "/rfax@faxtest.crouse.org") & "]", "[^A-Za-z0-9\@\.\=/]", "")

            End If


        ElseIf InStr(LCase(sPotentialFaxEmail), "fn=") > 0 Then


            If bOnPrem Then

                Return sPotentialFaxEmail 'Already in corerct format


                'sToLine = "/Name=Fax/Fax=" & TextBox2.Text & "/rfax@faxtest.crouse.org"

                'Regex.Replace(, "[^A-Za-z0-9\@\.\=/]", "")

                Return Regex.Replace("/Name=Fax/Fax=" & funGrabBetween(sPotentialFaxEmail & "]", "FN=", "]") & "/rfax@faxtest.crouse.org", "[^A-Za-z0-9\@\.\=/]", "")

            End If

        End If

        Return sPotentialFaxEmail 'if nothing above, just return what it is

    End Function

Center for to Screen or Parent Window



Parent Window

    Public Shared Sub CenterForm(ByVal frm As Form, Optional ByVal parent As Form = Nothing)

        '' Note: call this from frm's Load event!

        Dim r As Rectangle

        If parent IsNot Nothing Then

            r = parent.RectangleToScreen(parent.ClientRectangle)


            r = Screen.FromPoint(frm.Location).WorkingArea

        End If

        Dim x = r.Left + (r.Width - frm.Width) \ 2

        Dim y = r.Top + (r.Height - frm.Height) \ 2

        frm.Location = New Point(x, y)

    End Sub