I don't know whether it is correct to ask question here. If not then moderator please remove this post.
My query is as follows:-
I use "Send Workbook Template" created by Ron De Bruin. It works well, for me but I need to modify this code for two three things:-
1. I need to modify the This Workbook Sheet and insert macro code into that.
2. I need to copy one sheet but Hide it before it been sent along with the mail.
The problem I am facing is I am not able to figure out where to put my code for above, so that it actually works. Following is the code as given by Ron De Bruin.
<code><code>
</code></code>
My query is as follows:-
I use "Send Workbook Template" created by Ron De Bruin. It works well, for me but I need to modify this code for two three things:-
1. I need to modify the This Workbook Sheet and insert macro code into that.
2. I need to copy one sheet but Hide it before it been sent along with the mail.
The problem I am facing is I am not able to figure out where to put my code for above, so that it actually works. Following is the code as given by Ron De Bruin.
<code><code>
Code:
Option Explicit
Private Sub RDB_Outlook_Click()
Dim StringTo As String, StringCC As String, StringBCC As String
Dim ShArr() As String, FArr() As String, strDate As String
Dim myCell As Range, cell As Range, rng As Range, Fname As String, Fname2 As String
Dim wb As Workbook, sh As Worksheet
Dim DefPath As String
Dim olApp As Object
Dim olMail As Object
Dim FileExtStr As String
Dim FileExtStr2 As String
Dim FileFormatNum As Long
Dim ToArray As Variant
Dim CCArray As Variant
Dim BCCArray As Variant
Dim StringFileNames As String
Dim StringSheetNames As String
Dim FileNamesArray As Variant
Dim SheetNamesArray As Variant
Dim I As Long, S As Long, F As Long
Dim WrongData As Boolean
If Len(ThisWorkbook.Path) = 0 Then
MsgBox "This macro will only work if the file is Saved once", 48, "RDBMailOutlook"
Exit Sub
End If
If Me.ProtectContents = True Or ActiveWindow.SelectedSheets.Count > 1 Then
MsgBox "This macro will not work if the RDBMailOutlook worksheet is " & _
"protected or if you have more then sheet selected(grouped)", 48, "RDBMailOutlook"
Exit Sub
End If
'Set folder where we save the temporary files
DefPath = Application.DefaultFilePath
If Right(DefPath, 1) <> "" Then
DefPath = DefPath & ""
End If
'Set reference to Outlook and turn of ScreenUpdating and Events
Set olApp = CreateObject("Outlook.Application")
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'Set cells with Red interior color to no fill(cells with wrong data)
Range("A6").ListObject.DataBodyRange.Interior.Pattern = xlNone
'Set rng to the first column of the table
Set rng = Me.Range("A6").ListObject.ListColumns(1).Range
For Each myCell In rng
'Create mail if "Yes" in column A
If LCase(myCell.Value) = "yes" Then
StringTo = "": StringCC = "": StringBCC = ""
S = 0: F = 0
Erase ShArr: Erase FArr
'Set Error Boolean to False
WrongData = False
'Check if there are Sheet names in column B
'If B is empty S = 0 so you not want to send a sheet or sheets
If Trim(Me.Cells(myCell.Row, "B").Value) = "" Then S = 0
'If there are sheet names in the B column S is the number of sheets it add to the Array
If LCase(Trim(Me.Cells(myCell.Row, "B").Value)) <> "workbook" Then
StringSheetNames = Me.Cells(myCell.Row, "B").Value
SheetNamesArray = Split(StringSheetNames, Chr(10), -1)
For I = LBound(SheetNamesArray) To UBound(SheetNamesArray)
On Error Resume Next
If SheetNamesArray(I) <> "" Then
If SheetExists(CStr(SheetNamesArray(I))) = False Then
Me.Cells(myCell.Row, "B").Interior.ColorIndex = 3
WrongData = True
Else
S = S + 1
ReDim Preserve ShArr(1 To S)
ShArr(S) = SheetNamesArray(I)
End If
End If
On Error GoTo 0
Next I
Else
'If you only enter "workbook" in colomn B to mail the whole workbook S = -1
S = -1
End If
''''''
'Check to Mail addresses in column F
If Trim(Me.Cells(myCell.Row, "F").Value) <> "" Then
StringTo = Me.Cells(myCell.Row, "F").Value
ToArray = Split(StringTo, Chr(10), -1)
StringTo = ""
For I = LBound(ToArray) To UBound(ToArray)
If ToArray(I) Like "?*@?*.?*" Then
StringTo = StringTo & ";" & ToArray(I)
End If
Next I
End If
'Check to Mail addresses in column G
If Trim(Me.Cells(myCell.Row, "G").Value) <> "" Then
StringCC = Me.Cells(myCell.Row, "G").Value
CCArray = Split(StringCC, Chr(10), -1)
StringCC = ""
For I = LBound(CCArray) To UBound(CCArray)
If CCArray(I) Like "?*@?*.?*" Then
StringCC = StringCC & ";" & CCArray(I)
End If
Next I
End If
'Check to Mail addresses in column H
If Trim(Me.Cells(myCell.Row, "H").Value) <> "" Then
StringBCC = Me.Cells(myCell.Row, "H").Value
BCCArray = Split(StringBCC, Chr(10), -1)
StringBCC = ""
For I = LBound(BCCArray) To UBound(BCCArray)
If BCCArray(I) Like "?*@?*.?*" Then
StringBCC = StringBCC & ";" & BCCArray(I)
End If
Next I
End If
If StringTo = "" And StringCC = "" And StringBCC = "" Then
Me.Cells(myCell.Row, "F").Resize(, 3).Interior.ColorIndex = 3
WrongData = True
End If
'Check the other files that you want to attach in column J
If Trim(Me.Cells(myCell.Row, "J").Value) <> "" Then
StringFileNames = Me.Cells(myCell.Row, "J").Value
FileNamesArray = Split(StringFileNames, Chr(10), -1)
For I = LBound(FileNamesArray) To UBound(FileNamesArray)
On Error Resume Next
If FileNamesArray(I) <> "" Then
If Dir(FileNamesArray(I)) <> "" Then
If Err.Number = 0 Then
F = F + 1
ReDim Preserve FArr(1 To F)
FArr(F) = FileNamesArray(I)
Else
Err.Clear
Me.Cells(myCell.Row, "J").Interior.ColorIndex = 3
WrongData = True
End If
Else
Me.Cells(myCell.Row, "J").Interior.ColorIndex = 3
WrongData = True
End If
End If
On Error GoTo 0
Next I
End If
'Not create the mail if there are Errors in the row (wrong sheet or file names or no mail addresses)
If WrongData = True Then GoTo MailNot
strDate = Format(Now, "dd-mmm-yyyy hh-mm-ss")
'Copy the sheet(s)to a new workbook
If S > 0 Then
ThisWorkbook.Sheets(ShArr).Copy
Set wb = ActiveWorkbook
'Determine the Excel version and file extension/format
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
Select Case ThisWorkbook.FileFormat
Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If wb.HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56: FileExtStr = ".xls": FileFormatNum = 56
Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
Fname = DefPath & Trim(Me.Cells(myCell.Row, "C").Value) & _
" " & FileExtStr
End If
'You enter only "workbook" in colomn B to mail the whole workbook
'Use SaveCopyAs to make a copy of the workbook
If S = -1 Then
FileExtStr2 = "." & LCase(Right(ThisWorkbook.Name, _
Len(ThisWorkbook.Name) - InStrRev(ThisWorkbook.Name, ".", , 1)))
Fname2 = DefPath & Trim(Me.Cells(myCell.Row, "C").Value) & _
" " & FileExtStr2
ThisWorkbook.SaveCopyAs Fname2
Me.Activate
Set wb = Workbooks.Open(Fname2)
Application.DisplayAlerts = False
wb.Sheets(Me.Name).Delete
Application.DisplayAlerts = True
If wb.Sheets(1).Visible = xlSheetVisible Then wb.Sheets(1).Select
End If
'Make values of your formulas if you enter yes in the Values column.
'Delete all objects if you enter yes in the delete objects column.
'If you only want to delete Forms or ActiveX controls see
'http://www.rondebruin.nl/controlsobjectsworksheet.htm
If S <> 0 Then
If LCase(Me.Cells(myCell.Row, "D").Value) = "yes" Or _
LCase(Me.Cells(myCell.Row, "E").Value) = "yes" Then
For Each sh In wb.Worksheets
If sh.Visible = xlSheetVisible Then
sh.Select
If sh.ProtectContents = False Then
If LCase(Me.Cells(myCell.Row, "D").Value) = "yes" Then
With sh.UsedRange
.Cells.Copy
.Cells.PasteSpecial xlPasteValues
.Cells(1).Select
End With
Application.CutCopyMode = False
End If
If LCase(Me.Cells(myCell.Row, "E").Value) = "yes" Then
On Error Resume Next
sh.DrawingObjects.Visible = True
sh.DrawingObjects.Delete
On Error GoTo 0
End If
ElseIf sh.ProtectContents = True Then
On Error Resume Next
sh.Unprotect Trim(Me.Range("C4").Value)
On Error GoTo 0
If sh.ProtectContents = False Then
If LCase(Me.Cells(myCell.Row, "D").Value) = "yes" Then
With sh.UsedRange
.Cells.Copy
.Cells.PasteSpecial xlPasteValues
.Cells(1).Select
End With
Application.CutCopyMode = False
End If
If LCase(Me.Cells(myCell.Row, "E").Value) = "yes" Then
On Error Resume Next
sh.DrawingObjects.Visible = True
sh.DrawingObjects.Delete
On Error GoTo 0
End If
sh.Protect Trim(Me.Range("C4").Value)
Else
Me.Cells(myCell.Row, "D").Resize(, 2).Interior.ColorIndex = 3
WrongData = True
End If
End If
End If
Next sh
If wb.Sheets(1).Visible = xlSheetVisible Then wb.Sheets(1).Select
End If
'There password is not correct for all sheets, not possible to make values
'or delete objects. we not create this mail.
If WrongData = True Then
wb.Close False
If S = -1 Then
Kill Fname2
End If
Set wb = Nothing
GoTo MailNot
End If
If S = -1 Then
wb.Save
Else
wb.SaveAs Fname, FileFormatNum
End If
wb.Close False
Set wb = Nothing
End If
On Error Resume Next
Set olMail = olApp.CreateItem(0)
With olMail
.To = StringTo
.CC = StringCC
.BCC = StringBCC
.Subject = Me.Cells(myCell.Row, "I").Value
.Body = Me.Cells(myCell.Row, "K").Value
If S > 0 Then .Attachments.Add Fname
If S = -1 Then .Attachments.Add Fname2
If F > 0 Then
For I = LBound(FArr) To UBound(FArr)
.Attachments.Add FArr(I)
Next I
End If
'Set Importance 0 = Low, 2 = High, 1 = Normal
If LCase(Me.Cells(myCell.Row, "L").Value) = "yes" Then
.Importance = 2
End If
'Display the mail or send it directly, see cell C3
If LCase(Me.Range("C3").Value) = "yes" Then
.Display
Else
.Send
End If
End With
If S > 0 Then Kill Fname
If S = -1 Then Kill Fname2
On Error GoTo 0
Set olMail = Nothing
End If
MailNot:
Next myCell
If LCase(Me.Range("C3").Value) = "no" Then
MsgBox "The macro is ready and if correct the mail or mails are created." & vbNewLine & _
"If you see Red cells in the table then the information in the cells is " & vbNewLine & _
"not correct. For example there is a sheet or filename that not exist." & vbNewLine & _
"Note: It will not create a Mail of the information in a row with a " & vbNewLine & _
"Red cell or cells.", 48, "RDBMailOutlook"
End If
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
Set olApp = Nothing
End Sub
Function SheetExists(wksName As String) As Boolean
On Error Resume Next
SheetExists = CBool(Len(ThisWorkbook.Sheets(wksName).Name) > 0)
On Error GoTo 0
End Function
Private Sub BrowseAddFiles_Click()
Dim Fname As Variant
Dim fnum As Long
If ActiveCell.Column = 10 And ActiveCell.Row > 6 Then
Fname = Application.GetOpenFilename(filefilter:="All Files (*.*), *.*", _
MultiSelect:=True)
If IsArray(Fname) Then
For fnum = LBound(Fname) To UBound(Fname)
If fnum = 1 And ActiveCell.Value = "" Then
ActiveCell.Value = ActiveCell.Value & Fname(fnum)
Else
If Right(ActiveCell, 1) = Chr(10) Then
ActiveCell.Value = ActiveCell.Value & Fname(fnum)
Else
ActiveCell.Value = ActiveCell.Value & Chr(10) & Fname(fnum)
End If
End If
Next fnum
With Me.Range("J1").EntireColumn
.ColumnWidth = 255
.AutoFit
End With
With Me.Rows
.AutoFit
End With
End If
Else
MsgBox "Select a cell in the ""Attach other files"" column", 48, "RDBMailOutlook"
End If
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column > 5 And Target.Column < 9 And Target.Row > 6 Then
With Range(Target.Address)
.Hyperlinks.Delete
End With
End If
End Sub
