Snasui Excel Forum

Code: Select all

Sub SendEmail_Outlook()
Dim OutlookApp As Object
Dim MItem As Object
Dim email_ As String
Dim subject_ As String
Dim body_ As String
Dim CCemail_ As String

Set OutlookApp = CreateObject("Outlook.Application")
email_ = Range("F5").Value
subject_ = Range("B2").Value
body_ = Range("G11").Value
CCemail_ = Range("I5").Value

Set MItem = OutlookApp.CreateItem(0)
With MItem
.To = email_
.CC = CCemail_
.Subject = subject_
.Body = body_ & Chr(13) & Chr(13) & Range("D2") & Chr(13) & Range("E2") & Chr(13) & Range("F2") & Chr(13) & Range("G2") & Chr(13) & Range("H2")
.send
End With
End Sub

Code: Select all

Sub Object()
'
' Object Macro
'
' Keyboard Shortcut: Ctrl+Shift+E
'
    Range("A1:J37").Select
    Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
    Range("K1").Select
    ActiveSheet.Paste
End Sub

Code: Select all

Sub SendEmail_Outlook()

        Dim oOutlook As Object
        Dim OutlookApp As Object
        Dim MItem As Object
        Dim email_ As String
        Dim subject_ As String
        Dim body_ As String
        Dim CCemail_ As String
        Dim objRange As Range
        Dim WshShell As Object
        
        On Error Resume Next
        Set oOutlook = GetObject(, "Outlook.Application")
        On Error GoTo 0
        
        If oOutlook Is Nothing Then
            MsgBox "Outlook is not open, open Outlook and try again"
        Else
            Set objRange = Sheets("Sheet1").Range("J1:A31")
            objRange.Copy
            Set OutlookApp = CreateObject("Outlook.Application")
            
            
            email_ = Range("F5").Value
            subject_ = Range("B2").Value
            body_ = Range("G11").Value
            CCemail_ = Range("I5").Value
            
            Set MItem = OutlookApp.CreateItem(0)
            MItem.Display
    
            With MItem
                
                .To = email_
                .CC = CCemail_
                .Subject = subject_
                Set WshShell = CreateObject("WScript.Shell")
                WshShell.AppActivate MItem
                Call SendKey
    
            End With
        End If
        
Set oOutlook = Nothing
Set OutlookApp = Nothing
Set WshShell = Nothing
Set objRange = Nothing

End Sub

Sub SendKey()
                SendKeys "{TAB}"
                SendKeys "{TAB}"
                SendKeys "{TAB}"
                SendKeys "^v"
End Sub