Hope this saves someone else a lot of pain...
Function redimArray(poNewMemberArray)
Dim foTmpArray()
Dim fiIncrement
foTmpArray = poNewMemberArray
fiIncrement = UBound(foTmpArray, 1) + 1
ReDim poNewMemberArray(fiIncrement, UBound(foTmpArray, 2))
'Copy temp array back into larger original array:
For fiRow = LBound(foTmpArray, 1) To UBound(foTmpArray, 1) 'Loop for 1st dimension
For fiCol = LBound(foTmpArray, 2) To UBound(foTmpArray, 2) 'Loop for 2nd dimension
poNewMemberArray(fiRow, fiCol) = foTmpArray(fiRow, fiCol)
Next fiCol
Next fiRow
Erase foTmpArray
redimArray = poNewMemberArray
End Function
Function removeArrayRow(poNewMemberArray, piRowIdx)
Dim foTmpArray()
Dim fiCurIdx: fiCurIdx = 0
ReDim foTmpArray(UBound(poNewMemberArray, 1) - 1, UBound(poNewMemberArray, 2))
'Copy original array into temp array minus row
For fiRow = LBound(poNewMemberArray, 1) To UBound(poNewMemberArray, 1) 'Loop for 1st dimension
If fiRow <> piRowIdx Then
For fiCol = LBound(poNewMemberArray, 2) To UBound(poNewMemberArray, 2) 'Loop for 2nd dimension
foTmpArray(fiCurIdx, fiCol) = poNewMemberArray(fiRow, fiCol)
Next fiCol
fiCurIdx = fiCurIdx + 1
End If
Next fiRow
poNewMemberArray = foTmpArray
Erase foTmpArray
removeArrayRow = poNewMemberArray
End Function
Sub distlist()
MsgBox ("Select the file to load for Newletter Subscribers")
Dim foDialog
' Create a dialog object
Set foDialog = CreateObject("UserAccounts.CommonDialog")
' Default initial folder is "My Documents"
foDialog.InitialDir = CreateObject("WScript.Shell").SpecialFolders("MyDocuments")
' Use the specified file filter
foDialog.Filter = "*.csv|*.xls"
' Open the dialog and return the selected file name
If foDialog.ShowOpen Then
fsFileName = foDialog.FileName
Else
fsFileName = ""
End If
Set foDialog = Nothing
If fsFileName = "" Then
foAnswer = MsgBox("A file must be selected. Exiting process", vbExclamation)
Exit Sub
End If
Set foOutlook = CreateObject("Outlook.Application")
Set foExcel = CreateObject("Excel.Application")
Set foNamespace = foOutlook.GetNamespace("MAPI")
' Get new Newsletter distribution list members.
Dim foNewMemberArray()
ReDim foNewMemberArray(0, 1)
Set foNewWorkbook = foExcel.Workbooks.Open(fsFileName)
' Sort by most recent entry first
Const xlDescending = 2
Const xlYes = 1
Set foSortSheet = foNewWorkbook.Worksheets(1)
Set foRange = foSortSheet.UsedRange
Set foSortCol = foExcel.Range("A1")
foRange.Sort foSortCol, xlDescending, , , , , , xlYes
Dim fiLoopCount: fiLoopCount = 2
' Check first row has columns we need
If (foExcel.Cells(1, 2).value <> "Name" And foExcel.Cells(1, 3).value <> "Email") Then
foAnswer = MsgBox("File must have columns Time, Name, Email, Profession, City/Town, Browser IP Address, Unique ID", vbExclamation)
Exit Sub
End If
Do While Not IsEmpty(foExcel.Cells(fiLoopCount, 1).value)
Dim i 'For looping through the columns on each row
Dim value 'Value extracted from each cell
' Dont incerase array if its the first row i.e. 0
If (fiLoopCount - 2) > 0 Then
foNewMemberArray = redimArray(foNewMemberArray)
End If
'Spreadsheet is 7 columns across; we only need column 2 and 3
For i = 2 To 3
foNewMemberArray(fiLoopCount - 2, i - 2) = foExcel.Cells(fiLoopCount, i).value
Next
fiLoopCount = fiLoopCount + 1
Loop
Set foSortSheet = Nothing
Set foRange = Nothing
Set foSortCol = Nothing
foExcel.DisplayAlerts = False
foExcel.ActiveWorkbook.Close False
foExcel.DisplayAlerts = True
' Create workbook and worksheet for current Newsletter distribution list members.
foExcel.Workbooks.Add
Set foSheet = foExcel.ActiveWorkbook.Worksheets(1)
' Save all current Newsletter distribution list members
Dim fiRowIdx
fiRowIdx = 1
Set foContacts = foNamespace.GetDefaultFolder(olFolderContacts).Items
For Each foContactItems In foContacts
If TypeName(foContactItems) = "DistListItem" Then
If InStr(UCase(foContactItems.DLname), UCase("Newsletter")) Then
For fiIdx = 1 To foContactItems.MemberCount
' Add old members to the array
foNewMemberArray = redimArray(foNewMemberArray)
foNewMemberArray(fiLoopCount - 2, 0) = foContactItems.GetMember(fiIdx).Name
foNewMemberArray(fiLoopCount - 2, 1) = foContactItems.GetMember(fiIdx).Address
' Save new members to worksheet
foSheet.Cells(fiRowIdx, 1).value = foContactItems.GetMember(fiIdx).Name
foSheet.Cells(fiRowIdx, 2).value = foContactItems.GetMember(fiIdx).Address
' GetMember(x).AddressEntry.GetContact only available in 2007 or with
www.dimastr.com fiLoopCount = fiLoopCount + 1
fiRowIdx = fiRowIdx + 1
Next
End If
End If
Next
' Save the current Newsletter distribution list members.
fsFileOut = CreateObject("WScript.Shell").SpecialFolders("MyDocuments")
fsDateTime = Year(Now) & Month(Now) & Day(Now) & Hour(Now) & Minute(Now) & Second(Now)
fsFileOut = fsFileOut & "\NewsletterMemberList" & fsDateTime & ".xls"
foExcel.ActiveWorkbook.SaveAs fsFileOut
' Delete Newsletter distribution lists
For Each foContactItems In foContacts
If TypeName(foContactItems) = "DistListItem" Then
If InStr(UCase(foContactItems.DLname), UCase("Newsletter")) Then
foContactItems.Delete
End If
End If
Next
' Remove older duplicates; So array is new members sorted by date + contents of old distribution list
i = 0
Do While i < UBound(foNewMemberArray)
j = i + 1
Do While j <= UBound(foNewMemberArray)
If LCase(foNewMemberArray(i, 1)) = LCase(foNewMemberArray(j, 1)) Then
foNewMemberArray = removeArrayRow(foNewMemberArray, j)
Else
j = j + 1
End If
Loop
i = i + 1
Loop
' Sort the members by email
For i = LBound(foNewMemberArray) To UBound(foNewMemberArray) - 1
For j = (i + 1) To UBound(foNewMemberArray)
If LCase(foNewMemberArray(i, 1)) > LCase(foNewMemberArray(j, 1)) Then
fsColOne = foNewMemberArray(i, 0)
fsColTwo = foNewMemberArray(i, 1)
foNewMemberArray(i, 0) = foNewMemberArray(j, 0)
foNewMemberArray(i, 1) = foNewMemberArray(j, 1)
foNewMemberArray(j, 0) = fsColOne
foNewMemberArray(j, 1) = fsColTwo
End If
Next
Next
' Close and Quit Excel.
foExcel.ActiveWorkbook.Close
foExcel.Application.Quit
Set foExcel = Nothing
Dim foMAPIContacts As Outlook.MAPIFolder
Dim foOContactItems As Outlook.Items
Dim foObj As Object
Dim foDistListItem As DistListItem
Dim foRecipients As Recipients
Dim foMailItem As MailItem
Dim fsEmailAddress As String
Set foMAPIContacts = foNamespace.GetDefaultFolder(olFolderContacts)
Set foOContactItems = foMAPIContacts.Items
' Add members to distribution list
fiMaxLoopCount = Int(100)
fiLoopCount = Int(fiMaxLoopCount)
fiDistList = 1
For fiIdx = 0 To UBound(foNewMemberArray)
If fiMaxLoopCount <= fiLoopCount Then
Set foDistListItem = foOutlook.CreateItem(olDistributionListItem)
foDistListItem.DLname = "Newsletter " & fiDistList
fiLoopCount = Int(0)
fiDistList = fiDistList + 1
End If
' Hack to get the name and email in the right fields
fsEmailAddress = foNewMemberArray(fiIdx, 0) & "<" & foNewMemberArray(fiIdx, 1) & ">"
Set foObj = foOContactItems.Add("IPM.Contact")
foObj.Email1Address = fsEmailAddress
Set foMailItem = foOutlook.CreateItem(olMailItem)
Set foRecipients = foMailItem.Recipients
foRecipients.Add foObj.Email1Address
foRecipients.ResolveAll
foDistListItem.AddMembers foRecipients
foDistListItem.Save
fiLoopCount = Int(fiLoopCount) + Int(1)
Next
'Close distribution list objects
Set foMailItem = Nothing
Set foRecipients = Nothing
Set foDistListItem = Nothing
Set foObj = Nothing
Set foOContactItems = Nothing
Set foMAPIContacts = Nothing
' Close objects
Set foContacts = Nothing
Set foNamespace = Nothing
Set foOutlook = Nothing
End Sub