I want the code below to run on Open of an .oft file/email.
I am getting a Runtime 91 error.
Public WithEvents myItem As Outlook.MailItem
Public EventsDisable As Boolean
Private Sub Application_ItemLoad(ByVal Item As Object)
If EventsDisable = True Then Exit Sub
Set myItem = Item
End Sub
Private Sub myItem_Open(Cancel As Boolean)
EventsDisable = True
Dim Insp As Inspector
Dim obj As Object
Set Insp = Application.ActiveInspector
Set obj = Insp.CurrentItem
obj.HTMLBody = Replace(obj.HTMLBody, "XXXX", Format(Now + 14, "MMMM dd, yyyy"))
Set obj = Nothing
Set Insp = Nothing
EventsDisable = False
End Sub
If I run the last Sub myItem_Open as a public sub manually it works perfectly.
You need to use the Inspectors.NewInspector event instead (Inspectors can be retrieved from Application.Inspectors).
UPDATE. Off the top my head
Public WithEvents myInspectors As Outlook.Inspectors
Private Sub Application_Startup()
set myInspectors = Application.Inspectors
MsgBox "Application_Startup"
End Sub
Private Sub myInspectors_NewInspector(ByVal insp As Inspector)
MsgBox "myInspectors_NewInspector"
Set obj = Insp.CurrentItem
obj.HTMLBody = Replace(obj.HTMLBody, "XXXX", Format(Now + 14, "MMMM dd, yyyy"))
Set obj = Nothing
End Sub
Related
I have a script that works on my main inbox. It will move the email to a sub folder when a category is assigned. The sub folder is the same name as the category.
How do I modify the code to reference a shared mailbox?
My code that works on main inbox:
Private WithEvents xInboxFld As Outlook.Folder
Private WithEvents xInboxItems As Outlook.Items
Private Sub Application_Startup()
Set xInboxFld = Outlook.Application.Session.GetDefaultFolder(olFolderInbox)
Set xInboxItems = xInboxFld.Items
End Sub
Private Sub xInboxItems_ItemChange(ByVal Item As Object)
Dim xMailItem As Outlook.MailItem
Dim xFlds As Outlook.Folders
Dim xFld As Outlook.Folder
Dim xTargetFld As Outlook.Folder
Dim xFlag As Boolean
On Error Resume Next
If Item.Class = olMail Then
Set xMailItem = Item
xFlag = False
If xMailItem.Categories <> "" Then
Set xFlds = Application.Session.GetDefaultFolder(olFolderInbox).Folders
If xFlds.Count <> 0 Then
For Each xFld In xFlds
If xFld.Name = xMailItem.Categories Then
xFlag = True
End If
Next
End If
If xFlag = False Then
Application.Session.GetDefaultFolder(olFolderInbox).Folders.Add xMailItem.Categories, olFolderInbox
End If
Set xTargetFld = Application.Session.GetDefaultFolder(olFolderInbox).Folders(xMailItem.Categories)
xMailItem.Move xTargetFld
End If
End If
End Sub
I was able to get it working with the below
Option Explicit
Private WithEvents SharedInboxFld As Outlook.Folder
Private WithEvents SharedInboxItems As Outlook.Items
Private Sub Application_Startup()
Set SharedInboxFld = Outlook.Application.Session.Folders.Item("Shared MailboxName").Folders("Inbox") 'use the appropriate folder name
Set SharedInboxItems = SharedInboxFld.Items
End Sub
Private Sub SharedInboxItems_ItemChange(ByVal Item As Object)
Dim xFlds As Outlook.Folders
Dim xFld As Outlook.Folder
Dim xTargetFld As Outlook.Folder
Dim xFlag As Boolean
On Error Resume Next
If Item.Class = olMail Then
xFlag = False
If Item.Categories <> "" Then
Set xFlds = SharedInboxFld.Folders
If xFlds.Count <> 0 Then
For Each xFld In xFlds
If xFld.Name = Item.Categories Then
xFlag = True
End If
Next
End If
If xFlag = False Then
SharedInboxFld.Folders.Add Item.Categories, olFolderInbox
End If
Set xTargetFld = SharedInboxFld.Folders(Item.Categories)
Item.Move xTargetFld
End If
End If
End Sub
Instead of GetDefaultFolder, call Outlook.Application.Session.CreateRecipient, and pass the returned Recipient object to GetSharedDefaultFolder.
I want to move emails, once they are categorized, into a folder with the same name as the category.
What I found so far:
Private WithEvents Explorer As Outlook.Explorer
Private WithEvents Mail As Outlook.MailItem
Private MoveToThisFolder As Outlook.MAPIFolder
Friend Sub Application_Startup()
On Error Resume Next
Set Explorer = Application.ActiveExplorer
End Sub
Private Sub Explorer_SelectionChange()
Dim obj As Object
Dim Sel As Outlook.Selection
Set Mail = Nothing
Set Sel = Explorer.Selection
If Sel.Count > 0 Then
Set obj = Sel(1)
If TypeOf obj Is Outlook.MailItem Then
Set Mail = obj
End If
End If
End Sub
Private Sub Mail_PropertyChange(ByVal Name As String)
Dim Ns As Outlook.NameSpace
Dim Inbox As Outlook.MAPIFolder
Dim Subfolder As Outlook.MAPIFolder
Dim SubfolderName As String
If Name = "Categories" Then
Set Ns = Application.GetNamespace("MAPI")
Set Inbox = Ns.GetDefaultFolder(olFolderInbox)
SubfolderName = Mail.Categories
If Len(SubfolderName) = 0 Then Exit Sub
Set Subfolder = Inbox.Folders(SubfolderName)
If Subfolder.EntryID <> Mail.Parent.EntryID Then
Set MoveToThisFolder = Subfolder
EnableTimer 500, Me
End If
End If
End Sub
Friend Sub TimerEvent()
DisableTimer
If Mail Is Nothing Then Exit Sub
If MoveToThisFolder Is Nothing Then Exit Sub
Mail.Move MoveToThisFolder
Set Mail = Nothing
Set MoveToThisFolder = Nothing
End Sub
I have some problems with respect to Friend Sub TimerEvent () because it gives me
Sub or Function not compiled correctly
At the end i figured out in this way:
Private WithEvents xInboxFld As Outlook.Folder
Private WithEvents xInboxItems As Outlook.Items
Private Sub Application_Startup()
Set xInboxFld = Outlook.Application.Session.GetDefaultFolder(olFolderInbox)
Set xInboxItems = xInboxFld.Items
End Sub
Private Sub xInboxItems_ItemChange(ByVal Item As Object)
Dim xMailItem As Outlook.MailItem
Dim xFlds As Outlook.Folders
Dim xFld As Outlook.Folder
Dim xTargetFld As Outlook.Folder
Dim xFlag As Boolean
On Error Resume Next
If Item.Class = olMail Then
Set xMailItem = Item
xFlag = False
If xMailItem.Categories <> "" Then
Set xFlds = Application.Session.GetDefaultFolder(olFolderInbox).Folders
If xFlds.Count <> 0 Then
For Each xFld In xFlds
If xFld.Name = xMailItem.Categories Then
xFlag = True
End If
Next
End If
If xFlag = False Then
Application.Session.GetDefaultFolder(olFolderInbox).Folders.Add xMailItem.Categories, olFolderInbox
End If
Set xTargetFld = Application.Session.GetDefaultFolder(olFolderInbox).Folders(xMailItem.Categories)
xMailItem.Move xTargetFld
End If
End If
End Sub
Hope it could help!!!
The error is due to missing code for DisableTimer and EnableTimer.
The category has not yet updated when the code is triggered.
EnableTimer delays the move until after the category updates.
Without a delay, there would be an error when attempting to update, due to the item having been moved.
Attribution: http://www.vboffice.net/en/developers/trigger-actions-with-categories/
I have a macro in that creates a ListBox.
The first item should be selected as default.
I tried
UserForm.ListBox.Selected(0) = True
I get
How can I control the Listbox from the keyboard? I need to scroll up and down with "UP" and "DOWN" keys and if "ENTER" is pressed the selected Item should be taken.
I tried the following, but this captures every "ENTER" during the code (not only when the UserForm (ListBox) is loaded).
Public Sub Listbox_Enter()
'DO Something
End Sub
Current code:
Option Explicit
Public WithEvents GExplorer As Outlook.Explorer
Public WithEvents GMailItem As Outlook.MailItem
Public WithEvents objInspectors As Outlook.Inspectors
Public WithEvents objTask As Outlook.TaskItem
'Start Outlook
Private Sub Application_Startup()
Set GExplorer = Outlook.Application.ActiveExplorer
Set objInspectors = Outlook.Application.Inspectors
End Sub
'Capture every change, but on same ActiveExplorer (Window)
Private Sub GExplorer_SelectionChange()
Dim xItem As Object
On Error Resume Next
Set xItem = GExplorer.Selection.Item(1)
If xItem.Class <> olMail Then Exit Sub
Set GMailItem = xItem
End Sub
'Reply pressed
Private Sub GMailItem_Reply(ByVal Response As Object, Cancel As Boolean)
AutoAddGreetingtoReply Response
End Sub
'ReplyAll pressed
Private Sub GMailItem_ReplyAll(ByVal Response As Object, Cancel As Boolean)
AutoAddGreetingtoReply Response
End Sub
'Forward pressed
Private Sub GMailItem_Forward(ByVal Response As Object, Cancel As Boolean)
AutoAddGreetingtoReply Response
End Sub
Sub AutoAddGreetingtoReply(Item As Object)
Dim xGreetStr As String: Dim xReplyMail As MailItem
Dim xSenderName As String: Dim lSpace As Long
Dim xRecipient As Recipient: Dim obj As Outlook.MailItem
Dim EmailAdress As String: Dim EmailNameBeforeAtIkon As String:
Dim c As ContactItem
Dim names As String
On Error Resume Next:
Set obj = Outlook.ActiveExplorer.Selection.Item(1)
'This part finds the receipients
If Item.Class <> olMail Then Exit Sub 'Quits if no email is chosen
Set xReplyMail = Item
For Each xRecipient In xReplyMail.Recipients
If xSenderName = "" Then
xSenderName = xRecipient.name
Else
xSenderName = xSenderName & ", " & xRecipient.name
End If
Next xRecipient
Dim lSpace_f As Variant
Dim stFirstNAme As String
Dim st_FirstName As String
Dim currentNAme As String
lSpace_f = InStr(1, xSenderName, " ", vbTextCompare)
If lSpace_f > 0 Then
stFirstNAme = Trim(Split(xSenderName, ",")(1))
st_FirstName = Split(stFirstNAme, " ")(0)
currentNAme = st_FirstName + ","
End If
'Writes a greeting
With UserForm1.Listbox_Auswahl
.AddItem "Hello " + currentNAme
.AddItem "Good morning " + currentNAme
End With
UserForm1.Caption = ("Greeting")
Load UserForm1
UserForm1.StartUpPosition = 2
UserForm1.Show
'Creates the email
With xReplyMail
.Display
.HTMLBody = "<HTML><Body><span style=""color:#0e4a80"">" + markierterEintrag + "</span style=""color:#0e4a80""></HTML></Body>" & .HTMLBody
Sendkeys "{DOWN}", True
Sendkeys "{ENTER}", True
Call Sendkeys("", False)
.Close olSave
End With
End Sub
Public Sub Sendkeys(text As Variant, Optional wait As Boolean = False)
Dim WshShell As Object
Set WshShell = CreateObject("wscript.shell")
WshShell.Sendkeys CStr(text), wait
Set WshShell = Nothing
End Sub
'-------------------------------------
Public Sub Listbox_Auswahl_Click()
If UserForm1.Listbox_Auswahl.ListIndex > -1 Then
markierterEintrag = UserForm1.Listbox_Auswahl.List(UserForm1.Listbox_Auswahl.ListIndex)
End If
Unload UserForm1
End Sub
'Public Sub Listbox_Auswahl_Enter()
' If UserForm1.Listbox_Auswahl.ListIndex > -1 Then
' markierterEintrag = UserForm1.Listbox_Auswahl.List(UserForm1.Listbox_Auswahl.ListIndex)
' End If
'
' Unload UserForm1
'End Sub
This worked for me:
Public Sub Listbox_Auswahl_Click()
If UserForm1.Listbox_Auswahl.ListIndex > -1 Then
markierterEintrag = UserForm1.Listbox_Auswahl.List(UserForm1.Listbox_Auswahl.ListIndex)
End If
End Sub
Public Sub Listbox_Auswahl_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
If KeyAscii = 13 Then
With Me.Listbox_Auswahl
If .ListIndex > -1 Then
markierterEintrag = .List(.ListIndex)
End If
End With
Unload UserForm1
End If
End Sub
Public Sub Listbox_Auswahl_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If Button = 1 Then
'pressed_key_flag = 1
If UserForm1.Listbox_Auswahl.ListIndex > -1 Then
markierterEintrag = UserForm1.Listbox_Auswahl.List(UserForm1.Listbox_Auswahl.ListIndex)
Unload UserForm1
End If
End If
End Sub
I found this code online. It is supposed to auto populate my subject line with any attachments I provide. The code does not run.
I don't receive an error or anything that suggests its even going through the code.
Public WithEvents olInspectors As Outlook.Inspectors
Public WithEvents olMail As Outlook.MailItem
Private Sub Initialize_handlers()
Set olInspectors = Application.Inspectors
End Sub
Private Sub olInspectors_NewInspector(ByVal Inspector As Inspector)
Dim olItem As Object
Set olItem = Inspector.CurrentItem
If TypeName(olItem) = "MailItem" Then Set olMail = olItem
End Sub
Private Sub olMail_AttachmentAdd(ByVal Attachment As Attachment)
MsgBox "This is a test."
If olMail.Subject = "" Then
'If you don't want the prompt,
'Just delete the Msgbox line and its corresponding "End if".
If MsgBox("Do you want to use the attachment name as the subject", vbYesNo) = vbYes Then
olMail.Subject = Attachment.DisplayName
End If
End If
End Sub
There is nothing wrong with your code, you simply need to Initialize the Inspectors
Click on Sub Initialize_handlers() and press F5
Private Sub Initialize_handlers()
Set olInspectors = Application.Inspectors
End Sub
Or just use Application.Startup Event (Outlook), Save it and restart Outlook then it should work
Example
Public WithEvents olInspectors As Outlook.Inspectors
Public WithEvents olMail As Outlook.mailitem
Private Sub Application_Startup()
Set olInspectors = Application.Inspectors
End Sub
Private Sub Initialize_handlers()
Set olInspectors = Application.Inspectors
End Sub
Private Sub olInspectors_NewInspector(ByVal Inspector As Inspector)
Dim olItem As Object
Set olItem = Inspector.CurrentItem
If TypeName(olItem) = "MailItem" Then Set olMail = olItem
End Sub
Private Sub olMail_AttachmentAdd(ByVal Attachment As Attachment)
MsgBox "This is a test."
If olMail.Subject = "" Then
'If you don't want the prompt,
'Just delete the Msgbox line and its corresponding "End if".
If MsgBox("Do you want to use the attachment name as the subject", _
vbYesNo) = vbYes Then
olMail.Subject = Attachment.DisplayName
End If
End If
End Sub
With a Context Menu option, managed in a class called "Tickets", I want to call a method called "TEmail" defined in the same class that manages the menu event.
I tried to define many different types of .OnAction property using instance, class, name, etc. but without success. I cannot run "TEmail" code.
Public WithEvents AppEvent As Outlook.Application
Private Sub AppEvent_ItemContextMenuDisplay(ByVal CommandBar As Office.CommandBar, ByVal Selection As Selection)
Dim objButton As Office.CommandBarButton
On Error GoTo ErrRoutine
Set objButton = CommandBar.Controls.Add(msoControlButton)
With objButton
.BeginGroup = True
.Caption = "Test-TEmail"
.FaceID = 1000
.Tag = "T-Email"
.OnAction = "TEmail"
End With
EndRoutine:
Exit Sub
ErrRoutine:
MsgBox Err.Number & " - " & Err.Description, vbOKOnly Or vbCritical, "Application_ItemContextMenuDisplay"
GoTo EndRoutine
End Sub
Public Sub TEmail()
... my code ...
End Sub
The solution is to create an event handler.
Public WithEvents AppEvent As Outlook.Application
Public WithEvents myControl As CommandBarButton
Private Sub AppEvent_ItemContextMenuDisplay(ByVal CommandBar As Office.CommandBar, _
ByVal Selection As Selection)
Dim objButton As Office.CommandBarButton
Dim oExp As Outlook.Explorer
Set oExp = Outlook.ActiveExplorer
On Error GoTo ErrRoutine
Set myControl = CommandBar.FindControl(, , "OpenForm")
If myControl Is Nothing Then
Set myControl = CommandBar.Controls.Add(msoControlButton)
With myControl
.Caption = "TEmail"
.FaceID = 59
.Style = msoButtonIconAndCaption
.Tag = "TEmail"
.Visible = True
End With
End If
' ...
End Sub
Private Sub myControl_Click(ByVal Ctrl As Office.CommandBarButton, _
CancelDefault As Boolean)
TEmail
End Sub
Public Sub TEmail()
' ...
End Sub