自己做的, 请各位达人指点一下:

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