OUTLOOK2000的收件箱内容复制到ACCESS数据库

haemon

自己做的, 请各位达人指点一下:
Sub CopyMessages()
Const MailBox = "个人文件夹"
Dim Cnt As New ADODB.Connection
Dim Mbox As New ADODB.Recordset
Dim fld As ADODB.Field
Dim Hist As New ADODB.Recordset
Dim ConnectString As String
Dim conn As New ADODB.Connection
Dim cntstring As String
ConnectString = "Provider=Microsoft.Jet.OLEDB.4.0;Persist Security Info=False;Data Source=" + "d:\vb\ado outlook\dbMessage.mdb" + ";Mode=Share Deny None"
conn.Open ConnectString
Hist.Open "tbl_Msg", conn, adOpenKeyset, adLockOptimistic '打开ACCESS数据库里的表

cntstring = "Provider=Microsoft.Jet.OLEDB.4.0;Outlook 9.0;MAPILEVEL=" & MailBox & "|收件箱;" & "DATABASE=C:\Temp\;"
Cnt.Open cntstring
Mbox.Open "select * from Official", Cnt '打开收件箱

Do Until Mbox.EOF
With Hist
    .AddNew
    !Msg_Sender = Mbox("来自")
    !Msg_Received = Mbox("已收到")
    !Msg_Subject = Mbox("主题")
    !Msg_Body = Mbox("内容")
    !Msg_Attch = Mbox("附件")
    .Update
End With
Mbox.MoveNext
Loop '把收件箱里的有关信息复制到ACCESS表

Mbox.Close
Set Mbox = Nothing
Cnt.Close
Set Cnt = Nothing
Hist.Close
Set Hist = Nothing
conn.Close
Set conn = Nothing
MsgBox "结束"
End Sub