I'm using Outlook set up with a number of accounts (both POP and IMAP). When writing a new email I can obviously change which account is used to send the email by clicking the "From" button and selecting the appropriate account. However, I often forget to do this and the email then gets sent from the default account.
What I would like to be able to do is to trap the creation of the new email and display a form with radio buttons listing all the accounts so that the correct sender account can be selected before the email is drafted.
I can create the form with the list of accounts and which will return the selected account. I can also trap the creation of a new email with the Inspectors_NewInspector event but I am having problems when trying the set the Sender account.
I have tried the following code (in ThisOutlookSession) using the SendUsingAccount property but the code flags up an error saying that the property is read-only. Any ideas would be much appreciated.
Option Explicit
Private WithEvents objInspectors As Outlook.Inspectors
Private Sub Application_Startup()
Set objInspectors = Application.Inspectors
End Sub
Private Sub objInspectors_NewInspector(ByVal Inspector As Inspector)
Dim oEmail As Outlook.MailItem
If TypeName(Inspector.CurrentItem) = "MailItem" Then
Set oEmail = Inspector.CurrentItem
Set oEmail.SendUsingAccount = GetUserSelectedInput '<<<<gives error 440 - property is read-only
End If
End Sub
Private Function GetUserSelectedInput() As Account
Dim oNs As Outlook.NameSpace
Set oNs = Application.GetNamespace("MAPI")
'The following line is selecting an arbitrary account for testing purposes
'this will be replaced with the code to call a userform
'that will return the selected account
Set GetUserSelectedInput = oNs.Accounts.Item(2)
End Function
First of all, the Inspectors.NewInspector event is not the right place for accessing the mail item object. The event occurs after the new Inspector object is created but before the inspector window appears. So, I'd suggest waiting for the Inspector.Activate event which is fired when an inspector becomes the active window, either as a result of user action or through program code.
You may find the Implement a wrapper for inspectors and track item-level events in each inspector article helpful.
Second, the MailItem.SendUsingAccount property allows to set an Account object that represents the account under which the MailItem is to be sent. For example, a VBA sample code shows how to set up the property:
Sub SendUsingAccount()
Dim oAccount As Outlook.account
For Each oAccount In Application.Session.Accounts
If oAccount.AccountType = olPop3 Then
Dim oMail As Outlook.MailItem
Set oMail = Application.CreateItem(olMailItem)
oMail.Subject = "Sent using POP3 Account"
oMail.Recipients.Add ("someone#example.com")
oMail.Recipients.ResolveAll
Set oMail.SendUsingAccount = oAccount
oMail.Send
End If
Next
End Sub
I tried using the Inspector.Activate event and still had the same problem with the SendUsingAccount property being read only. I also tried using the MailIem.Open event and still the property errors as read only.
I then modified the code to Save the email before attempting to write to the SendUsingAccount property and that works, However, I'm not completely happy that it's a particularly elegant solution since it forces the email to be saved as a draft. What I can't understand is what "state" the email is in prior to the Save and whether there's another solution where the SendUsingAccount can be changed without doing the Save.
The code I'm currently using is shown below. Any comments would be welcomed.
Option Explicit
Private WithEvents objInspectors As Outlook.Inspectors
Private WithEvents objEmail As Outlook.MailItem
Public Sub test()
Set objInspectors = Application.Inspectors
End Sub
Private Sub Application_Startup()
Set objInspectors = Application.Inspectors
End Sub
Private Sub objInspectors_NewInspector(ByVal Inspector As Inspector)
If TypeOf Inspector.CurrentItem Is Outlook.MailItem Then
If Len(Inspector.CurrentItem.EntryID) = 0 Then
Set objEmail = Inspector.CurrentItem
End If
End If
End Sub
Private Sub objEmail_Open(Cancel As Boolean)
Dim objAcc As Outlook.Account
With objEmail
Set objAcc = GetUserSelectedInput()
If objAcc Is Nothing Then
Cancel = True
Else
.Save
.SendUsingAccount = objAcc
End If
End With
Set objAcc = Nothing
Set objEmail = Nothing
End Sub
Private Function GetUserSelectedInput() As Outlook.Account
Dim oNs As Outlook.NameSpace
Set oNs = Application.GetNamespace("MAPI")
'The following line is selecting an arbitrary account for testing purposes
'this will be replaced with the code to call a userform
'that will return the selected account
Set GetUserSelectedInput = oNs.Accounts.Item(3)
End Function
OK, that was silly - I was sure that I was getting a read-only error when setting SendUsingAccount property. Thanks niton for pointing out it works without it. So now I have the complete solution and it's working as required. For those that are interested, the complete code is listed below. It requires a simple form ("SelectAccount") which has a frame ("frmeOptionButtons") and two buttons ("btnOk" & "btnCancel") below the frame. The frame and form will resize depending on the number of accounts. It relies on using the form.tag property to pass a default account address when the form is opened and the selected address when OK is clicked.
The code for ThisOutlookSession is:
Option Explicit
Private WithEvents objInspectors As Outlook.Inspectors
Private WithEvents objEmail As Outlook.MailItem
Public Sub test()
Set objInspectors = Application.Inspectors
End Sub
Private Sub Application_Startup()
Set objInspectors = Application.Inspectors
End Sub
Private Sub objInspectors_NewInspector(ByVal Inspector As Inspector)
If TypeOf Inspector.CurrentItem Is Outlook.MailItem Then
If Len(Inspector.CurrentItem.EntryID) = 0 Then
Set objEmail = Inspector.CurrentItem
End If
End If
End Sub
Private Sub objEmail_Open(Cancel As Boolean)
Dim objAcc As Outlook.Account
With objEmail
Set objAcc = GetUserSelectedInput(.SendUsingAccount.SmtpAddress)
If objAcc Is Nothing Then
Cancel = True
Else
.SendUsingAccount = objAcc
End If
End With
Set objAcc = Nothing
Set objEmail = Nothing
End Sub
Private Function GetUserSelectedInput(DefaultAccount As String) As Outlook.Account
Dim objNs As Outlook.NameSpace
Dim objAcc As Outlook.Account
Dim SelectedAccount As String
With SelectAccount
.tag = LCase(DefaultAccount)
.Show
SelectedAccount = ""
On Error Resume Next 'in case form is closed
SelectedAccount = .tag
On Error GoTo 0
End With
If SelectedAccount = "" Then Exit Function
Set objNs = Application.GetNamespace("MAPI")
For Each objAcc In objNs.Accounts
If LCase(objAcc.SmtpAddress) = SelectedAccount Then
Set GetUserSelectedInput = objAcc
Exit For
End If
Next
Set objAcc = Nothing
Set objNs = Nothing
End Function
The code for the SelectAccount form is:
Option Explicit
Private Sub btnCancel_Click()
Me.tag = ""
Me.Hide
End Sub
Private Sub btnOk_Click()
Dim optButton As MSForms.OptionButton
Me.tag = ""
For Each optButton In Me.frmeOptionButtons.Controls
If optButton.value Then
Me.tag = optButton.tag
Exit For
End If
Next
Me.Hide
End Sub
Private Sub UserForm_Activate()
Dim optButton As MSForms.OptionButton
Dim NoOfBtns As Integer
Dim CaptionWidth As Long
Dim AccList() As String
Dim DefaulAccount As String
Dim i As Integer
DefaulAccount = LCase(Me.tag)
AccList = GetAccountList
NoOfBtns = UBound(AccList)
Me.btnOk.top = Me.frmeOptionButtons.top + (NoOfBtns) * 18 + 4
Me.btnCancel.top = Me.btnOk.top
Me.Height = Me.btnOk.top + Me.btnOk.Height + 36
With Me.frmeOptionButtons
.Height = NoOfBtns * 18 + 2
For Each optButton In .Controls
.Controls.Remove (optButton.Name)
Next
CaptionWidth = .Width - 4
For i = 1 To NoOfBtns
Set optButton = .Controls.Add("Forms.OptionButton.1")
With optButton
.left = 0
.top = 18 * (i - 1)
.Height = 18
.Width = CaptionWidth
.tag = LCase(AccList(i))
.Caption = AccList(i)
.value = (.tag = DefaulAccount)
End With
Next
End With
End Sub
Private Function GetAccountList() As Variant
Dim objNs As Outlook.NameSpace
Dim objAcc As Outlook.Account
Dim strAcc() As String
Dim i As Integer
Set objNs = Application.GetNamespace("MAPI")
i = 0
For Each objAcc In objNs.Accounts
i = i + 1
ReDim Preserve strAcc(i)
strAcc(i) = objAcc.SmtpAddress
Next
GetAccountList = strAcc
Set objAcc = Nothing
Set objNs = Nothing
End Function
Related
Once I tab to the email's body I want to check the subject.
If equal to a specific text then open a template.
I wrote the part about the template.
The difficult part is using the inspectors to check the subject while writing the mail.
Code in thisOutlookSession
Private Sub subject()
Dim subject As String
Dim item As Outlook.MailItem
Dim inspector As Outlook.inspector
Dim template As Outlook.MailItem
Set inspector = Outlook.ActiveInspector
Set item = inspector.CurrentItem
subject = item.subject
Debug.Print subject
If subject = "test" Then
Set template = Application.CreateItemFromTemplate("C:test\test.oft")
Display.template
Else
End If
End Sub
Please, try the next way:
Create three variables on top of ThisOutlookSession:
Private WithEvents m_Inspectors As Outlook.Inspectors
Private WithEvents m_Inspector As Outlook.Inspector
Private WithEvents myItem As Outlook.MailItem
Copy the next Startup event code in ThisOutlookSession module:
Private Sub Application_Startup()
Set m_Inspectors = Application.Inspectors
End Sub
Or copy only the line Set m_Inspectors = Application.Inspectors inside it, if already used for other purposes.
Then, copy the next events code in the same module:
Private Sub m_Inspectors_NewInspector(ByVal Inspector As Outlook.Inspector)
If TypeOf Inspector.CurrentItem Is Outlook.MailItem Then
'Handle emails only:
Set m_Inspector = Inspector
End If
End Sub
Private Sub m_Inspector_Activate()
If TypeOf m_Inspector.CurrentItem Is MailItem Then
Set myItem = m_Inspector.CurrentItem '!!!
End If
End Sub
And the PropertyChange event to be triggered when pressing enter after writing the subject (or clicking somewhere else: body, To, CC etc.):
Private Sub myItem_PropertyChange(ByVal Name As String)
Const specSubject As String = "mySubject..." 'use here the subject you need to open the template!
Const templFullName As String = "C:test\test.oft"
If Name = "Subject" Then
If myItem.Subject = specSubject Then
'do whatever you need...
myItem.Close False 'probably you want closing the new Email. If not, comment this line...
With Application.CreateItemFromTemplate(templFullName)
.Display
End With
End If
End If
End Sub
Now, manually press New Email button and play with the new mail window Subject...
The MailItem exposes aPropertyChange(String Name) event, which fires when the email subject field looses focus (among other).
You can hookup to it, but you need to declare the mail item WithEvents at module level.
See an example below:
Private WithEvents m_item As MailItem
Sub T()
Set m_item = Application.CreateItem(olMailItem)
m_item.Display
End Sub
Private Sub m_item_PropertyChange(ByVal Name As String)
If Name = "Subject" Then Debug.Print m_item.Subject
End Sub
I would like to move emails to a sub-folder of my inbox when I assign it a category
I found the following code from Extended Office but it does not work.
It is supposed to move mail to a subfolder with the same name as the category and create a folder if it does not exist.
I have enabled macros in Outlook's security settings and inserted some message box alerts to confirm that does in fact run.
The code is in ThisOutlookSession
Private WithEvents xInboxFld As Outlook.Folder
Private WithEvents xInboxItems As Outlook.Items
Private Sub Application_Startup()
MsgBox "Macros are working"
Set xInboxFld = Outlook.Application.Session.GetDefaultFolder(olFolderInbox)
Set xInboxItems = xInboxFld.Items
End Sub
Private Sub xInboxItems_ItemChange(ByVal Item As Object)
MsgBox "Item Changed"
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 don't know exactly why but this suddenly started working today, I had restarted Outlook several times before but after I needed to force close Outlook this morning it started working.
(I'm not even sure if it started working immediately because of the restart or if it was a short time afterwards triggered by something else)
I am looking for a way that when performing any email action (new email, reply, reply all, forward, etc.) that the CC field gets filled with an email "example#domain.com" before actually sending the email (an Outlook rules adds the CC after sending the email so this does not work)
Reason for adding the CC before the email is sent is so that the user has the ability to remove "examlle#domain.com" if the email is confidential
Any help is greatly appreciated as I have been searching for hours!
I am unsure of your level of VBA experience but here is a question that was asked on Stack Overflow that contains all the basis of what you want to do.
Add CC
The only things to change would be adding the other actions(currently the code use .forward only): New Email, Reply and Reply All.
Be sure to use .Display and not .Send, so that way the email will be displayed and the sender can then edit what he wants before sending the email.
[EDIT]
Option Explicit
Private WithEvents oExpl As Explorer
Private WithEvents oItem As MailItem
Private bDiscardEvents As Boolean
Dim oResponse As MailItem
'to start the macro when outlook starts
Private Sub Application_Startup()
Set oExpl = Application.ActiveExplorer
bDiscardEvents = False
End Sub
Private Sub oExpl_SelectionChange()
On Error Resume Next
Set oItem = oExpl.Selection.Item(1)
End Sub
'on Reply
Private Sub oItem_Reply(ByVal Response As Object, Cancel As Boolean)
Cancel = True
bDiscardEvents = True
Set oResponse = oItem.Reply
afterReply
End Sub
'on Forward
Private Sub oItem_Forward(ByVal Response As Object, Cancel As Boolean)
Cancel = True
bDiscardEvents = True
Set oResponse = oItem.Forward
afterReply
End Sub
'On Reply All
Private Sub oItem_ReplyAll(ByVal Response As Object, Cancel As Boolean)
Cancel = True
bDiscardEvents = True
Set oResponse = oItem.ReplyAll
afterReply
End Sub
Private Sub afterReply()
oResponse.Display
' do whatever here with .to, .cc, .cci, .subject, .HTMLBody, .Attachements.Add, etc.
oResponse.CC = "example#domain.com"
End Sub
Here is the code I put together and tested in my environnement. Just paste it in your VBA editor under ThisOutlookSession. To lauch it click inside the Application_Startup Sub and hit play. It was heavily inspired by another code I found a while back. I do not have the source however. With this everytime you starup Outlook it should start automatically.
#LaZoR_Bear
From some code I found online a while ago to solve this purpose (automatically change the from address on all new emails, replies, reply all, forwards, etc.), I finally figured out the syntax to make it CC on new emails (but your code is still required so thank you again for that).
Code solely to change the from address:
'=================================================================
'Description: Outlook macro to automatically set a different
' From address.
'
'Comment: You can set the email address at the bottom of the code.
' Uncomment the myOlExp_InlineResponse sub to also make it
' work with the Reading Pane reply feature of Outlook 2013/2016/365.
'
' author : Robert Sparnaaij
' version: 1.1
' website: https://www.howto-outlook.com/howto/setfromaddress.htm
'=================================================================
Dim WithEvents objInspectors As Outlook.Inspectors
Dim WithEvents objMailItem As Outlook.MailItem
Dim WithEvents myOlExp As Outlook.Explorer
Private Sub Application_Startup()
Initialize_handler
End Sub
Public Sub Initialize_handler()
Set objInspectors = Application.Inspectors
Set myOlExp = Application.ActiveExplorer
End Sub
Private Sub objInspectors_NewInspector(ByVal Inspector As Inspector)
If Inspector.CurrentItem.Class = olMail Then
Set objMailItem = Inspector.CurrentItem
If objMailItem.Sent = False Then
Call SetFromAddress(objMailItem)
End If
End If
End Sub
'The next 3 lines to enable Outlook 2013/2016/365 Reading Pane Reply
Private Sub myOlExp_InlineResponse(ByVal objItem As Object)
Call SetFromAddress(objItem)
End Sub
Public Sub SetFromAddress(oMail As Outlook.MailItem)
' Set your preferred default From address below.
' Exchange permissions determine if it is actually stamped
' as "Sent On Behalf Of" or "Sent As".
' The address is not properly updated for the InlineResponse
' feature in Outlook 2013/2016/365. This is only a visual bug.
oMail.SentOnBehalfOfName = "example#doman.com"
End Sub
And then with your code added onto it (plus adding oMail.CC = "example#domain.com" to the code above) looks like this:
Option Explicit
Private WithEvents oExpl As Explorer
Private WithEvents oItem As MailItem
Private bDiscardEvents As Boolean
Dim oResponse As MailItem
Dim WithEvents objInspectors As Outlook.Inspectors
Dim WithEvents objMailItem As Outlook.MailItem
Dim WithEvents myOlExp As Outlook.Explorer
Private Sub Application_Startup()
Initialize_handler
Set oExpl = Application.ActiveExplorer
bDiscardEvents = False
End Sub
Public Sub Initialize_handler()
Set objInspectors = Application.Inspectors
Set myOlExp = Application.ActiveExplorer
End Sub
Private Sub objInspectors_NewInspector(ByVal Inspector As Inspector)
If Inspector.CurrentItem.Class = olMail Then
Set objMailItem = Inspector.CurrentItem
If objMailItem.Sent = False Then
Call SetFromAddress(objMailItem)
End If
End If
End Sub
'The next 3 lines to enable Outlook 2013/2016/365 Reading Pane Reply
Private Sub myOlExp_InlineResponse(ByVal objItem As Object)
Call SetFromAddress(objItem)
End Sub
Public Sub SetFromAddress(oMail As Outlook.MailItem)
' Set your preferred default From address below.
' Exchange permissions determine if it is actually stamped
' as "Sent On Behalf Of" or "Sent As".
' The address is not properly updated for the InlineResponse
' feature in Outlook 2013/2016/365. This is only a visual bug.
oMail.SentOnBehalfOfName = "example#domain.com"
oMail.CC = "example#domain.com"
End Sub
Private Sub oExpl_SelectionChange()
On Error Resume Next
Set oItem = oExpl.Selection.item(1)
End Sub
'on Reply
Private Sub oItem_Reply(ByVal Response As Object, Cancel As Boolean)
Cancel = True
bDiscardEvents = True
Set oResponse = oItem.Reply
afterReply
End Sub
'on Forward
Private Sub oItem_Forward(ByVal Response As Object, Cancel As Boolean)
Cancel = True
bDiscardEvents = True
Set oResponse = oItem.Forward
afterReply
End Sub
'On Reply All
Private Sub oItem_ReplyAll(ByVal Response As Object, Cancel As Boolean)
Cancel = True
bDiscardEvents = True
Set oResponse = oItem.ReplyAll
afterReply
End Sub
Private Sub afterReply()
oResponse.Display
' do whatever here with .to, .cc, .cci, .subject, .HTMLBody, .Attachements.Add, etc.
oResponse.CC = "example#domain.com"
End Sub
I have a userform that is prompted when I send emails (works great. not the problem) and from there when I click the buttons on the form it moves that email to the respective folder.
What I now want is for that same userform (rather, a duplicate) to be prompted when a message in my inbox goes from unread to read. The buttons on the userform would then move that message to the respective folder.
Code to bring up userform when sending emails:
Private Sub Application_ItemSend(ByVal Item As Object, cancel As Boolean)
UserForm1.Show vbModal
cancel = False
End Sub
Code snippet for a button of the userform:
Private Sub CommandButton1_Click()
On Error GoTo error_movemessage
Dim myolapp As New Outlook.Application
Dim mynamespace As Outlook.NameSpace
Dim myinbox As Outlook.MAPIFolder
Dim mydestfolder As Outlook.MAPIFolder
Dim myitems As Outlook.Items
Dim myItem As Object
Set mynamespace = myolapp.GetNamespace("MAPI")
Set myinbox = Session.GetDefaultFolder(olFolderInbox).Parent.Folders("RetainPermanently")
Set myitems = myinbox.Items
Set mydestfolder = myinbox
Set myItem = Application.ActiveInspector.CurrentItem
myItem.Move mydestfolder
Unload Me
exit_CommandButton1_Click:
Exit Sub
error_movemessage:
MsgBox "ERROR! " & Err.Description
Resume exit_CommandButton1_Click
End Sub
I searched far and wide for pieces to this puzzle and ultimately ended up unsuccessful. Thank you in advance!
Update:
Private Sub getselecteditem_click()
Dim oApp As New Outlook.Application
Dim oExp As Outlook.Explorer
Dim oSel As Outlook.Selection
Dim oItem As Object
Set oExp = oApp.Application
Set oSel = oExp.Selection
For i = 1 To oSel.Count
Set oItem = oSel.Item(i)
If oItem.Class = olMail Then
End If
Next i
End Sub
Sub oItem_PropertyChange(ByVal Name As String)
Select Case Name
Case "UnRead"
If oItem.UnRead = False Then
UserForm2.Show vbModal
End If
End Select
End Sub
Still doesn't work however.
I realized that I've been making this much harder than it needs to be. I can simply get it to pull up the prompt whenever i load a mailitem that happens to be unread. Here is an update:
Private Sub Application_ItemLoad(ByVal Item As Object)
If Item.Class = olMail Then
If Item.UnRead Then
UserForm2.Show vbModal
End If
End If
End Sub
Firstly, if you move an item to a different folder when the message is sent, you are asking for trouble - if you want the message to be saved in a folder other than Sent Items, set the MailItem.SaveSentMessageFolder property.
To move a message when its read state changes, track the Explorer.SelectionChange event. When SelectionChange event fires, start tracking the events on multiple messages from the Explorer.Selection collection (there can be more than one, but you can get away with just the first one as a proof of concept). When MailItem.PropertyChange event fires on the Unread property, display your prompt and move the message.
I have a macro to export relevant field of emails in a subfolder but I need it to automatically run every time I receive a new email. In fact I only want the subject line exported, is there a script which will trigger that macro ('ExportMessagesToExcel') when an email lands in 'M_M_Asia'?
I'm in Outlook 2007.
I'll be forever grateful if anyone can help. Cheers guys.
You should be able to use the Application_NewMail (or NewMailEx) event in ThisOutlookSession module to call your own macro.
Another way is to create a rule that runs a VBA-script, but then you VBA sub needs to handle a MailItem parameter:
Option Explicit
Sub MyVBARule(poMail As MailItem)
End Sub
Or you could add 'ItemAdd' event handler, example here:
Option Explicit
Private Const ASIA_FOLDER_NAME As String = "M_M_Asia"
Private WithEvents m_outlookFolderItems As Outlook.Items
Private Sub Application_Startup()
Initialize_Handler
End Sub
Private Sub m_outlookFolderItems_ItemAdd(ByVal Item As Object)
' You have new mail in folder ASIA_FOLDER_NAME
RunExcelMacro
End Sub
Private Sub Initialize_Handler()
Dim outlookFolder As Outlook.MAPIFolder
Dim defaultInboxFolder As Outlook.MAPIFolder
Dim outlookNameSpace As Outlook.NameSpace
Set outlookNameSpace = Outlook.GetNamespace("MAPI")
Set defaultInboxFolder = outlookNameSpace.GetDefaultFolder(olFolderInbox)
Set outlookFolder = defaultInboxFolder.Folders(ASIA_FOLDER_NAME)
Set m_outlookFolderItems = outlookFolder.Items
End Sub
Public Sub RunExcelMacro()
On Error GoTo RunExcelMacro_Err
Const path As String = "C:\temp\Excel_VBA\"
Const fileName As String = "CallMeFromOutloouk.xlsm"
Const macroName As String = "CallMeFromOutlook"
Dim excelObject As Object
Dim workbookObject As Object
Set excelObject = CreateObject("Excel.Application")
On Error Resume Next
Set workbookObject = excelObject.Workbooks(fileName)
On Error GoTo RunExcelMacro_Err
If workbookObject Is Nothing Then
Set workbookObject = excelObject.Workbooks.Open(path & fileName)
End If
excelObject.Run fileName & "!" & macroName
Exit Sub
RunExcelMacro_Err:
MsgBox Err.Description
End Sub