sassriverrat
Well-known Member
- Joined
- Oct 4, 2018
- Messages
- 655
So a gentleman on here made this piece of code, to be called within a macro, that eliminates the warning when opening URLs. Could this be tweaked so that when forcing excel to send an email (second code below), the warning for excel sending an email on your behalf was hidden?
thanks!
email
thanks!
Rich (BB code):
Option Explicit
Enum W32_Window_State
Show_Normal = 1
Show_Minimized = 2
Show_Maximized = 3
Show_Min_No_Active = 7
Show_Default = 10
End Enum
Private Declare Function ShellExecute Lib "shell32.dll" _
Alias "ShellExecuteA" (ByVal hWnd As Long, _
ByVal lpOperation As String, ByVal lpFile As String, _
ByVal lpParameters As String, ByVal lpDirectory As String, _
ByVal nShowCmd As Long) As Long
Function OpenURL(URL As String, WindowState As W32_Window_State) As Boolean
'Opens passed URL with default application, or Error Code (<32) upon error
Dim lngHWnd As Long
Dim lngReturn As Long
lngReturn = ShellExecute(lngHWnd, "open", URL, vbNullString, _
vbNullString, WindowState)
OpenURL = (lngReturn > 32)
End Function
Rich (BB code):
Public Sub Email_Active_Sheet()
Dim OutApp As Object, OutMail As Object
Dim emailSubject As String, bodyText As String, toEmailAddresses As String
Dim cell As Range, printRange As Range
Dim TempFileName As String
Dim name As String
name = Sheets("Notes").Range("N4")
'Sets parameters of email
With ThisWorkbook.Worksheets("Notes")
emailSubject = .Range("L45").Value
bodyText = .Range("L46").Value
toEmailAddresses = ""
For Each cell In .Range("L37:L43")
If cell.Value = "" Then
Exit Sub
Else: If cell.Value Like "?*@?*.?*" Then toEmailAddresses = toEmailAddresses & cell.Value & ";"
End If
Next
End With
'sets active sheet type (pdf)
With ThisWorkbook.ActiveSheet
TempFileName = Environ("temp") & "\" & .name & " Report " & Format(Now, "dd-mmm-yy") & ".pdf"
'Check Print Range
If .PageSetup.PrintArea = vbNullString Then
MsgBox (Environ("temp") & "\" & .name & " Report " & Format(Now, "dd-mmm-yy") & ".pdf")
MsgBox "You must first set the Print Area(s) on the '" & .name & "' sheet.", vbExclamation, name
Exit Sub
End If
'Continue with email piece
Set printRange = Range(.PageSetup.PrintArea)
printRange.ExportAsFixedFormat Type:=xlTypePDF, Filename:=TempFileName, _
Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
End With
'sets outlook to run
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
'On Error Resume Next
With OutMail
.To = Left(toEmailAddresses, Len(toEmailAddresses) - 1)
.CC = ""
.BCC = ""
.Subject = emailSubject
.Body = bodyText
.Attachments.Add TempFileName
.Send
End With
'On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
Kill TempFileName
End Sub