Excel Sheets Selected in listbox4 load in e-mail (each sheet as individual workbook)

[blaker]

I have a workbook with forms listbox that list out the sheets in the workbook, I have the below code that takes the sheets that are selected in the listbox and saves as a new workbook as a temp file (with all sheets selected in the forms listbox ) in a new workbook and loads this in my e-mail dialog box.
is there a was to take all sheets selected in the forms list box and create a new workbook for each sheet selected in the listbox and load all those workbooks in my e-mail dialog box ?

here is the code i am currently using:

Dim OutApp As Object
Dim outmial As Object
Dim strbody As String


Dim FileExtStr As String
Dim FileFormatNum As Long
Dim SourceWB As Workbook
Dim Destwb As Workbook
Dim TempFilePath As String
Dim TempFileName As String

Dim lX As Long
Dim aryWorksheets() As Variant
Dim sWorksheets As String
Dim iAnswer As VbMsgBoxResult

' selects all items selected in list box4 and adds to one workbook...
Dim i As Integer, sht As String, arr() As String, n As Long
For i = 0 To ListBox4.ListCount - 1
If ListBox4.Selected(i) = True Then
ReDim Preserve arr
arr = ListBox4.List(i)
n = n + 1
End If
Next i
Sheets(arr).Select
' end of adding selected sheets to one workbook



With Application
.ScreenUpdating = False
.EnableEvents = False
End With

Set SourceWB = ActiveWorkbook

'Copy the ActiveSheet to a new workbook
' ActiveSheet.Copy


' new

For lX = 1 To ActiveWindow.SelectedSheets.count
ReDim Preserve aryWorksheets(1 To lX)
aryWorksheets(lX) = ActiveWindow.SelectedSheets(lX).Name
sWorksheets = sWorksheets & " " & ActiveWindow.SelectedSheets(lX).Name & vbLf
Next

iAnswer = MsgBox("You currently have the following reports" & _
IIf(ActiveWindow.SelectedSheets.count > 1, "s", "") & " selected:" & vbLf & vbLf & _
sWorksheets & vbLf & "Click 'OK' if " & _
IIf(ActiveWindow.SelectedSheets.count > 1, "these are", "this is") & " the worksheet" & _
IIf(ActiveWindow.SelectedSheets.count > 1, "s", "") & " that you want to attach to the e-mail" & vbLf & _
"Click 'Cancel' if you want to change your selection." & vbLf & vbLf & _
" ", vbOKCancel, _
"Attach Selected Worksheets?")
If iAnswer = vbCancel Then End
Sheets(aryWorksheets).Copy

' end of new................


Set Destwb = ActiveWorkbook

'Determine the Excel version and file extension/format
With Destwb
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007-2016
Select Case SourceWB.FileFormat
Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If .HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56: FileExtStr = ".xls": FileFormatNum = 56
Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
End With



TempFilePath = Environ$("temp") & "\"
TempFileName = "Conversion Items for " & ActiveSheet.Range("l1") & " " & ActiveSheet.Range("b2") & " " & Format(Now, "dd-mmm h-mm-ss")



Set OutApp = CreateObject("outlook.application")
Set outmail = OutApp.CreateItem(0)


With Destwb



.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
On Error Resume Next
With outmail
.To = ActiveSheet.Range("b11").Value

.CC = ""
.Bcc = ""
.Subject = "Conversion Items To Review For: " & ActiveSheet.Range("l1").Value



If ActiveSheet.Range("l6").Value > 0 Then

.Body = "Hey " & ActiveSheet.Range("c10").Value & "," & vbNewLine & "" & vbNewLine & "Attached are the reports for the Product Selection, please review and let me know if you have any questions..." & vbNewLine & vbNewLine & ActiveSheet.Range("k179").Value & vbNewLine & "Thanks for all your help!" & vbNewLine & "Blake"
Else
.Body = "Hey " & ActiveSheet.Range("c10").Value & "," & vbNewLine & "" & vbNewLine & "The Attached File has the Conversion Items for your review, Please Review and let me know what questions you have. " & vbNewLine & vbNewLine & " " & "Thanks for all your help!" & vbNewLine & " " & "Blake"

End If

.HTMLBody = strbody & .HTMLBody

.Attachments.Add Destwb.FullName


.display 'or use .Display
.Attachments.Add ("C:\test.txt")

End With
On Error GoTo 0
'.Close savechanges:=False
End With

'Delete the file you have send
' Kill TempFilePath & TempFileName & FileExtStr

'Set outmail = Nothing
'Set OutApp = Nothing

With Application
.ScreenUpdating = True
.EnableEvents = True




End With



End Sub