Advanced Multi VBA - Creating multiple temporary files and attach them to one email on outlook

[Hayf13]

Hi Hive Mind - really struggling with this one.

I have a large multi purpose spreadsheet built - have customised and built vbas that all work for the functionality I need - i'm looking for a way to streamline this into all one process.

I've actually named these buttons Step 1/2/3/4 in my sheet

Step 1 creates a pdf on variable data and asks where i'd like to save it
Step 2 creates a different pdf on variable data and asks where i'd like to save it
Step 3 creates a blank excel file with the relevant data I need to send
Step 4 creates an automated email pop up which I then have to manually attach files created in step 1/2.

Is there a way to turn Steps 1/2/3 into temporary files instead and attach all to the email on step 4? (As an added extra if it were possible, a pop up at this stage asking which of the 3 files i'd like to add to this email would be amazing, on rare occasions i do not require to add all of the above)

Code for each as below - all code works individually so not looking for any changes there. Thanks all! For reference I've removed some sensitive code/ranges from the below that wouldn't impact the answer (I don't think...) in red.

Step 1

Sub flashpdf()

'Ranges in this part
Set xSht = Worksheets("x").Range("x")
Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)

If xFileDlg.Show = True Then
xFolder = xFileDlg.SelectedItems(1)

Else
MsgBox "You must specify a folder to save the PDF into." & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Must Specify Destination Folder"
Exit Sub
End If
xFolder = xFolder + "\" + XFlash + ".pdf"

'Check if file already exist
If Len(Dir(xFolder)) > 0 Then
xYesorNo = MsgBox(xFolder & " already exists." & vbCrLf & vbCrLf & "Do you want to overwrite it?", _
vbYesNo + vbQuestion, "File Exists")
On Error Resume Next
If xYesorNo = vbYes Then
Kill xFolder
Else
MsgBox "if you don't overwrite the existing PDF, I can't continue." _
& vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Exiting Macro"
Exit Sub
End If
If Err.number <> 0 Then
MsgBox "Unable to delete existing file. Please make sure the file is not open or write protected." _
& vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Unable to Delete File"
Exit Sub
End If
End If

Set xUsedRng = xSht
If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then
'Save as PDF file
xSht.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xFolder, Quality:=xlQualityStandard

Step 2

Sub Recon()

'Ranges in this part
Set xSht = Worksheets("x").Range("x")
Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)

If xFileDlg.Show = True Then
xFolder = xFileDlg.SelectedItems(1)

Else
MsgBox "You must specify a folder to save the PDF into." & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Must Specify Destination Folder"
Exit Sub
End If
xFolder = xFolder + "\" + Xrecon + ".pdf"

'Check if file already exist
If Len(Dir(xFolder)) > 0 Then
xYesorNo = MsgBox(xFolder & " already exists." & vbCrLf & vbCrLf & "Do you want to overwrite it?", _
vbYesNo + vbQuestion, "File Exists")
On Error Resume Next
If xYesorNo = vbYes Then
Kill xFolder
Else
MsgBox "if you don't overwrite the existing PDF, I can't continue." _
& vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Exiting Macro"
Exit Sub
End If
If Err.number <> 0 Then
MsgBox "Unable to delete existing file. Please make sure the file is not open or write protected." _
& vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Unable to Delete File"
Exit Sub
End If
End If

Set xUsedRng = xSht
If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then
'Save as PDF file
xSht.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xFolder, Quality:=xlQualityStandard
'


End If
End Sub

Step 3

Sub x()



Range("x").Select
Selection.AutoFill Destination:=Range("x"), Type:=xlFillDefault
Range("x").Select
Dim sheetArr() As String, i As Long, c As Range
For Each c In Range("x")
If c = True Then
ReDim Preserve sheetArr(0 To i)
sheetArr(i) = c.Offset(, -1).Value
i = i + 1
End If
Range("x").Select

Next

Sheets(sheetArr).Select

Range("x").Select

'Part 2

ActiveWindow.SelectedSheets.Copy
ActiveWorkbook.Sheets.Select

'selects all sheets in sheet

Dim myArray() As Variant
Dim i As Integer
Dim j As Integer
j = 0
For i = 1 To Sheets.Count
If Sheets(i).Visible = True Then
ReDim Preserve myArray(j)
myArray(j) = i
j = j + 1
End If
Next i
Sheets(myArray).Select

Links = ActiveWorkbook.LinkSources(Type:=xlLinkTypeExcelLinks)
For i = 1 To UBound(Links)
ActiveWorkbook.BreakLink _
Name:=Links(i), _
Type:=xlLinkTypeExcelLinks
Next i

Columns("x").Select
Selection.Delete

Dim ws As Worksheet

For Each ws In Worksheets
If ws.Name <> "x" Then
ws.Range("x").EntireColumn.Hidden = True
Columns("x").Select
Selection.ClearContents
Selection.ClearFormats

Range("d8").Select
End If
Next ws

Sheets(1).Select
Range("d8").Select


End Sub



Step 4

Private Function Local_Workbook_Name(ByRef wb As Workbook) As String

Dim Ctr As Long
Dim objShell As Object
Dim UserProfilePath As String

'Check if it looks like a OneDrive location
If InStr(1, wb.FullName, "https://", vbTextCompare) > 0 Then

'Replace forward slashes with back slashes
Local_Workbook_Name = Replace(wb.FullName, "/", "\")

'Get environment path using vbscript
Set objShell = CreateObject("WScript.Shell")
UserProfilePath = objShell.ExpandEnvironmentStrings("%UserProfile%")

'Trim OneDrive designators
For Ctr = 1 To 4
Local_Workbook_Name = Mid(Local_Workbook_Name, InStr(Local_Workbook_Name, "\") + 1)
Next

'Construct the name
Local_Workbook_Name = UserProfilePath & "\OneDrive\" & Local_Workbook_Name

Else

Local_Workbook_Name = wb.FullName

End If

End Function

Private Sub testy()

MsgBox ActiveWorkbook.FullName & vbCrLf & Local_Workbook_Name(ActiveWorkbook)

Sub x()

If Range("-") = "x" Then
ErrMsg:
Range("x").Select
MsgBox ("x"), , "x"

Else


Dim OutlookApp As Object
Dim OutlookMail As Object
Set OutlookApp = CreateObject("Outlook.Application")
Set OutlookMail = OutlookApp.CreateItem(0)


'Ranges in this part


With OutlookMail
.Display
End With
signature = OutlookMail.Body
With OutlookMail
.To = ""
.Subject =
.Display
.Body =
.Display
End With

Set OutlookMail = Nothing
Set OutlookApp = Nothing
End If
End Sub







End If
End Sub

 

[John_w]

Hard to follow your code without VBA tags to preserve the indentation.

One simple way is to save the full file names of the 3 steps in 3 unused worksheet cells (adjust the sheet name and cells to suit):

    'Insert in Step 1
    Worksheets("Sheet1").Range("A1").Value = xFolder
    
    'Insert in Step 2
    Worksheets("Sheet1").Range("A2").Value = xFolder

    'Insert in Step 3
    Worksheets("Sheet1").Range("A3").Value = newWorkbookFullName

For Step 3, I can't see any code which saves the new workbook, so I've assumed its full file name is assigned to the String variable newWorkbookFullName.

Then in Step 4, prompt for the number(s) of the step(s) whose files you want to attach:

    'Insert in Step 4
    
    Dim files As String
    
    files = InputBox("Enter the step number(s) of the file(s) you wish to attach to the email.", "Choose Files", "1,2,3")
    If files <> "" Then
        With OutlookMail
            If InStr(files, "1") Then .Attachments.Add Worksheets("Sheet1").Range("A1").Value
            If InStr(files, "2") Then .Attachments.Add Worksheets("Sheet1").Range("A2").Value
            If InStr(files, "3") Then .Attachments.Add Worksheets("Sheet1").Range("A3").Value
        End With
    Else
        MsgBox "No file steps entered, therefore email not created."
    End If

Another approach, if all 3 files are saved in the same folder, is to use Application.FileDialog(msoFileDialogFilePicker) with AllowMultiSelect = True in Step 4 to allow you to browse and select the file(s).

 

[Hayf13]

Thanks John, I'll have a bit of a go and report back tomorrow!