PDA

View Full Version : VBA Help: Email attachment via folder or direct-link



harky
07-16-2019, 10:02 PM
Hi, I need someone help.
I dont know any vb code. Possible if someone could help me merge this code into 1 (highlighted in red)?

This is how the idea is.
Col H will use/check either Folder or Direct Full link

IF Folder path found, it will attach all files from the folder
IF direct-link found, it will attach the file
IF no link found, it will just send email as normal



A
B
C
D
E
F
G
H


S/N
TO
CC
Subject
Greeting
Body Text
Signature
Path of Attachment folder / Direct Link


1






C:\Users\ABC\Desktop\SavedFolder\Folder1\
*all attach all files found in folder


2






C:\Users\ABC\Desktop\SavedFolder\Folder2\abc.pdf
* or direct path - can be jpg, pdf, zip, doc*







Sub SendEmail3()
Dim i As Integer, Mail_Object, Email_Subject, o As Variant, lr As Long
Dim wks As Worksheet, wPath As String, wFile As Variant

'START of confirmation message box'
response = MsgBox("Start sending email?", vbYesNo)
If response = vbNo Then
MsgBox ("Macro Canceled!")
Exit Sub
End If
'END of confirmation message box'

lr = Cells(Rows.Count, "B").End(xlUp).Row
Set Mail_Object = CreateObject("Outlook.Application")
Set wks = Worksheets("SendEmail_MOD2") 'worksheet name
For i = 2 To lr
With Mail_Object.CreateItem(o)
.To = wks.Range("B" & i).Value
.CC = wks.Range("C" & i).Value
'.BCC = wks.Range("G" & I).Value 'G is refer to column G in excel
.Subject = wks.Range("D" & i).Value

.Body = wks.Range("E" & i).Value & vbNewLine & _
wks.Range("F" & i).Value & vbNewLine & _
wks.Range("G" & i).Value

If wks.Range("I" & i).Value <> "" Then
.Attachments.Add Range("I" & i).Value
End If

wPath = wks.Range("H" & i).Value
If Right(wPath, 1) <> "" Then wPath = wPath & ""
If Dir(wPath, vbDirectory) <> "" Then
wFile = Dir(wPath & "*.*")
Do While wFile <> ""
.Attachments.Add wPath & wFile
wFile = Dir()
Loop
End If

'Send
.display 'disable display and enable send to send automatically
Application.Wait (Now + TimeValue("0:00:03")) 'Pausing an application for 3s, before next email
End With
Next i
MsgBox "E-mail successfully sent", 64
Application.DisplayAlerts = False
Set Mail_Object = Nothing
End Sub

gmayor
07-17-2019, 01:12 AM
The following will do what you asked

Option Explicit

Sub SendEmail4()
'Graham Mayor - https://www.gmayor.com - Last updated - 17 Jul 2019
Dim i As Integer
Dim olApp As Object
Dim olMailItem As Object
Dim lngLastRow As Long
Dim wks As Worksheet
Dim strPath As String
Dim strFile As String
Dim lngResponse As Long
Dim oFSO As Object


'START of confirmation message box'
lngResponse = MsgBox("Start sending email?", vbYesNo)
If lngResponse = vbNo Then
MsgBox ("Macro Canceled!")
Exit Sub
End If
'END of confirmation message box'


Set oFSO = CreateObject("Scripting.FileSystemObject")


Set olApp = CreateObject("Outlook.Application")
Set wks = Worksheets("SendEmail_MOD2") 'worksheet name
lngLastRow = wks.Cells(wks.Rows.Count, "B").End(xlUp).Row
For i = 2 To lngLastRow
Set olMailItem = olApp.createitem(0)
With olMailItem
.To = wks.Range("B" & i).value
.CC = wks.Range("C" & i).value
'.BCC = wks.Range("G" & I).Value 'G is refer to column G in excel
.display 'disable display and enable send to send automatically


.Subject = wks.Range("D" & i).value


.Body = wks.Range("E" & i).value & vbNewLine & _
wks.Range("F" & i).value & vbNewLine & _
wks.Range("G" & i).value


If wks.Range("I" & i).value <> "" Then
.Attachments.Add Range("I" & i).value
End If


strPath = wks.Range("H" & i).value
If Right(strPath, 1) = Chr(92) Then 'value is a folder
If Dir(strPath, vbDirectory) <> "" Then
strFile = Dir(strPath & "*.*")
Do While strFile <> ""
.Attachments.Add strPath & strFile, , 1
strFile = Dir()
Loop
End If
Else
If oFSO.FileExists(strPath) Then
.Attachments.Add strPath, , 1
End If
End If


'.Send
Application.Wait (Now + TimeValue("0:00:03")) 'Pausing an application for 3s, before next email
End With
Next i
MsgBox "E-mail successfully sent", 64
Application.DisplayAlerts = False
Set olApp = Nothing
Set olMailItem = Nothing
Set oFSO = Nothing
Set wks = Nothing
End Sub

harky
07-17-2019, 09:06 AM
omg! It work great and i notice it actually check the attached files size too.

Ehhh can i had a request? : pray2:

I like to put status at Col I

This below is for .send (mode), as i got alot of email to send. So it better not to use .display as it will had many pop-up or abort

if email
exceed server size, it will ABORT SEND EMAIL than state (remark: exceed server size) at Col I and process the next email.
wrong file path, , it will ABORT SEND EMAIL than state (remark: wrong file path) at Col I and process the next email.
wrong folder path, , it will ABORT SEND EMAIL than state (remark: wrong folder path) at Col I and process the next email.
email send, than state (remark: email send!) at Col I and process the next email.

email send mean
- server size ok or
- files path ok or
- folder path ok or
- no link found at Col H


Remark at Col I
Offset(, 8).Value = "exceed server size" 'attached files exceed server size <-- can put colour in red?
Offset(, 8).Value = "wrong file path " 'Path file wrong <-- can put colour in red?
Offset(, 8).Value = "wrong folder path " 'Path folder wrong <-- can put colour in red?
Offset(, 8).Value = "email send!" 'successful send email


The following will do what you asked

Option Explicit

Sub SendEmail4()
'Graham Mayor - https://www.gmayor.com - Last updated - 17 Jul 2019
Dim i As Integer
Dim olApp As Object
Dim olMailItem As Object
Dim lngLastRow As Long
Dim wks As Worksheet
Dim strPath As String
Dim strFile As String
Dim lngResponse As Long
Dim oFSO As Object


'START of confirmation message box'
lngResponse = MsgBox("Start sending email?", vbYesNo)
If lngResponse = vbNo Then
MsgBox ("Macro Canceled!")
Exit Sub
End If
'END of confirmation message box'


Set oFSO = CreateObject("Scripting.FileSystemObject")


Set olApp = CreateObject("Outlook.Application")
Set wks = Worksheets("SendEmail_MOD2") 'worksheet name
lngLastRow = wks.Cells(wks.Rows.Count, "B").End(xlUp).Row
For i = 2 To lngLastRow
Set olMailItem = olApp.createitem(0)
With olMailItem
.To = wks.Range("B" & i).value
.CC = wks.Range("C" & i).value
'.BCC = wks.Range("G" & I).Value 'G is refer to column G in excel
.display 'disable display and enable send to send automatically


.Subject = wks.Range("D" & i).value


.Body = wks.Range("E" & i).value & vbNewLine & _
wks.Range("F" & i).value & vbNewLine & _
wks.Range("G" & i).value


If wks.Range("I" & i).value <> "" Then
.Attachments.Add Range("I" & i).value
End If


strPath = wks.Range("H" & i).value
If Right(strPath, 1) = Chr(92) Then 'value is a folder
If Dir(strPath, vbDirectory) <> "" Then
strFile = Dir(strPath & "*.*")
Do While strFile <> ""
.Attachments.Add strPath & strFile, , 1
strFile = Dir()
Loop
End If
Else
If oFSO.FileExists(strPath) Then
.Attachments.Add strPath, , 1
End If
End If


'.Send
Application.Wait (Now + TimeValue("0:00:03")) 'Pausing an application for 3s, before next email
End With
Next i
MsgBox "E-mail successfully sent", 64
Application.DisplayAlerts = False
Set olApp = Nothing
Set olMailItem = Nothing
Set oFSO = Nothing
Set wks = Nothing
End Sub

harky
07-19-2019, 12:10 PM
hi, my request had been solved. Thanks