Code for forwarding emails is slow - excel

I send email to a big list of contacts. I don't want to lose the format of the original email.
I am using this code:
Dim emailad, firstname, pretit, midtit, prebod, bod, postbod As String
Dim n As Integer
n = 1
pretit = Sheets(CurrSh).Range("pretit").Value
midtit = Sheets(CurrSh).Range("midtit").Value
prebod = Sheets(CurrSh).Range("prebod").Value
bod = Sheets(CurrSh).Range("bod").Value
postbod = Sheets(CurrSh).Range("postbod").Value
Dim objMail(1 To 500) As Object
Set objitem = GetCurrentItem()
'********** Send e-mail for each e-mail in the list ***********
Set objMail(n) = CreateObject("Outlook.Application")
While (Sheets(CurrSh).Range("emailad_ini").Offset(n, 0).Value <> "")
emailad = Sheets(CurrSh).Range("emailad_ini").Offset(n, 0).Value
firstname = Sheets(CurrSh).Range("firstname_ini").Offset(n, 0).Value
Set objMail(n) = objitem.Forward
objMail(n).To = emailad
objMail(n).Subject = pretit & " " & firstname & midtit & " FWD: " & objitem.Subject
objMail(n).HtmlBody = "<HTML><BODY><FONT FACE='Arial'><FONT SIZE='2'>" & prebod & " " & firstname & "," & "<br>" & bod & "<br>" & postbod & objMail(n).HtmlBody & "</FONT></FONT></BODY></HTML>"
objMail(n).Display
Set objMail(n) = Nothing
n = n + 1
Wend
Theend:
End Sub
The problem is this code is so slow.

The strongest suspect for poor performance in this loop is the creation of a new Outlook.Application object for each iteration of the loop. This shouldn't be necessary. Move the Set ObjApp = CreateObject("Outlook.Application") call to just before the WHILE loop and simply re-use the same reference therein.
Revised for OP based on further comment:
I am going to simplify this code to match what I think you're trying to accomplish. I see no need for the large array of mail objects, as you set them to Nothing after they're Displayed. It seems all you want to do is take the current item and send it to each member of your list, customized with their own name as the subject. In that vein, I'd try this:
Dim emailad, firstname, pretit, midtit, prebod, bod, postbod As String
Dim mailApp
Dim newItem
Dim n As Integer
n = 1
pretit = Sheets(CurrSh).Range("pretit").Value
midtit = Sheets(CurrSh).Range("midtit").Value
prebod = Sheets(CurrSh).Range("prebod").Value
bod = Sheets(CurrSh).Range("bod").Value
postbod = Sheets(CurrSh).Range("postbod").Value
Set objitem = GetCurrentItem()
Set mailApp = CreateObject("Outlook.Application")
'********** Send e-mail for each e-mail in the list ***********
While (Sheets(CurrSh).Range("emailad_ini").Offset(n, 0).Value <> "")
emailad = Sheets(CurrSh).Range("emailad_ini").Offset(n, 0).Value
firstname = Sheets(CurrSh).Range("firstname_ini").Offset(n, 0).Value
Set newItem = mailApp.CreateItem(0) ' Create a new Mailitem; olMailItem = 0
newItem.To = emailad
newItem.Subject = pretit & " " & firstname & midtit & " FWD: " & objitem.Subject
newItem.HtmlBody = "<HTML><BODY><FONT FACE='Arial'><FONT SIZE='2'>" & prebod & " " & firstname & "," & "<br>" & bod & "<br>" & postbod & objItem.HtmlBody & "</FONT></FONT></BODY></HTML>"
newItem.Send
n = n + 1
Wend
Beyond this, what portion (specifically) is slow? Sending 60 copies of this message shouldn't take that long. Are you sure your loop is terminating when you expect (with only 60 names), or is the data in your sheet possibly preventing your termination from occurring when you expect, causing it to run indefinitely?

Related

"Cannot Parse Condition" Error when utilizing the Items.Find method with VBA

I'm trying to search for emails I previously sent and reply to those emails.
I utilized the Items.Find method in the Outlook class to search for the subject line of those emails in my sent folder. The Items.Find method is not parsing the string.
I have an Excel sheet with Company Name, First Name, Last Name, Company email that I pull data from into defined variables and iterate through the list to search for the sent emails. I have another Excel sheet that contains the contents of the reply email I am writing.
'Define Variables
Sub SendReplyEmails()
Dim ol As Outlook.Application
Dim outm As Outlook.MailItem
Dim ns As Outlook.Namespace
Dim fol As Outlook.Folder
Dim i As Long
Dim j As Object
Dim FilterText As String
Dim subjectLine As String
Dim searchString As String
Dim wsCont As Worksheet
Dim wsDash As Worksheet
Dim strHTML As String
Dim sig As String
Dim attachDoc As String
'Set Values
Set wsCont = ActiveWorkbook.Sheets("Contacts")
Set wsDash = ActiveWorkbook.Sheets("Dashboard")
vaData = wsCont.Range("Contact_Data").Value
groupNum = wsDash.Range("C5").Value
ccLine = wsDash.Range("C18").Value
attachNum = wsDash.Range("C22").Value
introLine1 = wsDash.Range("C29").Value
introLine2 = wsDash.Range("C30").Value
endingLine = wsDash.Range("C36").Value
signOff = wsDash.Range("C41").Value
nameLine = wsDash.Range("C42").Value
subjectLine = wsDash.Range("C14").Value
'For loop to run through each contact in list
For i = 1 To groupNum
Set ol = New Outlook.Application
Set ns = ol.GetNamespace("MAPI")
Set fol = ns.GetDefaultFolder(olFolderSentMail)
searchString = subjectLine & vaData(i, 1)
Debug.Print "searchString = " & searchString
FilterText = "#SQL=""http://schemas.microsoft.com/mapi/proptag/0x0037001f"" = searchString'"
Set j = fol.Items.Find(FilterText)
If j Is Nothing Then
Debug.Print "J is nothing"
End If
If j.Class <> olMail Then
Debug.Print "J is not an email"
End If
If Not j Is Nothing And j.Class = olMail Then
Debug.Print "Executed"
Set replyEmail = j.ReplyAll
replyEmail.Display
sig = replyEmail.HTMLBody
replyEmail.To = vaData(i, 4)
replyEmail.CC = ccLine
replyEmail.BodyFormat = olFormatHTML
strHTML = "<html><body>" & "<section>" & "Hi " & vaData(i, 2) & ", " & "<br>" & "<br>" & introLine1 & _
"<br>" & "<br>" & introLine2 & "<br>" & "<br>" & "<ul>" & "</ul>" & endingLine & "<br>" & "<br>" & signOff & "<br>" & nameLine & sig
replyEmail.HTMLBody = strHTML
replyEmail.Send
End If
Next
End Sub
I messed around with the syntax of the Items.Find method according to Microsoft documentation but I have been unable to find one that works.
The search string is "Important: Event Title | Company Name, LLC".
First of all, you need to replace a string literal with a variable in the search criteria string:
searchString = subjectLine & vaData(i, 1)
Debug.Print "searchString = " & searchString
FilterText = "#SQL=""http://schemas.microsoft.com/mapi/proptag/0x0037001f"" = searchString'"
So, the filter string should look like that:
searchString = subjectLine & vaData(i, 1)
Debug.Print "searchString = " & searchString
FilterText = "#SQL=""http://schemas.microsoft.com/mapi/proptag/0x0037001f"" = '" & searchString & "'"
Second, searching Outlook items with the exact subject line is not really a good idea. The Subject string may contain prefixes like RE or FW and other artifacts etc. So, you need to search for a phrase match instead:
searchString = subjectLine & vaData(i, 1)
Debug.Print "searchString = " & searchString
FilterText = "#SQL=" & Chr(34) & "https://schemas.microsoft.com/mapi/proptag/0x0037001E" _
& Chr(34) & " ci_phrasematch '" & searchString & "'"
See Filtering Items Using a String Comparison for more information about that.
You may also find the following articles helpful:
How To: Use Find and FindNext methods to retrieve Outlook mail items from a folder (C#, VB.NET)
How To: Use Restrict method to retrieve Outlook mail items from a folder

How to create emails from Excel table?

I have a table in Excel. It is built as follows:
|Information on food|
|date: April 28th, 2021|
|Person|Email|Apples|Bananas|Bread|
|------|-----|------|-------|-----|
|Person_A|person_A#mailme.com|3|8|9|
|Person_B|person_B#mailme.com|10|59|11|
|Person _C|person_C#maime.com|98|12|20|
There is also a date field in the table. For a test, this could be set to todays date.
Based on this information, I am looking for a VBA code which prepares an email to each of the listed persons and is telling them what they have eaten on the specific date.
I need to access several fields in the table, and at the same time loop through the email addresses. Then I would like VBA to open Outlook and prepare the emails. Ideally not send them so I can take a final look before I send the mails.
It would be fine to access certain cells specifically via ranges etc. I am using Excel/Outlook 2016.
How can this be achieved in VBA?
Assuming the data is a named table and title/date are above the corner of the table as shown in your example. Also all the rows of the table have valid data. The emails are prepared and shown but not sent (unless you change the code where shown).
Option Explicit
Sub EmailMenu()
Const TBL_NAME = "Table1"
Const CSS = "body{font:12px Verdana};h1{font:14px Verdana Bold};"
Dim emails As Object, k
Set emails = CreateObject("Scripting.Dictionary")
Dim ws As Worksheet, rng As Range
Dim sName As String, sAddress As String
Dim r As Long, c As Integer, s As String, msg As String
Dim sTitle As String, sDate As String
Set ws = ThisWorkbook.Sheets("Sheet1")
Set rng = ws.ListObjects(TBL_NAME).Range
sTitle = rng.Cells(-1, 1)
sDate = rng.Cells(0, 1)
' prepare emails
For r = 2 To rng.Rows.Count
sName = rng.Cells(r, 1)
sAddress = rng.Cells(r, 2)
If InStr(sAddress, "#") = 0 Then
MsgBox "Invalid Email: '" & sAddress & "'", vbCritical, "Error Row " & r
Exit Sub
End If
s = "<style>" & CSS & "</style><h1>" & sDate & "<br>" & sName & "</h1>"
s = s & "<table border=""1"" cellspacing=""0"" cellpadding=""5"">" & _
"<tr bgcolor=""#ddddff""><th>Item</th><th>Qu.</th></tr>"
For c = 3 To rng.Columns.Count
s = s & "<tr><td>" & rng.Cells(1, c) & _
"</td><td>" & rng.Cells(r, c) & _
"</td></tr>" & vbCrLf
Next
s = s & "</table>"
' add to dictonary
emails.Add sAddress, Array(sName, sDate, s)
Next
' confirm
msg = "Do you want to send " & emails.Count & " emails ?"
If MsgBox(msg, vbYesNo) = vbNo Then Exit Sub
' send emails
Dim oApp As Object, oMail As Object, ar
Set oApp = CreateObject("Outlook.Application")
For Each k In emails.keys
ar = emails(k)
Set oMail = oApp.CreateItem(0)
With oMail
.To = CStr(k)
'.CC = "email#test.com"
.Subject = sTitle
.HTMLBody = ar(2)
.display ' or .send
End With
Next
oApp.Quit
End Sub

Advice to send emails to each student using VBA

I'm trying to send emails to each student contain the (student name and his marks ) using VBA ..
I have excel sheet as below
From above excel i need to send email to each student with email body text as below
Hi " Student name "
Below you can found your marks:-
Math :- " his mark"
Network :- "his mark"
Physics :- "his mark"
Antenna :- " his mark"
I already wort the code in VBA , but i don't know how send like this text to each student in the mailBody section ..
My code as below
Sub SendMail()
Dim objEmail
Const cdoSendUsingPort = 2 ' Send the message using SMTP
Const cdoBasicAuth = 1 ' Clear-text authentication
Const cdoTimeout = 100 ' Timeout for SMTP in seconds
mailServer = "smtp.gmail.com"
SMTPport = 465 '25 'SMTPport = 465
mailusername = Range("j9").Value
mailpassword = Range("j10").Value
''''''''
Dim n As Integer
n = Application.WorksheetFunction.CountA(Range("c:c")) - 1
For i = 1 To n
mailto = Range("c1").Offset(i, 0).Value
mailSubject = Range("e1").Offset(i, 0).Value
**mailBody = ??** What i should to set ?
Set objEmail = CreateObject("CDO.Message")
Set objConf = objEmail.Configuration
Set objFlds = objConf.Fields
With objFlds
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = cdoSendUsingPort
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = mailServer
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = SMTPport
.Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
.Item("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = cdoTimeout
.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = cdoBasicAuth
.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = mailusername
.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = mailpassword
.Update
End With
objEmail.To = mailto
objEmail.From = mailusername
objEmail.subject = mailSubject
objEmail.TextBody = mailBody
'objEmail.AddAttachment "C:\report.pdf"
objEmail.CC = Range("d1").Offset(i, 0).Value
objEmail.BCC = Range("k1").Offset(i, 0).Value
objEmail.Send
Set objFlds = Nothing
Set objConf = Nothing
Set objEmail = Nothing
Next i
End Sub
Kind Regards..
Try this approach, please:
mailBody = "Hy " & Range("B" & i) & "," & vbCrLf & vbCrLf & _
"Below you can find your marks:" & vbCrLf & vbCrLf & _
"Network: - " & Range("G" & i) & vbCrLf & _
"Physics: - " & Range("H" & i) & vbCrLf & _
"Antenna: - " & Range("I" & i)
And start the iteration from 2:
For i = 2 To n
Then no need to any Offset:
objEmail.CC = Range("d" & i).Value
objEmail.BCC = Range("k" & i).Value

Excel VBA Macro to copy a macro

SOLVED. Solution at bottom!
Hopefully you brainiacs can help me out as I've apparently reached the limit of my programming capabilities.
I am looking for a way to write a VBA sub which duplicates another VBA Sub, but replace the name and another input. The case in details:
I am trying to build an Excel template for the organization, which will allow the users to inport/export data to/from Access databases (.accdb), as the end-users reluctance towards using real databases (as opposed to excel lists) apparently lies in their inability to extract/submit the data to/from Excel, where they are comfortable working with the data.
The challenge is, that users who don't know how to link to Access, for sure don't know anything about VBA code. Hence, I have created a worksheet from which the users selects a database using a file-path, table, password, set filters, define where to copy/insert datasets, fields to import etc. A Macro then handles the rest.
However, I want to create a macro which allows the user to create additional database links. As it is right now, this would require the user to open VBE and copy two macros and change one line of code... but that is a recipe for disaster. So how can I add a button to the sheet that copies the code I have written and rename the macro?
... I was considering if using a function, but cannot get my head around how that should Work.
Does it make sense? Any ideas/ experiences? Is there a completely different way around it that I haven't considered?
I'd really appreciate your inputs - even if this turns out to be impossible.
Edit:
Macro Man, you asked for the code - it's rather long due to all the user input fields, so I was trying to save you Guys for it since the code in and of itself is working fine...
Sub GetData1()
' Click on Tools, References and select
' the Microsoft ActiveX Data Objects 2.0 Library
Dim DBFullName As String
Dim Connect As String, Source As String
Dim Connection As ADODB.Connection
Dim Recordset As ADODB.Recordset
Dim Col As Integer
Dim DBInfoLocation As Range
Dim PW As String
Dim WSforData As String
Dim CellforData As String
Dim FieldList As Integer
'******************************
'Enter location for Database conectivity details below:
'******************************
Set DBInfoLocation = ActiveWorkbook.Sheets("DBLinks").Range("C15:I21")
FieldList = ActiveWorkbook.Sheets("DBLinks").Range("P1").Value
'******************************
' Define data location
WSforData = DBInfoLocation.Rows(4).Columns(1).Value
CellforData = DBInfoLocation.Rows(5).Columns(1).Value
'Set filters
Dim FilField1, FilField2, FilFieldA, FilFieldB, FilFieldC, FilFieldD, FilFieldE, FilOperator1, FilOperator2, FilOperatorA, FilOperatorB, FilOperatorC, FilOperatorD, FilOperatorE, FilAdMth1, FilAdMthA, FilAdMthB, FilAdMthC, FilAdMthD As String
Dim Filtxt1, Filtxt2, FiltxtA, FiltxtB, FiltxtC, FiltxtD, FiltxtE As String
Dim ExtFld1, ExtFld2, ExtFld3, ExtFld4, ExtFld5, ExtFld6, ExtFld7, ExtFld As String
Dim FilCnt, FilCntA As Integer
Dim FilVar1 As String
'Set DB field names
FilField1 = DBInfoLocation.Rows(1).Columns(5).Value
FilField2 = DBInfoLocation.Rows(2).Columns(5).Value
FilFieldA = DBInfoLocation.Rows(3).Columns(5).Value
FilFieldB = DBInfoLocation.Rows(4).Columns(5).Value
FilFieldC = DBInfoLocation.Rows(5).Columns(5).Value
FilFieldD = DBInfoLocation.Rows(6).Columns(5).Value
FilFieldE = DBInfoLocation.Rows(7).Columns(5).Value
'Set filter operators
FilOperator1 = DBInfoLocation.Rows(1).Columns(6).Value
FilOperator2 = DBInfoLocation.Rows(2).Columns(6).Value
FilOperatorA = DBInfoLocation.Rows(3).Columns(6).Value
FilOperatorB = DBInfoLocation.Rows(4).Columns(6).Value
FilOperatorC = DBInfoLocation.Rows(5).Columns(6).Value
FilOperatorD = DBInfoLocation.Rows(6).Columns(6).Value
FilOperatorE = DBInfoLocation.Rows(7).Columns(6).Value
'Run through criteria to find VarType(FilCrit1) (the Dimension data type) for the criteria field and set the appropriate data type for the filter
currentLoad = IIf(IsNumeric(DBInfoLocation.Rows(1).Columns(7).Value), CDbl(FilCrit1), IIf((DBInfoLocation.Rows(1).Columns(7).Value = "True" Or DBInfoLocation.Rows(1).Columns(7).Value = "False"), CBool(FilCrit1), IIf(IsDate(DBInfoLocation.Rows(1).Columns(7).Value), CDate(FilCrit1), CStr(FilCrit1))))
currentLoad = IIf(IsNumeric(DBInfoLocation.Rows(2).Columns(7).Value), CDbl(FilCrit2), IIf((DBInfoLocation.Rows(2).Columns(7).Value = "True" Or DBInfoLocation.Rows(2).Columns(7).Value = "False"), CBool(FilCrit2), IIf(IsDate(DBInfoLocation.Rows(2).Columns(7).Value), CDate(FilCrit2), CStr(FilCrit2))))
currentLoad = IIf(IsNumeric(DBInfoLocation.Rows(3).Columns(7).Value), CDbl(FilCrit3), IIf((DBInfoLocation.Rows(3).Columns(7).Value = "True" Or DBInfoLocation.Rows(3).Columns(7).Value = "False"), CBool(FilCrit3), IIf(IsDate(DBInfoLocation.Rows(3).Columns(7).Value), CDate(FilCrit3), CStr(FilCrit3))))
currentLoad = IIf(IsNumeric(DBInfoLocation.Rows(4).Columns(7).Value), CDbl(FilCrit4), IIf((DBInfoLocation.Rows(4).Columns(7).Value = "True" Or DBInfoLocation.Rows(4).Columns(7).Value = "False"), CBool(FilCrit4), IIf(IsDate(DBInfoLocation.Rows(4).Columns(7).Value), CDate(FilCrit4), CStr(FilCrit4))))
currentLoad = IIf(IsNumeric(DBInfoLocation.Rows(5).Columns(7).Value), CDbl(FilCrit5), IIf((DBInfoLocation.Rows(5).Columns(7).Value = "True" Or DBInfoLocation.Rows(5).Columns(7).Value = "False"), CBool(FilCrit5), IIf(IsDate(DBInfoLocation.Rows(5).Columns(7).Value), CDate(FilCrit5), CStr(FilCrit5))))
currentLoad = IIf(IsNumeric(DBInfoLocation.Rows(6).Columns(7).Value), CDbl(FilCrit6), IIf((DBInfoLocation.Rows(6).Columns(7).Value = "True" Or DBInfoLocation.Rows(6).Columns(7).Value = "False"), CBool(FilCrit6), IIf(IsDate(DBInfoLocation.Rows(6).Columns(7).Value), CDate(FilCrit6), CStr(FilCrit6))))
currentLoad = IIf(IsNumeric(DBInfoLocation.Rows(7).Columns(7).Value), CDbl(FilCrit7), IIf((DBInfoLocation.Rows(7).Columns(7).Value = "True" Or DBInfoLocation.Rows(7).Columns(7).Value = "False"), CBool(FilCrit7), IIf(IsDate(DBInfoLocation.Rows(7).Columns(7).Value), CDate(FilCrit7), CStr(FilCrit7))))
'Set Filter criteria
FilCrit1 = DBInfoLocation.Rows(1).Columns(7).Value
FilCrit2 = DBInfoLocation.Rows(2).Columns(7).Value
FilCrit3 = DBInfoLocation.Rows(3).Columns(7).Value
FilCrit4 = DBInfoLocation.Rows(4).Columns(7).Value
FilCrit5 = DBInfoLocation.Rows(5).Columns(7).Value
FilCrit6 = DBInfoLocation.Rows(6).Columns(7).Value
FilCrit7 = DBInfoLocation.Rows(7).Columns(7).Value
'Set additional filter-method
FilAdMth1 = DBInfoLocation.Rows(1).Columns(8).Value
FilAdMthA = DBInfoLocation.Rows(3).Columns(8).Value
FilAdMthB = DBInfoLocation.Rows(4).Columns(8).Value
FilAdMthC = DBInfoLocation.Rows(5).Columns(8).Value
FilAdMthD = DBInfoLocation.Rows(6).Columns(8).Value
'Set which fields to extract
ExtFld1 = DBInfoLocation.Rows(1).Columns(9).Value
ExtFld2 = DBInfoLocation.Rows(2).Columns(9).Value
ExtFld3 = DBInfoLocation.Rows(3).Columns(9).Value
ExtFld4 = DBInfoLocation.Rows(4).Columns(9).Value
ExtFld5 = DBInfoLocation.Rows(5).Columns(9).Value
ExtFld6 = DBInfoLocation.Rows(6).Columns(9).Value
ExtFld7 = DBInfoLocation.Rows(7).Columns(9).Value
'Filter on query
'Only criteria of value type string should have single quotation marks around them
FilCnt = 0
If FilField1 <> "" Then
If VarType(FilCrit1) = vbString Then
Filtxt1 = " WHERE [" & FilField1 & "] " & FilOperator1 & " '" & FilCrit1 & "'"
Else
Filtxt1 = " WHERE [" & FilField1 & "] " & FilOperator1 & " " & FilCrit1
End If
FilCnt = 1
End If
If FilField2 <> "" And FilCnt = 1 Then
If VarType(FilCrit2) = vbString Then
Filtxt2 = " " & FilAdMth1 & " [" & FilField2 & "] " & FilOperator2 & " '" & FilCrit2 & "'"
Else
Filtxt2 = " " & FilAdMth1 & " [" & FilField2 & "] " & FilOperator2 & " " & FilCrit2
End If
FilCnt = 2
End If
'Filter on Dataset
FilCntA = 0
If FilFieldA <> "" Then
If VarType(FilCrit3) = vbString Then
FiltxtA = FilFieldA & " " & FilOperatorA & " '" & FilCrit3 & "'"
Else
FiltxtA = FilFieldA & " " & FilOperatorA & " " & FilCrit3
End If
FilCntA = 1
End If
If FilFieldB <> "" And FilCntA = 1 Then
If VarType(FilCrit4) = vbString Then
FiltxtB = " " & FilAdMthA & " " & FilFieldB & " " & FilOperatorB & " '" & FilCrit4 & "'"
Else
FiltxtB = " " & FilAdMthA & " " & FilFieldB & " " & FilOperatorB & " " & FilCrit4
End If
FilCntA = 2
End If
If FilFieldC <> "" And FilCntA = 2 Then
If VarType(FilCrit5) = vbString Then
FiltxtC = " " & FilAdMthB & " " & FilFieldC & " " & FilOperatorC & " '" & FilCrit5 & "'"
Else
FiltxtC = " " & FilAdMthB & " " & FilFieldC & " " & FilOperatorC & " " & FilCrit5
End If
FilCntA = 3
End If
If FilFieldD <> "" And FilCntA = 3 Then
If VarType(FilCrit6) = vbString Then
FiltxtD = " " & FilAdMthC & " " & FilFieldD & " " & FilOperatorD & " '" & FilCrit6 & "'"
Else
FiltxtD = " " & FilAdMthC & " " & FilFieldD & " " & FilOperatorD & " " & FilCrit6
End If
FilCntA = 4
End If
If FilFieldE <> "" And FilCntA = 4 Then
If VarType(FilCrit7) = vbString Then
FiltxtE = " " & FilAdMthD & " " & FilFieldE & " " & FilOperatorE & " '" & FilCrit7 & "'"
Else
FiltxtE = " " & FilAdMthD & " " & FilFieldE & " " & FilOperatorE & " " & FilCrit7
End If
FilCntA = 5
End If
' Select Fields to Extract
ExtFld = "*"
If ExtFld1 <> "" Then
ExtFld = "[" & ExtFld1 & "]"
End If
If ExtFld2 <> "" Then
ExtFld = "[" & ExtFld1 & "],[" & ExtFld2 & "]"
End If
If ExtFld3 <> "" Then
ExtFld = "[" & ExtFld1 & "],[" & ExtFld2 & "],[" & ExtFld3 & "]"
End If
If ExtFld4 <> "" Then
ExtFld = "[" & ExtFld1 & "],[" & ExtFld2 & "],[" & ExtFld3 & "],[" & ExtFld4 & "]"
End If
If ExtFld5 <> "" Then
ExtFld = "[" & ExtFld1 & "],[" & ExtFld2 & "],[" & ExtFld3 & "],[" & ExtFld4 & "],[" & ExtFld5 & "]"
End If
If ExtFld6 <> "" Then
ExtFld = "[" & ExtFld1 & "],[" & ExtFld2 & "],[" & ExtFld3 & "],[" & ExtFld4 & "],[" & ExtFld5 & "],[" & ExtFld6 & "]"
End If
If ExtFld7 <> "" Then
ExtFld = "[" & ExtFld1 & "],[" & ExtFld2 & "],[" & ExtFld3 & "],[" & ExtFld4 & "],[" & ExtFld5 & "],[" & ExtFld6 & "],[" & ExtFld7 & "]"
End If
' Database path info
PW = DBInfoLocation.Rows(3).Columns(1).Value
' Your path will be different
DBFullName = DBInfoLocation.Rows(1).Columns(1).Value
DBTable = DBInfoLocation.Rows(2).Columns(1).Value
' Open the connection
Set Connection = New ADODB.Connection
Connect = "Provider=Microsoft.ACE.OLEDB.12.0;"
Connect = Connect & "Data Source=" & DBFullName & ";Jet OLEDB:Database Password=" & PW & ";"
Connection.Open ConnectionString:=Connect
' Create RecordSet & Define data to extract
Set Recordset = New ADODB.Recordset
With Recordset
'Get All Field Names by opening the DB, extracting a recordset, entering the field names and closing the dataset
Source = DBTable
.Open Source:=Source, ActiveConnection:=Connection
For ColH = 0 To Recordset.Fields.Count - 1
ActiveWorkbook.Worksheets("DBLinks").Range("A1").Offset(ColH + 3, FieldList - 1).Cells.Clear
ActiveWorkbook.Worksheets("DBLinks").Range("A1").Offset(ColH + 3, FieldList - 1).Value = Recordset.Fields(ColH).Name
ActiveWorkbook.Worksheets("RangeNames").Range("A1").Offset(ColH + 2, (DBInfoLocation.Rows(1).Columns(2).Value) - 1).Cells.Clear
ActiveWorkbook.Worksheets("RangeNames").Range("A1").Offset(ColH + 2, (DBInfoLocation.Rows(1).Columns(2).Value) - 1).Value = Recordset.Fields(ColH).Name
Next
Set Recordset = Nothing
End With
' Get the recordset, but only extract the field names of those defined in the spreadsheet.
' If no fields have been selected, all fields will be extracted.
Set Connection = New ADODB.Connection
Connect = "Provider=Microsoft.ACE.OLEDB.12.0;"
Connect = Connect & "Data Source=" & DBFullName & ";Jet OLEDB:Database Password=" & PW & ";"
Connection.Open ConnectionString:=Connect
Set Recordset = New ADODB.Recordset
With Recordset
If FilCnt = 0 Then 'No filter
Source = "SELECT " & ExtFld & " FROM " & DBTable
End If
' Filter Data if selected
If FilCnt = 1 Then
Source = "SELECT " & ExtFld & " FROM " & DBTable & Filtxt1
End If
If FilCnt = 2 Then
Source = "SELECT " & ExtFld & " FROM " & DBTable & Filtxt1 & Filtxt2
End If
.Open Source:=Source, ActiveConnection:=Connection
If FilCntA = 1 Then
Recordset.Filter = FiltxtA
End If
If FilCntA = 2 Then
Recordset.Filter = FiltxtA & FiltxtB
End If
If FilCntA = 3 Then
Recordset.Filter = FiltxtA & FiltxtB & FiltxtC
End If
If FilCntA = 4 Then
Recordset.Filter = FiltxtA & FiltxtB & FiltxtC & FiltxtD
End If
If FilCntA = 5 Then
Recordset.Filter = FiltxtA & FiltxtB & FiltxtC & FiltxtD & FiltxtE
End If
'Debug.Print Recordset.Filter
' Clear data
For Col = 0 To Recordset.Fields.Count - 1
If WSforData <> "" Then
ActiveWorkbook.Worksheets(WSforData).Range(CellforData).Offset(0, Col).EntireColumn.Clear
End If
'ActiveWorkbook.Worksheets("DBLinks").Range("A1").Offset(Col + 3, FieldList - 1).Cells.Clear
Next
' Write field names
For Col = 0 To Recordset.Fields.Count - 1
If WSforData <> "" Then
ActiveWorkbook.Worksheets(WSforData).Range(CellforData).Offset(0, Col).Value = Recordset.Fields(Col).Name
End If
Next
' Write recordset
If WSforData <> "" Then
ActiveWorkbook.Worksheets(WSforData).Range(CellforData).Offset(1, 0).CopyFromRecordset Recordset
ActiveWorkbook.Worksheets(WSforData).Columns.AutoFit
End If
End With
' Clear recordset and close connection
Set Recordset = Nothing
Connection.Close
Set Connection = Nothing
End Sub
This piece of the "DBLinks" worksheet is probably also needed for full understanding of the code:
DBLinks user input area for database connectivity
SOLUTION:
I followed the advice to look into VBProject.VBComponents which copied the macro. I created a simple form which asked for the name to use for the macro and the rest of the inputs comes from the relative reference. I will spare you for a full copy of my long and less than graceful code, but the essential of the code are:
In case someone else could benefit from my experience: In the Click-action of the command button on the form:
Private Sub cmdCreateDB_Click()
'Go to Tools, References and add: Microsoft Visual Basic for Applications Extensibility 5.3
Dim VBProj As VBIDE.VBProject
Dim VBComp As VBIDE.VBComponent
Dim CodeMod As VBIDE.CodeModule
Dim LineNum As Long
Const DQUOTE = """" ' one " character
Set VBProj = ActiveWorkbook.VBProject
Set VBComp = VBProj.VBComponents("Module1")
Set CodeMod = VBComp.CodeModule
Dim txtDBLinkName As String
txtDBLinkName = Me.txtDBName
With CodeMod
LineNum = .CountOfLines + 1
.InsertLines LineNum, " Sub " & txtDBLinkName & "()"
LineNum = LineNum + 1
.InsertLines LineNum, " ' Click on Tools, References and select"
LineNum = LineNum + 1
.InsertLines LineNum, " ' the Microsoft ActiveX Data Objects 2.0 Library"
' And then it goes on forever through all the lines of the original code...
' just remember to replace all double quotations with(Without Square brackets):
' [" & DQUOTE & "]
'And it ends up with:
LineNum = LineNum + 1
.InsertLines LineNum, " Set Recordset = Nothing"
LineNum = LineNum + 1
.InsertLines LineNum, " Connection.Close"
LineNum = LineNum + 1
.InsertLines LineNum, " Set Connection = Nothing"
LineNum = LineNum + 1
.InsertLines LineNum, " End Sub"
End With
Unload Me
End Sub
Thank you everyone for your help. - Especially you #findwindow for coming up with the path to a solution.
For the sake of completion, here's how this could be dealt with without metaprogramming.
Problems that boil down to "do the same thing - but..." can often be solved by making the program as generic as possible. All data specific to a single use-case should be passed down from above in a clear manner, allowing the program to be reused.
Let's look at an example of how this could be implemented in order to generate query strings from one or many ranges of varying sizes.
The first step is to group all data that belongs to the concept of a Filter. Since VBA doesn't have object literals, we can use an Array, a Collection or a Type to represent a Filter instead.
Generating the query strings requires distinction between QueryFilters and RecordFilters. Looking at the code, the two variants are similar enough to be handled by a simple Boolean within a single Type.
Option Explicit
Private Type Filter
Field As String
Operator As String
Criteria As Variant
AdditionalMethod As String
ExtractedFields As String
IsQueryFilter As Boolean
FilterString As String
End Type
Now we can use a single variable instead of keeping track of multiple variables to represent a single concept.
One way a Filter can be generated is by using a Range.
' Generates a Filter from a given Range of input data.
Private Function GenerateFilter(ByRef source As Range) As Filter
With GenerateFilter
.Field = CStr(source)
.Operator = CStr(source.Offset(0, 1))
.Criteria = source.Offset(0, 2)
.AdditionalMethod = CStr(source.Offset(0, 3))
.ExtractedFields = CStr(source.Offset(0, 4))
.IsQueryFilter = CBool(source.Offset(0, 5))
.FilterString = GenerateFilterString(GenerateFilter)
End With
End Function
Just as a single concept can be declared as a Type, a group of things can be declared as an Array (or a Collection, Dictionary, ...). This is useful, as it lets us decouple the logic from a specific Range.
' Generates a Filter for each row of a given Range of input data.
Private Function GenerateFilters(ByRef source As Range) As Filter()
Dim filters() As Filter
Dim filterRow As Range
Dim i As Long
ReDim filters(0 To source.Rows.Count)
i = 0
For Each filterRow In source.Rows
filters(i) = GenerateFilter(filterRow)
i = i + 1
Next
GenerateFilters = filters()
End Function
We now have a function that can return an Array of Filters from a given Range - and, as long as the columns are laid down in the right order, the code will work just fine with any Range.
With all of the data in a convenient package, it's easy enough to assemble the FilterString.
' Generates a FilterString for a given Filter.
Private Function GenerateFilterString(ByRef aFilter As Filter) As String
Dim temp As String
temp = " "
With aFilter
If .AdditionalMethod <> "" Then temp = temp & .AdditionalMethod & " "
If .IsQueryFilter Then
temp = temp & "[" & .Field & "]"
Else
temp = temp & .Field
End If
temp = temp & " " & .Operator & " "
If VarType(.Criteria) = vbString Then
temp = temp & "'" & .Criteria & "'"
Else
temp = temp & .Criteria
End If
End With
GenerateFilterString = temp
End Function
The data can then be merged to strings that can be used in queries regardless of how many Filters of either type are present in the specified Range.
' Merges the FilterStrings of Filters that have IsQueryString set as True.
Private Function MergeQueryFilterStrings(ByRef filters() As Filter) As String
Dim temp As String
Dim i As Long
temp = " WHERE"
For i = 0 To UBound(filters)
If filters(i).IsQueryFilter Then temp = temp & filters(i).FilterString
Next
MergeQueryFilterStrings = temp
End Function
' Merges the FilterStrings of Filters that have IsQueryString set as False.
Private Function MergeRecordFilterStrings(ByRef filters() As Filter) As String
Dim temp As String
Dim i As Long
For i = 0 To UBound(filters)
If Not filters(i).IsQueryFilter Then _
temp = temp & filters(i).FilterString
Next
MergeRecordFilterStrings = temp
End Function
' Merges the ExtractedFields of all Filters.
Private Function MergeExtractedFields(ByRef filters() As Filter) As String
Dim temp As String
Dim i As Long
temp = ""
For i = 0 To UBound(filters)
If filters(i).ExtractedFields <> "" Then _
temp = temp & "[" & filters(i).ExtractedFields & "],"
Next
If temp = "" Then
temp = "*"
Else
temp = Left(temp, Len(temp) - 1) ' Remove dangling comma.
End If
MergeExtractedFields = temp
End Function
With all of that done, we can finally plug a single Range in and get the generated strings out. It would be trivial to change filterRange or generate Filters from multiple Ranges.
Public Sub TestStringGeneration()
Dim filters() As Filter
Dim filterRange As Range
Set filterRange = Range("A1:A10")
filters = GenerateFilters(filterRange)
Debug.Print MergeQueryFilterStrings(filters)
Debug.Print MergeRecordFilterStrings(filters)
Debug.Print MergeExtractedFields(filters)
End Sub
TL;DR
Split code to reusable Functions & Subs
Favor sending data as arguments
Avoid hard-coding
Group data that represent a single concept
Use Arrays or other data structures over multiple variables

[H]:MM:SS Format from Excel Cell to body of Outlook Email

Ok So I'm stuck on this Excel VBA code. I have it automatically generating emials in outlook with information from the sheet already inputed. BUT When i try to move a Cell thats formatted as [h]:mm:ss it puts a decimal version of the number in the outlook email.
Sub Mail_test()
'Set variables/objects for code.
Dim OutApp As Object
Dim OutMail As Object
Dim eto As String
Dim ecc As String
Dim esub As String
Dim ebody As String
Dim ebody1 As String
Dim ebody2 As String
Dim ebody3 As String
Dim ebody4 As String
Dim intbody As String
Dim wkDay As String
Dim otOff As String
Dim intbody2 As String
Dim intbody3 As String
Dim ebody6 As String
Dim intbody4 As String
Dim intbody5 As String
Dim ebody7 As String
Dim Ebody10 As String
Dim ebody11 As String
Dim Ebody12 As String
Dim intbody12 As String
Dim intbody13 As String
Dim Ebody13 As String
Dim ebody15 As String
Dim ebody20 As String
Dim Ebody21 As String
Dim Ebody22 As String
Dim Tempefile As String
'Sets application to update with code executions.
With Application
.ScreenUpdating = True
.EnableEvents = False
End With
'Conditional to determine if the code should continue.
mydate = E3
'Sets default body of the email.
Ebody12 = "Hello "
intbody12 = Sheets("Emails").Range("b3")
ebody15 = "," & vbNewLine & vbNewLine
Ebody13 = "We are doing our Bi-Weekly Aux 2 Audit. " & vbNewLine & vbNewLine
ebody11 = "This Escalation is for Agent: "
Ebody10 = Sheets("Emails").Range("AgentName").Value & vbNewLine & vbNewLine
ebody1 = "Your agent was over the allotted time for aux 2 for the two week period :"
ebody2 = "Agents are allotted 1.33% of their staffed time. " & vbNewLine & vbNewLine
ebody3 = "Your agents staffed time was : "
intbody = Sheets("Emails").Range("stafftime") & vbNewLine & vbNewLine
ebody4 = "Your Agents Aux 2 percentage for the last two weeks was : "
intbody2 = Sheets("Emails").Range("auxper").Value
ebody5 = "????"
intbody3 = Sheets("Emails").Range("F3").Value
ebody6 = " Can we please have this coached? " & vbNewLine & vbNewLine
intbody4 = Sheets("Emails").Range("g3").Value & vbNewLine & vbNewLine
ebody7 = "Your agents Aux 2 time was :"
intbody5 = Sheets("Emails").Range("Auxhours").Value & vbNewLine & vbNewLine
intbody13 = Sheets("Emails").Range("I3").Value & vbNewLine & vbNewLine
ebody20 = "Thank you,"
Ebody21 = " - "
Ebody22 = "%" & vbNewLine & vbNewLine
' Begins loop for adherence entry, loops until no further records exist to enter.
'Resets variables for body of the email.
intbody = ""
ebody = ""
'Conditional, if agent doesn't have overtime for tomorrow, skips to next agent..
'Continues to reset variables for email communication
eto = Sheets("Emails").Range("Supname") & ";" & Sheets("Emails").Range("managerName") 'sets the value in email data tab for To field
ecc = "christopher.meyers#pace.com" 'sets the value in email data tab for CC field
esub = "Aux 2 Escalation" 'sets the value in email data tab for Subject field
intbody = Sheets("Emails").Range("d3").Value & vbNewLine & vbNewLine
ebody = Ebody12 + intbody12 + ebody15 + ebody11 + Ebody10 + Ebody13 + ebody + ebody1 + intbody3 + inbody + Ebody21 + intbody4 + ebody2 + ebody3 + intbody + ebody7 + intbody5 + ebody4 + intbody2 + Ebody22 + ebody6 + ebody20
'Starts outlook application to send email.
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
'Sets variables for email.
On Error Resume Next
With OutMail
.To = eto
.CC = ecc
.BCC = ebcc
.Subject = esub
.Body = ebody
.Importance = 2
'You can add other files also like this
'.Attachments.Add ("C:\test.txt")
.Display 'or use .Send
End With
' Unlocks outlook
Set OutMail = Nothing
Set OutApp = Nothing
' Removes the row and loops back to the beginning to enter a new record.
Application.Wait Now + TimeValue("00:00:02")
Rows(6).EntireRow.Delete
End Sub
These two are the ones that I am wanting to show up [H]:MM:SS format
intbody5 = Sheets("Emails").Range("Auxhours").Value & vbNewLine & vbNewLine
intbody = Sheets("Emails").Range("stafftime") & vbNewLine & vbNewLine
I've tried
tempfile = Sheets("Emails").Range("stafftime") & Format (Time, "[H]:MM:SS")
and using the tempfile instead of the intbody in the body portion of the coding but it just retunrs the same numbers with 00:00:00 at the end.
Any Help wwould be appreicated
Use .text instead of .value
.text puts it as you view it in the cell
intbody5 = Sheets("Emails").Range("Auxhours").text & vbNewLine & vbNewLine

Resources