![]() |
#1
|
|||
|
|||
![]()
Hoping someone can help.
I've got a list of names in a Excel Spreadsheet that i would like to set up us a list of sub-folders under a parent folder in Outlook 2013 Any help would be greatly appreciated |
#2
|
||||
|
||||
![]()
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
__________________
Graham Mayor - MS MVP (Word) (2002-2019) Visit my web site for more programming tips and ready made processes www.gmayor.com |
![]() |
Tags |
excel 2013, outlook 2013, vba code |
Thread Tools | |
Display Modes | |
|
![]() |
||||
Thread | Thread Starter | Forum | Replies | Last Post |
![]() |
Rramjet | Word | 5 | 03-09-2016 02:28 AM |
Outlook 2010 folder list annoying | crazyoldvet | Outlook | 1 | 10-02-2015 09:49 PM |
![]() |
bartoch | Outlook | 2 | 08-11-2015 07:05 AM |
Outlook Distrubtion list from Excel | AngelaSWard | Outlook | 1 | 11-20-2014 03:36 AM |
Change Contacts View icon folder to List | arthurshurn | Outlook | 0 | 10-29-2013 09:53 AM |