When searching for items in All Outlook Items, it shows the messages/items found. Part of the search result items include the folder the message resides in. I'm trying to open a new window of the parent folder where the item resides then highlight that message in the new window. The following code opens the folder, but I cannot figure out how to locate and select the item.
'Opens folder in new windows of current messages folder location
Public Sub OpenFolderPath()
Dim obj As Object
Dim objOLApp As Outlook.Application
Dim objExp As Outlook.Explorer
Dim F As Outlook.MAPIFolder
Dim Msg$
Dim SelMsg As MailItem
Set obj = Application.ActiveWindow
If TypeOf obj Is Outlook.Inspector Then
Set obj = obj.CurrentItem
Else
Set obj = obj.Selection(1)
End If
Set F = obj.Parent
Msg = "The path is: " & F.Name & vbCrLf
Msg = Msg & "Switch to the folder?"
If MsgBox(Msg, vbYesNo) = vbYes Then
Set objExp = Application.Explorers.Add(F, olFolderDisplayNormal)
objExp.Activate
End If
' The following does not work
For Each SelMsg In objExp.CurrentFolder.Items
If obj.EntryID = SelMsg.EntryID Then
MsgBox SelMsg.EntryID
' What to put here to select the found item.
End If
Next
End Sub
Here's code that will work:
'Opens folder in new windows of current messages folder location
Public Sub OpenFolderPath()
Dim obj As Object
Dim objOLApp As Outlook.Application
Dim objExp As Outlook.Explorer
Dim F As Outlook.MAPIFolder
Dim Msg$
Dim SelMsg As MailItem
Dim i as Long
Set obj = Application.ActiveWindow
If TypeOf obj Is Outlook.Inspector Then
Set obj = obj.CurrentItem
Else
Set obj = obj.Selection(1)
End If
Set F = obj.Parent
Msg = "The path is: " & F.Name & vbCrLf
Msg = Msg & "Switch to the folder?"
If MsgBox(Msg, vbYesNo) = vbYes Then
Set objExp = Application.Explorers.Add(F, olFolderDisplayNormal)
objExp.Activate
End If
'Wait for the user interface to catch up
' (Wait for the new window to finish displaying)
DoEvents
objExp.ClearSelection
For Each SelMsg In objExp.CurrentFolder.Items
If obj.EntryID = SelMsg.EntryID Then
objExp.AddToSelection SelMsg
End If
Next
End Sub
'Opens folder in new windows of current messages folder location
Public Sub OpenFolderPath()
Dim obj As Object
Dim objOLApp As Outlook.Application
Dim objExp As Outlook.Explorer
Dim F As Outlook.MAPIFolder
Dim Msg$
Dim SelMsg As MailItem
Dim i as Long
Set obj = Application.ActiveWindow
If TypeOf obj Is Outlook.Inspector Then
Set obj = obj.CurrentItem
Else
Set obj = obj.Selection(1)
End If
Set F = obj.Parent
Msg = "The path is: " & F.Name & vbCrLf
Msg = Msg & "Switch to the folder?"
If MsgBox(Msg, vbYesNo) = vbYes Then
Set objExp = Application.Explorers.Add(F, olFolderDisplayNormal)
objExp.Activate
End If
' The following does not work
i = 1
For Each SelMsg In objExp.CurrentFolder.Items
If obj.EntryID = SelMsg.EntryID Then
MsgBox objExp.CurrentFolder.Items.Item(i)
' What to put here to select the found item.
End If
i = i + 1
Next
End Sub
Related
I found VBA code to sync my Outlook calendar with OneNote.
On line 7, I get
User-defined type not defined.
I have One Note 15 and Outlook 16 selected in references.
Sub SyncCalendarWithOneNote()
Dim olApp As Outlook.Application
Dim olCalendar As Outlook.Folder
Dim olItems As Outlook.Items
Dim olItem As Object
Dim onApp As OneNote.Application
Dim onNotebook As OneNote.Notebook
Dim onSection As OneNote.Section
Dim onPage As OneNote.Page
Dim onPageContent As String
Dim onPageID As String
' Connect to Outlook and OneNote
Set olApp = Outlook.Application
Set onApp = OneNote.Application
' Get the calendar folder and its items
Set olCalendar = olApp.Session.GetDefaultFolder(olFolderCalendar)
Set olItems = olCalendar.Items
' Loop through the calendar items
For Each olItem In olItems
' Check if the item is an appointment
If TypeOf olItem Is Outlook.AppointmentItem Then
' Get the appointment information
Dim olSubject As String
Dim olStart As Date
Dim olEnd As Date
olSubject = olItem.Subject
olStart = olItem.Start
olEnd = olItem.End
' Create a OneNote page for the appointment
Set onNotebook = onApp.ActiveNotebook
Set onSection = onNotebook.Sections("Calendar")
onApp.CreateNewPage Onenote.nsHierarchyScopeSection, onSection.ID, onPageID
Set onPage = onApp.GetPageContent(onPageID)
onPageContent = "Subject: " & olSubject & vbCrLf & _
"Start: " & olStart & vbCrLf & _
"End: " & olEnd
onApp.UpdatePageContent onPage.ID, onPageContent
End If
Next
' Clean up
Set olCalendar = Nothing
Set olItems = Nothing
Set olItem = Nothing
Set onApp = Nothing
Set onNotebook = Nothing
Set onSection = Nothing
Set onPage = Nothing
End Sub
I want to sync Outlook Calendar with OneNote where a new note will be created for each calendar event.
I have written a macro to open the path to a selected email in the results of the Outlook search.
The email is not automatically marked in the open folder so I search for the email in "ActiveExplorer". With .display, I can open the email, but I could not find a way to select the found email in "ActiveExplorer".
Public Sub MailOrdnerPfad()
Dim obj As Object
Dim Ordner As Outlook.MAPIFolder
Dim Betreff As String
Dim Mail As MailItem
Set obj = Application.ActiveWindow
If TypeOf obj Is Outlook.Inspector Then
Set obj = obj.CurrentItem
Else
Set obj = obj.Selection(1)
End If
Betreff = obj.ConversationTopic
Set Ordner = obj.Parent
Set Application.ActiveExplorer.CurrentFolder = Ordner
For Each Mail In Ordner.Items
If Mail.ConversationTopic = Betreff Then
Mail.Display
Exit For
End If
Next
End Sub
Clear the original selection then add the found item.
Option Explicit
Public Sub MailOrdnerPfad()
Dim obj As Object
Dim Ordner As Folder
Dim ordItem As Object
Dim Betreff As String
Dim myMail As MailItem
Set obj = ActiveWindow
If TypeOf obj Is Inspector Then
Set obj = obj.CurrentItem
Else
Set obj = obj.Selection(1)
End If
If obj.Class = olMail Then
Betreff = obj.ConversationTopic
Debug.Print "Betreff: " & Betreff
Set Ordner = obj.Parent
Set ActiveExplorer.CurrentFolder = Ordner
Debug.Print "Ordner.: " & Ordner
For Each ordItem In Ordner.items
If ordItem.Class = olMail Then
Set myMail = ordItem
Debug.Print "myMail.ConversationTopic: " & myMail.ConversationTopic
If myMail.ConversationTopic = Betreff Then
ActiveExplorer.ClearSelection
' myMail.Display
ActiveExplorer.AddToSelection myMail
Exit For
End If
End If
Next
End If
End Sub
Note: I wrote the following code in Outlook VBA. Basically the code is in ThisOutlookSession and I scan emails that start with "new", save the attachment in Desktop and debug.print the value in Cells(1,1). However, Outlook crashed and said "Object doesn't support this property or method" on the " Debug.Print sourceSH.Cells(1,1)" line. What is wrong?
Public WithEvents myOlItems As Outlook.Items
Private Sub Application_Startup()
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")
Dim f As Folder
Set f = Application.Session.Folders.item("me").Folders.item("Inbox")
Set myOlItems = f.Items
Call LoadForm
End Sub
Private Sub myOlItems_ItemAdd(ByVal item As Object)
On Error GoTo ErrorHandler
Dim Msg As Outlook.MailItem
Dim name As String
Dim res As String
Dim sourceWB As Workbook
Dim sourceSH As Worksheet
Dim NewFileName As String
Dim xlApp As Object
If TypeName(item) = "MailItem" Then
Set Msg = item
' do stuff with item
If Left(Msg.Subject, 3) = "New" And Msg.Attachments.Count > 0 Then
NewFileName = "C:\Desktop\" & Msg.Attachments.item(1).Filename
' save file
Msg.Attachments.item(1).SaveAsFile NewFileName
Set xlApp = CreateObject("Excel.Application")
xlApp.Application.Visible = True
Set sourceWB = xlApp.Workbooks.Open(NewFileName, True, True)
Set sourceSH = sourceWB.Worksheets(1)
Debug.Print sourceSH.Cells(1,1)
End If
End If
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub
Debug.Print sourceSH.Cells(1,1)
The Print method output the message to the immediate window. You need to pass a string, not the Range object. Try to pass the Text property values to the Print method.
Debug.Print sourceSH.Cells(1,1).Text
got a little problem, I hope someone can help me.
(Outlook 2010 VBA)
this is my current code, what i need is when i click on a mail (only the mail i clicked on, not every mail in the folder/same place)
it has to check if the Sender of the mail is already in my contacts or in the
Addressbook 'All Users',
and if it's not a one of those yet, open the AddContact window and fill in his/her information
what doesn't work yet is:
most important of all, it doesn't run the script when i click on a mail
the current check if the contact already exsist doesn't work
and goes with a vbMsgBox (yes or no and response stuff) wich is not what i want/need
if the contact already exsist then nothing has to happen.
I hope i gave enough information and someone can help me out here :)
Sub AddAddressesToContacts(objMail As Outlook.MailItem)
Dim folContacts As Outlook.MAPIFolder
Dim colItems As Outlook.Items
Dim oContact As Outlook.ContactItem
Dim oMail As Outlook.MailItem
Dim obj As Object
Dim oNS As Outlook.NameSpace
''don't want or need a vbBox/ask box, this is a part of the current contactcheck
''wich doesn't work and is totaly wrong :P
Dim response As VbMsgBoxResult
Dim bContinue As Boolean
Dim sSenderName As String
On Error Resume Next
Set oNS = Application.GetNamespace("MAPI")
Set folContacts = oNS.GetDefaultFolder(olFolderContacts)
Set colItems = folContacts.Items
''this selects the mail that is currently selected.
''what i want is that the sender of the new incoming mail gets added to contacts
''(ofcourse, if that contact doesn't exsist yet)
''so the new incoming mail gotta be selected.
For Each obj In Application.ActiveExplorer.Selection
If obj.Class = olMail Then
Set oContact = Nothing
bContinue = True
sSenderName = ""
Set oMail = obj
sSenderName = oMail.SentOnBehalfOfName
If sSenderName = ";" Then
sSenderName = oMail.SenderName
End If
Set oContact = colItems.Find("[FullName] = '" & sSenderName & "'")
''this part till the --- is wrong, i need someting to check if the contact (the sender)
''already exsists. Any ideas?
If Not (oContact Is Nothing) Then
response = vbAbort
If response = vbAbort Then
bContinue = False
End If
End If
''---------
If bContinue Then
Set oContact = colItems.Add(olContactItem)
With oContact
.Email1Address = oMail.SenderEmailAddress
.Email1DisplayName = sSenderName
.Email1AddressType = oMail.SenderEmailType
.FullName = oMail.SenderName
'.Save
oContact.Display
End With
End If
End If
Next
Set folContacts = Nothing
Set colItems = Nothing
Set oContact = Nothing
Set oMail = Nothing
Set obj = Nothing
Set oNS = Nothing
End Sub
hey, i still have a last question,
'sets the name of the contact
Set oContact = colItems.Find("[FullName] = '" & sSenderName & "'")
'checks if the contact exsist, if it does exit the for loop
If Not oContact Is Nothing Then
Exit For
End If
End If
this checks if the name is already in contacts,
i need it that it checks if the E-mailaddress is in contacts or not,
can you help me with that?
i had someting like this in mind
set oSendermail = ?the e-mailaddress?
If Not oSendermail Is Nothing Then
Exit For
End If
End If
A solution (including test routine) could look as follows:
(assuming that we only consider external SMTP mails. Adjust the path to your contact folder and add some more error checking!)
Option Explicit
Private Declare Function GetTickCount Lib "kernel32.dll" () As Long
Sub AutoContactMessageRule(newMail As Outlook.mailItem)
' "script" routine to be called for each incoming Mail message
' This subroutine has to be linked to this mail type using
' Outlook's rule assistant
Dim EntryID As String
Dim StoreID As Variant
Dim mi As Outlook.mailItem
Dim contactFolder As Outlook.Folder
Dim contact As Outlook.ContactItem
On Error GoTo ErrorHandler
' we have to access the new mail via an application reference
' to avoid security warnings
EntryID = newMail.EntryID
StoreID = newMail.Parent.StoreID
Set mi = Application.Session.GetItemFromID(EntryID, StoreID)
With mi
If .SenderEmailType = "SMTP" Then
Set contactFolder = FindFolder("Kemper\_local\TestContacts")
Set contact = contactFolder.items.Find("[Email1Address]=" & Chr(34) & .SenderEmailAddress & Chr(34))
If Not TypeName(contact) <> "Nothing" Then
Set contact = contactFolder.items.Add(olContactItem)
contact.Email1Address = .SenderEmailAddress
contact.Email1AddressType = .SenderEmailType
contact.FullName = .SenderName
contact.Save
End If
End If
End With
Exit Sub
ErrorHandler:
MsgBox Err.Description, vbCritical, "Ooops!"
Err.Clear
On Error GoTo 0
End Sub
Private Function FindFolder(path As String) As Outlook.Folder
' Locate MAPI Folder.
' Separate sub-folder using '/' . Example: "My/2012/Letters"
Dim fd As Outlook.Folder
Dim subPath() As String
Dim I As Integer
Dim ns As NameSpace
Dim s As String
On Error GoTo ErrorHandler
s = Replace(path, "\", "/")
If InStr(s, "//") = 1 Then
s = Mid(s, 3)
End If
subPath = Split(s, "/", -1, 1)
Set ns = Application.GetNamespace("MAPI")
For I = 0 To UBound(subPath)
If I = 0 Then
Set fd = ns.Folders(subPath(0))
Else
Set fd = fd.Folders(subPath(I))
End If
If fd Is Nothing Then
Exit For
End If
Next
Set FindFolder = fd
Exit Function
ErrorHandler:
Set FindFolder = Nothing
End Function
Public Sub TestAutoContactMessageRule()
' Routine to test Mail Handlers AutoContactMessageRule()'
' without incoming mail messages
' select an existing mail before executing this routine
Dim objItem As Object
Dim objMail As Outlook.mailItem
Dim started As Long
For Each objItem In Application.ActiveExplorer.Selection
If TypeName(objItem) = "MailItem" Then
Set objMail = objItem
started = GetTickCount()
AutoContactMessageRule objMail
Debug.Print "elapsed " & (GetTickCount() - started) / 1000# & "s"
End If
Next
End Sub
Is there a way to add a column to the search result in outlook, that shows the folderpath instead of only the folders name? If yes, may you provide some tutorials or documentation?
thank you
You can get this information, one email at a time with this.
http://vboffice.net/sample.html?lang=en&mnu=2&smp=65&cmd=showitem
Public Sub GetItemsFolderPath()
Dim obj As Object
Dim F As Outlook.MAPIFolder
Dim Msg$
Set obj = Application.ActiveWindow
If TypeOf obj Is Outlook.Inspector Then
Set obj = obj.CurrentItem
Else
Set obj = obj.Selection(1)
End If
Set F = obj.Parent
Msg = "The path is: " & F.FolderPath & vbCrLf
Msg = Msg & "Switch to the folder?"
If MsgBox(Msg, vbYesNo) = vbYes Then
Set Application.ActiveExplorer.CurrentFolder = F
End If
End Sub