espenskeie
Well-known Member
- Joined
- Mar 30, 2009
- Messages
- 636
- Office Version
- 2016
- Platform
- 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:
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.
Kind regards
Espen
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 SubEspen
Last edited:
