Looping through textboxes to copy files and send emails.

[ecalid]

Good afternoon all,

I am wondering if you somebody could help me with a slight issue I have.

I have put together a 'database updater' and this has worked great, unfortunately it can only send a single file to a single folder.

I would like this to be able to cycle through approx 12 textboxes in a userform and then create a folder based on this information, and then send an email to email addressed found in more text boxes.

I will put up my existing code so you can see what I mean:

Ignore the sheet references as the information it will pull will be from userform textboxes instead.

Public Sub sbCopyFile2()
If Range("D5").Value = "Please click the folder icon to select a file to upload." Then
    MsgBox "Please select a file to upload by clicking the orange folder icon."
    Exit Sub
End If
If Range("D10").Value = "" Then
    MsgBox "Please enter a first name."
    Exit Sub
End If
If Range("D11").Value = "" Then
    MsgBox "Please enter a surname."
    Exit Sub
End If
If Range("D12").Value = "Please select department." Then
    MsgBox "Please select a department."
    Exit Sub
End If
If Range("D13").Value = "Please select a shift." Then
    MsgBox "Please select a department."
    Exit Sub
End If
If Range("D18").Value = "" Then
    MsgBox "Please enter an area"
    Exit Sub
End If
If Range("D19").Value = "" Then
    MsgBox "Please enter Document Type"
    Exit Sub
End If
Dim Cell As Range
With ActiveSheet
    For Each Cell In Application.Intersect(.UsedRange, .Range("D10:D11")).Cells
        Cell.Formula = UCase(Left(Cell.Text, 1)) & LCase(Mid(Cell.Text, 2))
    Next Cell
End With
Sheet5.Range("D10").Value = Trim(Sheet5.Range("D10"))
Sheet5.Range("D11").Value = Trim(Sheet5.Range("D11"))
Sheet5.Range("D19").Value = Trim(Sheet5.Range("D19"))
Sheet5.Range("D20").Value = Trim(Sheet5.Range("D20"))
Dim trg2 As String, src As String
Dim ok As Boolean
Dim OutApp As Object
trg2 = Sheet5.Range("D36") & ""
src = Sheet5.Range("filePath") & ""
If Len(src) <> 0 Then
    If Len(Dir$(src)) <> 0 Then
        ok = True
    End If
Else
    MsgBox "Please select a file to upload."
    Exit Sub
End If
If Not ok Then
    MsgBox "Source document does not exists."
    Exit Sub
End If
SpecialMkDir (trg2)
If Len(Dir$(trg2)) <> 0 Then
    MsgBox ("This document already exists. Please choose another name or date for the document.")
    Exit Sub
End If
VBA.FileCopy src, trg2
Dim OutMail As Object
Dim strbody As String
Dim MakeJPG As String
With Application
        .EnableEvents = False
        .ScreenUpdating = False
End With
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
eRecipient3 = ActiveSheet.Range("G39").Value
strbody = "This is an automated email."
MakeJPG = CopyRangeToJPG("Employee Record Updater", "A1:J27")
If MakeJPG = "" Then
      MsgBox "Something went wrong, the email couldn't be created"
      With Application
            .EnableEvents = True
            .ScreenUpdating = True
      End With
      Exit Sub
End If
On Error Resume Next
 With OutMail
      .To = "XXXXXXXXXXXXXX"
      .CC = ""
      .BCC = ""
      .Subject = "New Employee Record " & "(" & Range("D18") & ")"
      .Attachments.Add Range("D36").Value
      .Attachments.Add MakeJPG, 1, 1
      .HTMLBody = "<font color=red><b>This is an automated email.</b></font><br><br>A new document has been uploaded." _
      & "<br><br><br>" & "<b>Employee:</b> " & Range("D10").Value & " " & Range("D11").Value & "<br><br>" & " _
       <b>Department:</b> " & Range("D12").Value & "<br><br>" & "<b>Shift:</b> " & Range("D13").Value & " _
     <br><br>" & "<b>File:</b> " & Range("D23").Value & "<br><br><br>If you wish to upload a document to an _
     employee's file then please use the uploader:<br><a _
     href="XXXXXXXXXXXXXXXXXXXXX">XXXXXXXXXXXXXXXXXXXXXXXXXX</a><br><br><br>Many thanks,"
     .Send
End With
With Application
      .EnableEvents = True
      .ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
MsgBox "Thank you. The document has been submitted to H&S. You will recieve a confirmation email shortly."
Resume Next
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
      .To = XXXXXXXXXXXXXXXXXX
      .CC = ""
      .BCC = ""
      .Subject = "New Employee Record " & "(" & Range("D18") & ")"
      .Attachments.Add Range("D36").Value
      .HTMLBody = "<font color=red><b>This is an automated email.</b></font><br><br>A new document has been uploaded." _
      & "<br><br><br>" & "<b>Employee:</b> " & Range("D10").Value & " " & Range("D11").Value & "<br><br>" & " _
      <b>Department:</b> " & Range("D12").Value & "<br><br>" & "<b>Shift:</b> " & Range("D13").Value & " _
     <br><br>" & "<b>File:</b> " & Range("D23").Value & "<br><br><br>If you wish to upload a document to an _
     employee's file then please use the uploader:<br><a href=""XXXXXXXXXXXX"">XXXXXXXXXXXXXXXXXXXXX</a> _
    <br><br><br>Many thanks,"
     .Send
End With
With Application
      .EnableEvents = True
      .ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
Resume Next
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
      .To = ActiveSheet.Range("D14").Value
      .Subject = "New record in your H&S file"
      .Attachments.Add Range("D36").Value
      .HTMLBody = "<font color=red><b>This is an automated email and your email address was not saved.</b></font><br> _
     <br>Hello, " & Range("D10").Value & "<br><br>" & "A new document has been uploaded to your H&S file. Please see _
     attached." & "<br><br><br>" & "<b>Employee:</b> " & Range("D10").Value & " " & Range("D11").Value & " _
     <br><br>" & "<b>Department:</b> " & Range("D12").Value & "<br><br>" & "<b>Shift:</b> " & Range("D13").Value & " _
     <br><br>" & "<b>File:</b> " & Range("D23").Value & "<br><br><br>Many thanks,"
     .DeleteAfterSubmit = True
     .Send
End With
On Error GoTo 0
Kill MakeJPG
With Application
      .EnableEvents = True
      .ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
If Range("D14").Value > 0 Then
    MsgBox "A copy was sent to the employee's email provided."
Else
End If
Range("D5").Value = "Please click the folder icon to select a file to upload."
Exit Sub
End Sub


Function CopyRangeToJPG(NameWorksheet3 As String, RangeAddress As String) As String
Dim PictureRange As Range
With ActiveWorkbook
     On Error Resume Next
     .Worksheets(NameWorksheet3).Activate
     Set PictureRange = .Worksheets(NameWorksheet3).Range(RangeAddress)
     If PictureRange Is Nothing Then
          MsgBox "Sorry this is not a correct range"
          On Error GoTo 0
         Exit Function
    End If
    PictureRange.CopyPicture
    With .Worksheets(NameWorksheet3).ChartObjects.Add(PictureRange.Left, PictureRange.Top, PictureRange.Width, _
    PictureRange.Height)
          .Activate
          .Chart.Paste
          .Chart.Export Environ$("temp") & Application.PathSeparator & "newempdoc.jpg", "JPG"
    End With
    .Worksheets(NameWorksheet3).ChartObjects(.Worksheets(NameWorksheet3).ChartObjects.Count).Delete
End With
CopyRangeToJPG = Environ$("temp") & Application.PathSeparator & "newempdoc.jpg"
Set PictureRange = Nothing
End Function


Private Sub SpecialMkDir(ByVal path As String)
Dim var As Variant, p As String
Dim i As Integer
var = Split(path, "")
On Error Resume Next
For i = 0 To UBound(var) - 1
    p = p & var(i)
    VBA.MkDir p
    p = p & ""
Next
End Sub

Screenshot 2023-09-18 144659.jpg

Any help you could provide would be amazing.

Many thanks in advance.