Sábado, 01 setembro 2018
  0 Respostas
  2.6 mil visitas
Instalei o kutools para ajudar em um projeto de trabalho. Também gerencio um relatório de uma grande empresa que possui uma macro criando um e-mail a partir das informações inseridas. Essa macro parou de funcionar no meu computador. Funciona nos computadores que não possuem kutools. Alguém já passou por algo assim antes? Aqui está a macro que funciona bem em outros computadores:

SubMail_Sheet_Outlook_Body()
'Trabalhando no Excel 2000-2016
Application.ReferenceStyle = xlA1
Dim rng como alcance
Dim OutApp como objeto
Escurecer OutMail como objeto
Dim xFolder como String
Dim xSht As Planilha
Dim xSub como string
Resposta de escurecimento como string
Escurecer mensagem como string
Dim Style Como String
Dim Título como String

Definir xSht = ActiveSheet
Msg = "Tem certeza de que deseja enviar este formulário por e-mail?" ' Definir mensagem.
Estilo = vbYesNo + vbCritical + vbDefaultButton2 ' Define botões.
Title = "Confirmação de envio de e-mail" ' Define o título.
Resposta = MsgBox(Msg, Estilo)

Se Resposta = vbSim Então
xFolder = Environ("USERPROFILE") + "\Desktop\" + "\Field Audit Form--" + CStr(xSht.Cells(19, "A").Value) + "--.pdf"
'xSub = "Auditoria de campo para loja " + CStr(xSht.Cells(19, "A").Value)
Com aplicação
.EntableEvents = False
.ScreenUpdating = False
Terminar com

Definir rng = Nada
Definir rng = ActiveSheet.UsedRange
'Você também pode usar um nome de planilha
'Set rng = Sheets("YourSheet").UsedRange

Set OutApp = CreateObject("Outlook.Application")
Definir OutMail = OutApp.CreateItem(0)
Dim varCellvalue As Long




On Error Resume Next
Com o OutMail
.Para = ""
.CC = ""
.BCC = ""
.Assunto = "Recapitulação"
.Anexos.Adicionar xFolder
.HTMLBody = RangetoHTML(rng)
.Display 'ou use .Display

Terminar com
Em erro GoTo 0

Com aplicação
.EnableEvents = True
.ScreenUpdating = True
Terminar com

Definir OutMail = Nada
Set OutApp = Nada
Se acabar
End Sub


Função RangetoHTML(rng As Range)
' Trabalhando no Office 2000-2016
Dim fso como objeto
Dim ts como objeto
Dim TempFile como string
Dim TempWB como pasta de trabalho

TempFile = Environ$("temp") & "\" & Format(Agora, "dd-mm-aa h-mm-ss") & ".htm"

'Copia o intervalo e cria uma nova pasta de trabalho para colar os dados em
rng.Copiar
Definir TempWB = Workbooks.Add(1)
Com TempWB.Sheets(1)
.Cells(1).Colar Pasta Especial:=8
.Cells(1).PasteSpecial xlPasteValues, , Falso, Falso
.Cells(1).PasteSpecial xlPasteFormats, , Falso, Falso
.Células(1).Selecione
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = Verdadeiro
.DrawingObjects.Delete
Em erro GoTo 0
Terminar com

'Publica a planilha em um arquivo htm
Com TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Nome do arquivo:=TempFile, _
Planilha:=TempWB.Planilhas(1).Nome, _
Fonte:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publicar (Verdadeiro)
Terminar com

'Lê todos os dados do arquivo htm para RangetoHTML
Defina fso = CreateObject ("Scripting.FileSystemObject")
Defina ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.readall
ts.Fechar
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")

'Fechar TempWB
TempWB.Fechar savechanges:=Falso

'Deleta o arquivo htm que usamos nesta função
Matar arquivo temporário
Definir ts = Nada
Definir fso = nada
Definir TempWB = Nada

Função final
Ainda não há respostas para esta postagem.