Microsoft Office Forums - View Single Post - [Solved] Outlook folder set up from Excel List

gmayor · 04-22-2016, 11:27 PM

Assuming a list of Folders in column A of the worksheet with a header row the following Outlook macro will provide an option select the folder and will add the list of folders as sub folders of the selected folder. Change the name and path of the workbook and the sheet name as appropriate. I n case you inadvertently select the wrong folder, I have included a macro to delete the listed files from the folder.

Code:

Option Explicit
Const strWorkbook As String = "C:\Path\Forums\OutlookFolders.xlsx"
Const strSheet As String = "Sheet1"
Private olNS As Outlook.NameSpace
Private olFolder As Outlook.Folder
Private olCheck As Folder
Private strFolders As String
Private lngRow As Long
Private Arr() As Variant

Sub AddFolderListFromExcel()
'Graham Mayor - www.gmayor.com
    strFolders = ""
    On Error Resume Next
    Set olNS = GetNamespace("MAPI")
    Set olFolder = olNS.PickFolder
    Arr = xlFillArray(strWorkbook, strSheet)
    For lngRow = 0 To UBound(Arr, 2)
        olFolder.folders.Add Arr(0, lngRow)
        strFolders = strFolders & Arr(0, lngRow) & vbNewLine
    Next lngRow
    MsgBox strFolders & vbNewLine & "added to " & olFolder
lbl_Exit:
    Set olFolder = Nothing
    Exit Sub
End Sub

Sub DeleteFolderListFromExcel()
'Graham Mayor - www.gmayor.com
    strFolders = ""
    On Error Resume Next
    Set olNS = GetNamespace("MAPI")
    Set olFolder = olNS.PickFolder
    Arr = xlFillArray(strWorkbook, strSheet)
    For lngRow = 0 To UBound(Arr, 2)
        olFolder.folders(Arr(0, lngRow)).Delete
        strFolders = strFolders & Arr(0, lngRow) & vbNewLine
    Next lngRow
    MsgBox strFolders & vbNewLine & "deleted from " & olFolder
lbl_Exit:
    Set olFolder = Nothing
    Exit Sub
End Sub

Private Function xlFillArray(strWorkbook As String, _
                             strWorksheetName As String) As Variant
'Graham Mayor - www.gmayor.com
Dim RS As Object
Dim CN As Object
Dim iRows As Integer

    strWorksheetName = strWorksheetName & "$]"
    Set CN = CreateObject("ADODB.Connection")
    CN.Open ConnectionString:="Provider=Microsoft.ACE.OLEDB.12.0;" & _
                              "Data Source=" & strWorkbook & ";" & _
                              "Extended Properties=""Excel 12.0 Xml;HDR=YES"";"

    Set RS = CreateObject("ADODB.Recordset")
    RS.Open "SELECT * FROM [" & strWorksheetName, CN, 2, 1

    With RS
        .MoveLast
        iRows = .RecordCount
        .MoveFirst
    End With
    xlFillArray = RS.GetRows(iRows)
    If RS.State = 1 Then RS.Close
    Set RS = Nothing
    If CN.State = 1 Then CN.Close
    Set CN = Nothing
lbl_Exit:
    Exit Function
End Function