Exchange编程学习实例2--移动邮件到公用文件夹 vbs

qaqa12345667

　　继上次的开发纪录
程序的基本目的是将传真邮箱里保留一个月的邮件其余移动到公用文件夹内。
1、移动方法的选择：
recordset中没有找到相应的方法，只有在record中找到了Rec.MoveRecord方法
所以需要进行set record对象
在得到每一个记录的同时给他们榜定record。然后使用Rec.MoveRecord。
2、开始移动文件夹--不允新直接移动到根目录中，必须写明目的邮件的文件名。
我开始选择公用文件夹的邮件进行移动,本打算将原邮件移动到文件夹内，进行默认的文件命名（不更改名称）
urlMoveto="file://./backofficestorage/server.com.cn/public folders/test1/"
结果一下子将文件夹删除了！！！不知道是那里的错误。
3、邮件的访问权限。
使用公用文件夹，但是使用moverecord后返回权限不够的结果，提升了操作账号的权限，但是还是没有作用！测试以下其他的操作，deleterecord结果成功！！这是为何？？已经给了文件夹和操作的权限，而且在打开纪录的时候说明了是可读些的。
（Rec.Open URLFrom, Conn, adModeReadWrite
NewURL = Rec.MoveRecord( , URLTo, , , adMoveOverWrite)
）
搜吧，原来如此阿：这个得先声明以下
Const adModeReadWrite = 3
Const adMoveOverWrite = 1
成功！
4、开始转换文件夹，从私有邮箱移动到公共文件夹。
居然告诉我无法完成操作！奇怪！
差了半天，最后在sdk中的moverecord中看到一个说明：不支持私有邮箱和公共文件夹的互相移动。
这个怎么办啊，不能没有办法啊！
继续搜！
任何事情都能做到！人类是聪明的！
可以使用stream的savefileto。
好的开始做实验！
Set stm = CreateObject("ADODB.Stream")
没问题，但是使用stm.SaveToFile的时候说函数格式不正确，查了资料没有错误，但是发现一点，人家的例子都是机器的地址，又看了sdk地说明，这个市不支持网络地址的，于是将他转为虚拟盘符。成功。
但是我有点疑问，没有作试验，如果是exchange2003呢？找不到虚拟盘符阿！有高手指点一下。
5、看了测试结果，这个过程这能是复制相应的邮件，没有达到相应的移动效果。于是开始模仿move动作，拷贝后删除。
这时候删除我们可选择record.deleterecord方法！（删除邮件的另一种方法，彻底的删除！）成功
6、还有一点，查询日期的时候要使用urn:schemas:httpmail:date,不要使用urn:schemas:httpmail:datereceived因为，一次我移动后发现他的这属性消失了！破坏了数据结构，所以尽量不要使用。

顺便指出，最好去文件名称的时候用"DAV:href",这样的地质比较准确，href他是最这连接的打开地质不同的，如果用file他就是file的地址，用http就是http的地址。
href="DAV:href"
newname=trim(replace(href,"file://./backofficestorage/server.cn/MBX/fax.shanghai/Inbox/",""))
然后再组合成文件名称。
如果是异地服务器（账号在新加坡，但是exchange是2003无法通过m盘符访问）可以共享目录访问。

下面提出源代码供大家参考指正：

sUrl="file://./backofficestorage/servercom.cn/MBX/fax-tj/Inbox"
Const adModeReadWrite = 3
Const adMoveOverWrite = 1
Const adModeRead = 1
Const adModeWrite = 2
Const adOpenStreamFromRecord = 4
Const adSaveCreateNotExist = 1
Const adSaveCreateOverWrite = 2
Const adDefaultStream = -1 ‘注意声明尤其在2000系统
　　Dim Info
Dim InfoNT
Dim sFolderUrl
Dim sQuery

mytime = DateAdd("m", -1, Date)
　　mytime=mytime&"T00:00:00Z"
　　DateRng = " < CAST("""&mytime&""" as 'dateTime')"
　　Dim Conn
Set Conn = CreateObject("ADODB.Connection")
Conn.Provider = "ExOLEDB.DataSource"
Conn.Open sUrl
sQuery = "SELECT ""urn:schemas:httpmail:date"",""DAV:displayname"" FROM scope('shallow traversal of " & Chr(34) & sURL & Chr(34) & "') "
squery = squery & "WHERE ""urn:schemas:httpmail:date"" " & DateRng
　　Set Rs = CreateObject("ADODB.Recordset")
　　Rs.Open sQuery, Conn
　　cItems = Rs.RecordCount
　　do while not rs.eof
emailname=Rs.fields("DAV:displayname").value
urlMoveFrom="file://./backofficestorage/server.com.cn/MBX/fax-tj/Inbox/"&emailname
　　'wscript.echo urlMoveFrom
　　Set Conn2 = CreateObject("ADODB.Connection")
Conn2.Provider = "ExOLEDB.DataSource"
Conn2.Open urlMoveFrom
Set Rec = CreateObject("ADODB.Record")
　　Rec.Open urlMoveFrom,Conn2,adModeReadWrite
　　Set stm = CreateObject("ADODB.Stream")
　　stm.Open Rec,adModeRead,adOpenStreamFromRecord

stm.SaveToFile "M:\SERVER.COM.CN\PUBLIC FOLDERS\fax tianjin\"&emailname, adSaveCreateOverWrite  &#8216;注意地址的格式

stm.close

set stm=nothing

Rec.DeleteRecord

Rec.close

conn2.close

Set Rec = Nothing

Set Conn2 = Nothing

rs.Move 1,0

loop