Export Recipient Mail Address instead of Name in Outlook VBA - vba

I try to export the Mail Addresses from my SentObjekts to Excel - this works fine.
But the Outlook VBA Variable for the recipients Mail Address "To" exports the Name of the Recipient and not the Mail address. I will see the Mail Address in my Excel.
Did anybody knows how to export only the Mail address?
Dim RecipientEmailAddress As String
RecipientEmailAddress = .To

The following functions should be adaptable for what you require. A listener for new e-mail will be needed (which I assume you have), but you can then pass the MailItem into the EmailAddressInfo function which returns a 3 dimension array for the sender, To and CC addresses. I've included a test function which can be used to check this
The code should be expandable in the case of unknown e-mail types through the use of the CASE declarations
Private Const olOriginator As Long = 0, olTo As Long = 1, olCC As Long = 2, olBCC As Long = 3
Function PrintEmailAddresses(olItem As MailItem)
If olItem.Class <> olMail Then Exit Function
Dim Arr As Variant: Arr = EmailAddressInfo(olItem)
Debug.Print "Sender: " & Arr(0)
Debug.Print "To Address: " & Arr(1)
Debug.Print "CC Address: " & Arr(2)
End Function
Private Function EmailAddressInfo(olItem As MailItem) As Variant
If olItem.Class <> olMail Then Exit Function
Dim olRecipient As Outlook.Recipient
Dim ToAddress, CCAddress, Originator, email As String
With olItem
Select Case UCase(.SenderEmailType)
Case "SMTP": Originator = .SenderEmailAddress
Case Else: Originator = .Sender.GetExchangeUser.PrimarySmtpAddress
End Select
End With
For Each olRecipient In olItem.Recipients
With olRecipient
Select Case UCase(.AddressEntry.Type)
Case "SMTP": email = .Address
Case Else: email = .AddressEntry.GetExchangeUser.PrimarySmtpAddress
End Select
Select Case .Type
Case olTo: ToAddress = ToAddress & email & ";"
Case olCC: CCAddress = CCAddress & email & ";"
End Select
End With
Next
EmailAddressInfo = Array(Originator, ToAddress, CCAddress)
End Function

Related

How to remove a specific recipient from all e-mail templates in a directory on my desktop?

I have a directory folder (folder on desktop) of outlook messages (.msg) that I use as templates for crafting e-mails.
There may be 500 e-mails in this folder. I need to delete a specific e-mail address from each of these emails sometimes after every month.
Sub test()
Dim m As MailItem 'object/mail item iterator
Dim recip As Recipient 'object to represent recipient(s)
Dim email As Long
Set Remove = m.Remove
email = InputBox("Please enter the e-mail address you wish to remove")
answer = MsgBox("Are you sure you want to delete this e-mail?", vbYesNo + vbCritical, "Delete?")
If answer = vbYes Then
For Each m In Application.ActiveExplorer.Selection
If m.Class = olMail Then
Set Remove = m.Recipients.Remove(email)
End If
m.Save
End If
Next
End Sub
How do I do it with VBA?
If an e-mail has johndoe#gmail.com, I expect that e-mail to be deleted after i run this code in all TO,CC,BCC etc.
Try this
Option Explicit
Public Sub Example()
Dim Path As String
Path = "C:\Temp"
Dim msgFile As String
msgFile = Dir(Path & "\*.msg")
Dim msg As Object
Do While Len(msgFile) > 0
Set msg = Application.Session.OpenSharedItem(Path & "\" & msgFile)
Debug.Print msg.Subject
GetSMTPAddress msg
msgFile = Dir
Loop
Set msg = Nothing
End Sub
Private Sub GetSMTPAddress(Mail As Outlook.MailItem)
Dim pa As Outlook.PropertyAccessor
Const PR_SMTP_ADDRESS As String = _
"http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
Dim i As Long
For i = Mail.Recipients.Count To 1 Step -1
DoEvents
Set pa = Mail.Recipients(i).PropertyAccessor
If LCase(pa.GetProperty(PR_SMTP_ADDRESS)) = _
LCase("0m3r#Email.com") Then
Mail.Recipients.Remove (i)
Debug.Print pa.GetProperty(PR_SMTP_ADDRESS)
Mail.Save
End If
Next
End Sub
Make sure to update email address 0m3r#Email.com and folder path Path = "C:\Temp"
Call Application.Session.OpenSharedItem for each MSG file, remove the recipient, call MailItem.Save.

Warn before sending messages outside of multiple possible internal domains?

I'm trying to check if recipients of my e-mail are in our Global Address List in Outlook 2016.
If all the recipients are internal (our GAL includes only internal addresses) then the message is released.
If at least one of the recipients are external (from outside of GAL), then I should get a warning message, which will ask if I still want to send this e-mail.
I tried this topic, but I need a solution without copying the addresses to external Excel spreadsheet.
I also worked with this solution, but our company is big, and has multiple branches all around the globe. The cited solution checks if my domain is the same with the recipients domains. The problem occurs when I'm trying to send an e-mail to people from my company, but outside my region - I'm from EMEA, and e.g. I'm sending an e-mail to PAM. Unfortunately, this solution is not enough in this moment. Because PAM is using a different domain - the warning message occurs.
The simplest way for me, would be to check the recipients in GAL, but I'm not sure if this is even possible.
Code from the second solution below:
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim recips As Outlook.Recipients
Dim recip As Outlook.Recipient
Dim pa As Outlook.propertyAccessor
Dim prompt As String
Dim Address As String
Dim lLen
Dim strMyDomain
Dim internal As Long
Dim external As Long
Const PR_SMTP_ADDRESS As String = "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
' non-exchange
' userAddress = Session.CurrentUser.Address
' use for exchange accounts
userAddress = Session.CurrentUser.AddressEntry.GetExchangeUser.PrimarySmtpAddress
lLen = Len(userAddress) - InStrRev(userAddress, "#")
strMyDomain = Right(userAddress, lLen)
Set recips = Item.Recipients
For Each recip In recips
Set pa = recip.propertyAccessor
Address = LCase(pa.GetProperty(PR_SMTP_ADDRESS))
lLen = Len(Address) - InStrRev(Address, "#")
str1 = Right(Address, lLen)
If str1 = strMyDomain Then internal = 1
If str1 <> strMyDomain Then external = 1
Next
If internal + external = 2 Then
prompt = "This email is being sent to Internal and External addresses. Do you still wish to send?"
If MsgBox(prompt, vbYesNo + vbExclamation + vbMsgBoxSetForeground, "Check Address") = vbNo Then
Cancel = True
End If
End If
End Sub
You could replace the single internal domain with an array of domains.
Option Explicit
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim recips As Recipients
Dim recip As Recipient
Dim pa As propertyAccessor
Dim prompt As String
Dim Address As String
Dim lLen As Long
Dim Str1 As String
Dim arrayDomains() As Variant
Dim i As Long
Dim internalFlag As Boolean
Dim externalFlag As Boolean
Dim strExtAdd As String
arrayDomains = Array("PAM domain", "EMEA domain", "other internal domain")
Const PR_SMTP_ADDRESS As String = "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
Set recips = Item.Recipients
For Each recip In recips
Set pa = recip.propertyAccessor
Address = LCase(pa.GetProperty(PR_SMTP_ADDRESS))
lLen = Len(Address) - InStrRev(Address, "#")
Str1 = Right(Address, lLen)
internalFlag = False
For i = LBound(arrayDomains) To UBound(arrayDomains)
If Str1 = arrayDomains(i) Then
internalFlag = True
Exit For
End If
Next
If internalFlag = False Then
externalFlag = True
strExtAdd = strExtAdd & vbCr & Address
End If
Next
If externalFlag = True Then
prompt = "This email is being sent to external addresses. Do you still wish to send?" & strExtAdd
If MsgBox(prompt, vbYesNo + vbExclamation + vbMsgBoxSetForeground, "Check Address") = vbNo Then
Cancel = True
End If
'Else
'Debug.Print "Internal addresses only."
End If
End Sub

Exclude signature from attachment look up macro

I'm working on a macro which checks the attachment name against the subject name and the domain.
At the moment there's a couple of minor issues, I don't want the macro to recognise images in the signature as an attachment. Solutions I've seen include using an if statement to work out the size, so for example only check attachments over 5kb etc.
The other issue is, if there is no attachment at all, the macro falls over! I think I need another if statement in there at the end to do an item count but I'm not sure how that alters my conditions at the end of the macro!
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim outRecips As Outlook.Recipients
Dim outRecip As Outlook.Recipient
Dim outPropAcc As Outlook.PropertyAccessor
Dim strDomain As String
Dim lngPreDom As Long
Dim lngPostDom As Long
Dim strSubject As String
Dim objAttachments As Outlook.Attachments
Dim strAttachment As String
Dim Response As String
' set domain value
Const PR_SMTP_ADDRESS As String = "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
Set outRecips = Item.Recipients
For Each outRecip In outRecips
Set outPropAcc = outRecip.PropertyAccessor
strDomain = outPropAcc.GetProperty(PR_SMTP_ADDRESS)
strDomain = Split(strDomain, "#")(1)
lngPreDom = InStr(strDomain, "#")
lngPostDom = InStr(strDomain, ".")
strDomain = LCase(Mid(strDomain, lngPreDom + 1, lngPostDom - lngPreDom - 1))
Exit For
Next
' set subject value
strSubject = LCase(Item.Subject)
' set attachment name
Set objAttachments = Item.Attachments
strAttachment = LCase(objAttachments.Item(1).FileName)
' if external recipient, check email contents
If strDomain <> "exampleemail" _
Then
If InStr(strSubject, strDomain) = 0 _
Or InStr(strAttachment, strDomain) = 0 _
Or InStr(strAttachment, strSubject) = 0 _
Then
Response = "Attachment/Subject do not match Recipient(s)" & vbNewLine & "Send Anyway?"
If MsgBox(Response, vbYesNo + vbExclamation + vbMsgBoxSetForeground, "Check Recipients") = vbNo Then
Cancel = True
End If
End If
End If
End Sub
Use the Attachment.PropertyAccessor object to read the PR_ATTACHMENT_HIDDEN property (http://schemas.microsoft.com/mapi/proptag/0x7FFE000B); if it's true it's an embedded image (usually in signatures).

Adding multiple attachments to a single email using outlook VBA

EDIT
Sub CreateEmail(Subject As String, Body As String, ToSend As String, CCs As String, FilePathtoAdd As String)
Dim OlApp As Object
Dim OlMail As MailItem
Dim ToRecipient As Variant
Dim CcRecipient As Variant
Dim Attachments() As String
Dim i As Integer
Set OlApp = Application
Set OlMail = OlApp.CreateItem(olMailItem)
OlMail.Recipients.Add ToSend
OlMail.Subject = Subject
OlMail.Body = Body
OlMail.SentOnBehalfOfName = "mailbox"
If FilePath1 <> "" Then
If FilePathtoAdd <> "" Then
Attachments = Split(FilePathtoAdd, ",")
For i = LBound(Attachments) To UBound(Attachments)
If Attachments(i) <> "" Then
OMail.Attachments.Add Trim(Attachments(i))
End If
Next i
End If
End If
OlMail.Display 'change this to OlMail.Send if you just want to send it without previewing it
End Sub
Sub EmailIt()
CreateEmail "This is Subject", "Body", "To", "CC", "C:\Users\b\Desktop\NFM\Export\0418 LSN " & Format(Date, "mm-dd-yy") & ".xls", "C:\Users\b\Desktop\NFM\Export\0418 Backorder " & Format(Date, "mm-dd-yy") & ".xls"
End Sub
I'm using the code below, in outlook vba, to create an email, attach a file, and send the email. It works fine, except I can't figure out how to add multiple attachments to a single email? Any help is greatly appreciated.
Sub CreateEmail(Subject As String, Body As String, ToSend As String, CCs As String, FilePathtoAdd As String)
'write the default Outlook contact name list to the active worksheet
Dim OlApp As Object
Dim OlMail As MailItem
Dim ToRecipient As Variant
Dim CcRecipient As Variant
'Set OlApp = CreateObject("Outlook.Application")
'Set OlMail = OlApp.CreateItem(olMailItem)
Set OlApp = Application
Set OlMail = OlApp.CreateItem(olMailItem)
'For Each ToRecipient In Array("mba.szabist#gmail.com", "mba.szabist#gmail.com", "mba.szabist#gmail.com")
'OlMail.Recipients.Add ToRecipient
OlMail.Recipients.Add ToSend
'Next ToRecipient
'fill in Subject field
OlMail.Subject = Subject
OlMail.Body = Body
OlMail.SentOnBehalfOfName = "email.com"
'Add the active workbook as an attachment
' OlMail.Attachments.Add "C:\Users\Ali\Desktop\Sentence Correction\Comparisons.pdf"
If FilePathtoAdd <> "" Then
OlMail.Attachments.Add FilePathtoAdd
End If
'Display the message
OlMail.Display 'change this to OlMail.Send if you just want to send it without previewing it
End Sub
Sub EmailIt()
CreateEmail "This is Subject", "Body", "email.com", " ", "C:\Users\b\Desktop\NFM\Export\0418 LSN " & Format(Date, "mm-dd-yy") & ".xls"
End Sub
You just need to do:
Olmail.attachments.add secondpath
If you put the attachment paths in a comma delimited string and pass it as "FilePathToAdd" then you can do this:
Dim Attachments() As String
Dim i As Integer
If FilePathToAdd <> "" Then
Attachments = Split(FilePathToAdd, ",")
For i = LBound(Attachments) To UBound(Attachments)
If Attachments(i) <> "" Then
OlMail.Attachments.Add Trim(Attachments(i))
End If
Next i
End If
The following lines from your code add the attachment:
'Add the active workbook as an attachment
' OlMail.Attachments.Add "C:\Users\Ali\Desktop\Sentence Correction\Comparisons.pdf"
If FilePathtoAdd <> "" Then
OlMail.Attachments.Add FilePathtoAdd
End If
You just need to call the Add method of the Attachment class as many times as you need to add attachments specifying different file paths.

How do you extract email addresses from the 'To' field in outlook?

I have been using VBA to some degree, using this code:
Sub ExtractEmail()
Dim OlApp As Outlook.Application
Dim Mailobject As Object
Dim Email As String
Dim NS As NameSpace
Dim Folder As MAPIFolder
Set OlApp = CreateObject("Outlook.Application")
' Setup Namespace
Set NS = ThisOutlookSession.Session
' Display select folder dialog
Set Folder = NS.PickFolder
' Create Text File
Set fs = CreateObject("Scripting.FileSystemObject")
Set a = fs.CreateTextFile("c:\mydocuments\emailss.txt", True)
' loop to read email address from mail items.
For Each Mailobject In Folder.Items
Email = Mailobject.To
a.WriteLine (Email)
Next
Set OlApp = Nothing
Set Mailobject = Nothing
a.Close
End Sub
However this gives output as the names of the email addresses and not the actual email address with the "something#this.domain".
Is there an attributte of the mailobject that will allow the email addresses and not the names to be written from the 'To' Textbox.
Thanks
Check out the Recipients collection object for your mail item, which should allow you to get the address: http://msdn.microsoft.com/en-us/library/office/ff868695.aspx
Update 8/10/2017
Looking back on this answer, I realized I did a bad thing by only linking somewhere and not providing a bit more info.
Here's a code snippet from that MSDN link above, showing how the Recipients object can be used to get an email address (snippet is in VBA):
Sub GetSMTPAddressForRecipients(mail As Outlook.MailItem)
Dim recips As Outlook.Recipients
Dim recip As Outlook.Recipient
Dim pa As Outlook.PropertyAccessor
Const PR_SMTP_ADDRESS As String = _
"http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
Set recips = mail.Recipients
For Each recip In recips
Set pa = recip.PropertyAccessor
Debug.Print recip.name &; " SMTP=" _
&; pa.GetProperty(PR_SMTP_ADDRESS)
Next
End Sub
It looks like, for email addresses outside of your organization, the SMTP address is hidden in emailObject.Recipients(i).Address, though it doesn't seem to allow you to distinguish To/CC/BCC.
The Microsoft code was giving me an error, and some investigating reveals that the schema page is no longer available. I wanted a semicolon-delaminated list of email addresses that were either in my Exchange organization or outside of it. Combining it with another S/O answer to convert inner-company email display names to SMTP names, this does the trick.
Function getRecepientEmailAddress(eml As Variant)
Set out = CreateObject("System.Collections.Arraylist") ' a JavaScript-y array
For Each emlAddr In eml.Recipients
If Left(emlAddr.Address, 1) = "/" Then
' it's an Exchange email address... resolve it to an SMTP email address
out.Add ResolveDisplayNameToSMTP(emlAddr)
Else
out.Add emlAddr.Address
End If
Next
getRecepientEmailAddres = Join(out.ToArray(), ";")
End Function
If the email is inside your organization, you need to convert it to an SMTP email address. I found this function from another StackOverflow answer helpful:
Function ResolveDisplayNameToSMTP(sFromName) As String
' takes a Display Name (i.e. "James Smith") and turns it into an email address (james.smith#myco.com)
' necessary because the Outlook address is a long, convoluted string when the email is going to someone in the organization.
' source: https://stackoverflow.com/questions/31161726/creating-a-check-names-button-in-excel
Dim OLApp As Object 'Outlook.Application
Dim oRecip As Object 'Outlook.Recipient
Dim oEU As Object 'Outlook.ExchangeUser
Dim oEDL As Object 'Outlook.ExchangeDistributionList
Set OLApp = CreateObject("Outlook.Application")
Set oRecip = OLApp.Session.CreateRecipient(sFromName)
oRecip.Resolve
If oRecip.Resolved Then
Select Case oRecip.AddressEntry.AddressEntryUserType
Case 0, 5 'olExchangeUserAddressEntry & olExchangeRemoteUserAddressEntry
Set oEU = oRecip.AddressEntry.GetExchangeUser
If Not (oEU Is Nothing) Then
ResolveDisplayNameToSMTP = oEU.PrimarySmtpAddress
End If
Case 10, 30 'olOutlookContactAddressEntry & 'olSmtpAddressEntry
ResolveDisplayNameToSMTP = oRecip.AddressEntry.Address
End Select
End If
End Function
The answers above did not work for me. I think they only work when the recipient is in the address book. The following code is also to able to lookup email addresses from outside the organisation. Additionally it makes a distinction between to/cc/bcc
Dim olRecipient As Outlook.Recipient
Dim strToEmails, strCcEmails, strBCcEmails As String
For Each olRecipient In item.Recipients
Dim mail As String
If olRecipient.AddressEntry Is Nothing Then
mail = olRecipient.Address
ElseIf olRecipient.AddressEntry.GetExchangeUser Is Nothing Then
mail = olRecipient.Address
Else
mail = olRecipient.AddressEntry.GetExchangeUser.PrimarySmtpAddress
End If
Debug.Print "resolved", olRecipient.Name, mail
If olRecipient.Type = Outlook.OlMailRecipientType.olTo Then
strToEmails = strToEmails + mail & ";"
ElseIf olRecipient.Type = Outlook.OlMailRecipientType.olCC Then
strCcEmails = strCcEmails + mail & ";"
ElseIf olRecipient.Type = Outlook.OlMailRecipientType.olBCC Then
strBCcEmails = strBCcEmails + mail & ";"
End If
Next
Debug.Print strToEmails
Debug.Print strCcEmails
Debug.Print strBCcEmails
Another code alternative (based initially on the answer by #andreasDL) which should be able to be used...
Pass in a MailItem to the EmailAddressInfo function to get an array of the Sender, To and CC fields from the message
Private Const olOriginator As Long = 0, olTo As Long = 1, olCC As Long = 2, olBCC As Long = 3
'BCC addresses are not included within received messages
Function PrintEmailAddresses(olItem As MailItem)
If olItem.Class <> olMail Then Exit Function
Dim Arr As Variant: Arr = EmailAddressInfo(olItem)
Debug.Print "Sender: " & Arr(olOriginator)
Debug.Print "To Address: " & Arr(olTo)
Debug.Print "CC Address: " & Arr(olCC)
End Function
Private Function EmailAddressInfo(olItem As MailItem) As Variant
If olItem.Class <> olMail Then Exit Function
On Error GoTo ExitFunction
Dim olRecipient As Outlook.Recipient
Dim olEU As Outlook.ExchangeUser
Dim olEDL As Outlook.ExchangeDistributionList
Dim ToAddress, CCAddress, Originator, email As String
With olItem
Select Case UCase(.SenderEmailType)
Case "SMTP": Originator = .SenderEmailAddress
Case Else
Set olEU = .Sender.GetExchangeUser
If Not olEU Is Nothing Then Originator = olEU.PrimarySmtpAddress
End Select
End With
For Each olRecipient In olItem.Recipients
With olRecipient
Select Case .AddressEntry.AddressEntryUserType
Case olSmtpAddressEntry 'OlAddressEntryUserType.
email = .Address
Case olExchangeDistributionListAddressEntry, olOutlookDistributionListAddressEntry
Set olEDL = .AddressEntry.GetExchangeDistributionList
email = IIf(Not olEDL Is Nothing, olEDL.PrimarySmtpAddress, "")
Case Else
Set olEU = .AddressEntry.GetExchangeUser
email = IIf(Not olEU Is Nothing, olEU.PrimarySmtpAddress, "")
End Select
If email <> "" Then
Select Case .Type
Case olTo: ToAddress = ToAddress & email & ";"
Case olCC: CCAddress = CCAddress & email & ";"
End Select
End If
End With
Next
EmailAddressInfo = Array(Originator, ToAddress, CCAddress)
ExitFunction:
End Function
This is what worked for me with Outlook 2019. Use your internal domain name(s). Might need some tweaking yet - not heavily tested. Place code in the ThisOutlookSession module. (Updated to handle Exchange distribution lists 7/31/20.)
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim xMailItem As Outlook.MailItem
Dim xRecipients As Outlook.Recipients
Dim OutRec As Outlook.Recipient
Dim OutTI As Outlook.TaskItem
Dim i As Long
Dim j As Long
Dim xOKCancel As Integer
Dim sMsg As String
Dim oMembers As AddressEntries
Dim oMember As AddressEntry
Dim sDomains As String
Dim sTemp As String
On Error Resume Next
If Item.Class <> olMail Then GoTo ExitCode
sDomains = "#test1.com #test2.com"
Set xMailItem = Item
Set xRecipients = xMailItem.Recipients
'Loop through email recipients to get email addresses
For i = xRecipients.Count To 1 Step -1
'If we have a text address entry in the email
If InStr(xRecipients.Item(i).AddressEntry, "#") > 0 Then
sTemp = xRecipients.Item(i).AddressEntry
If InStrRev(sDomains, LCase(Mid(sTemp, InStr(sTemp, "#"), 254))) <= 0 Then
sMsg = sMsg & sTemp & vbCrLf
End If
Else
Select Case xRecipients.Item(i).AddressEntry.DisplayType
Case Is = olDistList
Set oMembers = xRecipients.Item(i).AddressEntry.Members
For j = oMembers.Count To 1 Step -1
Set oMember = oMembers.Item(j)
sTemp = oMember.GetExchangeUser.PrimarySmtpAddress
If InStrRev(sDomains, LCase(Mid(sTemp, InStr(sTemp, "#"), 254))) <= 0 Then
sMsg = sMsg & sTemp & vbCrLf
End If
Set oMember = Nothing
Next j
Set oMembers = Nothing
Case Is = olUser
Set OutTI = Application.CreateItem(3)
OutTI.Assign
Set OutRec = OutTI.Recipients.Add(xRecipients.Item(i).AddressEntry)
OutRec.Resolve
If OutRec.Resolved Then
sTemp = OutRec.AddressEntry.GetExchangeUser.PrimarySmtpAddress
If InStrRev(sDomains, LCase(Mid(sTemp, InStr(sTemp, "#"), 254))) <= 0 Then
sMsg = sMsg & sTemp & vbCrLf
End If
End If
Set OutTI = Nothing
Set OutRec = Nothing
Case Else
MsgBox "Unaccomodated AddressEntry.DisplayType."
GoTo ExitCode
End Select
End If
Next i
'Display user message
If Len(sMsg) > 0 Then
sMsg = "This email is addressed to the following external Recipients:" & vbCrLf & vbCrLf & sMsg
xOKCancel = MsgBox(sMsg, vbOKCancel + vbQuestion, "Warning")
If xOKCancel = vbCancel Then Cancel = True
End If
End Sub