A
aussiegirlone
Ron de Bruin
Can you help with your code please
I cannot lock any of the worksheets that have @ in Cell B1, because if I do
the whole sheet becomes hyperlinked and as soon as I click anywhere onto it,
it opens outlook and prepares the send. Can you edit this code that it
deselects B1 after send on every sheet that has @ and move the curser to
select A1 or C1 at the end of the process
Your Email Code to be edited
Sub Mail_Every_Worksheet()
'Working in 2000-2007
Dim sh As Worksheet
Dim wb As Workbook
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim TempFilePath As String
Dim TempFileName As String
Dim OutApp As Object
Dim OutMail As Object
TempFilePath = Environ$("temp") & "\"
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007
FileExtStr = ".xlsm": FileFormatNum = 52
End If
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
For Each sh In ThisWorkbook.Worksheets
If sh.Range("B1").Value Like "?*@?*.?*" Then
sh.Copy
Set wb = ActiveWorkbook
TempFileName = "Sheet " & sh.Name & " of " _
& ThisWorkbook.Name & " " & Format(Now, "dd-mmm-yy
h-mm-ss")
Set OutMail = OutApp.CreateItem(0)
With wb
.SaveAs TempFilePath & TempFileName & FileExtStr,
FileFormat:=FileFormatNum
On Error Resume Next
With OutMail
.To = sh.Range("B1").Value
.CC = ""
.BCC = ""
.Subject = "Your Roster for the Week"
.Body = "Please Confirm if this is correct"
.Attachments.Add wb.FullName
'You can add other files also like this
'.Attachments.Add ("C:\test.txt")
.Display 'or use .Send
End With
On Error GoTo 0
Range("A1").Select
.Close savechanges:=False
End With
Set OutMail = Nothing
Kill TempFilePath & TempFileName & FileExtStr
End If
Next sh
Set OutApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Can you help with your code please
I cannot lock any of the worksheets that have @ in Cell B1, because if I do
the whole sheet becomes hyperlinked and as soon as I click anywhere onto it,
it opens outlook and prepares the send. Can you edit this code that it
deselects B1 after send on every sheet that has @ and move the curser to
select A1 or C1 at the end of the process
Your Email Code to be edited
Sub Mail_Every_Worksheet()
'Working in 2000-2007
Dim sh As Worksheet
Dim wb As Workbook
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim TempFilePath As String
Dim TempFileName As String
Dim OutApp As Object
Dim OutMail As Object
TempFilePath = Environ$("temp") & "\"
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007
FileExtStr = ".xlsm": FileFormatNum = 52
End If
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
For Each sh In ThisWorkbook.Worksheets
If sh.Range("B1").Value Like "?*@?*.?*" Then
sh.Copy
Set wb = ActiveWorkbook
TempFileName = "Sheet " & sh.Name & " of " _
& ThisWorkbook.Name & " " & Format(Now, "dd-mmm-yy
h-mm-ss")
Set OutMail = OutApp.CreateItem(0)
With wb
.SaveAs TempFilePath & TempFileName & FileExtStr,
FileFormat:=FileFormatNum
On Error Resume Next
With OutMail
.To = sh.Range("B1").Value
.CC = ""
.BCC = ""
.Subject = "Your Roster for the Week"
.Body = "Please Confirm if this is correct"
.Attachments.Add wb.FullName
'You can add other files also like this
'.Attachments.Add ("C:\test.txt")
.Display 'or use .Send
End With
On Error GoTo 0
Range("A1").Select
.Close savechanges:=False
End With
Set OutMail = Nothing
Kill TempFilePath & TempFileName & FileExtStr
End If
Next sh
Set OutApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub