SCMLife.com

 找回密码
 立即注册

QQ登录

只需一步,快速开始

扫一扫,访问微社区

查看: 8982|回复: 2

[原创] 从ad里导出电子邮件地址

[复制链接]
发表于 2011-4-2 11:21:08 | 显示全部楼层 |阅读模式
ad没有现成的方法导出用户的电子邮件地址。我以前都是在project server中导出,比较麻烦,曲线救国,可以满足需要。最近有人问我怎样导出,我看了些资料,自己写了个脚本。大家拍砖
6 B; {: h+ J5 o# ?Set objCommand =   CreateObject("ADODB.Command")* v9 A. k4 c9 b, a! A7 ^' ~
Set objConnection = CreateObject("ADODB.Connection")
9 w% O; s/ k- ^1 G( Z+ J4 @# |objConnection.Provider = "ADsDSOObject"
' H7 B+ s# ~" @$ }  LobjConnection.Open "Active Directory Provider"
: E6 ~3 J0 n. N  w" l* A7 [Set objCommand.ActiveConnection = objConnection. z2 V/ [) p* S1 `5 ?9 E, d
objCommand.CommandText =  "SELECT distinguishedName,userPrincipalName FROM 'LDAP://OU=软件部,OU=xxxx,DC=xxx,DC=xxxx' WHERE objectCategory='user' " $ l$ ?; ~& E: C0 ^( k$ f
Set objRecordSet = objCommand.Execute
/ G, r8 n( m' c. R: f        objRecordSet.MoveFirst
' ]# d2 H8 }" k3 A8 y0 V/ w  Set xlsApp = CreateObject("Excel.Application")# B. H5 t" j- K2 b! a1 \) g8 O6 n' ^
set newBook = xlsApp.Workbooks.Add2 E( U, y) v6 Z& @% o
with newBook! k" h; @0 l4 U  u" v
        .Title = "email"6 l6 Q8 b+ d) d' R
        .Subject = "email address"+ @8 c7 E1 ~! r+ u& @, Y! `% y
        .Activate  o; Z/ _5 S% D% D- H7 p% @! n
End With
# d* v6 o6 A" c9 N+ w' work with sheet1( T4 I4 m5 i& F% V/ d1 ]
Set newSheet = newBook.Worksheets("Sheet1")4 d( g* H( L. ?/ Y/ b1 g  \
newSheet.Visible = True. J, i8 E+ B0 {% Q" s
newSheet.Name = "邮件信息"
% q. A3 w* D& o4 H9 @' set column title5 [6 J  Q. l) o5 g) S; }/ }+ x
newSheet.Range("A1:C1").Value = Array("姓名","邮件地址","OU")
* O3 I+ M( [4 Q; |5 o7 S4 G' o1 ]newSheet.Range("A1:C1").Font.Bold = True$ _7 ~* P, }7 ?( c8 n
newSheet.Range("A1:C1").wraptext=true
, I/ q' m% X' tnewSheet.Range("A1:C1").Font.Size = "11"; ^4 c) Y8 i7 f
Dim i( U( f, ~- g  @/ m6 O
i=2
! _" Y$ f' W+ ~4 Z. d        Do Until objRecordSet.EOF0 F, A0 P3 s) u$ U
            arrDN = objRecordSet.Fields("distinguishedName").Value1 Z" H6 p) a$ z' X) h& \0 L  {& P/ N
            arrDN2 = objRecordSet.Fields("userPrincipalName").Value
. M1 i, A7 N4 s objInfo = Split(arrDN,",")
" c- n9 l- j( KobjInfo2 = Split(objInfo(0),"=")0 o! _$ {/ p; K' y- @
objInfo3 = Split(objInfo(1),"=")+ f' @, Y+ J  ~0 ~
'MsgBox arrDN2
) o; p- l- N; ?'MsgBox arrDN5 c# d3 ^& T. Q: D& }% @
            If IsArray(arrDN) = True Then
) s/ Y8 I1 A* k7 H4 g7 K                    WScript.Echo strUserDisplayName4 B0 }- W+ L8 x* Z- u9 H
                    FindUserDN = arrDN(0)  d6 ]4 V' G0 G0 m( a5 q
            Else
4 v( H9 g, ^3 n% O- y                    FindUserDN = arrDN
& U1 G3 c9 f1 B0 _            End if
" ]- [' t: Y  F6 u! p+ k            objRecordSet.MoveNext# z0 M  a. ^& q6 l2 o; O
newSheet.Cells(i,1).Value = objInfo2(1)
: i" U, p) V  N- t; D  newSheet.Cells(i,2).Value =arrDN2
0 U$ R$ U) o- n# l1 ]: w  newSheet.Cells(i,3).Value = objInfo3(1)
" h. ~1 z, c1 Q; |3 DnewSheet.Columns(1).ColumnWidth=10 " F" R; d8 R) N) F. d
newSheet.Columns(2).ColumnWidth=25
1 M$ v. g7 X8 z( ~; jnewSheet.Columns(1).Font.Size = "10"
' n/ i! W  e0 U6 X- Ni=i+1  y+ h2 \. H1 Z. J
        Loop
* X/ _; |; ?2 N1 V2 r, I        If Err.Number <> 0 Then
5 ^- L: N6 i, |& ?  f                WScript.Echo Err.Description & ":" & strUserDisplayName+ }4 u4 T( A! a9 R3 i
                Err.Clear
- i! n5 v! T- w4 B; a        End If        
$ z( w4 K) X- X# D3 U  `s=date* U# c% h9 w1 c. ?. v  f
' Save changes to the excel
3 N1 W5 a( D, Q  Y& lnewBook.SaveAs("c:\导出ad信息.xls")$ I3 `- g5 t+ C9 ^1 z# c
' release the objects; m& ]+ N" d9 Y6 D/ ^/ K1 P
Set newsheet=Nothing* a! |" B& H; m3 J* |% Z& s
MsgBox "导出成功到C盘"
1 m# d* ]- O3 L7 e6 j; l

本帖被以下淘专辑推荐:

发表于 2012-10-12 13:47:32 | 显示全部楼层
mark
: K) f# ~' J( R: s6 \( q" x6 d$ B6 |0 M. E
好东西啊、先收藏了。说不定哪天就能用到的
回复 支持 反对

使用道具 举报

发表于 2013-7-29 12:11:01 | 显示全部楼层
路过学习!!!!
回复 支持 反对

使用道具 举报

您需要登录后才可以回帖 登录 | 立即注册

本版积分规则

关闭

SCMLife推荐上一条 /4 下一条

QQ|小黑屋|手机版|无图版|SCMLife.com ( 京ICP备06056490号-1 )

GMT+8, 2018-7-19 17:44 , Processed in 0.064618 second(s), 7 queries , Gzip On, MemCache On.

Powered by SCMLife X3.4 Licensed

© 2001-2017 JoyShare.

快速回复 返回顶部 返回列表