Problem with SendKeys excel to outlook vba

espenskeie

Well-known Member
Joined
Mar 30, 2009
Messages
636
Office Version
  1. 2016
Platform
  1. Windows
Hi

I have a code that comes from rondebruin.nl's website. I have tried to deactivate the security-warning that normally pop's up by the code:

Code:
Application.Wait (Now + TimeValue("0:00:02"))
        Application.SendKeys "%{s}"

instead of just using .Send

But it seems very unreliable, today I cannot get it to work.

Are there any other ways to do the security-skipping?

I checked out some CDO-mail, but I don't think my Windows 7 will send from SMTP without some extra installation, and the workbook I'm writing on is supposed to be used by others. Therefore would like to keep it as straight-forward as possible.

Code:
Sub Mail()


' Denne skal passe til Excel 2000, Excel 2002, Excel 2003, Excel 2007, Excel 2010,
' Outlook 2000, Outlook 2002, Outlook 2003, Outlook 2007, Outlook 2010.
    
    Dim rng As Range
    Dim Stamp As String
    Dim OutApp As Object
    Dim OutMail As Object
    Dim sFileName As String
    Dim preStrBody As String
    Dim sFileName1 As String
    Dim sFileName2 As String
    Dim postStrBody As String
    Dim DesktopOpen As String
    Dim fr As Long, lr As Long
    Dim TopVisibleCell As Range
    Dim ToRangeCounter As Variant
    
    
    Set rng = Nothing
    On Error Resume Next
    'Only the visible cells in the selection
    Set rng = Sheets("Indigosec morning notes").Range("A1:M67").SpecialCells(xlCellTypeVisible)
    'You can also use a range if you want
    'Set rng = Sheets("YourSheet").Range("D4:D12").SpecialCells(xlCellTypeVisible)
    On Error GoTo 0


    'Setter adressen til folderen som skal legges på skrivebordet
    DesktopOpen = CreateObject("WScript.Shell").SpecialFolders("Desktop")
    
    'Denne gir PDF-fila dagens dato
    Stamp = Format(Date, "DD.MM.YYYY")
    
    Sheets("SetUp").Activate
    
    'Adresse og navn til filen som skal være vedlagt
    sFileName = DesktopOpen & "\XYZ\Rapport_" & Stamp & ".pdf"
    
    'Om ønskelig en ekstrafil vedlagt?
    sFileName1 = DesktopOpen & "\XYZ\DailyReport.GIF"
    
    'Om ønskelig en ekstrafil vedlagt?
    sFileName2 = DesktopOpen & "\XYZ\eMail to PDF.xlsm"
    On Error Resume Next
    
    '*** Legge på filter på de som står som aktive mottakere av e-mail
    '*** lage en gruppe med mail som kan legges inn under .BCC
            lr = Sheets("SetUp").Range("C65536").End(xlUp).Row
            
            Set rng = Sheets("SetUp").Range("D2:D" & lr)
            With Sheets("SetUp")
                .Range("$A$1:$D$4").AutoFilter Field:=4, Criteria1:="yes" ' sorterer bort alle kunder som står markert med "no" eller annet.. KUN yes Yes yEs yeS går igjennom
                
                Set TopVisibleCell = rng.Offset(1).SpecialCells(xlCellTypeVisible).Cells(1) 'denne finner selve cellen med innhold
                
                fr = TopVisibleCell.Row ' finner første synlige rad i filteret
                lr = .Range("C65536").End(xlUp).Row ' siste rad i filteret er lett å finne :-)
                
                .Range("$A$1:$D$4").AutoFilter Field:=4 'Nullstille filteret
            End With
            
            For Each xCell In Sheets("SetUp").Range("C" & fr & ":C" & lr)
             ToRangeCounter = ToRangeCounter + 1
            Next xCell
        
         If ToRangeCounter = 256 Then ToRangeCounter = 1 ' Litt usikker på denne, tror det har noe med max mailadresser å gjøre
        
             For Each xRecipient In Range("C" & fr & ":C" & lr).Resize(ToRangeCounter, 1)
                 RecipientList = RecipientList & ";" & xRecipient
             Next xRecipient
           
   Set OutApp = CreateObject("Outlook.Application")
   Set OutMail = OutApp.createitem(0)
   
        preStrBody = "[FONT=calibri]" & _
                     "God børsdag " & "

" & _
                     "Vedlagt følger morgenrapporten fra vår analyseavdeling. " & _
                     "Håper du finner informasjonen som bla bla bla. " & "

" & _
                     "Best regards / Med vennlig hilsen" & "

" & _
                     "**********" & "

" & _
                     "CEO & founder of *****" & "
" & _
                     "Indigo Sec" & "

" & _
                     "Indigo Sec
[/FONT]
" & _
                     "

"
        
    '*****Imellom her kommer GIF-filen som viser rapporten i selve mailen (se .HTMLBody)
        
    postStrBody = "[FONT=calibri][LEFT]" & _
                    "
" & "..................................................." _
                    & "

" & _
                    "CONFIDENTIALITY NOTICE:" & "
" & "This email is intended only for the person or entity to which it is addressed and may contain confidential and/or privileged material. Delivery" & "
" & _
                    "of this email or any of the information contained herein to anyone other than the intended recipient or his designated representative is unauthorized and any other use, " & "
" & _
                    "reproduction, distribution or copying of this document or the information contained herein, in whole or in part, without the prior written consent of sender or " & "
" & _
                    "its affiliates is prohibited and may be unlawful. Any performance information contained herein may be unaudited and estimated. Past performance is not necessarily an indication " & "
" & _
                    "of future performance. If you have received this message in error, please notify the sender immediately and delete this message and any related attachments. " _
                    & "

" & _
                    "..................................................." & "[/FONT][/LEFT]"
                
               ' Dette feltet sier seg selv....
                With OutMail
                    .To = "e*******gmail.com" 'cell.Value 'Scanner igjennom lista og sender privat mail, en mail pr adresse,
                                     ' slik at det ikke er nødvendig med .BCC
                    .cc = ""
                    .BCC = RecipientList
                    .Subject = "Morning notes - " & Stamp & ", Indigo Sec"
                    .Attachments.Add (sFileName) ''' Dette er PDF-fila
                    .Attachments.Add (sFileName2) ''' Dette er denne excelboka
                    .Attachments.Add (sFileName1) '''Dette er GIF-fila
                    .HTMLBody = preStrBody & "[IMG]http://www.mrexcel.com/forum/ajax.php[/IMG]" & postStrBody
                    
                    .NoAging = True
                                        
                    ' Tallet i parantes forteller hvilken konto du sender fra
                    .SendUsingAccount = OutApp.Session.Accounts.Item(1)
                    
                    .Display
                End With
                
                On Error GoTo 0
        
        Application.Wait (Now + TimeValue("0:00:02"))
        Application.SendKeys "%{s}" ', True 'Denne overstyrer varselboksen om at noen forsøker å sende en mail fra Outlook
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Kind regards
Espen
 
Last edited:

Excel Facts

How to find 2nd largest value in a column?
MAX finds the largest value. =LARGE(A:A,2) will find the second largest. =SMALL(A:A,3) will find the third smallest
Hi

I have a code that comes from rondebruin.pl's website. I have tried to deactivate the security-warning that normally pop's up by the code:

Code:
Application.Wait (Now + TimeValue("0:00:02"))
        Application.SendKeys "%{s}"

instead of just using .Send

But it seems very unreliable, today I cannot get it to work.

Are there any other ways to do the security-skipping?

I checked out some CDO-mail, but I don't think my Windows 7 will send from SMTP without some extra installation, and the workbook I'm writing on is supposed to be used by others. Therefore would like to keep it as straight-forward as possible.

Code:
Sub Mail()


' Denne skal passe til Excel 2000, Excel 2002, Excel 2003, Excel 2007, Excel 2010,
' Outlook 2000, Outlook 2002, Outlook 2003, Outlook 2007, Outlook 2010.
    
    Dim rng As Range
    Dim Stamp As String
    Dim OutApp As Object
    Dim OutMail As Object
    Dim sFileName As String
    Dim preStrBody As String
    Dim sFileName1 As String
    Dim sFileName2 As String
    Dim postStrBody As String
    Dim DesktopOpen As String
    Dim fr As Long, lr As Long
    Dim TopVisibleCell As Range
    Dim ToRangeCounter As Variant
    
    
    Set rng = Nothing
    On Error Resume Next
    'Only the visible cells in the selection
    Set rng = Sheets("Indigosec morning notes").Range("A1:M67").SpecialCells(xlCellTypeVisible)
    'You can also use a range if you want
    'Set rng = Sheets("YourSheet").Range("D4:D12").SpecialCells(xlCellTypeVisible)
    On Error GoTo 0


    'Setter adressen til folderen som skal legges på skrivebordet
    DesktopOpen = CreateObject("WScript.Shell").SpecialFolders("Desktop")
    
    'Denne gir PDF-fila dagens dato
    Stamp = Format(Date, "DD.MM.YYYY")
    
    Sheets("SetUp").Activate
    
    'Adresse og navn til filen som skal være vedlagt
    sFileName = DesktopOpen & "\XYZ\Rapport_" & Stamp & ".pdf"
    
    'Om ønskelig en ekstrafil vedlagt?
    sFileName1 = DesktopOpen & "\XYZ\DailyReport.GIF"
    
    'Om ønskelig en ekstrafil vedlagt?
    sFileName2 = DesktopOpen & "\XYZ\eMail to PDF.xlsm"
    On Error Resume Next
    
    '*** Legge på filter på de som står som aktive mottakere av e-mail
    '*** lage en gruppe med mail som kan legges inn under .BCC
            lr = Sheets("SetUp").Range("C65536").End(xlUp).Row
            
            Set rng = Sheets("SetUp").Range("D2:D" & lr)
            With Sheets("SetUp")
                .Range("$A$1:$D$4").AutoFilter Field:=4, Criteria1:="yes" ' sorterer bort alle kunder som står markert med "no" eller annet.. KUN yes Yes yEs yeS går igjennom
                
                Set TopVisibleCell = rng.Offset(1).SpecialCells(xlCellTypeVisible).Cells(1) 'denne finner selve cellen med innhold
                
                fr = TopVisibleCell.Row ' finner første synlige rad i filteret
                lr = .Range("C65536").End(xlUp).Row ' siste rad i filteret er lett å finne :-)
                
                .Range("$A$1:$D$4").AutoFilter Field:=4 'Nullstille filteret
            End With
            
            For Each xCell In Sheets("SetUp").Range("C" & fr & ":C" & lr)
             ToRangeCounter = ToRangeCounter + 1
            Next xCell
        
         If ToRangeCounter = 256 Then ToRangeCounter = 1 ' Litt usikker på denne, tror det har noe med max mailadresser å gjøre
        
             For Each xRecipient In Range("C" & fr & ":C" & lr).Resize(ToRangeCounter, 1)
                 RecipientList = RecipientList & ";" & xRecipient
             Next xRecipient
           
   Set OutApp = CreateObject("Outlook.Application")
   Set OutMail = OutApp.createitem(0)
   
        preStrBody = "<p style='font-family:calibri;font-size:11'>" & _
                     "God børsdag " & "<br><br>" & _
                     "Vedlagt følger morgenrapporten fra vår analyseavdeling. " & _
                     "Håper du finner informasjonen som bla bla bla. " & "<br><br>" & _
                     "Best regards / Med vennlig hilsen" & "<br><br>" & _
                     "**********" & "<br><br>" & _
                     "CEO & founder of *****" & "<br>" & _
                     "Indigo Sec" & "<br><br>" & _
                     "<a href=""http://www.dn.no/"">Indigo Sec</a><br></p>" & _
                     "<br><br>"
        
    '*****Imellom her kommer GIF-filen som viser rapporten i selve mailen (se .HTMLBody)
        
    postStrBody = "<p style='font-family:calibri;font-size:11', align=left>" & _
                    "<br>" & "..................................................." _
                    & "<br><br>" & _
                    "CONFIDENTIALITY NOTICE:" & "<br>" & "This email is intended only for the person or entity to which it is addressed and may contain confidential and/or privileged material. Delivery" & "<br>" & _
                    "of this email or any of the information contained herein to anyone other than the intended recipient or his designated representative is unauthorized and any other use, " & "<br>" & _
                    "reproduction, distribution or copying of this document or the information contained herein, in whole or in part, without the prior written consent of sender or " & "<br>" & _
                    "its affiliates is prohibited and may be unlawful. Any performance information contained herein may be unaudited and estimated. Past performance is not necessarily an indication " & "<br>" & _
                    "of future performance. If you have received this message in error, please notify the sender immediately and delete this message and any related attachments. " _
                    & "<br><br>" & _
                    "..................................................." & "</p>"
                
               ' Dette feltet sier seg selv....
                With OutMail
                    .To = "e*******gmail.com" 'cell.Value 'Scanner igjennom lista og sender privat mail, en mail pr adresse,
                                     ' slik at det ikke er nødvendig med .BCC
                    .cc = ""
                    .BCC = RecipientList
                    .Subject = "Morning notes - " & Stamp & ", Indigo Sec"
                    .Attachments.Add (sFileName) ''' Dette er PDF-fila
                    .Attachments.Add (sFileName2) ''' Dette er denne excelboka
                    .Attachments.Add (sFileName1) '''Dette er GIF-fila
                    .HTMLBody = preStrBody & "<img src=""cid:DailyReport.GIF"">" & postStrBody
                    
                    .NoAging = True
                                        
                    ' Tallet i parantes forteller hvilken konto du sender fra
                    .SendUsingAccount = OutApp.Session.Accounts.Item(1)
                    
                    .Display
                End With
                
                On Error GoTo 0
        
        Application.Wait (Now + TimeValue("0:00:02"))
        Application.SendKeys "%{s}" ', True 'Denne overstyrer varselboksen om at noen forsøker å sende en mail fra Outlook
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Kind regards
Espen

Upgrade to 2007 or 2010 and if your AV is OK you will not get this waning
See also
Security (Prevent displaying the dialog to Send or not Send)
 
Upvote 0
Hello Ron :)

Very nice to hear from the master of this subject. I thought it would be best to run the CDO after I read on your website, but it just ran through the code (it took some time when it had past the .send) and then nothing happend. I have a HTMLBody, but did also add .TextBody = "".

Code:
Sub Mail()


' Denne skal passe til Excel 2000, Excel 2002, Excel 2003, Excel 2007, Excel 2010,
' Outlook 2000, Outlook 2002, Outlook 2003, Outlook 2007, Outlook 2010.
    
    Dim rng As Range
    Dim Stamp As String
    Dim OutApp As Object
    Dim OutMail As Object
    Dim sFileName As String
    Dim preStrBody As String
    Dim sFileName1 As String
    Dim sFileName2 As String
    Dim postStrBody As String
    Dim DesktopOpen As String
    Dim fr As Long, lr As Long
    Dim TopVisibleCell As Range
    Dim ToRangeCounter As Variant
    
Dim iMsg As Object
Dim iConf As Object
'Dim strbody As String
Dim Flds As Variant
Set iMsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")


iConf.Load -1     'CDO Source Defaults
Set Flds = iConf.Fields
    With Flds
           .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
            .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") _
                          = "smtp.gmail.com"
            .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
            .Update
        End With


    
    Set rng = Nothing
    On Error Resume Next
    
    Set rng = Sheets("Indigosec morning notes").Range("A1:M67").SpecialCells(xlCellTypeVisible)
   
  
    On Error GoTo 0


   
    DesktopOpen = CreateObject("WScript.Shell").SpecialFolders("Desktop")
    
   
    Stamp = Format(Date, "DD.MM.YYYY")
    
    Sheets("SetUp").Activate
    
   
    sFileName = DesktopOpen & "\XYZ\Rapport_" & Stamp & ".pdf"
    
  
    sFileName1 = DesktopOpen & "\XYZ\DailyReport.GIF"
    
   
    sFileName2 = DesktopOpen & "\XYZ\eMail to PDF.xlsm"
    On Error Resume Next
    
               lr = Sheets("SetUp").Range("C65536").End(xlUp).Row
            
            Set rng = Sheets("SetUp").Range("D2:D" & lr)
            With Sheets("SetUp")
                .Range("$A$1:$D$4").AutoFilter Field:=4, Criteria1:="yes" ' sorterer bort alle kunder som står markert med "no" eller annet.. KUN yes Yes yEs yeS går igjennom
                
               
                Set TopVisibleCell = Cells(Columns("D").Rows.Count, "D").End(xlUp)
                fr = TopVisibleCell.Row ' finner første synlige rad i filteret
                lr = .Range("C65536").End(xlUp).Row ' siste rad i filteret er lett å finne :-)
                
                .Range("$A$1:$D$4").AutoFilter Field:=4 'Nullstille filteret
            End With
            
            For Each xCell In Sheets("SetUp").Range("C" & fr & ":C" & lr)
             ToRangeCounter = ToRangeCounter + 1
            Next xCell
        
         If ToRangeCounter = 256 Then ToRangeCounter = 1 ' Litt usikker på denne, tror det har noe med max mailadresser å gjøre
        
             For Each xRecipient In Range("C" & fr & ":C" & lr).Resize(ToRangeCounter, 1)
                 RecipientList = RecipientList & ";" & xRecipient
             Next xRecipient
           
    
        preStrBody = "<p style='font-family:calibri;font-size:11'>" & _
                     "God børsdag " & "<br><br>" & _
                     "Vedlagt følger morgenrapporten fra vår analyseavdeling. " & _
                     "Håper du finner informasjonen som bla bla bla. " & "<br><br>" & _
                     "Best regards / Med vennlig hilsen" & "<br><br>" & _
                     "P*********ng" & "<br><br>" & _
                     "CEO & founder of Indigo Sec" & "<br>" & _
                     "Indigo Sec" & "<br><br>" & _
                     "<a href=""http://www.dn.no/"">I***o Sec</a><br></p>" & _
                     "<br><br>"
        
    '*****Imellom her kommer GIF-filen som viser rapporten i selve mailen (se .HTMLBody)
        
    postStrBody = "<p style='font-family:calibri;font-size:11', align=left>" & _
                    "<br>" & "..................................................." _
                    & "<br><br>" & _
                    "CONFIDENTIALITY NOTICE:" & "<br>" & "This email is intended only for the person or entity to which it is addressed and may contain confidential and/or privileged material. Delivery" & "<br>" & _
                    "of this email or any of the information contained herein to anyone other than the intended recipient or his designated representative is unauthorized and any other use, " & "<br>" & _
                    "reproduction, distribution or copying of this document or the information contained herein, in whole or in part, without the prior written consent of sender or " & "<br>" & _
                    "its affiliates is prohibited and may be unlawful. Any performance information contained herein may be unaudited and estimated. Past performance is not necessarily an indication " & "<br>" & _
                    "of future performance. If you have received this message in error, please notify the sender immediately and delete this message and any related attachments. " _
                    & "<br><br>" & _
                    "..................................................." & "</p>"
                
               ' Dette feltet sier seg selv....
                With iMsg
                Set .Configuration = iConf
                    .To = "esp***********mail.com" 'cell.Value 'Scanner igjennom lista og sender privat mail, en mail pr adresse,
                                     ' slik at det ikke er nødvendig med .BCC
                    .cc = ""
                    .BCC = RecipientList
                    .From = """Espen"" <espe*********gmail.com>"
                    .Subject = "Morning notes - " & Stamp & ", Indigo Sec"
                    .Attachments.Add (sFileName) ''' Dette er PDF-fila
                    .Attachments.Add (sFileName2) ''' Dette er denne excelboka
                    .Attachments.Add (sFileName1) '''Dette er GIF-fila
                    .TextBody = ""
                    .HTMLBody = preStrBody & "<img src=""cid:DailyReport.GIF"">" & postStrBody
                    
                     .Send
                End With
                
                On Error GoTo 0
       
End Sub

The vba is supposed to send email every morning, so it should be as reliable as possible. But when the Application.SendKeys "%{s}", True starts to act funny I don't know what to do.

BTW I use 2010, on windows 7.

Kind regards
Espen
 
Upvote 0
You're right, it worked with just the .Send, and I got no security-warning popping up. But what is the case with my friends computer where this warning pop's up? He has Office 2010, just as I have.

Kind regards
Espen
 
Upvote 0
I found out that the difference between my computer (where .send works without security-warning) and my friends computer where he gets the security-warning is that I have a valid antivirus-program, and he doesn't.

Problem solved :)
 
Upvote 0

Forum statistics

Threads
1,213,550
Messages
6,114,265
Members
448,558
Latest member
aivin

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top