使用Excel中的VBA宏验证Outlook / Exchange的电子邮件ID [英] Validate the email ID against Outlook/Exchange using VBA Macro in Excel
问题描述
我正在尝试实施一项功能 其中，我在excel中有一个电子邮件地址列，我想要一个VBA宏来验证这个电子邮件地址对交换服务器/ Active Directory。
原因，我问的是因为在我的Excel列表中，有大约12K的记录，而且有些电子邮件ID没有激活，这些电子邮件ID的用户已经离开了公司。因此，它们在Active Directory中不存在。因此，我面临着一个巨大的
任务来识别活动/非活动用户。
这可能吗？
我需要检查此excel列的单元格中存在的电子邮件ID是否为有效和活跃用户。
虽然我已经看到以下代码：
Private Sub GetAddresses（）
Dim o，AddressList，AddressEntry
Dim c As Range，r As Range，AddressName As String
Set o = CreateObject（" Outlook.Application"）
Set AddressList = o.Session.AddressLists（" Global Address List"）
Set r = Range（" a1： a3"）
For each c in r
AddressName = Trim（c.Value）& "，" &安培;修剪（c.Offset（0,1）.Value）
对于每个AddressEntry在AddressList.AddressEntries中
如果AddressEntry.Name = AddressName那么
c.Offset（0,2）.Value = AddressEntry.Address
退出
结束如果
下一个AddressEntry
下一个c
结束子
看来，它不是正确的，我正在寻找。
如果我了解您的要求，您需要一个活动用户列表，其中包含Active Directory中的电子邮件地址，然后您可以使用这些用户来清除不活动的电子邮件。
要获取Active Directory用户列表，我们可以使用LDAP。
此工作簿将使用电子邮件地址下载Active Directory用户：
https://www.dropbox.com/s/f3z0or2iyvrvebv/LDAP.xlsm?dl=0
有关如何使用工作簿的说明，请访问：
https://www.dropbox.com/s/ahf6opm2gp9pyxn/LDAP.pdf？ dl = 0
主要代码是：
Public Sub GetUsers（）
'描述：从LDAP获取用户名和其他属性
'输入：*无
'输出：*无（tblUsers）
'要求：*无
'示例：GetUsers
'注意：RootDSE https://msdn.microsoft.com/en-us/library/ms684291(v=vs.85).aspx
'用户属性http： //www.kouti.com/tables/userattributes.htm
'日期Ini修改
'08 / 07/15 CWH初始编程
'声明
Const cRoutine As String =" GetUsers"
Dim oRootDSE As Object'RootDSE
Dim sDN As String'Domain Name
Dim oCN As Object'ADO Connection
Dim oRS As Object'ADO RecordSet
Dim sSQL As String'SQL Request String
Dim n As Long'Generic Counter
Const sTable As String =" tblUsers"
'错误处理初始化
错误GoTo ErrHandler
'Initialize Variables
'确定DNS域名。
设置oRootDSE = GetObject（" LDAP：// RootDSE"）
sDN = oRootDSE.Get（" defaultNamingContext"）
'程序
'删除表如果它存在
如果不是IsError（Evaluate（sTable））那么
带有Evaluate（sTable）
如果.ListObject是Nothing那么_
。删除Else _
。 ListObject.Delete
以
结束如果
'获取数据 - 注意！字段列表向后加载LDAP
sSQL =" SELECT company，department，telephoneNumber，mail，ipPhone，sn，givenName" &安培; _
" FROM'LDAP：//" &安培; sDN& "'' &安培; _
" WHERE objectClass ='Person'" &安培; _
"和userAccountControl<> 514" &安培; _
"和userAccountControl<> "546" &安培; _
" 和&NBSP;&NBSP; mail ='*'"
Set oCN = CreateObject（" ADODB.Connection"）
Set oRS = CreateObject（" ADODB.Recordset"）
oCN.Provider =" ADsDSOObject"
oCN.Open"Active Directory Provider"
oRS.Open sSQL，oCN
with wksUsers
.Activate
n = .UsedRange.SpecialCells（xlCellTypeLastCell）.row + 2
With .ListObjects.Add（SourceType： = xlSrcQuery，_
source：= oRS，_
destination：=。Cells（n，1））
.QueryTable.Refresh
.Name = sTable
'格式表
.ListColumns（1）.Name =" First Name"
.ListColumns（2）.Name =" Last Name"
.ListColumns（3）.Name =" Extension"
.ListColumns（4）.Name =" Email"
.ListColumns（5）.Name =" Cell Phone"
.ListColumns（6）.Name =" Department"
.ListColumns（7）.Name =" Company"
.HeaderRowRange.Style = ThisWorkbook.Styles（21）
.Range.EntireColumn.AutoFit
'排序表
.Sort.SortFields.Add .ListColumns（1）.Range（ 1），_
Excel.XlSortOn.xlSortOnValues，_
Excel.XlSortOrder.xlAscending
.Sort.Apply
'Freeze Panes
ActiveWindow.FreezePanes = False
.HeaderRowRange.Cells（2,1）。选择
ActiveWindow.FreezePanes = True
结束
结束
ErrHandler：
选择案例Err.Number
Case Is = 0：'没有错误。什么都不做
Case Else：
Select Case msgBox（err.Description，_
vbAbortRetryIgnore + vbMsgBoxHelpButton，_
"GetUsers"，_
err.HelpFile，_
err.HelpContext）
案例Is = vbAbort：停止：恢复'调试模式 - 跟踪
案例是= vbRetry：恢复'再试一次
案例是= vbIgnore：'结束例程
结束选择
结束选择
结束子
am trying to implement a functionality wherein, i am having a column in excel with email addressess and i would like to a VBA Macro to validate this email address against the exchange server/Active Directory.
the reason, am asking is because in my excel list, there are some 12K records and some of the email ids were not active and the users of these email ids have already left the company. so they are non-existent in the Active Directory.Thus , am facing a huge task to identity the active/ non-active users.
is this possible?
I need to check whether the email IDs present in this excel column's cells are valid and active users.
though i have seen the below code :
Private Sub GetAddresses()
Dim o, AddressList, AddressEntry
Dim c As Range, r As Range, AddressName As String
Set o = CreateObject("Outlook.Application")
Set AddressList = o.Session.AddressLists("Global Address List")
Set r = Range("a1:a3")
For Each c In r
AddressName = Trim(c.Value) & ", " & Trim(c.Offset(0, 1).Value)
For Each AddressEntry In AddressList.AddressEntries
If AddressEntry.Name = AddressName Then
c.Offset(0, 2).Value = AddressEntry.Address
Exit For
End If
Next AddressEntry
Next c
End Sub
it seems, its not the correct one, i am looking for.
If I understand your requirements, you need a list of active users with their email addresses from Active Directory which you can then use to weed out inactive emails.
To get list of Active Directory users we can use LDAP.
This workbook will download Active Directory users with Email addresses: https://www.dropbox.com/s/f3z0or2iyvrvebv/LDAP.xlsm?dl=0
Instructions on how to use the workbook are here: https://www.dropbox.com/s/ahf6opm2gp9pyxn/LDAP.pdf?dl=0
The main code is:
Public Sub GetUsers() ' Description:Get User names and other attributes from LDAP ' Inputs: *None ' Outputs: *None (tblUsers) ' Requisites: *None ' Example: GetUsers ' Notes: RootDSE https://msdn.microsoft.com/en-us/library/ms684291(v=vs.85).aspx ' User Attributes http://www.kouti.com/tables/userattributes.htm ' Date Ini Modification ' 08/07/15 CWH Initial Programming ' Declarations Const cRoutine As String = "GetUsers" Dim oRootDSE As Object 'RootDSE Dim sDN As String 'Domain Name Dim oCN As Object 'ADO Connection Dim oRS As Object 'ADO RecordSet Dim sSQL As String 'SQL Request String Dim n As Long 'Generic Counter Const sTable As String = "tblUsers" ' Error Handling Initialization On Error GoTo ErrHandler ' Initialize Variables ' Determine DNS domain name. Set oRootDSE = GetObject("LDAP://RootDSE") sDN = oRootDSE.Get("defaultNamingContext") ' Procedure ' Delete table if it exists If Not IsError(Evaluate(sTable)) Then With Evaluate(sTable) If .ListObject Is Nothing Then _ .Delete Else _ .ListObject.Delete End With End If ' Get Data - NOTE! Field list loaded backwards with LDAP sSQL = "SELECT company, department, telephoneNumber, mail, ipPhone, sn, givenName " & _ "FROM 'LDAP://" & sDN & "' " & _ "WHERE objectClass='Person' " & _ " And userAccountControl <> 514 " & _ " And userAccountControl <> 546 " & _ " And mail = '*' " Set oCN = CreateObject("ADODB.Connection") Set oRS = CreateObject("ADODB.Recordset") oCN.Provider = "ADsDSOObject" oCN.Open "Active Directory Provider" oRS.Open sSQL, oCN With wksUsers .Activate n = .UsedRange.SpecialCells(xlCellTypeLastCell).row + 2 With .ListObjects.Add(SourceType:=xlSrcQuery, _ source:=oRS, _ destination:=.Cells(n, 1)) .QueryTable.Refresh .Name = sTable ' Format Table .ListColumns(1).Name = "First Name" .ListColumns(2).Name = "Last Name" .ListColumns(3).Name = "Extension" .ListColumns(4).Name = "Email" .ListColumns(5).Name = "Cell Phone" .ListColumns(6).Name = "Department" .ListColumns(7).Name = "Company" .HeaderRowRange.Style = ThisWorkbook.Styles(21) .Range.EntireColumn.AutoFit ' Sort Table .Sort.SortFields.Add .ListColumns(1).Range(1), _ Excel.XlSortOn.xlSortOnValues, _ Excel.XlSortOrder.xlAscending .Sort.Apply ' Freeze Panes ActiveWindow.FreezePanes = False .HeaderRowRange.Cells(2, 1).Select ActiveWindow.FreezePanes = True End With End With ErrHandler: Select Case Err.Number Case Is = 0: 'No Error. Do nothing Case Else: Select Case msgBox(err.Description, _
vbAbortRetryIgnore+vbMsgBoxHelpButton, _
"GetUsers", _
err.HelpFile, _
err.HelpContext)
Case Is = vbAbort: Stop: Resume 'Debug mode - Trace Case Is = vbRetry: Resume 'Try again Case Is = vbIgnore: 'End routine End Select End Select End Sub
这篇关于使用Excel中的VBA宏验证Outlook / Exchange的电子邮件ID的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！
