Copy from clipboard to array in VB - excel

I'm trying to use the split funtion here. I'm trying to get content from the clipboard then store it into an array then populate the subject line with whatever I get from the array. But i always get a type mismatch error. I will appreciate some help. Here's my code
Dim DataObj As MsForms.DataObject
Set DataObj = New MsForms.DataObject
Dim varArray() As Variant
Dim myString As String
'Get data from the clipboard.
DataObj.GetFromClipboard
'Get clipboard contents
myString = DataObj.GetText
varArray() = Split(myString, Chr(10))
With OutMail
.BodyFormat = 3
.To = ""
.CC = ""
.BCC = ""
.subject = varArray(0) & " - " & varArray(2) & " - " & varArray(4)
Set olInsp = .GetInspector
Set wdDoc = olInsp.WordEditor
Set oRng = wdDoc.Range
oRng.collapse 1
oRng.Paste
.Display
End With
On Error GoTo 0

change
Dim varArray() As Variant to Dim varArray () as String
also, varArray = Split(myString, Chr(10)) is fine.

Related

Attach files in batches of 7, change Subject & Body accordingly

The below code attaches one file per email. I need to attach seven files from the folder.
I have approximately 150 files.
I need to
In the first email attach the first 7 files and then loop to attach 7 files to each subsequent email then in the last email attach the remaining three PDF files.
Subject for the first email: Invoice 001 to Invoice 007
Body for First Email:
Please find attached the following invoices
Invoice 001 to Invoice 007 (7 invoices)
...
Subject for the last email: Invoice 148 to Invoice 150
Body for last Email:
Please find attached the following invoices
Invoice 148 to Invoice 150 (3 invoices)
Sub sendmailsss()
Dim path As String
Dim counter As Integer
counter = ThisWorkbook.Worksheets("Sheet").Range("I4")
path = ThisWorkbook.Worksheets("Sheet").Range("M2")
If ThisWorkbook.Worksheets("Sheet").Range("M2") = "" Then
MsgBox "No folder selected. Please Select a folder with Invoives."
Exit Sub
End If
fpath = path & "\*.pdf"
fname = Dir(path)
Dim OutApp As Outlook.Application
Dim Source As String
Dim subj() As String
Do While fname <> ""
subj = Split(fname, ".")
Set OutApp = CreateObject("Outlook.Application")
On Error GoTo 0
Dim OutMail As Outlook.MailItem
Dim OutAccount As Outlook.Account
Set OutAccount = OutApp.Session.Accounts.Item(2)
Set OutMail = OutApp.CreateItem(olMailItem)
Source = path & fname
With OutMail
.To = "info#abc.co.uk"
.Subject = "Company Ltd " & subj(0)
.HTMLBody = "Invoice attached"
.Attachments.Add Source
.SendUsingAccount = OutAccount
'.Display
.Send
End With
If Err Then
MsgBox "Error while sending Email" & vbLf & "Press OK to check it in the Outlook", vbExclamation
'.Display
Else
ms = ms + 1
End If
On Error GoTo 0
Application.Wait Now + #12:00:10 AM#
fname = Dir()
'If ms = 3 Then
' Exit Do
'End If
Loop
MsgBox "Process Completed. " & ms & " emails sent."
End Sub
Here is the re-built code:
Sub SendMailSSS()
Dim path As String
'Dim counter As Integer
Dim outApp As Outlook.Application
Dim outMail As Outlook.MailItem
Dim outAccount As Outlook.Account
Dim source As String
'Dim subj() As String
Dim fPath As String
Dim fName As String
Dim fileList As Variant
Dim innerLoop As Integer
Dim fileCounter As Integer
'counter = ThisWorkbook.Worksheets("Sheet").Range("I4")
path = ThisWorkbook.Worksheets("Sheet1").Range("M2")
If path <> "" Then
fileList = FncGetFilesFromPath(path)
fileCounter = 0
Do While fileCounter < UBound(fileList)
Set outApp = CreateObject("Outlook.Application")
Set outAccount = outApp.Session.Accounts.Item(2)
Set outMail = outApp.CreateItem(olMailItem)
With outMail
.To = "info#abc.co.uk"
.Subject = "Company Ltd " & "Whatever 'subj' array was supposed to be doing in your code"
.HTMLBody = "Invoice attached"
.SendUsingAccount = outAccount
'Gets next up to 7 files
For innerLoop = fileCounter To (fileCounter + 7)
If innerLoop <= UBound(fileList) Then
.Attachments.Add fileList(innerLoop)
Else
Exit For
End If
Next innerLoop
End With
outMail.Send
fileCounter = fileCounter + innerLoop
Loop
Else
MsgBox "No folder selected. Please Select a folder with Invoices."
End If
Set outApp = Nothing
Set outMail = Nothing
Set outAccount = Nothing
End Sub
Private Function FncGetFilesFromPath(fPath As String) As Variant
Dim result As Variant
Dim fName As String
Dim i As Integer
ReDim result(0)
i = 0
fName = Dir(fPath)
Do While fName <> ""
ReDim Preserve result(i)
result(i) = fPath & fName
i = i + 1
fName = Dir()
Loop
FncGetFilesFromPath = result
End Function
You should be able to adapt this into your existing code. What you need to do I think is add all the references to the attachment files to an array first. This will allow you to loop over them according to your specific counting requirements of 7 per e-mail:
Sub SendMailSSS()
Dim path As String
'Dim counter As Integer
Dim outApp As Outlook.Application
Dim outMail As Outlook.MailItem
Dim outAccount As Outlook.Account
Dim source As String
'Dim subj() As String
Dim fPath As String
Dim fName As String
Dim fileList As Variant
Dim innerLoop As Integer
Dim fileCounter As Integer
'counter = ThisWorkbook.Worksheets("Sheet").Range("I4")
path = ThisWorkbook.Worksheets("Sheet1").Range("M2")
If path <> "" Then
fileList = FncGetFilesFromPath(path & "\*.pdf")
fileCounter = 0
Do While fileCounter < UBound(fileList)
Set outApp = CreateObject("Outlook.Application")
Set outAccount = outApp.Session.Accounts.Item(2)
Set outMail = outApp.CreateItem(olMailItem)
With outMail
.To = "info#abc.co.uk"
.Subject = "Company Ltd " & "Whatever 'subj' array was supposed to be doing in your code"
.HTMLBody = "Invoice attached"
.SendUsingAccount = outAccount
'Gets next up to 7 files
For innerLoop = fileCounter To (fileCounter + 7)
If innerLoop <= UBound(fileList) Then
.Attachments.Add fileList(innerLoop)
Else
Exit For
End If
Next innerLoop
End With
outMail.Send
fileCounter = fileCounter + innerLoop
Loop
Else
MsgBox "No folder selected. Please Select a folder with Invoices."
End If
Set outApp = Nothing
Set outMail = Nothing
Set outAccount = Nothing
End Sub
Private Function FncGetFilesFromPath(fPath As String) As Variant
Dim result As Variant
Dim fName As String
Dim i As Integer
ReDim result(0)
i = 0
fName = Dir(fPath)
Do While fName <> ""
ReDim Preserve result(i)
result(i) = fPath & fName
i = i + 1
fName = Dir()
Loop
FncGetFilesFromPath = result
End Function
I'm not sure what "subj" or "counter" are supposed to be doing in your code so I have commented them out. I cannot 100% test this, because I don't have Outlook on this machine, but it should give you the idea of how the looping will work.

How to make a loop that will incrementally add lines to an email body if a certain condition is met?

So I'm really new to VBA (and by new I mean a couple of days in). I'm looking to make a loop that will incrementally add lines to an email body if a certain condition is met. I apologise in advance if it is horrible to read but it does seem to work so far! If anyone can tell me how I can add something to the loop so that it adds a new line to the email body every time the condition is met, I would appreciate it.
Here's what I have so far:
Sub SendEmailReminder()
Dim x As Integer
Dim Removal As String
Dim RemovalTitle As String
Removal = Removal
RemovalTitle = RemovalTitle
' Set numrows = number of rows of data.
numrows = Range("C2").End(xlDown).row - 1
' Select cell 2.
Range("C2").Select
' Establish "For" loop to loop "numrows" number of times.
For x = 1 To numrows
If ActiveCell = Date - 30 Then
Removal = ActiveCell.Offset(0, -2)
RemovalTitle = ActiveCell.Offset(0, -1)
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strbody = Removal & " - " & RemovalTitle & " needs to be removed from New Releases"
On Error Resume Next
With OutMail
.To = ""
.CC = ""
.BCC = ""
.Subject = ""
.Body = strbody
.Display 'or use .Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End If
' Selects cell down 1 row from active cell.
ActiveCell.Offset(1, 0).Select
Next
End Sub
You can do this:
Sub SendEmailReminder()
Dim x As Integer
Dim c As Range
Dim OutApp As Object
Dim strbody As String
Set c = Range("C2")
'loop while cell is not empty
Do While Len(c.Value) > 0
If c.Value = Date - 30 Then
'build the message
strbody = strbody & vbCrLf & c.Offset(0, -2) & " - " & _
c.Offset(0, -1) & " needs to be removed from New Releases"
End If
Set c = c.Offset(1, 0) 'next cell
Loop
Set OutApp = CreateObject("Outlook.Application")
On Error Resume Next
With OutApp.CreateItem(0)
.To = ""
.CC = ""
.BCC = ""
.Subject = ""
.Body = strbody
.Display 'or use .Send
End With
On Error GoTo 0
Set OutApp = Nothing
End Sub

How to call on two variables in Excel to Cc outlook email?

This macro uses an HTML file that holds the template to send mass emails.
I set up a function to call on a column of email addresses to fill the CC.
Needs have changed and I would like to not condense two columns into one to CC two people.
I tried making a second function to add the second variable to the CC.
I'd like .Cc = email#email.com; email#email.com
The macro pulls from pre-filled email address list which is why it has a range in the function.
Sub PreviewEmail(wsNew As Worksheet, looper As Range, month As Range, year As Range)
'Macro Purpose: To send an email through Outlook
Dim rng As Range
Dim ToEmailList As String
Dim CcEmailList As String
Dim CcEmailListT As String
Dim sSubject As String
Dim sName As String
Dim line As String
Dim oFSO
Dim oFs
Dim pathName As String
pathName = ActiveWorkbook.Path & "\template.htm"
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFs = oFSO.OpenTextFile(pathName)
ToEmailList = setToEmail
CcEmailList = setCcEmail
CcEmailListT = setCcEmailT
sSubject = "This is a test"
sName = setSendName
Set OutApp = GetObject(, "Outlook.Application")
If OutApp Is Nothing Then Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
Set rng = wsNew.Range("A1:F" & wsNew.UsedRange.Rows.Count)
With OutMail
stext = oFs.readall
For Each cell In looper
line = line & cell.Text & " " & cell.Offset(0, 1).Text & " <br />"
Next
stext = Replace(stext, "%variable%", line)
stext = Replace(stext, "monthmonthmonth", month.Text)
stext = Replace(stext, "yearyearyear", year.Text)
.SentOnBehalfOfName = "JPMC Workforce Screening"
.To = ToEmailList
.Cc = CcEmailList, CcEmailListT
.Subject = sSubject
.HTMLBody = stext
.Display
End With
End Sub
Replace
.Cc = CcEmailList, CcEmailListT
with
.Cc = CcEmailList & ";" & CcEmailListT

Add email attachment(s) from excel to outlook based on condition

I have a list of names, email, attachment name and I need to send email and attach these attachment, my macro worked if I specify number of attachment, but what I have is not a fix number of attachments for each name/email, sometimes it's one and sometimes more than 1. Can you check my macro and advise what should I change/add in order to make the attachment dynamic?
Sub CreateNewMessage()
Dim aOutlook As Object
Dim aEmail As Object
Dim obj As Object
Dim olInsp As Object
Dim myDoc As Object
Dim oRng As Object
Set aOutlook = CreateObject("Outlook.Application")
Set aEmail = aOutlook.CreateItem(0)
Dim ToCc As Range, strBody, strSig As String
Dim fColorBlue, fColorGreen, fColorRed, fDukeBlue1, fDukeBlue2, fAggieMaroon, fAggieGray As String
Dim Greeting, emailContent As String
Dim emailOpen, emailMid1, emailMid2, emailMid3, emailClose, emailCustom, emailSig As String
Dim AttachmentPath, AttachmentNm As String
AttachmentPath = [O1] & "\"
fColorBlue = "#003846"
fColorGreen = "#5e9732"
fColorRed = "#FF0000"
fDukeBlue1 = "#001A57"
fDukeBlue2 = "#00009C"
fAggieMaroon = "#500000"
fAggieGray = "#332C2C"
For Each ToCc In ActiveSheet.[A2:A100] 'This is the range for how many records (rows) you want to send email
'=============================================================
Dim ToEmail, CcEmail, ToNm, CcNm, CcLNm As String
Dim DescrDt, LocID, LsmID, DescrNm As String
Dim Attach1, Attach2, Attach3 As String
ToNm = Cells(ToCc.Row, [To___fName].Column).Value
CcNm = Cells(ToCc.Row, [Cc___fName].Column).Value
CcLNm = Cells(ToCc.Row, [Cc___LName].Column).Value
ToEmail = Cells(ToCc.Row, [To___Email].Column).Value
CcEmail = Cells(ToCc.Row, [Cc___Email].Column).Value
Attach1 = Cells(ToCc.Row, [Attachment1].Column).Value
Attach2 = Cells(ToCc.Row, [Attachment2].Column).Value
Attach3 = Cells(ToCc.Row, [Attachment3].Column).Value
AttachmentNm1 = Attach1
AttachmentNm2 = Attach2
AttachmentNm3 = Attach3
Dim FileAttach1 As String
Dim FileAttach2 As String
Dim FileAttach3 As String
FileAttach1 = AttachmentPath & AttachmentNm1
FileAttach2 = AttachmentPath & AttachmentNm2
FileAttach3 = AttachmentPath & AttachmentNm3
'MsgBox FileAttach1
'MsgBox FileAttach2
'MsgBox FileAttach3
'Exit Sub
'=============================================================
Set aEmail = aOutlook.CreateItem(0)
With aEmail
'.SentOnBehalfOfName = "name#company.com"
.SentOnBehalfOfName = "name2#company.com"
.To = ToEmail
.cc = CcEmail '& "; " & SupvEmail & "; " & HREmail
.Subject = "LSM Monthly Dashboard " & Application.WorksheetFunction.Proper(ToNm) & Chr(32) & Application.WorksheetFunction.Proper(DescrNm)
'.BodyFormat = olFormatPlain ' send plain text message
'.BodyFormat = olFormatHTML
'.Importance = olImportanceHigh
'.Sensitivity = olConfidential
.HTMLBody = emailContent
'MsgBox FileAttach1
.Attachments.Add FileAttach1
.Attachments.Add FileAttach2
.Attachments.Add FileAttach3
.display
' .send
End With
NEXT_ToCC:
Set aEmail = Nothing
Set olInsp = Nothing
Set myDoc = Nothing
Set oRng = Nothing
Next ToCc
End Sub
You should use array to do this.
Add files paths to an array.
Dim files()
Files = array(path1, path2)
And after ‚htmlbody’ write:
For i = lbound(files) to ubound(files)
.attachments.add files(i)
Next i

Sending Email Based on Cell Value within a Loop

I have a sample sheet
I have a module that runs through the list in a loop within another loop, checking for duplicate names and then grouping the names together to send an email with an attachment based on Column D (Division).
Sample 4 would get one email with 3 attachments.
I have been asked to build in the ability to exclude people based on a value (I chose yes or no, column C) before running the module.
Reason being that if the list is long (over 1000 names) to set it before generating the emails. I would build in a trigger to set that value, but it is apparently an arbitrary decision made by the senders in a dept.
I have tried to build an IF statement into the loop as shown below but it is as if the If statement is coming out as not being true (I stepped through).
Which means all the With Outmail objects will not work.
I was able to get it to work by using the if statement with a for/next setup on its own (no loops), but cannot get it to work with the loop, which is the more important piece.
Here is the main piece of code. The main loop and then the if statement to account for the yes or no values:
Do While r <= rng.Rows.Count
If rng.Cells(r, 3).Value Like "?*#?*.?*" And LCase(rng.Cells(r, 3)) = "yes" Then
Set OutMail = OutApp.CreateItem(0)
End If
And here is the full sub:
Sub EmailDivisions()
Dim OutApp As Object
Dim OutMail As Object
Dim cell, lookrng As Range
Dim strDir As String
Dim strFilename As String
Dim sigString As String
Dim strBody As String
Dim strName As Variant
Dim strName1 As Variant
Dim strDept As Variant
Dim strName2 As String
Dim strName3 As Variant
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
sigString = Environ("appdata") & _
"\Microsoft\Signatures\Divisions.htm"
If Dir(sigString) <> "" Then
signature = GetBoiler(sigString)
Else
signature = ""
End If
Set rng = ActiveSheet.UsedRange
r = 2
Do While r <= rng.Rows.Count
If rng.Cells(r, 3).Value Like "?*#?*.?*" And LCase(rng.Cells(r, 3)) = "yes" Then
Set OutMail = OutApp.CreateItem(0)
End If
Set strName = rng.Cells(r, 1)
Set strDept = rng.Cells(r, 4)
strName2 = Left(strName, InStr(strName & " ", " ") - 1)
With OutMail
strFilename = Dir("\\Divisons\1a*" & strDept & "*")
.SentOnBehalfOfName = "divisionalsend#xyz.org"
.To = rng.Cells(r, 2).Value
.Subject = "Monthly Divisional Report for " & strDept
.HTMLBody = "<Font Face=calibri>" & "Dear " & strName2 & ",<br><br>" & signature
.Attachments.Add strDir & strFilename
'See if the next row is for the same sender. If so, process that
'row as well. And then keep doing it until no more rows match
Do While rng.Cells(r, 2).Value = rng.Cells(r + 1, 2)
r = r + 1
Set strDept = rng.Cells(r, 4)
strfilename1 = Dir("\\Divisions\1a*" & strDept & "*")
.Subject = "Monthly Divisional Report for Your Departments"
.Attachments.Add strDir & strfilename1
Loop
.Display
End With
Set OutMail = Nothing
r = r + 1
Loop
Set OutApp = Nothing
End Sub
Function GetBoiler(ByVal sFile As String) As String
Dim FSO As Object
Dim ts As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
Set ts = FSO.GetFile(sFile).OpenAsTextStream(1, -2)
GetBoiler = ts.ReadAll
ts.Close
End Function
Figured it out, here is the final sub:
Sub EmailDivisions()
Dim OutApp As Object
Dim OutMail As Object
Dim cell, lookrng As Range
Dim strDir As String
Dim strFilename As String
Dim sigString As String
Dim strBody As String
Dim strName As Variant
Dim strName1 As Variant
Dim strDept As Variant
Dim strName2 As String
Dim strName3 As Variant
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
sigString = Environ("appdata") & _
"\Microsoft\Signatures\Divisions.htm"
If Dir(sigString) <> "" Then
signature = GetBoiler(sigString)
Else
signature = ""
End If
Set rng = ActiveSheet.UsedRange
r = 2
Do While r <= rng.Rows.Count
Debug.Print LCase(rng.Cells(r, 2))
If Cells(r, 2).Value Like "?*#?*.?*" And LCase(Cells(r, 3)) = "yes" Then
Set OutMail = OutApp.CreateItem(0)
ElseIf Cells(r, 2).Value Like "?*#?*.?*" And LCase(Cells(r, 3)) = "no" Then GoTo ContinueLoop
End If
Set strName = Cells(r, 1)
Set strDept = Cells(r, 4)
strName2 = Left(strName, InStr(strName & " ", " ") - 1)
With OutMail
strFilename = Dir("\\Divisons\1a*" & strDept & "*")
.SentOnBehalfOfName = "divisionalsend#xyz.org"
.To = Cells(r, 2).Value
.Subject = "Monthly Divisional Report for " & strDept
.HTMLBody = "<Font Face=calibri>" & "Dear " & strName2 & ",<br><br>" & signature
.Attachments.Add strDir & strFilename
.display
'See if the next row is for the same sender. If so, process that
'row as well. And then keep doing it until no more rows match
Do While rng.Cells(r, 2).Value = rng.Cells(r + 1, 2)
r = r + 1
Set strDept = Cells(r, 4)
strfilename1 = Dir("\\Divisions\1a*" & strDept & "*")
.Subject = "Monthly Divisional Report for Your Departments"
.Attachments.Add strDir & strfilename1
.Display
ContinueLoop:
Loop
End With
Set OutMail = Nothing
r = r + 1
Loop
Set OutApp = Nothing
End Sub
Function GetBoiler(ByVal sFile As String) As String
Dim FSO As Object
Dim ts As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
Set ts = FSO.GetFile(sFile).OpenAsTextStream(1, -2)
GetBoiler = ts.ReadAll
ts.Close
End Function

Resources