Outlook and Excel

[dave3009]

Hi Folks

I have managed to conjure up some code that will copy the current sheet from a given workbook, paste it to it's very own workbook, save it then e-mail it via Outlook.

see my code

Sub testpastecode()
Dim iTemp As Long
Dim Fpath, CrName As String
iTemp = Application.SheetsInNewWorkbook
Fpath = ThisWorkbook.Path
CrName = ThisWorkbook.Name
Application.SheetsInNewWorkbook = 1
Workbooks.Add
ActiveWorkbook.SaveAs Fpath & "\Report.xls"
Workbooks(CrName).ActiveSheet.Cells.Copy
Application.DisplayAlerts = False
With ActiveWorkbook
    .ActiveSheet.PasteSpecial
    .ActiveSheet.Name = Workbooks(CrName).ActiveSheet.Name
    .ActiveSheet.Range("A1").Select
    .Save
    .SendMail Recipients:="Dave3009"
End With
Application.DisplayAlerts = True
Application.SheetsInNewWorkbook = iTemp
Application.CutCopyMode = False

End Sub

Now this works, my only issue is that I get prompted if I want to Allow or Deny Outlook to send it. Ideally I'd want to just Allow as the end users are button pressers and may panic given an option.

In the above code I tried DisplayAlerts but that didn't do the trick.

Any help is much appreciated

Thanks


Dave


p.s. If I could save the file with the name Report plus a date time stamp I'd be doubly thankful

 

[dave3009]

OK so I did some seraching and came up with this but I still get the Outlook security message, is this maybe an Outlook issue?

Sub testpastecode()
Dim iTemp As Long
Dim Fpath, CrName As String
Dim OutGo As Object
iTemp = Application.SheetsInNewWorkbook
Fpath = ThisWorkbook.Path
CrName = ThisWorkbook.Name
Application.SheetsInNewWorkbook = 1
Workbooks.Add
ActiveWorkbook.SaveAs Fpath & "\Report.xls"
Workbooks(CrName).ActiveSheet.Cells.Copy
With ActiveWorkbook
    .ActiveSheet.PasteSpecial
    .ActiveSheet.Name = Workbooks(CrName).ActiveSheet.Name
    .ActiveSheet.Range("A1").Select
    .Save
    .Close
End With
Application.SheetsInNewWorkbook = iTemp
Application.CutCopyMode = False
MsgBox "When Prompted please select - Allow"
Dim OutlookApp As Object
  Dim MItem As Object
  Dim Subj As String
  Dim EmailAddr As String
  Dim Recipient As String
  Dim Msg As String
  
  'Create Outlook object
  Set OutlookApp = CreateObject("Outlook.Application")
      'Get the data
      Subj = "Subject"
      Recipient = "Dave3009"
      EmailAddr = "Dave@3009"
            
     'Compose message
      Msg = "Hi Dave" & vbCrLf & vbCrLf
      Msg = Msg & "Here is my Report"
      Set MItem = OutlookApp.CreateItem(0)
      With MItem
        .To = EmailAddr
        .Subject = Subj
        .Body = Msg
        .attachments.Add (Fpath & "\Report.xls")
        .Send
   End With
    
End Sub

 

[VoG]

Hi Dave

Annoying, isn't it! I think that you need Outlook Redemption http://www.dimastr.com/redemption/

 

[dave3009]

Cheers for the response

So as I'm using company equipment on which I have less privileges than I'd allow my own child, I suppose I should just tell the end users to expect it?

Here's how I cleaned up

Sub testpastecode()
Dim iTemp As Long
Dim Fpath, CrName, Msg, Subj As String
Dim OutlookApp, MItem As Object
Dim EmailAddr, Recipient As String

iTemp = Application.SheetsInNewWorkbook
Fpath = ThisWorkbook.Path
CrName = ThisWorkbook.Name

Application.SheetsInNewWorkbook = 1
Workbooks.Add
ActiveWorkbook.SaveAs Fpath & "\Report.xls"

Workbooks(CrName).ActiveSheet.Cells.Copy

With ActiveWorkbook
    .ActiveSheet.PasteSpecial
    .ActiveSheet.Name = Workbooks(CrName).ActiveSheet.Name
    .ActiveSheet.Range("A1").Select
    .Save
    .Close
End With
With Application
    .SheetsInNewWorkbook = iTemp
    .CutCopyMode = False
End With

MsgBox "When Prompted please select - Allow"

Set OutlookApp = CreateObject("Outlook.Application")

Subj = "Report"
EmailAddr = "dave@3009"
      
Msg = "Hi Dave" & vbCrLf & vbCrLf
Msg = Msg & "Here is my Report"
      
Set MItem = OutlookApp.CreateItem(0)

With MItem
    .To = EmailAddr
    .Subject = Subj
    .Body = Msg
    .attachments.Add (Fpath & "\Report.xls")
    .Send
End With
    
End Sub

Thanks again VoG II, I always appreciate your work