• Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 293
  • Last Modified:

Need help adding an InputBox in an address in an Outlook macro

I have a macro that constructs an MS Outlook email distribution from a column of email addresses in a MS Excel worksheet. The worksheet must be named Distribution.xls for the macro to work.  How can I change this VB so that the name of the worksheet is entered into an InputBox? Here is the procedure:

Sub MakeMultiDistListV2()

    Dim olkList As Outlook.DistListItem, _
        olkRecipient As Outlook.Recipient, _
        olkDummyItem As Outlook.MailItem, _
        excApp As Object, _
        excBook As Object, _
        excSheet As Object, _
        intRow As Integer, _
        intCol As Integer, _
        intCount As Integer, _
        intPart As Integer, _
        strBuffer As String, _
        strDLName As String
    'Change the root list name on the next line (no spaces)
    strDLName = InputBox("Enter email distribution name: ", "Email Distribution")
    intPart = 1
    intCount = 1
    Set olkDummyItem = Application.CreateItem(olMailItem)
    Set olkList = Application.CreateItem(olDistributionListItem)
    Set excApp = CreateObject("Excel.Application")
    'Change the path and filename to that of your spreadsheet
     Set excBook = excApp.Workbooks.Open("\\domain-01.com\dfs$\care-one\users\care-one_nanthony\desktop\Distribution.xls")
    'Change the sheet number as needed
    Set excSheet = excBook.Sheets(1)
    'Change the column number as needed
    intCol = 4
    'Change the starting row number as needed
    intRow = 2
    Do While True
        strBuffer = excSheet.Cells(intRow, intCol)
        If strBuffer = "" Then
            Exit Do
        Else
            Set olkRecipient = olkDummyItem.Recipients.Add(strBuffer)
            olkRecipient.Resolve
            olkList.AddMember olkRecipient
            intRow = intRow + 1
            If intCount = 100 Then
                olkList.DLName = strDLName & " - Part " & intPart
                olkList.Save
                Set olkList = Application.CreateItem(olDistributionListItem)
                intPart = intPart + 1
                intCount = 1
            Else
                intCount = intCount + 1
            End If
        End If
    Loop
    'Change the list name as needed
    olkList.DLName = strDLName & IIf(intPart > 1, " - Part " & intPart, "")
    olkList.Save
    Set olkDummyItem = Nothing
    Set olkRecipient = Nothing
    Set olkList = Nothing
    Set excSheet = Nothing
    excBook.Close False
    Set excBook = Nothing
    Set excApp = Nothing
    MsgBox "All done!"
End Sub
0
janthonyn
Asked:
janthonyn
  • 3
1 Solution
 
gtglonerCommented:
Try this amendment to your code:


Sub MakeMultiDistListV2()

    Dim olkList As Outlook.DistListItem, _
        olkRecipient As Outlook.Recipient, _
        olkDummyItem As Outlook.MailItem, _
        excApp As Object, _
        excBook As Object, _
        excSheet As Object, _
        intRow As Integer, _
        intCol As Integer, _
        intCount As Integer, _
        intPart As Integer, _
        strBuffer As String, _
        strDLName As String
       
     Dim yourfilename As String
     Dim thefilename As String
     
     yourfilename = InputBox("Please enter your filename here eg. Distribution.xls")
     thefilename = "\\domain-01.com\dfs$\care-one\users\care-one_nanthony\desktop\" & yourfilename
     
     
     
    'Change the root list name on the next line (no spaces)
    strDLName = InputBox("Enter email distribution name: ", "Email Distribution")
    intPart = 1
    intCount = 1
    Set olkDummyItem = Application.CreateItem(olMailItem)
    Set olkList = Application.CreateItem(olDistributionListItem)
    Set excApp = CreateObject("Excel.Application")
    'Change the path and filename to that of your spreadsheet
     Set excBook = excApp.Workbooks.Open(thefilename)
    'Change the sheet number as needed
    Set excSheet = excBook.Sheets(1)
    'Change the column number as needed
    intCol = 4
    'Change the starting row number as needed
    intRow = 2
    Do While True
        strBuffer = excSheet.Cells(intRow, intCol)
        If strBuffer = "" Then
            Exit Do
        Else
            Set olkRecipient = olkDummyItem.Recipients.Add(strBuffer)
            olkRecipient.Resolve
            olkList.AddMember olkRecipient
            intRow = intRow + 1
            If intCount = 100 Then
                olkList.DLName = strDLName & " - Part " & intPart
                olkList.Save
                Set olkList = Application.CreateItem(olDistributionListItem)
                intPart = intPart + 1
                intCount = 1
            Else
                intCount = intCount + 1
            End If
        End If
    Loop
    'Change the list name as needed
    olkList.DLName = strDLName & IIf(intPart > 1, " - Part " & intPart, "")
    olkList.Save
    Set olkDummyItem = Nothing
    Set olkRecipient = Nothing
    Set olkList = Nothing
    Set excSheet = Nothing
    excBook.Close False
    Set excBook = Nothing
    Set excApp = Nothing
    MsgBox "All done!"
End Sub
0
 
gtglonerCommented:
Afterthought - my code above assumes that the pathname to the other files you want to access will be the same as the one where "Distribution.xls" is on your system.
0
 
David LeeCommented:
Hi, janthonyn.  

Add the code below to what you already have and you'll have a complete solution for browsing to the file you want to use.  To use it in the code you already have, simply change this line

     Set excBook = excApp.Workbooks.Open("\\domain-01.com\dfs$\care-one\users\care-one_nanthony\desktop\Distribution.xls")

to

     Set excBook = excApp.Workbooks.Open(BrowseForFile("\\domain-01.com\dfs$\care-one\users\care-one_nanthony\desktop"))


Function BrowseForFile(Optional strStartingFolder As String) As String
    Dim objDialogBox As Object, _
        intResult As Integer
    Set objDialogBox = CreateObject("Useraccounts.Commondialog")
    With objDialogBox
        .InitialDir = IIf(strStartingFolder <> "", strStartingFolder, "C:\")
        .Filter = "Excel files|*.xls"
        .FilterIndex = 1
        intResult = .ShowOpen
        If (intResult = 0) Then 'Nothing was selected
            BrowseForFile = ""
        Else
            BrowseForFile = .FileName
        End If
    End With
    Set objDialogBox = Nothing
End Function
0
 
janthonynAuthor Commented:
Thanks! works great
0
 
gtglonerCommented:
You're welcome, hope to be able to assist again in the future!

Glenn
0

Featured Post

Vote for the Most Valuable Expert

It’s time to recognize experts that go above and beyond with helpful solutions and engagement on site. Choose from the top experts in the Hall of Fame or on the right rail of your favorite topic page. Look for the blue “Nominate” button on their profile to vote.

  • 3
Tackle projects and never again get stuck behind a technical roadblock.
Join Now