1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:
86:
87:
88:
89:
90:
91:
92:
93:
94:
95:
96:
97:
98:
99:
100:
101:
102:
103:
104:
105:
|
Option Explicit
Const ATTACHMENTFOLDER = "D:\Temp\1\Outlook Attachments\"
Sub launchpad()
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim MyFolder As Outlook.MAPIFolder
On Error Resume Next
Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")
Set MyFolder = objNS.PickFolder
Call ProcessFolder(MyFolder)
Set objNS = Nothing
Set MyFolder = Nothing
Set olApp = Nothing
Set objNS = Nothing
End Sub
Sub ProcessFolder(StartFolder As MAPIFolder)
Dim objFolder As Outlook.MAPIFolder
Dim oFolders As Outlook.MAPIFolder
Dim oFolderCount As Long
Dim oAttachment As Attachment
Dim iCount As Integer
Dim adoCon As Object, _
strFields As String, _
varValues As Variant, _
strKey As String, _
strPath As String
Dim objItem As mailitem
On Error GoTo ErrorHandler
Set oFolders = objFolder.folders
oFolderCount = oFolders.Count
'Check if there are any folders below oFolder
iCount = 0
If oFolderCount Then
strFields = "Bcc,Body,BodyFormat,Categories,Cc,CreationTime,HTMLBody,Importance,SenderName,Sensitivity,Subject,SentTo,MsgID"
Set adoCon = CreateObject("ADODB.Connection")
'Change the name and path of the database on the next line
adoCon.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=D:\Temp\1\Outlook.Mdb;Persist Security Info=False"
' process all the subfolders of this folder
For Each objFolder In StartFolder.folders
' process all the items in this folder
For Each objItem In StartFolder.Items
With objItem
strKey = Format(Now, "yyyymmdd") & "-" & Timer()
varValues = "'" & FixTextField(.BCC) & "'" _
& ",'" & FixTextField(.Body) & "'" _
& "," & .BodyFormat _
& ",'" & FixTextField(.Categories) & "'" _
& ",'" & FixTextField(.CC) & "'" _
& ",'" & .CreationTime & "'" _
& ",'" & FixTextField(.HTMLBody) & "'" _
& "," & .Importance _
& ",'" & FixTextField(.SenderName) & "'" _
& "," & .Sensitivity _
& ",'" & FixTextField(.Subject) & "'" _
& ",'" & FixTextField(.To) & "'" _
& ",'" & strKey & "'"
End With
Debug.Print " - - " & objItem
'Change the table name "Messages" on the following line as needed
adoCon.Execute "INSERT INTO Messages (" & strFields & ") VALUES(" & varValues & ")"
For Each oAttachment In objItem.Attachments
strPath = ATTACHMENTFOLDER & strKey & " - " & oAttachment.FileName
oAttachment.SaveAsFile strPath
adoCon.Execute "INSERT INTO Attachments (MsgID,FileLink) VALUES('" & strKey & "','" & strPath & "')"
iCount = iCount + 1
Debug.Print "True" & " " & iCount & " " & oAttachment.FileName
Next oAttachment
iCount = 0
Next objItem
Debug.Print " - " & objFolder.Name, "(" & iCount & ")"
Call ProcessFolder(objFolder)
Next objFolder
adoCon.Close
Set adoCon = Nothing
Set objFolder = Nothing
Set objItem = Nothing
End If
ErrorHandler:
Select Case Err.Number
Case 91
MsgBox Err.Number
Exit Sub
Case Else
MsgBox Err.Number
Exit Sub
End Select
'Resume
End Sub
Function FixTextField(varValue) As Variant
FixTextField = Replace(Replace(varValue, Chr(34), Chr(34) & Chr(34)), "'", "''")
End Function
|
