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
Related
I need to find the ID of a Outlook Calendar. It is a public calendar with many contributors/users, but not listed as "shared".
I want to automatically export selected calendars to an *.ics.
Currently I only can export my default folder with:
Set oNamespace = Application.GetNamespace("MAPI")
Set oFolder = oNamespace.GetDefaultFolder(olFolderCalendar)
Set oCalendarSharing = oFolder.GetCalendarExporter
oCalendarSharing.SaveAsICal "C:\calendar.ics"
I need to add the "ThisOne" to the export.
The properties do not have a location:
How to I find the ID, so I can use it with "GetFolderFromID()"? Or are there better ways to include the Calendar in the export or export it on its own?
Edit:
Now I think I got the Calendar-ID by using
Set oNamespace = Application.GetNamespace("MAPI")
Set oFolderPicked = oNamespace.PickFolder
Set oFolder = oNamespace.GetFolderFromID(oFolderPicked.EntryID, oFolderPicked.StoreID)
Set oCalendarSharing = oFolder.GetCalendarExporter
but this throws a exception at the last line (GetCalendarExporter):
If I export in the GUI (File -> Save), it works without a problem...
(Later I dont want to use PickFolder and just hard-code the EntryID to the script)
Open Outlook -> Goto Calendar of choice -> Alt F11 -> Immediate Window -> Type the following and hit enter.
? ActiveExplorer.CurrentFolder.EntryID
This demonstrates how to get the EntryID of a folder.
Option Explicit
Sub entryIDFromActiveExplorer()
Dim entryIDStr As String
Dim uPrompt As String
Dim uTitle As String
Dim uDefault As String
Dim msg As String
' Select a folder in the folder view
' Do not use the calendar view
entryIDStr = ActiveExplorer.CurrentFolder.entryID
uPrompt = "To hardcode the entryID of the " & _
Session.GetFolderFromID(entryIDStr) & _
" folder, copy this ID"
' Copy from the immediate pane
Debug.Print uPrompt
Debug.Print entryIDStr
uTitle = Session.GetFolderFromID(entryIDStr)
uDefault = entryIDStr
msg = InputBox(Prompt:=uPrompt, Title:=uTitle, Default:=uDefault)
End Sub
Sub entryIDFromPickfolder()
' If you do not want to select a folder
' in the normal way, from the GUI
Dim oFolderPicked As folder
Dim entryIDStr As String
Dim uPrompt As String
Dim uTitle As String
Dim uDefault As String
Dim msg As String
Set oFolderPicked = Session.PickFolder
If Not oFolderPicked Is Nothing Then
entryIDStr = oFolderPicked.entryID
uPrompt = "To hardcode the entryID of the " & _
Session.GetFolderFromID(entryIDStr) & _
" folder, copy this ID"
' Copy from the immediate pane
Debug.Print uPrompt
Debug.Print entryIDStr
Set ActiveExplorer.CurrentFolder = Session.GetFolderFromID(entryIDStr)
DoEvents
uTitle = Session.GetFolderFromID(entryIDStr)
uDefault = entryIDStr
msg = InputBox(Prompt:=uPrompt, Title:=uTitle, Default:=uDefault)
End If
ExitRoutine:
Set oFolderPicked = Nothing
End Sub
Is there a way to (in VBA)
(1) jump from a folder in the outlook favorites pane to the actual folder in the tree pane and
(2) is there a way to establish if the "selected" folder is in the tree or in the favorites pane?
I've been using this for #1 forever. Answering this question, I've solved it in part for #2.
The 2 macros find the folder of the currently selected email or finds a folder by name.
I've only updated the 1st macro for now.
Private m_Folder As Outlook.MAPIFolder
Private m_Find As String
Private m_Wildcard As Boolean
'Jumps to the folder based on currently selected email - works great from a search or search folder
'Offers to Jump to the folder (if it was also in the favorites view)
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
Debug.Print F.FolderPath
Debug.Print Application.ActiveExplorer.NavigationPane.CurrentModule.NavigationModuleType
Debug.Print Application.ActiveExplorer.NavigationPane.CurrentModule
Msg = "The path is: " & F.FolderPath & vbCrLf
'ModuleValue : Folder = 6 / Mail = 1
Msg = Msg & "Switch to the folder?"
If MsgBox(Msg, vbYesNo) = vbYes Then
Set Application.ActiveExplorer.CurrentFolder = F
End If
' If the found folder is a favorite... offer option to jump out of Mail ( favorites view )
' Should be able to figure it out prompting user (me) but this works for now
If Application.ActiveExplorer.NavigationPane.CurrentModule.NavigationModuleType = 0 Then
Msg = "If your folder is in your favorites list, you can Jump from Favorites. Do so now ? "
If MsgBox(Msg, vbYesNo) = vbYes Then
'The below does this "Set Application.ActiveExplorer.NavigationPane.CurrentModule.NavigationModuleType = 6"
'Toggle Back
Set Application.ActiveExplorer.NavigationPane.CurrentModule = Application.ActiveExplorer.NavigationPane.Modules(6)
'Toggle Back
Set Application.ActiveExplorer.NavigationPane.CurrentModule = Application.ActiveExplorer.NavigationPane.Modules(1)
End If
End If
End Sub
'Find a folder by name - case sensitive
Public Sub FindFolder()
Dim Name$
Dim Folders As Outlook.Folders
Set m_Folder = Nothing
m_Find = ""
m_Wildcard = False
Name = InputBox("Find Name:", "Search Folder")
If Len(Trim$(Name)) = 0 Then Exit Sub
m_Find = Name
m_Find = LCase$(m_Find)
m_Find = Replace(m_Find, "%", "*")
m_Wildcard = (InStr(m_Find, "*"))
Set Folders = Application.Session.Folders
LoopFolders Folders
If Not m_Folder Is Nothing Then
If MsgBox("Activate Folder: " & vbCrLf & m_Folder.FolderPath, vbQuestion Or vbYesNo) = vbYes Then
Set Application.ActiveExplorer.CurrentFolder = m_Folder
End If
Else
MsgBox "Not Found", vbInformation
End If
End Sub
'used by the search to loop through
Private Sub LoopFolders(Folders As Outlook.Folders)
Dim F As Outlook.MAPIFolder
Dim Found As Boolean
For Each F In Folders
If m_Wildcard Then
Found = (LCase$(F.Name) Like m_Find)
Else
Found = (LCase$(F.Name) = m_Find)
End If
If Found Then
Set m_Folder = F
Exit For
Else
LoopFolders F.Folders
If Not m_Folder Is Nothing Then Exit For
End If
Next
End Sub
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
i have the following code which is meant to forward an email, and include my own message.
Private Sub Items_ItemAdd(ByVal item As Object)
Dim filenum As Integer
Dim current_number As String
filenum = FreeFile()
Open "G:\Infrastructure Services\Engineering Services\Hazard Report Number.txt" For Input As #filenum
While Not EOF(filenum)
Line Input #filenum, current_number
Wend
If item.Class = olMail Then
If Left$(item.Subject, 29) = "Hazard Identification Report" Then
Dim Msg As Outlook.MailItem
Dim NewForward As Outlook.MailItem
Dim myFolder As Outlook.MAPIFolder
Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Set Msg = item
Set NewForward = Msg.Forward
Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
strSender = ""
strsenderName = Msg.SenderEmailAddress
If strsenderName = "EX" Then
Set objSender = itm.Sender
If Not (objSender Is Nothing) Then
Set objExchUser = Sender.GetExchangeUser()
If Not (objExchUser Is Nothing) Then
strSender = objExchUser.PrimarySmtpAddress
End If
End If
Else
strSender = strsenderName
End If
With NewForward
.Subject = "Hazard report reciept number:"
.To = strSender
.HTMLBody = "TYhank you for your email"
.Send
End With
End If
End If
ExitProc:
Set NewForward = Nothing
Set Msg = Nothing
Set olApp = Nothing
Set olNS = Nothing
End Sub
I've read the value in from my text file, no problem. the question i have is how do i delete the value from the text file, and print the value +1 back into the text file?
also, this is meant to forward the message back to the sender, including their original attachments and message (a photo and some GPS co-ordinates), but its not for some reason and i can't see why.
does any body have any suggestions?
I do not quite understand what your second problem is ("but ist not for some reason and I can't see why" is not the perfect error description).
But for replacing a txt-file with a new value use this:
Call textfile_replace(Value + 1)
and this is the code you need:
Sub textfile_replace(mytext As String)
On Error GoTo Fehler
Dim Datei As String
Dim Fnr As Long
Datei = "c:\mytest.txt"
Fnr = FreeFile
Open Datei For Output As Fnr
Print #Fnr, mytext
Close Fnr
Exit Sub
Fehler:
MsgBox "error" & Err.Number & " " & Err.Description
End Sub
If you send some more Information what problem you have with sending the mail I will try to help you there as well.
Max
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