cutemeatball
New Member
- Joined
- Jun 13, 2022
- Messages
- 20
- Office Version
- 365
- Platform
- Windows
So I have this existing Macro from 2012? This basically separates all the individual sheets from this one workbook and creates an outlook email with the correspondent sheet attached. Problem is it displays all the outlook emails ,but does not send it all automatically. Can anyone help me with this? the line that has If lngSend = vbYes Then OutMail.Display Else OutMail.Save is probably what needs to be looked at if im trying to guess here. I tried replacing Display with Send but nothing happened. Macro just kept running and no emails were sent.
VBA Code:
Option Explicit
Sub RenameToLocations()
Dim wks As Worksheet
Dim wksAddr As Worksheet
Dim rng As Range
Dim strCode As String
Dim strState As String
Set wksAddr = Worksheets("Addresses")
For Each rng In wksAddr.Range("A3:A" & wksAddr.Range("A" & Rows.Count).End(xlUp).Row)
strCode = rng
strState = rng.Offset(0, 1)
For Each wks In Worksheets
If LCase(wks.Name) = LCase(strCode) Then
wks.Name = strState
Exit For
Else: End If
Next wks
Next rng
End Sub
Sub SendSheets()
'
' Macro2 Macro
' Macro recorded 6/19/2009 by Jennie Warren
On Error GoTo Problem
Dim i As Integer
Dim strName As String
Dim wkbNew As Workbook
Dim wksSheet As Worksheet
Dim rngAddress As Range
Dim strSendTo As String
Dim intCount As Integer
Dim strFileName As String
Dim strBody As String
RenameToLocations
Set rngAddress = Worksheets("Addresses").Range("C3")
strBody = Worksheets("Addresses").Range("EmailSubject").Value
strBody = strBody & Worksheets("Addresses").Range("H2").Value 'Added 12/4/2012
intCount = 0
For i = 1 To Worksheets.Count
strName = Sheets(i).Name
Set wksSheet = Sheets(i)
If Not strName = "Summary" And Not strName = "Data_Sales" And Not strName = "Data_OpenOrders" And Not strName = "Data_CustInsCodes" And Not strName = "Addresses" And Not strName = "Summary By Loc" And Not strName = "Forecast By Reg Subtotaled" And Not strName = "MTD_Sales qry 975" And Not strName = "QTD_Sales qry 9951" And Not strName = "Data_Sales" And Not strName = "Data_OpenOrders" And Not strName = "Data_CustInsCodes" And Not strName = "Addresses" And Not strName = "Summary By Loc" And Not strName = "Forecast By Reg Subtotaled" And Not strName = "MTD_Sales qry 975" And Not strName = "LastYTDSales qry 9998" And Not strName = "Data_Sales" And Not strName = "Data_OpenOrders" And Not strName = "Data_CustInsCodes" And Not strName = "Addresses" And Not strName = "Summary By Loc" And Not strName = "Forecast By Reg Subtotaled" And Not strName = "MTD_Sales qry 975" And Not strName = "Forecast" And Not strName = "Misc" Then
intCount = intCount + 1
Set wkbNew = Workbooks.Add
wksSheet.Copy before:=wkbNew.Sheets(1)
With wkbNew.ActiveSheet.Cells
.Copy
.PasteSpecial Paste:=xlPasteValues
End With
For Each wksSheet In wkbNew.Worksheets
If Not wksSheet.Name = strName Then
Application.DisplayAlerts = False
wksSheet.Delete
Application.DisplayAlerts = True
End If
Next wksSheet
wkbNew.SaveAs ThisWorkbook.Path & "\" & strName & ".xlsx", FileFormat:=xlOpenXMLWorkbook
If Len(Trim(rngAddress.Value)) > 0 Then
strSendTo = rngAddress.Value
If Len(Trim(rngAddress.Offset(0, 1).Value)) > 0 Then
strSendTo = strSendTo & ";" & rngAddress.Offset(0, 1)
Else: End If
If Len(Trim(rngAddress.Offset(0, 2).Value)) > 0 Then
strSendTo = strSendTo & ";" & rngAddress.Offset(0, 2)
Else: End If
Set rngAddress = rngAddress.Offset(1, 0)
Else
strSendTo = InputBox("Mail " & strName & " to:", "Enter E-mail Address")
End If
strFileName = wkbNew.FullName
'SendNotesMsg strSendTo, , strName, strBody, strFileName
SendOutlookMsg strSendTo, , strName, strBody, strFileName '# Uses function for Outlook messages
wkbNew.Close
Kill strFileName
End If
Next i
End_Now:
Set wksSheet = Nothing
Set wkbNew = Nothing
Exit Sub
Problem:
MsgBox "An unexpected error occurred. Please contact your file administrator." & vbCrLf _
& "Error #: " & Err.Number & " Error Desc.: " & Err.Description & vbCrLf _
& "This procedure will now be terminated."
GoTo End_Now
End Sub
Function SendNotesMsg( _
ByVal sSendTo As Variant, _
Optional ByVal sCC As Variant, _
Optional ByVal sSubject As String, _
Optional ByVal sBodyText As String, _
Optional ByVal sAttachment As Variant _
) As Long
'*******************************************************************************
'Purpose: Send a Notes mail message
'Arguments: sSendTo (Required)- a string of the Name of a single recipient
' or an array of strings for multiple recipients
'If needs to use Multiple recipients, then
'sSendTo to must be passed in as an array
' sCC (Optional)- same rules as the sSendTo parameter, except the names
' will be used in the CC field
' sSubject (Optional)-the string to be used for the Subject line
' sBodyText (Optional)-the string to be used for the Body of the message
' sAttachment (Optional)-the string or an array of strings containing the
' path and file name of
' file(s) to be attached
'Sample Syntax SendNotesMsg "Blake Hartman", "This is the subject", "The body","C:\data\mydoc.doc"
'**********************************************************************************
Dim oSess As Object
Dim oDB As Object
Dim oDoc As Object
Dim oItem As Object
Dim i As Long
Dim v As Variant
Dim ntsServer As String
Dim ntsMailFile As String
'use the below constant lines instead of the above 2 lines
'only if hard coding in the server and mailfile name
'Use empty string for ntsServer if it is a local database
'Const ntsserver = "notes46/pchelps46"
'Const ntsmailFile = "mail\bhartman.nsf"
'On Error GoTo err_SendNotesMsg
'Set oSess = CreateObject("Notes.NotesSession")
'don't use the next 2 if using the constants
'gets server name
'ntsServer = oSess.GetEnvironmentString("MailServer", True)
'get the mailfile name of current user from the Notes.ini
'ntsMailFile = oSess.GetEnvironmentString("MailFile", True)
'Set oDB = oSess.GetDatabase(ntsServer, ntsMailFile)
Set oDB = oSess.GetDatabase("", "")
Set oDoc = oDB.CreateDocument
Set oItem = oDoc.CreateRichTextItem("BODY")
oDoc.Form = "Memo"
If Not IsMissing(sSubject) Then
If sSubject <> "" Then oDoc.Subject = sSubject
End If
If Not IsMissing(sSubject) Then
If sBodyText <> "" Then oDoc.Body = sBodyText
End If
oDoc.from = oSess.CommonUserName
oDoc.PostedDate = Date
If IsMissing(sAttachment) Then
' Nothing to do
ElseIf IsArray(sAttachment) Then
For i = LBound(sAttachment) To UBound(sAttachment)
If sAttachment(i) <> "" Then Call oItem.EmbedObject(1454, "", sAttachment(i))
Next
Else
If sAttachment <> "" Then Call oItem.EmbedObject(1454, "", sAttachment)
End If
If IsMissing(sCC) Then
' nothing to do
Else
oDoc.CopyTo = sCC
End If
'split sSendto into an array for multiple recipients
Dim sEmailArray() As String
sEmailArray = SplitEx(sSendTo, True, ";")
oDoc.SendTo = sEmailArray
oDoc.SaveMessageOnSend = True 'Added 12/4/2012 to save email in sent items folder
'send the message
Call oDoc.Send(False)
SendNotesMsg = 0
'MsgBox "Your message was sent", vbInformation
exit_SendNotesMsg:
On Error Resume Next
Set oSess = Nothing
Set oDB = Nothing
Set oDoc = Nothing
Set oItem = Nothing
Exit Function
err_SendNotesMsg:
SendNotesMsg = Err.Number
If Err.Number = 7225 Then
MsgBox "Couldn't create attachment. make sure it is a valid path and Filename!", vbCritical
Else
MsgBox "[" & Err.Number & "]: " & Err.Description
End If
MsgBox "Message was NOT sent!", vbCritical
Resume exit_SendNotesMsg
Resume
End Function
[FONT=georgia]Function SendOutlookMsg( _
ByVal sSendTo As Variant, _
Optional ByVal sCC As Variant, _
Optional ByVal sSubject As String, _
Optional ByVal sBodyText As String, _
Optional ByVal sAttachment As Variant, _
Optional ByVal lngSend As Long = vbYes _
) As Long
'################################################################
'# Added 8/20/2015 by Marshall Heikkila at theITSupportCenter #
'################################################################
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = sSendTo
.CC = sCC
.BCC = ""
.Subject = sSubject
.Body = sBodyText
.Attachments.Add sAttachment
.Send
End With
If lngSend = vbYes Then OutMail.Display Else OutMail.Save
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Function[/FONT]
Function SplitEx(ByVal InString As String, IgnoreDoubleDelmiters As Boolean, _
ParamArray Delims() As Variant) As String()
Dim Arr() As String
Dim Ndx As Long
Dim N As Long
If Len(InString) = 0 Then
SplitEx = Arr
Exit Function
End If
If IgnoreDoubleDelmiters = True Then
For Ndx = LBound(Delims) To UBound(Delims)
N = InStr(1, InString, Delims(Ndx) & Delims(Ndx), vbTextCompare)
Do Until N = 0
InString = Replace(InString, Delims(Ndx) & Delims(Ndx), Delims(Ndx))
N = InStr(1, InString, Delims(Ndx) & Delims(Ndx), vbTextCompare)
Loop
Next Ndx
End If
ReDim Arr(1 To Len(InString))
For Ndx = LBound(Delims) To UBound(Delims)
InString = Replace(InString, Delims(Ndx), Chr(1))
Next Ndx
Arr = Split(InString, Chr(1))
SplitEx = Arr
End Function
