I often have multiple email items open, some that I composed that are not yet sent and others that I received that I didn't yet close but I am referencing.
What I would like to do is have a fast way to cycle through all of the open windows to find the one that I am looking for.
In Excel I created a macro to cycle through the tabs of an Excel document like this.
Sub PreviousSheet()
On Error Resume Next
ActiveSheet.Previous.Select
End Sub
Sub NextSheet()
On Error Resume Next
ActiveSheet.Next.Select
End Sub
In Outlook, how would I cycle through the open windows using VBA?
Update
Sub test()
Dim olApp As Outlook.Application
Set olApp = GetOutlookApp()
'I think this is how to loop through the open items?
For i = olApp.Inspectors.Count To 1 Step -1
Set olItem = olApp.Inspectors.Item(i).CurrentItem
olItem.Select 'How do I set focus?
Next i
End Sub
Function GetOutlookApp() As Outlook.Application
' returns reference to native Application object
Set GetOutlookApp = Outlook.Application
End Function
Sub GetPreviousOpenItem()
Set MainWindow = Application.ActiveExplorer
Dim olApp As Outlook.Application
Set olApp = GetOutlookApp()
If olApp.ActiveInspector Is Nothing Then
Exit Sub
End If
ActiveInspectorIndex = GetIndexOfActiveInspector(olApp, olApp.ActiveInspector)
If ActiveInspectorIndex - 1 > 0 Then
Dim PreviousInspector As Inspector
Set PreviousInspector = olApp.Inspectors(ActiveInspectorIndex - 1)
olApp.Inspectors(ActiveInspectorIndex - 1).Display
Else
olApp.Inspectors(olApp.Inspectors.Count).Display
End If
MainWindow.Activate
End Sub
Sub GetNextOpenItem()
Set MainWindow = Application.ActiveExplorer
Dim olApp As Outlook.Application
Set olApp = GetOutlookApp()
If olApp.ActiveInspector Is Nothing Then
Exit Sub
End If
ActiveInspectorIndex = GetIndexOfActiveInspector(olApp, olApp.ActiveInspector)
If ActiveInspectorIndex + 1 <= olApp.Inspectors.Count Then
Dim NextInspector As Inspector
Set NextInspector = olApp.Inspectors(ActiveInspectorIndex + 1)
NextInspector.Display
Else
olApp.Inspectors(1).Display
End If
MainWindow.Activate
End Sub
Function GetIndexOfActiveInspector(olApp, CurrentItem) As Integer
CurrentItem = olApp.ActiveInspector
For i = 1 To olApp.Inspectors.Count
Dim Inspector
Set Inspector = olApp.Inspectors.Item(i)
Set olItem = Inspector.CurrentItem
If olItem Is CurrentItem Then
GetIndexOfActiveInspector = i
Exit Function
End If
Next i
MainWindow.Activate
End Function
Function GetOutlookApp() As Outlook.Application
' returns reference to native Application object
Set GetOutlookApp = Outlook.Application
End Function
I have code for emails and I want to connect to a column in an excel. When the macro is triggered, a dropdown should appear so I can choose to how to send the email depending on a list in an excel. The list is generated from other excels, it could have 2 full names or 40 full names. The list is in Sheet4 and the names are in column L, the email address is in column Q and the text in column P. If I choose from the dropdown, the name in L2, it should take the email address from Q2, the name from L2 and the text from P2. Here is what I have until now:
Sub email_to_one_person_from_the_list()
Dim OutApp As Object
Dim OutMail As Object
Dim xlApp As Object
Dim sourceWB As Object
Dim sourceWS As Object
Set xlApp = CreateObject("Excel.Application")
strFile = "C:\persons.xlsm"
Set sourceWB = xlApp.Workbooks.Open(strFile, , False, , , , , , , True)
Set sourceWH = sourceWB.Worksheets("Sheet4")
sourceWB.Activate
sourceWH.Application.Run "Module2.FetchData3"
On Error Resume Next
Set OutApp = GetObject(, "Outlook.Application")
If Err <> 0 Then Set OutApp = CreateObject("Outlook.Application")
On Error GoTo 0
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = sourceWH.Range("Q2").Value
.CC = ""
.BCC = ""
.Subject = "Dear " & sourceWH.Range("L2").Value
.Display
OutMail.HTMLBody = sourceWH.Range("P2").Value
sourceWB.Close SaveChanges:=False
xlApp.Quit
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
and the combobox:
Private Sub CancelButton_Click()
Unload Me
End
End Sub
Private Sub OKButton_Click()
thelist1 = ComboBox1.ListIndex
Unload Me
End Sub
Private Sub UserForm_Initialize()
With ComboBox1
' the excel list here
End With
End Sub
edited after OP's usage of my original code and further clarifications
here follows a complete refactoring code as per the following "rules"
Option Explicitstatement
this forces you to declare all variables
but this little extra work but earns you back with much more control over what your writing and less debugging and/or maintenance efforts
main "mega" code splitting into many single Sub/Funcs
this helps in
have more readable and maintainable code
keeping Userforms and Applications loading and unloading calls away from any UserForm code, which must only take care of its real work: gather information
place this in your Outlook Module:
Option Explicit
Sub email_DP2()
Dim mailData As Variant
mailData = GetMailDataFromExcel("C:\persons.xlsm", _
"Module2.FetchData3", _
"Sheet4", _
"L")
If mailData = Empty Then Exit Sub
With CreateItem(0)
.SentOnBehalfOfName = ""
.Importance = olImportanceHigh
.To = mailData(1)
.Subject = mailData(0)
.GetInspector.WordEditor.Range.collapse 1
.Display
.HTMLBody = mailData(2)
'.Paste 'what are you pasting from?
End With
End Sub
'-------------------------------------------------------
' Excel handling Subs and Funcs
'-------------------------------------------
Function GetMailDataFromExcel(strFile As String, fetchingModule As String, strSheet As String, colStrng As String) As Variant
Dim xlApp As Excel.Application
Dim closeExcel As Boolean
Dim namesRng As Excel.Range
Set xlApp = GetExcel(closeExcel)
If Not xlApp Is Nothing Then
Set namesRng = GetExcelRange(xlApp, strFile, fetchingModule, strSheet, colStrng) 'this will get the names range from given column of given worksheet of given workbook
With UserForm14
If namesRng.Count = 1 Then
.ComboBox1.AddItem namesRng.Value
Else
.ComboBox1.List = xlApp.Transpose(namesRng)
End If
.Show
With .ComboBox1
If .ListIndex > -1 Then GetMailDataFromExcel = Array(.Value, _
namesRng.Offset(, 5).Cells(.ListIndex + 1, 1).Value, _
namesRng.Offset(, 6).Cells(.ListIndex + 1, 1).Value)
End With
End With
Unload UserForm14
Set namesRng = Nothing
ReleaseExcel xlApp, closeExcel
End If
End Function
Function GetExcelRange(xlApp As Excel.Application, strFile As String, fetchingModule As String, strSheet As String, colStrng As String) As Excel.Range
With xlApp.Workbooks.Open(strFile, , False, , , , , , , True)
xlApp.Run fetchingModule
With .Worksheets(strSheet)
Set GetExcelRange = .Columns(colStrng).Resize(.Cells(.Rows.Count, colStrng).End(xlUp).Row)
End With
End With
End Function
Function GetExcel(closeExcel As Boolean) As Excel.Application
On Error Resume Next
Set GetExcel = GetObject(, "Excel.Application")
If GetExcel Is Nothing Then
Set GetExcel = CreateObject("Excel.Application")
closeExcel = True
End If
If GetExcel Is Nothing Then
MsgBox "Couldn't instantiate Excel!", vbCritical
End If
End Function
Sub ReleaseExcel(xlApp As Excel.Application, closeExcel As Boolean)
If closeExcel Then xlApp.Quit
Set xlApp = Nothing
End Sub
'-------------------------------------------------------
place this in your UserForm14 code pane
Option Explicit
Private Sub btnOK_Click()
Me.Hide
End Sub
Private Sub CancelButton_Click()
Me.Hide
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
If CloseMode = vbFormControlMenu Then
Cancel = True
Me.Hide
End If
End Sub
in this latter I
added Option Explicit statement
although not strictly necessary (there is no variables usage but "built in" ones), it builds on a good habit
added a UserForm_QueryCloseevent handler
that handles the possible user's clicking the UserForm "Close" button
erased the End statement
I always learned it's a bad habit to use it and better stick to Exit Sub/Exit Function ones (possibly with proper mix of If.. Then.. Else blocks) to achieve the same effect without any harm
To connect your Outlook to Excel, you first have to add a reference to "Microsoft Excel XX Object Library" where XX is some version number (Extras->References)
Then create a userform, mine looks like this:
Note that my combobox has 2 columns (first one has a width of 0 so it's invisible)
Then, when you are loading the Form, add code to open an Excel instance and load the combobox with values to select from:
Private Sub UserForm_Initialize()
'Define Excel-Variables
Dim xlApp As Excel.Application
Dim xlWB As Excel.Workbook
Dim xlSheet As Excel.Worksheet
'Create Excel Instance
Set xlApp = New Excel.Application
'Make it invisible
xlApp.Visible = False
'Open Workbook with Values
Set xlWB = xlApp.Workbooks.Open("PATH TO YOUR EXCEL FILE")
'Select the Sheet with Values
Set xlSheet = xlWB.Worksheets("sheet1")
Dim i As Integer
'Loop through the Values
For i = 1 To 30 Step 1
'This Combobox has 2 Columns where 1 is the bound one
'Add RowIndex to the first column(will be used to find the values later)
Me.cboTest.AddItem i
'Add the Name to the second Column
Me.cboTest.List(Me.cboTest.ListCount - 1, 1) = xlSheet.Cells(i, 1).Value
Next i
'Clean up and close Excel
Set xlSheet = Nothing
xlWB.Close False
xlApp.Quit
Set xlWB = Nothing
Set xlApp = Nothing
End Sub
Then you need to add some code to the button:
Private Sub cmdSend_Click()
'variables for the values we are getting now
Dim name As String, email As String, text As String
'more excel variables
Dim xlApp As Excel.Application
Dim xlWB As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Set xlApp = New Excel.Application
xlApp.Visible = False
Set xlWB = xlApp.Workbooks.Open("PATH TO EXCEL FILE")
Set xlSheet = xlWB.Worksheets("sheet1")
'access the rowindex from the first column of the combobox
'use it for the Cells() as row
'column may be edited as needed
name = xlSheet.Cells(Me.cboTest.List(Me.cboTest.ListIndex, 0), 1).Value
email = xlSheet.Cells(Me.cboTest.List(Me.cboTest.ListIndex, 0), 2).Value
text = xlSheet.Cells(Me.cboTest.List(Me.cboTest.ListIndex, 0), 3).Value
'excel cleanup
Set xlSheet = Nothing
xlWB.Close False
xlApp.Quit
Set xlWB = Nothing
Set xlApp = Nothing
'print output to console
'instead of this, write your email
Debug.Print "mailto:" & email & " name:" & name & " text: " & text
End Sub
Then, if we open the form, we can select from the values:
If we then click the button, it will open excel and get the relevant values of the item we have selected.
Output for Name5 looks like this:
By the way, my excel example list looks like this:
#user3598756
I made the config with your code:
userform14 code:"
Private Sub btnOK_Click()
Me.Hide
End Sub
Private Sub CancelButton_Click()
Me.Hide
End
End Sub
Private Sub UserForm_Click()
End Sub
and the function code:
Sub email_DP2()
Dim name As String, email As String, text As String
Dim OutApp As Object
Dim OutMail As Object
Dim olInsp As Object
Dim oRng As Object
Dim StrBdB As String
Dim xlApp As Object
Dim sourceWB As Object
Dim sourceWS As Object
Set xlApp = CreateObject("Excel.Application")
strFile = "C:\persons.xlsm"
Set sourceWB = xlApp.Workbooks.Open(strFile, , False, , , , , , , True)
Set sourceWH = sourceWB.Worksheets("Sheet4")
sourceWH.Application.Run "Module2.FetchData3"
Dim pickedName As String, emailAddress As String, emailText As String
Dim namesRng As Range
With sourceWH '<== change "myWorkbookName" and "Sheet4" to your needs
Set namesRng = .Range("L1:L" & .Cells(.Rows.Count, "L").End(xlUp).Row)
End With
With UserForm14 ' change it to whatever name your actual UserForm has
.ComboBox1.List = xlApp.Transpose(namesRng)
.Show
With ComboBox1
pickedName = .Value
emailAddress = namesRng.Offset(, 5).Cells(.ListIndex + 1, 1).Value
emailText = namesRng.Offset(, 6).Cells(.ListIndex + 1, 1).Value
End With
End With
Unload UserForm14
On Error Resume Next
Set OutApp = GetObject(, "Outlook.Application")
If Err <> 0 Then Set OutApp = CreateObject("Outlook.Application")
On Error GoTo 0
Set OutMail = OutApp.CreateItem(0)
With OutMail
OutMail.SentOnBehalfOfName = ""
.Importance = olImportanceHigh
.To = emailAddress
.Subject = pickedName
Set olInsp = .GetInspector
Set wdDoc = olInsp.WordEditor
Set oRng = wdDoc.Range
oRng.collapse 1
.Display
OutMail.HTMLBody = emailText
oRng.Paste
End With
Set OutMail = Nothing
Set OutApp = Nothing
Set olInsp = Nothing
Set wdDoc = Nothing
Set oRng = Nothing
End Sub
It gives object required on line pickedName = .Value - if i eliminate the line it will give the same at line emailAddress = namesRng.Offset ... I thing is a problem with With ComboBox1 - if i eliminate with , it will generate an email but without the to, subject and text added to it.
So I am trying to create a code to expedite inserting a hyperlink in Outlook.
I am trying to have it so that if I have already copied a path, I can just go in and type Ctrl W and it will insert the hyperlink for the word here. My attempt at the code is:
Sub InsertHyperlink()
'
'
'
On Error Resume Next
ActiveDocument.Hyperlinks.Add Anchor:=Selection.Range, Address:= _
"U:\plot.log", _
SubAddress:="", ScreenTip:="", TextToDisplay:="here"
End Sub
I am having issues on how to update my code so that will work in Outlook (I programmed it in Word) and so that the "U:\plot.log" would actually be the copied path (not the copied path when I recorded the macro).
Does anyone have any suggestions?
Set your references to Word object Library
Tools > References > add Word object Library
Option Explicit
Sub Add_Hyperlinks()
Dim olNameSpace As Outlook.NameSpace
Dim wDoc As Word.Document
Dim rngSel As Word.Selection
If Application.ActiveInspector.EditorType = olEditorWord Then
Set wDoc = Application.ActiveInspector.WordEditor ' use WordEditor
Set olNameSpace = Application.Session
Set rngSel = wDoc.Windows(1).Selection ' Current selection
wDoc.Hyperlinks.Add rngSel.Range, _
Address:="U:\plot.log", TextToDisplay:="Here is the link"
End If
Set wDoc = Nothing
Set olNameSpace = Nothing
End Sub
Thank you so much for the help, I really appreciate it! So I made a slight variation to your code to try and get it to paste whatever is on the clipboard.
My new code is as follows. Do I need to add in any error trapping? Also, what does the option explicit exactly do?
Option Explicit
Sub Add_Hyperlinks()
Dim olNameSpace As Outlook.NameSpace
Dim wDoc As Word.Document
Dim rngSel As Word.Selection
Dim DataObj As MSForms.DataObject
Set DataObj = New MSForms.DataObject
DataObj.GetFromClipboard
If Application.ActiveInspector.EditorType = olEditorWord Then
Set wDoc = Application.ActiveInspector.WordEditor ' use WordEditor
Set olNameSpace = Application.Session
Set rngSel = wDoc.Windows(1).Selection ' Current selection
wDoc.Hyperlinks.Add rngSel.Range, _
Address:=DataObj.GetText(1), TextToDisplay:="here"
End If
Set wDoc = Nothing
Set olNameSpace = Nothing
End Sub
I have an email ready to be sent in Outlook 2013
I want to scan the body of the email for bold text (i.e., bold characters) and change its color to red
(nice to have) Exclude from the macro the signature
I put together the code below but still not working. Any ideas?
Public Sub FormatSelectedText()
Dim objItem As Object
Dim objInsp As Outlook.Inspector
' Add reference to Word library
' in VBA Editor, Tools, References
Dim objWord As Word.Application
Dim objDoc As Word.Document
Dim objSel As Word.Selection
On Error Resume Next
'Reference the current Outlook item
Set objItem = Application.ActiveInspector.CurrentItem
If Not objItem Is Nothing Then
If objItem.Class = olMail Then
Set objInsp = objItem.GetInspector
If objInsp.EditorType = olEditorWord Then
Set objDoc = objInsp.WordEditor
Set objWord = objDoc.Application
Set objSel = objWord.Selection
Set objChar = Characters.Selection
' replace the With block with your code
With objChar
' Formatting code goes here
'.Font.Size = 18
If .Font.Bold = True Then
.Font.Color = wdColorBlue
End If
.Font.Color = wdColorRed
'.Font.Italic = True
'.Font.Name = "Arial"
End With
For Each Char In Characters.Selection
If Char.Font.Bold Then
Char.Font.Color = RGB(0, 0, 255) 'TextRGBTmp
End If
Next Char
For Each Char In Characters.Selection
If Not Char.Font.Bold And Char.Font.Color = RGB(0, 0, 255) Then
Char.Font.Color = RGB(0, 0, 0)
End If
Next Char
End If
End If
End If
Set objItem = Nothing
Set objWord = Nothing
Set objSel = Nothing
Set objInsp = Nothing
End Sub
This is a follow up to question: Programmatically change font properties in email body
first of all: don't use On Error Resume Next when you're trying to debug your code. It makes your life harder.
second: use Option Explicit at the beginning of the module. With that option enabled, VBA will show you every variable that's not initialized (some bugs only occur from misspellings).
I've corrected your code, so it works for me:
Public Sub FormatSelectedText()
Dim objOutlook As Outlook.Application ' i used this because im working in MS Access
Dim objItem As Object
Dim objInsp As Outlook.Inspector
' Add reference to Word library
' in VBA Editor, Tools, References
Dim objWord As Word.Application
Dim objDoc As Word.Document
Dim objSel As Word.Selection
Dim objChar As Object
Dim Char As Object
'Reference the current Outlook item
Set objOutlook = GetObject(, "Outlook.Application")
Set objItem = objOutlook.ActiveInspector.CurrentItem
If Not objItem Is Nothing Then
If objItem.Class = olMail Then
Set objInsp = objItem.GetInspector
If objInsp.EditorType = olEditorWord Then
Set objDoc = objInsp.WordEditor
Set objWord = objDoc.Application
Set objSel = objWord.Selection
Set objChar = objSel.Characters ' this wasn't initialized
' replace the With block with your code
' With objChar ' you don't Need this block because objChar is an array and it throws an error when you try to use this code on the whole objChar object
' ' Formatting code goes here
' '.Font.Size = 18
' If .Font.Bold = True Then
' .Font.color = wdColorBlue
' End If
' .Font.color = wdColorRed
' '.Font.Italic = True
' '.Font.Name = "Arial"
' End With
For Each Char In objSel.Characters
If Char.Font.Bold Then
Char.Font.color = rgb(255, 0, 0) 'TextRGBTmp (the rgb was filled backwards, so the text became blue. i fixed it.
End If
Next Char
' the code of the second For Each was not neccessary.
End If
End If
End If
Set objItem = Nothing
Set objWord = Nothing
Set objSel = Nothing
Set objInsp = Nothing
End Sub
I have some users who would like to have multiple calendars selected when they switch to calendar folder in theirs Outlook.
So I took a sample code from:
http://www.slipstick.com/developer/code-samples/select-multiple-calendars-outlook/
Modified it a little and gave to my users. Problem is that it is not working on one of these Outlooks and I cannot find out why.
Below is my code and the exact problem is that this macro cannot "select/enable" the calendar I want - but if I try to debug the code and put MsgBox for testing - looks like the code is in right place. Procmon is not showing any "access denied" or other kind of errors.
Could You help me to investigate this ?
Sub SelectCalendars()
Dim objPane As Outlook.NavigationPane
Dim objModule As Outlook.CalendarModule
Dim objGroupA, objGroupB As Outlook.NavigationGroup
Dim objNavFolder As Outlook.NavigationFolder
Dim objCalendar As Folder
Dim objFolder As Folder
Dim i As Integer
Dim test As Outlook.NavigationFolder
Set Application.ActiveExplorer.CurrentFolder = Session.GetDefaultFolder(olFolderCalendar)
DoEvents
Set objCalendar = Session.GetDefaultFolder(olFolderCalendar)
Set objPane = Application.ActiveExplorer.NavigationPane
Set objModule = objPane.Modules.GetNavigationModule(olModuleCalendar)
With objModule.NavigationGroups
Set objGroupA = .Item(1)
End With
' First calendar group
Set objNavFolder = objGroupA.NavigationFolders.Item(1)
MsgBox objNavFolder.DisplayName
MsgBox objNavFolder.IsSelected
objNavFolder.IsSelected = False
' Second calendar group
Set objNavFolder = objGroupA.NavigationFolders.Item(2)
MsgBox objNavFolder.DisplayName
MsgBox objNavFolder.IsSelected
objNavFolder.IsSelected = False
Set objPane = Nothing
Set objModule = Nothing
Set objGroup = Nothing
Set objNavFolder = Nothing
Set objCalendar = Nothing
Set objFolder = Nothing
End Sub
First of all, I'd suggest using the Debug.Print statements instead of Message boxes.
The IsSelected property of the NavigationFolder class allows to set a boolean variable that indicates whether the NavigationFolder object is selected for display. Try to set this property to true (instead of false).