Avoiding Outlook Excessive Security Warnings - my code
Banana
Take a look at my code
Public Sub Send_mail()
Dim myoutlook As Outlook.Application
Dim MyMail As Outlook.MailItem
Dim Subjectline As String
Dim BodyFile As String
Dim AttchFile As String
Dim fso As FileSystemObject
Dim MyBody As TextStream
Dim MyBodyText As String
Dim objOneRecip As Outlook.Recipient
Dim Address As String
Dim strCnn As String
Set fso = New FileSystemObject
'Assunto
If Me.assunto <> "" Then
Subjectline$ = Forms!Mail_para_Grupos!assunto
Else
MsgBox "Digite o Assunto da Mensagem.É obrigatório!" & vbNewLine & vbNewLine, vbCritical, "PSDB/RS"
Forms!Mail_Gru_Pes_02_jun_05!assunto.SetFocus
Exit Sub
End If
'Arquivo texto para o corpo da Mensagem
If Me.texto <> "" Then
BodyFile$ = Forms!Mail_para_Grupos!texto
If fso.FileExists(BodyFile$) = False Then
MsgBox "The body file isn't where you say it is. " & vbNewLine & vbNewLine & "Quitting...", vbCritical, "I Ain't Got No-Body!"
Exit Sub
End If
Set MyBody = fs

penTextFile(BodyFile, ForReading, False, TristateUseDefault)
MyBodyText = MyBody.ReadAll
MyBody.Close
Else
BodyFile$ = ""
End If
Set myoutlook = New Outlook.Application
'********************************************
Set MyMail = myoutlook.CreateItem(olMailItem)
Dim Mail As String
Dim var As Variant
Dim varItm As Variant
Dim lst1 As Access.ListBox
'Dim lst2 As Access.ListBox
'Dim lst3 As Access.ListBox
'Seleciona todos os itens das Listas de Mail Para, com Cópia Para e com cópia Oculta Para
' SelTodosItensList
Set lst1 = Me![lstSelectContacts]
' Set lst2 = Me![lstSelectContactsCC]
' Set lst3 = Me![lstSelectContactsBCC]
' If lst1.ItemsSelected.Count = 0 Then
' MsgBox "Selecione e Adicione, pelo menos, um Nome."
' Exit Sub
' End If
' mail's tipo: Para
tipo_mail = 1
SelTodosItensList
If lst1.ItemsSelected.Count = 0 Then
MsgBox "Adicione e Selecione, pelo menos, um Nome em Mail Para."
' Me.grupo.SetFocus
Exit Sub
End If
For Each varItm In Me.lstSelectContacts.ItemsSelected
Mail = Mail & Me.lstSelectContacts.ItemData(varItm)
Next varItm
Debug.Print Mail
For Each var In Me.lstSelectContacts.ItemsSelected
Debug.Print Me.lstSelectContacts.ItemData(var)
Mail = Me.lstSelectContacts.ItemData(var)
On Error GoTo erro
Set objOneRecip = MyMail.Recipients.Add(Mail)
objOneRecip.Type = olTo
Next var
' mail's tipo: Com Cópia Para
tipo_mail = 2
SelTodosItensList
For Each varItm In Me.lstSelectContactsCC.ItemsSelected
Mail = Mail & Me.lstSelectContactsCC.ItemData(varItm)
Next varItm
Debug.Print Mail
For Each var In Me.lstSelectContactsCC.ItemsSelected
Debug.Print Me.lstSelectContactsCC.ItemData(var)
Mail = Me.lstSelectContactsCC.ItemData(var)
Set objOneRecip = MyMail.Recipients.Add(Mail)
objOneRecip.Type = olCC
Next var
' mail's tipo: Com Cópia Oculta Para
tipo_mail = 3
SelTodosItensList
For Each varItm In Me.lstSelectContactsCC.ItemsSelected
Mail = Mail & Me.lstSelectContactsCC.ItemData(varItm)
Next varItm
Debug.Print Mail
For Each var In Me.lstSelectContactsBCC.ItemsSelected
Debug.Print Me.lstSelectContactsBCC.ItemData(var)
Mail = Me.lstSelectContactsBCC.ItemData(var)
Set objOneRecip = MyMail.Recipients.Add(Mail)
objOneRecip.Type = olBCC
Next var
'******************************************
MyMail.Subject = Subjectline$
MyMail.Body = MyBodyText
If Me.anexo <> "" Then
AttchFile$ = Forms!Mail_Gru_Pes_02_jun_05!anexo
MyMail.Attachments.Add AttchFile$, olByValue
Else
AttchFile$ = ""
End If
MyMail.Display
Set MyMail = Nothing
Set myoutlook = Nothing
tipo_mail = 1
DelTodosReg ("PessoasMail")
EliminaSelItensList
Me.lstSelectContacts.Requery
' Me.nome_grupo_to = ""
Me.qtde_to = ""
tipo_mail = 2
DelTodosReg ("PessoasMailCC")
EliminaSelItensList
Me.lstSelectContactsCC.Requery
' Me.nome_grupo_cc = ""
Me.qtde_cc = ""
tipo_mail = 3
DelTodosReg ("PessoasMailBCC")
EliminaSelItensList
Me.lstSelectContactsBCC.Requery
' Me.nome_grupo_bcc = ""
Me.qtde_bcc = ""
EliminaSelItensList
tipo_mail = 4 'Pessoas
DelTodosReg ("PessoasMailEsc")
EliminaSelItensList
Me.lstSelectPessoas.Requery
' Me.nome_grupo_bcc = ""
' Me.qtde_bcc = ""
EliminaSelItensList
erro:
Exit Sub
End Sub