|
'---------------------------------------------------- |
|
' Code by Ricardo Drizin (contact info at http://www.drizin.com.br) @Drizin |
|
'---------------------------------------------------- |
|
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) |
|
Option Explicit |
|
|
|
'--------------------------------------------------------------------- |
|
' This method closes ActiveInspectors if any. |
|
' All importing is based on the assumption that the EML |
|
' is opened by shell and we can refer to it through the ActiveInspector |
|
'--------------------------------------------------------------------- |
|
Function CloseOpenInspectors() As Boolean |
|
Dim app As Outlook.Application: Set app = CreateObject("Outlook.Application") |
|
Dim insp As Outlook.Inspector |
|
Dim count As Integer |
|
count = 0 |
|
repeat: |
|
count = count + 1 |
|
Set insp = app.ActiveInspector |
|
If TypeName(insp) = "Nothing" Then |
|
CloseOpenInspectors = True |
|
Exit Function |
|
End If |
|
If TypeName(insp.CurrentItem) = "Nothing" Then |
|
CloseOpenInspectors = True |
|
Exit Function |
|
End If |
|
If (count > 100) Then |
|
MsgBox "Error. Could not close ActiveInspector. " |
|
CloseOpenInspectors = False |
|
End If |
|
|
|
insp.Close (olDiscard) |
|
GoTo repeat |
|
End Function |
|
|
|
|
|
'--------------------------------------------------------------------- |
|
' This method allows user to choose a Root Folder in Outlook |
|
' All EML files will be imported under this folder |
|
'--------------------------------------------------------------------- |
|
Function GetRootFolder() As Outlook.folder |
|
Dim app As Outlook.Application: Set app = CreateObject("Outlook.Application") |
|
Dim NS As Outlook.NameSpace: Set NS = app.GetNamespace("MAPI") |
|
Dim fold As Outlook.folder |
|
Set fold = NS.PickFolder |
|
'MsgBox fold.Name |
|
Set GetRootFolder = fold |
|
End Function |
|
|
|
'--------------------------------------------------------------------- |
|
' Creates a child folder in Outlook, under root folder. |
|
'--------------------------------------------------------------------- |
|
Function GetChildFolder(parentFolder As Outlook.folder, name As String) |
|
On Error Resume Next |
|
Dim fold2 As Outlook.folder |
|
Set fold2 = parentFolder.folders.Item(name) |
|
If Err.Number Then |
|
On Error GoTo 0 |
|
Set fold2 = parentFolder.folders.Add(name) |
|
End If |
|
On Error GoTo 0 |
|
'MsgBox fold2.Name |
|
Set GetChildFolder = fold2 |
|
End Function |
|
|
|
'--------------------------------------------------------------------- |
|
' Imports the EML open in the current ActiveInspector |
|
' into the given folder |
|
'--------------------------------------------------------------------- |
|
Sub ImportOpenItem(targetFolder As Outlook.folder) |
|
Static appInspectorsCount As Long |
|
Dim app As Outlook.Application: Set app = CreateObject("Outlook.Application") |
|
Dim insp As Outlook.Inspector: Set insp = app.ActiveInspector |
|
|
|
Dim retries As Integer |
|
retries = 0 |
|
While TypeName(insp) = "Nothing" ' READING PANE should be visible, or else it will not work. |
|
'MsgWaitObj (1000) |
|
Sleep (50) |
|
DoEvents |
|
Sleep (50) |
|
Set insp = app.ActiveInspector |
|
retries = retries + 1 |
|
'If retries > 100 Then |
|
' Stop |
|
'End If |
|
Wend |
|
|
|
If TypeName(insp) = "Nothing" Then |
|
MsgBox "Error! Could not find open inspector for importing email." |
|
Exit Sub |
|
End If |
|
|
|
|
|
Dim m As Object, m2 As Object, m3 As Object |
|
Set m = insp.CurrentItem |
|
'MsgBox m.Subject |
|
Set m2 = m.Copy |
|
Set m3 = m2.Move(targetFolder) |
|
m3.Save |
|
Set m = Nothing |
|
Set m2 = Nothing |
|
Set m3 = Nothing |
|
insp.Close (olDiscard) |
|
Set insp = Nothing |
|
|
|
If appInspectorsCount = 0 And app.Inspectors.count <> 0 Then |
|
Debug.Print "app.Inspectors.Count: "; app.Inspectors.count |
|
appInspectorsCount = app.Inspectors.count |
|
End If |
|
If app.Inspectors.count > appInspectorsCount Then |
|
Debug.Print "app.Inspectors.Count: "; app.Inspectors.count |
|
Stop |
|
appInspectorsCount = 0 |
|
End If |
|
End Sub |
|
|
|
|
|
'--------------------------------------------------------------------- |
|
' Scans a given folder for *.EML files and import them |
|
' into the given folder. |
|
' Each EML file will be deleted after importing. |
|
'--------------------------------------------------------------------- |
|
Sub ImportEMLFromFolder(targetFolder As Outlook.folder, emlFolder As String) |
|
If Right(emlFolder, 1) <> "\" Then emlFolder = emlFolder & "\" |
|
Dim firstImport As Boolean: firstImport = True |
|
|
|
Dim file As String |
|
Dim count As Integer: count = 0 |
|
'MsgBox fold.Items.count |
|
'Exit Sub |
|
file = Dir(emlFolder & "*.eml") |
|
|
|
repeat: |
|
If file = "" Then |
|
'MsgBox "Finished importing EML files. Total = " & count |
|
Debug.Print "Finished importing EML files. Total = " & count |
|
Exit Sub |
|
End If |
|
count = count + 1 |
|
|
|
Debug.Print "Importing... " & file & " - " & emlFolder |
|
Shell ("explorer """ & emlFolder & file & """") |
|
'If firstImport Then Stop |
|
firstImport = False |
|
Sleep (50) |
|
On Error GoTo nextfile |
|
Call ImportOpenItem(targetFolder) |
|
Call Kill(emlFolder & file) |
|
nextfile: |
|
On Error GoTo 0 |
|
Sleep (50) |
|
|
|
file = Dir() |
|
GoTo repeat |
|
End Sub |
|
|
|
'--------------------------------------------------------------------- |
|
' Main method. |
|
' User chooses an Outlook root Folder, and a Windows Explorer root folder. |
|
' All EML files inside this folder and in immediate subfolders will be imported. |
|
'--------------------------------------------------------------------- |
|
Sub ImportAllEMLSubfolders() |
|
If Not CloseOpenInspectors Then |
|
MsgBox "Open Inspectors cannot be closed!. Try restarting Outlook" |
|
Exit Sub |
|
End If |
|
|
|
MsgBox "Choose a root folder for importing " |
|
Dim rootOutlookFolder As Outlook.folder |
|
Set rootOutlookFolder = GetRootFolder() |
|
If rootOutlookFolder Is Nothing Then Exit Sub |
|
|
|
Dim rootWindowsFolder As String |
|
rootWindowsFolder = "D:\OutlookExpress-EMLs-folder" |
|
rootWindowsFolder = InputBox("Choose a windows folder where you have your EML files", , rootWindowsFolder) |
|
If IsNull(rootWindowsFolder) Or IsEmpty(rootWindowsFolder) Or rootWindowsFolder = "" Then Exit Sub |
|
If Right(rootWindowsFolder, 1) <> "\" Then rootWindowsFolder = rootWindowsFolder & "\" |
|
|
|
Dim subFolders As New Collection |
|
|
|
Dim subFolder As String |
|
subFolder = Dir(rootWindowsFolder, vbDirectory) |
|
repeat: |
|
If subFolder = "." Or subFolder = ".." Then GoTo nextdir |
|
If (GetAttr(rootWindowsFolder & subFolder) And vbDirectory) = 0 Then GoTo nextdir |
|
subFolders.Add (subFolder) |
|
nextdir: |
|
subFolder = Dir() |
|
If subFolder <> "" Then GoTo repeat |
|
|
|
Dim outlookFolder As Outlook.folder |
|
|
|
' Importing main folder |
|
Call ImportEMLFromFolder(rootOutlookFolder, rootWindowsFolder) |
|
|
|
' Importing subfolders |
|
While subFolders.count |
|
subFolder = subFolders.Item(1) |
|
subFolders.Remove (1) |
|
Set outlookFolder = GetChildFolder(rootOutlookFolder, subFolder) |
|
Debug.Print "Importing " & rootWindowsFolder & subFolder & " into Outlook folder " & outlookFolder.name & "..." |
|
Call ImportEMLFromFolder(outlookFolder, rootWindowsFolder & subFolder) |
|
Wend |
|
Debug.Print "Finished" |
|
|
|
End Sub |
Thanks to @Drizin for this Gist. https://web.archive.org/web/20190914013907/http://drizin.io/Importing-EML-files-or-Outlook-Express-DBX-into-Outlook-2010/