1 Attachment(s)
Looping through textboxes to copy files and send emails.
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.
Code:
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
Attachment 31051
Any help you could provide would be amazing.
Many thanks in advance.
