SCMLife.com

 找回密码
 立即注册

QQ登录

只需一步,快速开始

扫一扫,访问微社区

查看: 8356|回复: 2

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

[复制链接]
发表于 2011-4-2 11:21:08 | 显示全部楼层 |阅读模式
ad没有现成的方法导出用户的电子邮件地址。我以前都是在project server中导出,比较麻烦,曲线救国,可以满足需要。最近有人问我怎样导出,我看了些资料,自己写了个脚本。大家拍砖) S6 C+ R- H% r9 k
Set objCommand =   CreateObject("ADODB.Command")! [1 M6 K- n3 _3 v" r( `4 L
Set objConnection = CreateObject("ADODB.Connection")
; I5 D/ l3 W  w1 }( wobjConnection.Provider = "ADsDSOObject"
1 N/ o) o+ D- N! E' IobjConnection.Open "Active Directory Provider"
( S: g& m+ I" zSet objCommand.ActiveConnection = objConnection" }+ b! W2 v7 }9 ?- B. N
objCommand.CommandText =  "SELECT distinguishedName,userPrincipalName FROM 'LDAP://OU=软件部,OU=xxxx,DC=xxx,DC=xxxx' WHERE objectCategory='user' "
+ e9 k/ k1 o1 p$ `* Z  ~Set objRecordSet = objCommand.Execute0 v4 u' ^3 U1 T, v0 J7 t
        objRecordSet.MoveFirst
8 U8 w# O, m3 U3 a  Set xlsApp = CreateObject("Excel.Application")
* `6 e+ J* L# J) ^$ s1 {set newBook = xlsApp.Workbooks.Add9 b6 D0 V5 H2 A4 I* H2 s' O6 v
with newBook
0 t0 H% r4 d" Z  Z3 {- y        .Title = "email"0 [% w7 u  I& ^' t
        .Subject = "email address"
' G3 K* G' @2 G        .Activate, v% M% S( j# q# {8 B
End With
1 l. G# M; {5 g: _" M' work with sheet1; J: o; ^9 N9 s) e. @; H
Set newSheet = newBook.Worksheets("Sheet1")" n; Q' n8 J# p0 O( t0 ?+ T
newSheet.Visible = True# S! ?- R) ]* J' Q
newSheet.Name = "邮件信息"
+ _# C/ F' I$ d; Z' set column title
$ E+ {0 {; H0 ?* \6 z( B5 anewSheet.Range("A1:C1").Value = Array("姓名","邮件地址","OU")
9 z* H+ F6 g/ [* GnewSheet.Range("A1:C1").Font.Bold = True
' V) Q0 E5 u! P7 E# T( t0 |newSheet.Range("A1:C1").wraptext=true
' z7 N8 g8 j$ SnewSheet.Range("A1:C1").Font.Size = "11"
! e1 @) |) z- ~$ QDim i6 N" `3 Q. N3 M* i. J9 c( q
i=2+ z( F8 ~7 z& J- I
        Do Until objRecordSet.EOF/ B! B/ Z' U- W% s2 h% s
            arrDN = objRecordSet.Fields("distinguishedName").Value# M/ I0 H7 k' x0 H
            arrDN2 = objRecordSet.Fields("userPrincipalName").Value( ]. }8 k+ |' G* G1 [
objInfo = Split(arrDN,",")' U. v( p9 q3 a8 A  h
objInfo2 = Split(objInfo(0),"=")
) k0 R5 t* l, T0 M! w; eobjInfo3 = Split(objInfo(1),"=")4 E4 z4 ^0 f8 N6 P7 ]
'MsgBox arrDN2
$ x; `+ s' s6 _! i'MsgBox arrDN
/ Z8 K) V7 |0 z6 t: o            If IsArray(arrDN) = True Then
3 l( O4 F4 Q3 n3 I6 z! p; a! s9 _                    WScript.Echo strUserDisplayName
" ~$ t6 K4 S7 Y: Y! A0 m                    FindUserDN = arrDN(0)2 N& _6 w6 I$ R6 x
            Else
. ~( u( ?( m4 c% _                    FindUserDN = arrDN1 ?2 F# d, `/ @7 E5 m
            End if
/ r( [) s$ F0 X6 Z, G* u4 f) I            objRecordSet.MoveNext
) }- x8 V* p8 O0 S newSheet.Cells(i,1).Value = objInfo2(1)
9 J% @/ t$ s. @' r0 C  newSheet.Cells(i,2).Value =arrDN2
6 E% K- u" {9 t2 `$ w) A( B9 }  newSheet.Cells(i,3).Value = objInfo3(1)3 U1 m4 Z" Q* ]! X
newSheet.Columns(1).ColumnWidth=10 ) @: K! w. I+ R3 K6 z
newSheet.Columns(2).ColumnWidth=25
+ K6 B$ {, J' K6 MnewSheet.Columns(1).Font.Size = "10"
# m( F/ m' X5 D0 D9 xi=i+1- ~: m2 @3 C+ p; k6 a( o' |) I; Q
        Loop
) K( d4 |) |1 K, j7 V$ ^8 o        If Err.Number <> 0 Then$ R* K) J% p( j; }+ D
                WScript.Echo Err.Description & ":" & strUserDisplayName
3 T3 `: d  b: f0 _! A. }3 R                Err.Clear8 g4 Z  o& n. s5 u1 o( M& M* C) u
        End If        
; S# e. y9 o8 Os=date
+ U+ @0 {# V  }+ d  C% w0 G( t7 D' Save changes to the excel
5 O, b; w3 f' ]3 S( M8 q! ]newBook.SaveAs("c:\导出ad信息.xls")
* y7 h: G" i2 |- ^3 x$ }" X9 o8 I( n7 o' release the objects. ~' ]1 K9 ~9 K3 @4 W* i4 c
Set newsheet=Nothing; h0 K- H- n  ~2 {, ^( R
MsgBox "导出成功到C盘"
- R, l# a8 d. p' H* A

本帖被以下淘专辑推荐:

发表于 2012-10-12 13:47:32 | 显示全部楼层
mark0 `1 M) o8 `$ {+ j( J/ W, I
( o3 u9 W) ~. S9 I/ `
好东西啊、先收藏了。说不定哪天就能用到的
回复 支持 反对

使用道具 举报

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

使用道具 举报

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

本版积分规则

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

GMT+8, 2018-1-20 23:37 , Processed in 0.062536 second(s), 7 queries , Gzip On, MemCache On.

Powered by SCMLife X3.4 Licensed

© 2001-2017 JoyShare.

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