2017-02-05 21:41
Changed global variable definition for event bug
2017-02-05 20:00
Changed the way to create outlook bar and buttons to be more dynamic (array of bars, array of buttons in bar)
This outlook addin was compiled as "outlook addin" in visual studio 2013
It is signed, but you can change the certificate before recompiling
Tested on outlook 2013
This will add a toolbar with "classer et faire lien" (wich is not what it is doing, it only does the link)
When you press the button in complements, it will generate a hyperlink to the message(s) selected or to the message actually open at the moment.
then you can paste the link in any other application as it will be an html outlook link.
------------------- vb.net visual studio 2013 -----------------------------
Imports System.Object
Imports System.IO
Imports System.Windows.Forms
Public Class ThisAddIn
Const RegHtml As String = "HTML Format"
Public WithEvents inspectors01 As Outlook.Inspectors
Public Class glovar
'=== this class have variables global to all the other classes
Public Shared button00 As Office.CommandBarButton '=== in explorer, aka main windows
Public Shared button01 As Office.CommandBarButton '=== in explorer, aka main windows
Public Shared button02 As Office.CommandBarButton '=== in explorer, aka main windows
End Class
'=== structure to pass to a function to create a toolbar in outlook
Public Structure bar_param
Dim bar_Exist01 As Integer '=== if bar exist we do not recreate
Dim bar_Caption01 As String '=== name of bar
Dim bar_inexplorer01 As Integer '=== create in main outlook window
Dim bar_ininspector01 As Integer '=== create in message window
Dim explorerorinspector01 As Object
Dim buttons01 As but_param()
End Structure
'=== strucutre to pass to a function to create a button in the bar we created just before
Public Structure but_param
Dim bar_obj As Object
Dim but_exist01 As Integer
Dim but_Caption01 As String
Dim but_tooltip01 As String
Dim but_onaction01 As String
Dim but_face01 As Integer '=== icon
Dim but_inexplorer01 As Integer '=== in main outlook window
Dim but_ininspector01 As Integer '=== in message window
Dim but_bar01 As Object '=== bar to add button to
End Structure
Private Sub ThisAddIn_Startup() Handles Me.Startup
Dim inspector01 As Microsoft.Office.Interop.Outlook.Inspector
inspectors01 = Me.Application.Inspectors
Dim dummy As Integer
dummy = add_bar_and_buttons(Globals.ThisAddIn.Application.ActiveExplorer)
Dim objNet = CreateObject("WScript.Network")
'=== get username logon from local machine
Dim usenam As String = LCase(objNet.UserName)
End Sub
Private Sub ThisAddIn_Shutdown() Handles Me.Shutdown
'outlookaddin1 = Nothing
End Sub
'Dim bar01 As Office.CommandBar '=== in explorer
'Dim bar03 As Office.CommandBar '=== in inspector
Public Sub inspectors01_NewInspector(ByVal Inspector As Microsoft.Office.Interop.Outlook.Inspector) Handles inspectors01.NewInspector
'=== a new inspector just openned (a new mail maybe?)
Dim dummy As Integer
'MsgBox("new inspector")
dummy = add_bar_and_buttons(Inspector)
'If logall = 1 Then file02.writeline(Now & " adding bar in inspector")
End Sub
Private Sub copierhyperlien01(ByVal ctrl As Office.CommandBarButton, ByRef Cancel As Boolean)
'''''''''''''''''''''''''''''''''
' the mail is open in inspector
'''''''''''''''''''''''''''''''''
Dim inspector01 As Microsoft.Office.Interop.Outlook.Inspector
inspector01 = Globals.ThisAddIn.Application.ActiveInspector
Dim item01(0) As Object
Dim item01ismailininspector = 0
If Not inspector01 Is Nothing Then
Try
'=== check the actual openned item, if it does not exist, then there is no mail open at the moment
item01(0) = inspector01.CurrentItem
item01ismailininspector = 1
Catch ex As Exception
'=== no item is openned, we create one later
item01(0) = Nothing
End Try
Else
'=== no inspector, that mean there is no item opened
End If
Dim itemcnt = 0
If item01ismailininspector = 0 Then
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' get all selected items in explorer (not inspector, wich would be an open item)
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'=== selected items in explorer window
Dim explorer01 = Globals.ThisAddIn.Application.ActiveExplorer
Dim selection01 = explorer01.Selection
For Each item02 In selection01
ReDim Preserve item01(itemcnt)
item01(itemcnt) = item02
itemcnt = itemcnt + 1
Next
itemcnt = itemcnt - 1
'MsgBox(selection01.Count)
Else
'=== the email is open right now in inspector
'=== we have only one email to process
End If
Dim link01 As String = ""
For i = 0 To itemcnt
If TypeOf item01(i) Is Outlook.MailItem Then
link01 = link01 & "<a href=""outlook:" & item01(i).EntryID & """>" & _
"LIEN OUTLOOK From: " & item01(i).SenderName & _
" Sujet: " & item01(i).Subject & _
" Date: " & item01(i).ReceivedTime & _
" Categorie: " & item01(i).categories & _
"</a><br>"
ElseIf TypeOf item01(i) Is Outlook.TaskItem Then
link01 = link01 & "<a href=""outlook:" & item01(i).EntryID & """>" & _
"LIEN OUTLOOK From: " & item01(i).Owner & _
" Sujet: " & item01(i).Subject & _
" Date due: " & item01(i).DueDate & _
" Categorie: " & item01(i).categories & _
"</a><br>"
ElseIf TypeOf item01(i) Is Outlook.ReportItem Then
link01 = link01 & "<a href=""outlook:" & item01(i).EntryID & """>" & _
"LIEN OUTLOOK From: OUTLOOK" & _
" Sujet: " & item01(i).Subject & _
" Date: " & item01(i).CreationTime & _
" Categorie: " & item01(i).categories & _
"</a><br>"
ElseIf TypeOf item01(i) Is Outlook.ContactItem Then
link01 = link01 & "<a href=""outlook:" & item01(i).EntryID & """>" & _
"LIEN OUTLOOK From: " & item01(i).FullNameAndCompany & _
" Categorie: " & item01(i).categories & _
"</a><br>"
'" Date: " & message.CreationTime & _
'" Sujet: " & message.Subject & _
Else
link01 = link01 & "ERREUR - Un item dans votre sélection est... étrange - pas de lien dans le presse-papier<br>"
End If
Next
'=== convert link to html ready to be put in clipboard
Dim dummy = SetHtml_put_in_clipboard(link01)
'MsgBox("You clicked: " + ctrl.Caption + vbCrLf + "link01: " + link01)
'=== put link01 in clipboard
'=== futur search for client contract number to move the mail to a client contract folder
'Dim txt02 = mail01(itemcnt).HTMLBody
'=== warning if a whole groupe was selected (selection of a whole day by accident)
'=== get subject and search 999000 (id)
'=== if no id found, ask for an id to be able to move the email in a folder
'=== get email content and search for 999000 (999 = client, 000 = project)
'=== search public folder for this id number (999000) 999 = client 000 = project
'=== if no public folder, search in inbox folder
'=== if noinbox folder, create one
'=== move a copy of the email in deleted items
'=== move the email in public folder or inbox folder
End Sub
Function SetHtml_put_in_clipboard(ByVal NewVal As String) As Boolean
'=== source: html string
'=== destination: html data block for clipboard
Dim n As String
Dim o As Object
Dim p As Object
Dim q As Object
Dim r As String
Dim i As Integer
Dim s As String
'=== replace all special caracters 128+ ascii with a code for html code
i = 1
While i < Len(NewVal)
s = Mid(NewVal, i, 1)
r = Asc(s)
If r > 128 Then
NewVal = Replace(NewVal, s, "&#" & Trim(CStr(r)) & ";")
i = i + 3 + Len(Trim(CStr(r)))
Else
i = i + 1
End If
End While
'=== build html structure for clipboard
n = "Version:0.9" & vbCrLf
n = n & "StartHTML:00000000" & vbCrLf
n = n & "EndHTML:00000000" & vbCrLf
n = n & "StartFragment:00000000" & vbCrLf
n = n & "EndFragment:00000000" & vbCrLf
n = n & "StartSelection:00000000" & vbCrLf
n = n & "EndSelection:00000000" & vbCrLf
n = n & "<html><body>" & vbCrLf
n = n & "<!--StartFragment-->" & vbCrLf
n = n & NewVal & vbCrLf
n = n & "<!--EndFragment-->" & vbCrLf
n = n & "</BODY></HTML>" & vbCrLf
'Version: vv version number of the clipboard. Starting version is 0.9.
'StartHTML: bytecount from the beginning of the clipboard to the start of the context, or -1 if no context.
'EndHTML: bytecount from the beginning of the clipboard to the end of the context, or -1 if no context.
'StartFragment: bytecount from the beginning of the clipboard to the start of the fragment.
'EndFragment: bytecount from the beginning of the clipboard to the end of the fragment.
'StartSelection: bytecount from the beginning of the clipboard to the start of the selection.
'EndSelection: bytecount from the beginning of the clipboard to the end of the selection.
'=== once the string is done, we can chek where are the chekpoints
'=== then write it in the string itself, padding with "0"
q = "<html>"
p = Trim(CStr(InStr(LCase(n), q) - 1))
o = StrDup(8 - Len(p), "0") & p
n = Replace(n, "StartHTML:00000000", "StartHTML:" & o, 1, 1)
q = ""
p = Trim(CStr(Len(n)))
o = StrDup(8 - Len(p), "0") & p
n = Replace(n, "EndHTML:00000000", "EndHTML:" & o, 1, 1)
q = "<!--startfragment-->"
p = Trim(CStr(InStr(LCase(n), q) + Len(q) - 1))
o = StrDup(8 - Len(p), "0") & p
n = Replace(n, "StartFragment:00000000", "StartFragment:" & o, 1, 1)
q = "<!--endfragment-->"
p = Trim(CStr(InStr(LCase(n), q) - 1))
o = StrDup(8 - Len(p), "0") & p
n = Replace(n, "EndFragment:00000000", "EndFragment:" & o, 1, 1)
Dim dataObject = New DataObject()
dataObject.SetData(DataFormats.Html, n)
'dataObject.SetData(DataFormats.Text, NewVal)
'dataObject.SetData(DataFormats.UnicodeText, NewVal)
Clipboard.SetDataObject(dataObject, 1)
Return 0
End Function
Function add_bar_and_buttons(inspectororexplorer01 As Object)
Dim buttoncnt = 0
Dim but_param01() As but_param
buttoncnt = 0
ReDim Preserve but_param01(buttoncnt)
but_param01(buttoncnt).but_exist01 = 0
but_param01(buttoncnt).but_Caption01 = "Aide Help"
but_param01(buttoncnt).but_tooltip01 = "Aide sur ce addin"
but_param01(buttoncnt).but_onaction01 = "aide01"
but_param01(buttoncnt).but_face01 = 5432
but_param01(buttoncnt).but_inexplorer01 = 1
but_param01(buttoncnt).but_ininspector01 = 1
buttoncnt = buttoncnt + 1
ReDim Preserve but_param01(buttoncnt)
but_param01(buttoncnt).but_exist01 = 0
but_param01(buttoncnt).but_Caption01 = "Classer Item"
but_param01(buttoncnt).but_tooltip01 = "Classer cet(ces) item dans un dossier de projet 999000"
but_param01(buttoncnt).but_onaction01 = "classeritem01"
but_param01(buttoncnt).but_face01 = 5432
but_param01(buttoncnt).but_inexplorer01 = 1
but_param01(buttoncnt).but_ininspector01 = 1
buttoncnt = buttoncnt + 1
ReDim Preserve but_param01(buttoncnt)
but_param01(buttoncnt).but_exist01 = 0
but_param01(buttoncnt).but_Caption01 = "Copier Hyperlien"
but_param01(buttoncnt).but_tooltip01 = "Copier un lien vers cet item dans le presse papier"
but_param01(buttoncnt).but_onaction01 = "copierhyperlien01"
but_param01(buttoncnt).but_face01 = 5432
but_param01(buttoncnt).but_inexplorer01 = 1
but_param01(buttoncnt).but_ininspector01 = 1
'=== toolbar
Dim toolbarcnt = 0
Dim bar_param01(toolbarcnt) As bar_param
bar_param01(toolbarcnt).bar_Exist01 = 0
bar_param01(toolbarcnt).bar_Caption01 = "Courriel01"
bar_param01(toolbarcnt).bar_inexplorer01 = 1
bar_param01(toolbarcnt).bar_ininspector01 = 1
bar_param01(toolbarcnt).explorerorinspector01 = inspectororexplorer01
bar_param01(toolbarcnt).buttons01 = but_param01
'=== add a toolbar object in outlook explorer (main window) or inspector (message)
'=== with a structure as parameter, we can add as many arguments we want before calling this function without modifying all the line that use it
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' toolbar(s)
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim toolbar_Add As Office.CommandBar
'Dim toolbar_Add As Microsoft.Office.Core.CommandBar
'MsgBox("add bar and buttons called")
For bartot01 = 0 To toolbarcnt
Dim bars01 As Object
Try
bars01 = inspectororexplorer01.CommandBars
Catch ex As Exception
'=== no bars at all in customs bars in outlook
'MsgBox("failed to get explorer bars or inspector bars")
End Try
If Not bars01 Is Nothing Then
'=== check if in all bars in a bar with same name exist
For Each bar01 In bars01
If Trim(LCase(bar01.Name)) = Trim(LCase(bar_param01(bartot01).bar_Caption01)) Then
bar_param01(bartot01).bar_Exist01 = 1
toolbar_Add = bar01
End If
Next
'=== add tolbar if not already there
If bar_param01(bartot01).bar_Exist01 = 0 Then
'=== we are in outlook main window
toolbar_Add = inspectororexplorer01.CommandBars.Add(bar_param01(bartot01).bar_Caption01)
End If
'=== make toolbar visible
If Not toolbar_Add Is Nothing Then
'MsgBox("bar added")
toolbar_Add.Name = bar_param01(bartot01).bar_Caption01
toolbar_Add.Visible = True
If bar_param01(bartot01).bar_Exist01 = 0 Then
toolbar_Add.Position = Office.MsoBarPosition.msoBarTop
End If
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' button(s)
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
For buttot01 = 0 To buttoncnt
'Dim button_Add As Office.CommandBarButton
'=== add a button in a toolbar
'=== the bar to add the button to is in the parameters structure
Dim button02 As Office.CommandBarButton
Dim dontadd01 As Integer = 0
'=== delete all buttons in bar
For Each button02 In toolbar_Add.Controls 'but_param01(buttot01).but_bar01.Controls
'=== no more delete all, we simply delete old buttons we dont want anymore
If LCase(but_param01(buttot01).but_Caption01) = LCase(button02.Caption) Then
dontadd01 = 1
Exit For
End If
If button02.Caption = "a effacer" Then
'button02.Delete()
End If
Next
'=== button add
If dontadd01 <> 1 Then
button02 = inspectororexplorer01.CommandBars(toolbar_Add.Name).Controls.Add(Type:=Office.MsoControlType.msoControlButton, Before:=1)
If Not button02 Is Nothing Then
With button02
'buttons(depnum, 0)
.Caption = but_param01(buttot01).but_Caption01
.TooltipText = but_param01(buttot01).but_tooltip01
.Enabled = True
.Visible = True
.OnAction = but_param01(buttot01).but_onaction01
'.OnAction = "!<" & & ">"
.Tag = but_param01(buttot01).but_Caption01
.Style = Office.MsoButtonStyle.msoButtonIconAndCaption
.FaceId = but_param01(buttot01).but_face01
'Dim Icon01 = LoadPicture("C:\_outlook\icon.bmp")
End With
'=== add event only in explorer (not in inspector)
'Microsoft.Office.Interop.Outlook.Inspector
'Globals.ThisAddIn.Application.ActiveExplorer
If TypeOf inspectororexplorer01 Is Outlook.Explorer Then
If but_param01(buttot01).but_Caption01 = but_param01(2).but_Caption01 Then
'=== copy hyerlink to open item or selected item(s)
glovar.button02 = button02
AddHandler glovar.button02.Click, AddressOf copierhyperlien01
'MsgBox("event added")
End If
If but_param01(buttot01).but_Caption01 = but_param01(1).but_Caption01 Then
'=== copy item in contract folder
'=== delete item (send to deleted items)
glovar.button01 = button02
AddHandler glovar.button01.Click, AddressOf classeritem01
End If
If but_param01(buttot01).but_Caption01 = but_param01(0).but_Caption01 Then
'=== help about this addin
glovar.button00 = button02
AddHandler glovar.button00.Click, AddressOf aide01
End If
Else
'=== no event definition
End If
Else
'=== button not created
End If
Else
'=== the button was already there
End If
Next
Else
'=== toolbar not created
End If
Else
'=== there was no toolbars anywhere?
End If
'=== there was no inspectors (message) or explorer opened at the startup of outlook
Next
Return 0
End Function
Private Sub aide01(ByVal ctrl As Office.CommandBarButton, ByRef Cancel As Boolean)
Dim msg01 As String = ""
msg01 = msg01 & "Aide Help" & vbCrLf & vbCrLf
msg01 = msg01 & "Par: Serge Fournier (sergefournier@hotmail.com)" & vbCrLf
msg01 = msg01 & "The version is in DLL properties" & vbCrLf & vbCrLf
msg01 = msg01 & "(C) 2017-02-05" & vbCrLf
MsgBox(msg01)
End Sub
Private Sub classeritem01(ByVal ctrl As Office.CommandBarButton, ByRef Cancel As Boolean)
'Microsoft.Office.Interop.Outlook.Inspector
'Globals.ThisAddIn.Application.ActiveExplorer
MsgBox("classer item")
'''''''''''''''''''''''''''''''''
' the mail is open in inspector
'''''''''''''''''''''''''''''''''
Dim inspector01 As Microsoft.Office.Interop.Outlook.Inspector
inspector01 = Globals.ThisAddIn.Application.ActiveInspector
Dim item01(0) As Object
Dim item01ismailininspector = 0
If Not inspector01 Is Nothing Then
Try
'=== check the actual openned item, if it does not exist, then there is no mail open at the moment
item01(0) = inspector01.CurrentItem
item01ismailininspector = 1
Catch ex As Exception
'=== no item is openned, we create one later
item01(0) = Nothing
End Try
Else
'=== no inspector, that mean there is no item opened
End If
Dim itemcnt = 0
If item01ismailininspector = 0 Then
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' get all selected items in explorer (not inspector, wich would be an open item)
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'=== selected items in explorer window
Dim explorer01 = Globals.ThisAddIn.Application.ActiveExplorer
Dim selection01 = explorer01.Selection
For Each item02 In selection01
ReDim Preserve item01(itemcnt)
item01(itemcnt) = item02
itemcnt = itemcnt + 1
Next
itemcnt = itemcnt - 1
'MsgBox(selection01.Count)
Else
'=== the item is open right now in inspector
'=== we have only one item to process: item01(0)
End If
For i = 0 To itemcnt
If TypeOf item01(i) Is Outlook.MailItem Then
Dim item02 As Outlook.MailItem
item02 = item01(i)
'=== look for any project code in item object 999000 (client 999, project 000)
Dim object01 As String
object01 = item02.Subject
Dim projectid01 As String
projectid01 = find_projet(object01, "######")
MsgBox("projectid01: " & projectid01)
'=== look for any project code in item content
ElseIf TypeOf item01(i) Is Outlook.TaskItem Then
ElseIf TypeOf item01(i) Is Outlook.ReportItem Then
ElseIf TypeOf item01(i) Is Outlook.ContactItem Then
End If
Next
End Sub
Private Function find_projet(text01 As String, mask01 As String) As String
Dim projectid01 As String = ""
If Len(text01) >= Len(mask01) Then
Dim found01 = 0
Dim char01 As String
Dim char02 As String
Dim totfound01 As Integer = 0
Dim i As Integer = 0
While totfound01 < Len(mask01) And i < Len(text01)
char01 = Mid(text01, i + 1, 1)
Dim i2 As Integer = 0
While totfound01 < Len(mask01) And i2 < Len(mask01)
char02 = Mid(mask01, i2 + 1, 1)
'=== find number sequence for project id
If char02 = "#" Then
If InStr(char01, "0123456789") <> 0 Then
totfound01 = totfound01 + 1
projectid01 = projectid01 & char01
Else
totfound01 = 0
projectid01 = ""
End If
i2 = i2 + 1
End If
End While
i = i + 1
End While
Else
projectid01 = ""
End If
Return projectid01
End Function
End Class
