Click on the top most Ribbon properties and then you'll see it
Change to TabMail (TabHome did not work for me)
https://www.c-sharpcorner.com/article/how-to-add-a-button-to-existing-ribbon-tab-in-office-applications2/
System.Diagnostics.Process.Start("iexplore", "http://www.yoursite.com")
Dim myProcess as new System.Diagnostics.Process()
myProcess.StartInfo = new System.Diagnostics.ProcessStartInfo("iexplore")
myProcess.Arguments = yourWebsite
myProcess.Start()
'Kill the process when you want to
myProcess.Kill()
https://social.msdn.microsoft.com/Forums/windows/en-US/63e7cddd-e29f-40f4-9e1e-634ac12cbf5c/open-ie-and-navigate-from-vbnet?forum=winforms
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.Clear(Color.White)
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)
graphics.Flush()
graphics.Dispose()
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
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
Me.Hide()
'Check it's Inspector or Explorer Window
If TypeName(ThisOutlookSession.ActiveWindow) = "Inspector" Then
'MsgBox("Inspector")
objsel = ThisOutlookSession.ActiveInspector.CurrentItem
'objsel.Subject += vbCrLf
objsel.Save()
subSendFax(objsel)
'MsgBox(objsel.Subject.ToString)
Else
MsgBox("Explorer")
'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
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
'MsgBox(mail.Body)
'Destination IP:" & vbTab & "64.129.121.84 " & vbTab
'Console.WriteLine(mail.Body)
Dim sOutput As String = ""
'For x = 1 To Len(mail.HTMLBody)
' sOutput = sOutput & Mid(mail.HTMLBody, x, 1)
'Next
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
frmWeb.Show()
Button1555.Label = "BlockIP"
End If
End If
End Sub
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
'MsgBox(Inspector.Caption)
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
.
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)
Next
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
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"
Else
sToLine = "[rfax:Fax@/FN=" & TextBox2.Text & "]"
End If
mail.To = ""
recipient = recipients.Add(sToLine.ToString)
MsgBox(sToLine.ToString)
'/Chad=Test/Fax=3156993964/rfax@faxtest.crouse.org
'Console.WriteLine(mail.To.ToString)
recipient.Resolve()
'mail.Send()
End Sub
Private Sub Application_ItemSend(Item As Object, ByRef Cancel As Boolean) Handles Application.ItemSend
'https://www.add-in-express.com/creating-addins-blog/2011/09/12/outlook-change-message-before-sending/
'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"
Else
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)
Try
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)
'MsgBox(x.Type.ToString)
mail.Recipients.Add(sReturn.ToString)
Next
recipient.Delete()
Else
Dim sReturn As String = funGetFaxStringOrReturnSameValue(recipient.Address.ToString, bOnPrem, recipient.Type.ToString)
'MsgBox(x.Type.ToString)
mail.Recipients.Add(sReturn.ToString)
recipient.Delete()
End If
Catch ex As Exception
Console.WriteLine("ERROR: " & ex.Message.ToString)
End Try
'
Next
mail.Recipients.ResolveAll()
'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
'Next
'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
'If
recipients = mail.Recipients
'ecipient = 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)
mail.Save()
'Cancel = True
End If
End Sub
http://www.vbaexpress.com/forum/showthread.php?53174-VBA-to-expand-Outlook-Distribution-Group-before-send
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
Else
'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
'Fax
ElseIf InStr(LCase(sPotentialFaxEmail), "fn=") > 0 Then
'fax
If bOnPrem Then
Return sPotentialFaxEmail 'Already in corerct format
Else
'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
Me.CenterToScreen()
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)
Else
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
'https://blogs.msdn.microsoft.com/deva/2009/02/17/how-to-get-explorer-inspector-selected-mail-item-using-outlook-object-model-oom-net/