获取OutLook邮件主题和接收时间

Sub findobinspec() '获取OutLook邮件主题和接收时间
Dim ns As outlook.Namespace
Dim str As Date, str1 As String, str2 As String
Set ns = session.Application.getnamespace("MAPI")
For Each fl In ns.Folders
For Each der In fl.Folders
If der = "收件箱" Then
For Each er In der.Folders
If er = "APPLY" Then '子文件夹
For Each r In er.items
If r.unread Then '如果为未读
str = Format(r.creationtime, "yyyy/m/d") 'r.creationtime 邮件接收时间
If str = Date Then
If InStr(r.Subject, "答复") = False Then 'r.Subject 邮件标题
r.unread = False '把邮件设置为已读
str2 = "(" & "'" & r.Subject & "'" & "," & "'" & r.creationtime & "'" & ")|" & str2
End If
End If
End If
Next
GoTo 100
End If
Next
End If
Next
Next
100:
str2 = Mid(str2, 1, Len(str2) - 1)
Call ADOEXCEL(str2) '向工作表中插入数据
Set ns = nothine
MsgBox "已提取"
End Sub

Sub ADOEXCEL(str As String) '用ADO向工作表插入数据
Dim con As Object, rs As Object, sql As String
Set con = CreateObject("adodb.connection")
Set rs = CreateObject("adodb.recordset")
strpath = "工作薄完整路径"
con.Open "provider=microsoft.ACE.OLEDB.12.0;Date Source=" & strpath & ";Extended properties=Excel 12.0"
arr = VBA.Split(str, "|")
For x = 0 To UBound(arr)
sql = "insert into 每日打单数据$ values " & arr(x)
con.Execute (sql) '执行SQL
Set rs = Nothing
con.Close: Set con = Nothing
End Sub