Bem amigo, pesquisando aqui na Net, eu encontrei isso aqui, testei separadamente e abriu conforme exatamente eu quero, porem nao sei como adaptar na Macro que o amigo fez a arrumacao, portanto poderia unir a macro de assinatura no codigo mais abaixo ?
Outra coisa, conforme ja relatei, a alteracao por vc fornecidas na sua ultima postagem deu erros, portanto voltei a anterior e troquei o 8 por 9 , conforme tb ja mencionado, e deu certo, so falta agora incluir a assinatura e o envio de email individual conforme Q22 =1 ou ""
Option Explicit
Dim assinatura As Variant
Public Function pega_assinatura(ByVal sFile As String) As String
'Dick Kusleika
Dim fso As Object
Dim ts As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
pega_assinatura = ts.ReadAll
ts.Close
End Function
Sub Cria_mensagem_HTML()
'Creates a new e-mail item and modifies its properties.
Dim olapp As Outlook.Application
Dim objMail As MailItem
Set olapp = Outlook.Application
'Create mail item
Set objMail = olapp.CreateItem(olMailItem)
' assinatura = pega_assinatura("C:Documents and Settings" & _
' Environ("username") & "AppDataRoamingMicrosoftAssinaturasPaulo.htm")
assinatura = pega_assinatura("C:AssinaturasAmigo Lojista.Html") ' & _
' Environ("username") & "Amigo Lojista.html")
With objMail
'Set body format to HTML
'a tag
'quebra linha
'a tag formata o texto para negrito
.BodyFormat = olFormatHTML
.HTMLBody = "Texto " & assinatura
.Display
End With
End Sub
Option Explicit
Sub XA_Lojas_Convites()
'Setting up the Excel variables.
Dim olapp As Outlook.Application
Dim OlMensagem As Outlook.MailItem
Dim wb As Workbook
Dim wsEN As Worksheet
Dim wsLoja As Worksheet
Dim wsEstado As Worksheet
Dim wsSendConvite As Worksheet
Dim iCounter As Integer
Dim Dest As Variant
Dim SDest As String
Dim Estado As String
Dim BuscaEstado As Range
Dim AbrevEstado As String
Dim Leitura As String
Dim contaEmail As String
Dim idEmail As Integer
Dim strbody As String
Dim Loja As String
Dim Caminho As String
Dim Quebralin1 As String
Dim QuebraLin2 As String
Dim ContCopy As Long
Dim i As Long
Dim j As Long
Dim w As Long
Set wb = ThisWorkbook
Set wsEN = wb.Worksheets("EN")
Set wsSendConvite = wb.Worksheets("Enviar Convites")
Quebralin1 = "<br>"
QuebraLin2 = "<br><br>"
Caminho = "C:UsersAndreDesktopPedidos Gauer"
' Enviar Convites Lojas
For i = 11 To 13
For j = 5 To 9
ContCopy = ContCopy + 1
If wb.ActiveSheet.Cells(i, j).Value = "" Then
Run "Copiar" & ContCopy
GoTo Segue
End If
Next j
Next i
Run "Copiar1"
Segue:
Loja = wb.ActiveSheet.Range("A1").Value
Set wsLoja = wb.Worksheets(Loja)
If wb.ActiveSheet.Range("K4").Value = 1 Then
strbody = "<H2>" & _
wsSendConvite.Range("V2").Value & _
"</H2>" & _
"<H3 style='color: #870c0c'>" & _
wsSendConvite.Range("V6").Value & _
"</H3>" & _
"<H3>" & _
wsSendConvite.Range("V10").Value & QuebraLin2 & _
wsSendConvite.Range("V14").Value & QuebraLin2 & _
wsSendConvite.Range("Z18").Value & QuebraLin2 & _
wsSendConvite.Range("Z22").Value & _
"</H3>" & _
QuebraLin2 & "<B>Obrigado por ser nosso parceiro, conte comigo!!</B>" & QuebraLin2
Else
strbody = "<H2>" & _
wsSendConvite.Range("Z2").Value & _
"</H2>" & _
"<H3 style='color: #870c0c'>" & _
wsSendConvite.Range("Z6").Value & _
"</H3>" & _
"<H3>" & _
wsSendConvite.Range("Z10").Value & QuebraLin2 & _
wsSendConvite.Range("Z14").Value & QuebraLin2 & _
wsSendConvite.Range("Z18").Value & QuebraLin2 & _
wsSendConvite.Range("Z22").Value & QuebraLin2 & _
wsSendConvite.Range("Z23").Value & QuebraLin2 & _
wsSendConvite.Range("Z24").Value & QuebraLin2 & _
wsSendConvite.Range("Z25").Value & QuebraLin2 & _
wsSendConvite.Range("Z26").Value & _
"</H3>" & _
QuebraLin2 & "<B>Obrigado por ser nosso parceiro, conte comigo!!</B>" & QuebraLin2
End If
Saltar:
Leitura = wsLoja.Range("I7").Value
Estado = Application.Caller
Application.ScreenUpdating = False
Set wsEstado = wb.Worksheets(Estado)
wsEstado.Visible = True
Application.DisplayAlerts = False 'desabilite o alerta
wb.ActiveSheet.Range("L2").Select
Set BuscaEstado = wb.ActiveSheet.Range("A3:A8").Find(Estado, LookIn:=xlValues, LookAt:=xlWhole)
If BuscaEstado Is Nothing Then
MsgBox "Estado não localizado"
GoTo Fim
Else
AbrevEstado = wsLoja.Cells(BuscaEstado.Row, 1).Value
End If
' Preste atencao aqui
contaEmail = wsLoja.Range("I8").Value
'Quero que aqui, ao inves de ter RJ tenha a variavel Estado que vai estar associado ao click na regiao do mapa.
wb.Worksheets(AbrevEstado).Select
iCounter = 2 'inicia na linha 2
'Create the Outlook application and the empty email.
Set olapp = CreateObject("Outlook.Application")
Set OlMensagem = olapp.CreateItem(0)
'------------------------------------------------------------------------------
'Este laço verifica se o nome da conta w no registro do windows é igual ao valor da célula
For w = 1 To olapp.Session.Accounts.Count
If olapp.Session.Accounts.Item(w).DisplayName = contaEmail Then 'Se for verdadeiro, solicita confirmação
If MsgBox("O E-mail será enviado usando a conta " & contaEmail & ". Confirma ?" & " ( Estado - " & Estado & " )", vbQuestion + vbYesNo, "Envio de e-mail") = vbYes Then
idEmail = w 'Define o id da conta para o comando enviar
Exit For 'Sai do laço
Else
wsEstado.Visible = False
wsLoja.Select
GoTo Fim 'Senão sai da rotina
End If
End If
Next
'-------------------------------------------------------------------------------
'Using the email, add multiple recipients, using a list of addresses in column C.
With OlMensagem
For iCounter = 2 To WorksheetFunction.CountA(Columns(3)) ' Linha 2 da coluna 3
'Sheets("Email").Select
SDest = SDest & ";" & Cells(iCounter, 3).Value
Next iCounter
' Sheets("parar").Select
'Do additional formatting on the BCC and Subject lines, add the body text from the spreadsheet, and send.
.Display
If wsSendConvite.Range("Q15").Value = 1 Then
.BCC = SDest
Else
.To = SDest
End If
If wsSendConvite.Range("K4").Value = 1 Then
.Subject = "Tabela de Pedidos da Gauer do Brasil"
Else
.Subject = "Tabela de Pedidos da Leader Nutrition"
End If
.HTMLBody = strbody & Quebralin1 & .HTMLBody
For i = 1 To 4
If wsLoja.Range("F" & i).Value > 0 Then
.Attachments.Add Caminho & wsLoja.Range("F" & i).Value & wsLoja.Range("I" & i).Value
End If
Next i
.ReadReceiptRequested = Leitura ' confirmação de leitura
.SendUsingAccount = olapp.Session.Accounts.Item(idEmail)
If wsLoja.Range("I6").Value = "SEND" Then
.Send
Else
.Display
End If
wsEN.Select
' Limpar Email Planilha EN ( Enviar Convites )
wsEN.Range("C1:C99").ClearContents
wsEN.Range("D1").Select
wsLoja.Select
If wsLoja.Range("K12").Value = 105 Then
wsLoja.Range("E11:I13").ClearContents
End If
Sheets(Estado).Visible = False
GoTo Fim
End With
Exit Sub
Fim:
'Clean up the Outlook application.
Set BuscaEstado = Nothing
Set OlMensagem = Nothing
Set olapp = Nothing
Set wb = Nothing
Set wsEN = Nothing
Set wsSendConvite = Nothing
Set wsLoja = Nothing
Set wsEstado = Nothing
End Sub
Postado : 16/04/2016 2:22 pm