Emailing document from listbox

[Zane Stein]

I am fairly new with VBA. I have created a document which, when completed, allows the user to click on a button and email the whole document to me. That works fine.

I want to modify it and am getting lost.
What I want is:
A list box which has the names of four different people in it.
The user clicks on one, two, three, or all four of those listed names to highlight them. If they click on a name a second time, it unhighlights that name.
Once the user has selected the person or persons they wanted, they will click the button, and it will send a copy of the document to the email address of each person highlighted in the list box.

Here is the code I have used for my single button, and as I said, this works fine:

Private Sub CommandButton1_Click()
Dim oStory As Range
For Each oStory In ActiveDocument.StoryRanges
oStory.Fields.Update
If oStory.StoryType <> wdMainTextStory Then
While Not (oStory.NextStoryRange Is Nothing)
Set oStory = oStory.NextStoryRange
oStory.Fields.Update
Wend
End If
Next oStory
Set oStory = Nothing

ActiveDocument.Fields.Update
ActiveDocument.SaveAs FileName:="PERMISSIONS REQUEST.doc"


MsgBox "Thank you. Your Permissions Request was sent to your IT Dept", vbOKOnly, "Thank you. Your Permissions Request was sent to your IT Dept"


'This macro requires the Outlook Object library to be checked

'in the vba editor Tools > References
Dim bStarted As Boolean
Dim oOutlookApp As Outlook.Application
Dim oItem As Outlook.MailItem
On Error Resume Next
If Len(ActiveDocument.Path) = 0 Then 'Document has not been saved
ActiveDocument.Save 'so save it
End If
'see if Outlook is running and if so turn your attention there
Set oOutlookApp = GetObject(, "Outlook.Application")
If Err <> 0 Then 'Outlook isn't running
'So fire it up
Set oOutlookApp = CreateObject("Outlook.Application")
bStarted = True
End If
'Open a new e-mail message
Set oItem = oOutlookApp.CreateItem(olMailItem)
With oItem 'and add the detail to it
.To = "stezan@sstuwa.org.au" 'send to this address
.Subject = "Permissions Request Form" 'This is the message subject
.Body = "Thank you. Your IT Department will review your form and contact you if there are any questions." ' This is the message body text
.Attachments.Add Source:=ActiveDocument.FullName, Type:=olByValue
.Send
'**********************************

End With
If bStarted Then 'If the macro started Outlook, stop it again.
oOutlookApp.Quit
End If
'Clean up
Set oItem = Nothing
Set oOutlookApp = Nothing
End Sub

-------------------------

Can anyone help me to write coding to do what I need it to do with the list box names?

Thank you.

Zane

[fumei]

There are a few issues with your code. But essentially, to get all the selected items in the listbox, make an array and fill it with the selected items. Then use the array, creating a new mailitem for each one.

Comments:

1. move the code regarding the field updates to a separate procedure, and then Call it. This keeps your more modular, and helps in debugging.

2. You use:
If bStarted Then 'If the macro started Outlook, stop it again.
This is pointless, as you HAVE used Outlook. It will never not be true.

3. You use:If Len(ActiveDocument.Path) = 0 Then 'Document has not been saved
ActiveDocument.Save 'so save it
End IfThis is also pointless, as you have already explicitly saved it previously in the code. It will never be 0.

Sub FieldsYadda()
Dim oStory As Range
For Each oStory In ActiveDocument.StoryRanges
oStory.Fields.Update
If oStory.StoryType <> wdMainTextStory Then
While Not (oStory.NextStoryRange Is Nothing)
Set oStory = oStory.NextStoryRange
oStory.Fields.Update
Wend
End If
Next oStory
Set oStory = Nothing

ActiveDocument.Fields.Update
ActiveDocument.SaveAs FileName:="PERMISSIONS REQUEST.doc"


MsgBox "Thank you. Your Permissions Request was sent to your IT Dept", vbOKOnly, _
"Thank you. Your Permissions Request was sent to your IT Dept"
End Sub
Private Sub CommandButton1_Click()
Dim Names() As String
Dim var
Dim i As Long
Dim bStarted As Boolean
Dim oOutlookApp As Outlook.Application
Dim oItem As Outlook.MailItem

Call FieldsYadda ' to take care of your fields

' fill an array of the selected items from the listbox
' this goes through each item in the listbox
' and if it is selected add it to the array

For var = 0 To ListBox1.ListCount - 1
If ListBox1.Selected(var) = True Then
ReDim Preserve Names(i)
Names(i) = ListBox1.List(var)
i = i + 1
End If
Next

On Error Resume Next

'see if Outlook is running and if so turn your attention there
Set oOutlookApp = GetObject(, "Outlook.Application")
If Err <> 0 Then 'Outlook isn't running
'So fire it up
Set oOutlookApp = CreateObject("Outlook.Application")
End If

'cycle through array using a new mailitem for each one
For var = 0 To UBound(Names())
Set oItem = oOutlookApp.CreateItem(olMailItem)
With oItem 'and add the detail to it
.To = Names(var) 'send to this address
.Subject = "Permissions Request Form" 'This is the message subject
.Body = "Thank you. Your IT Department will review your form and " & _
"contact you if there are any questions." ' This is the message body text
.Attachments.Add Source:=ActiveDocument.FullName, Type:=olByValue
.Send
End With
Set oItem = Nothing
Next var

'Clean up
oOutlookApp.Quit
Set oOutlookApp = Nothing
End Sub


Lastly, the code takes the text of the selected items and uses THAT for the TO: address. Obviously this requires that the listbox items are the full and complete email addresses.

If this is not the case (and most likely it will not), then you need to need to build further logic, along the lines of:

If Names(x) - "Joe Blow" then TO:= "jblow@whatever.org.au"