SCMLife.com

 找回密码
 立即注册

QQ登录

只需一步,快速开始

扫一扫,访问微社区

查看: 9336|回复: 2

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

[复制链接]
发表于 2011-4-2 11:21:08 | 显示全部楼层 |阅读模式
ad没有现成的方法导出用户的电子邮件地址。我以前都是在project server中导出,比较麻烦,曲线救国,可以满足需要。最近有人问我怎样导出,我看了些资料,自己写了个脚本。大家拍砖
, o8 J; r0 q, F9 f# {! o/ ?Set objCommand =   CreateObject("ADODB.Command")/ k, p2 f# u* i6 U
Set objConnection = CreateObject("ADODB.Connection")) o' E) \: m9 {+ }  z2 u1 S( y& r
objConnection.Provider = "ADsDSOObject"- U* [. e8 ~0 s" E
objConnection.Open "Active Directory Provider"1 `$ ], |+ Z+ c/ S# \
Set objCommand.ActiveConnection = objConnection
! D+ z/ M: _: ?% A: S objCommand.CommandText =  "SELECT distinguishedName,userPrincipalName FROM 'LDAP://OU=软件部,OU=xxxx,DC=xxx,DC=xxxx' WHERE objectCategory='user' " / o, v. S% U/ ~* a
Set objRecordSet = objCommand.Execute2 h: r: A5 o3 k+ e7 u( m
        objRecordSet.MoveFirst
! b) x9 L+ T0 f" \  i7 i! ?  Set xlsApp = CreateObject("Excel.Application")( r5 H( s' {0 \% }
set newBook = xlsApp.Workbooks.Add- V2 {" w! |, X9 S2 F9 t
with newBook
8 b6 d' R! s+ w7 t/ Y5 Z. T) K8 r8 M" }        .Title = "email"
& L- z1 Z; f& e        .Subject = "email address"$ H1 K% L3 @2 _; r! S: i
        .Activate/ w1 m6 O* K/ [: U2 O
End With
3 f9 i! p3 u0 g2 A# q7 k1 ^+ D' f3 m' work with sheet1' x, A9 n: _" t" o" S
Set newSheet = newBook.Worksheets("Sheet1")
8 Q1 ]& |( K: s  Q) R( Y$ LnewSheet.Visible = True
7 l( D. M; d: o* tnewSheet.Name = "邮件信息"3 q8 w0 t$ @3 e# S
' set column title
6 B7 ]! n# B1 a; VnewSheet.Range("A1:C1").Value = Array("姓名","邮件地址","OU")' V) g- g9 P; ?: w* j
newSheet.Range("A1:C1").Font.Bold = True
  A3 I; p/ c! u  Y- c2 @. knewSheet.Range("A1:C1").wraptext=true
4 w% q4 _1 p+ z# a2 L" inewSheet.Range("A1:C1").Font.Size = "11"
  Z$ l, n- q: m% ~( K3 O) sDim i9 J$ V* K  p! [# ]
i=2
$ W( a( n6 z0 r8 R' T$ `+ ~& V7 V        Do Until objRecordSet.EOF
" C+ h! W  x. A. A! P% y            arrDN = objRecordSet.Fields("distinguishedName").Value6 A# A2 r: H9 N; o. @' O2 ?
            arrDN2 = objRecordSet.Fields("userPrincipalName").Value
8 d8 h  p+ r. `: E6 ? objInfo = Split(arrDN,",")
' R7 P% F4 y, _' m' J4 RobjInfo2 = Split(objInfo(0),"=")
+ E  u, l% W& |" KobjInfo3 = Split(objInfo(1),"=")2 T  j9 w! N1 b
'MsgBox arrDN2# P3 v" X9 C! ]1 E1 ]
'MsgBox arrDN7 Y9 P" A+ l# w
            If IsArray(arrDN) = True Then
$ a+ I+ e6 h$ V- G                    WScript.Echo strUserDisplayName- }( E! `0 t2 G) @- I: h
                    FindUserDN = arrDN(0). j: v, ^9 ?' m9 C
            Else
* P1 s) k8 z+ S                    FindUserDN = arrDN- i* B+ {  y& [9 j2 N+ Z5 `5 B
            End if+ w2 S7 ]1 A+ Y) q  w
            objRecordSet.MoveNext
( t, I$ I% }) o7 ^ newSheet.Cells(i,1).Value = objInfo2(1)! \% h) B( I! F6 `% |3 F# ?
  newSheet.Cells(i,2).Value =arrDN2  A1 _& \0 K$ |
  newSheet.Cells(i,3).Value = objInfo3(1)! a+ a' a) F9 U) d9 W
newSheet.Columns(1).ColumnWidth=10 : k* z9 r9 {) n# [0 @6 E* u
newSheet.Columns(2).ColumnWidth=25
7 A7 G2 c  F, V6 hnewSheet.Columns(1).Font.Size = "10"
6 x9 l* v( q/ i2 mi=i+1
' V. E: B* R& @& t8 @- `5 f        Loop0 H( C6 u, B0 s
        If Err.Number <> 0 Then- D! g) p7 R9 `8 N4 s
                WScript.Echo Err.Description & ":" & strUserDisplayName8 Y! O& p# Y7 j! {3 }" T0 m
                Err.Clear
5 e6 r0 m  o- ^0 t5 ~$ Q        End If        " F4 l* V" K( |5 ?
s=date
) j6 w6 q8 t/ X2 }. n0 E' Save changes to the excel
7 L! H3 a6 {) y4 a; _2 W" jnewBook.SaveAs("c:\导出ad信息.xls")
) U5 Y; v8 V5 k% b% f1 e# x' release the objects
2 f2 P% J5 q$ Y% f% @Set newsheet=Nothing/ `5 g5 |3 [1 V$ H' K: i' Z
MsgBox "导出成功到C盘"
' C5 m" _1 S0 h! M& S" G

本帖被以下淘专辑推荐:

发表于 2012-10-12 13:47:32 | 显示全部楼层
mark" a+ d3 v0 w+ ]# a4 R8 P1 A) s

, x" P: E  ?- S9 ^) a3 c9 b9 ^好东西啊、先收藏了。说不定哪天就能用到的
回复 支持 反对

使用道具 举报

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

使用道具 举报

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

本版积分规则

关闭

SCMLife推荐上一条 /4 下一条

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

GMT+8, 2018-11-13 09:41 , Processed in 0.063255 second(s), 7 queries , Gzip On, MemCache On.

Powered by SCMLife X3.4 Licensed

© 2001-2017 JoyShare.

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