Fórum Excel Bácico, Avançado e Vba

Este fórum é destina a usuário de Excel, que queiram compartilhar informações a básicas, avançadas e programação em VBA...
 
InícioInício  FAQFAQ  BuscarBuscar  MembrosMembros  GruposGrupos  Registrar-seRegistrar-se  Login  

Compartilhe | 
 

 Enviar Resumo de Formulario por Ooutlook

Ver o tópico anterior Ver o tópico seguinte Ir em baixo 
AutorMensagem
jrogowski



Mensagens : 23
Data de inscrição : 27/09/2014

MensagemAssunto: Enviar Resumo de Formulario por Ooutlook   Dom Mar 15, 2015 2:46 pm

Bom dia pessoal,

Estou precisando de uma ajuda, tenho um formulario onde os usuarios preenchem fazendo solicitações de serviços e após feito este formulario é anexado ao e-mail e enviado para a equipe de manutenção.

preciso de uma macro onde apenas uma parte deste formulário ( A1:H24 ) por exemplo seja inserido como uma tabela no corpo do e-mail. Podem em ajudar?

Caso necessário mais detalhes me falem.

Obrigado
Voltar ao Topo Ir em baixo
Ver perfil do usuário
alexandrevba



Mensagens : 1820
Data de inscrição : 13/07/2011
Localização : Serra - ES

MensagemAssunto: Re: Enviar Resumo de Formulario por Ooutlook   Seg Mar 16, 2015 3:14 am

Boa noite!!

Conforme postagem em:
http://gurudoexcel.com/forum/t/enviar-formulario-por-e-mail/#post-6032
Código:
Sub Mail_Selection_Range_Outlook_Body()
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
'Don't forget to copy the function RangetoHTML in the module.
'Working in Excel 2000-2013
    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object

    Set rng = Nothing
    On Error Resume Next
    'Only the visible cells in the selection
    Set rng = Selection.SpecialCells(xlCellTypeVisible)
    'You can also use a fixed range if you want
    Set rng = Sheets("Plan1").Range("A1:B10").SpecialCells(xlCellTypeVisible)
    On Error GoTo 0

    If rng Is Nothing Then
        MsgBox "A seleção não é um intervalo ou a guia está protegida" & _
              vbNewLine & "por favor corrija e tente novamente.", vbOKOnly
        Exit Sub
    End If

    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    On Error Resume Next
    With OutMail
        .To = "ron@debruin.nl" 'Destinatário
        .CC = ""
        .BCC = ""
        .Subject = "Enviando intervalo de guia via email"
        .HTMLBody = RangetoHTML(rng)
        .Send  'or use .Display
    End With
    On Error GoTo 0

    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With

    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub
Código:

Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2013
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook

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

    'Copy the range and create a new workbook to past the data in
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With

    'Publish the sheet to a htm file
    With TempWB.PublishObjects.Add( _
        SourceType:=xlSourceRange, _
        Filename:=TempFile, _
        Sheet:=TempWB.Sheets(1).Name, _
        Source:=TempWB.Sheets(1).UsedRange.Address, _
        HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With

    'Read all data from the htm file into RangetoHTML
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.readall
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")

    'Close TempWB
    TempWB.Close savechanges:=False

    'Delete the htm file we used in this function
    Kill TempFile

    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function
Att
Voltar ao Topo Ir em baixo
Ver perfil do usuário
jrogowski



Mensagens : 23
Data de inscrição : 27/09/2014

MensagemAssunto: Re: Enviar Resumo de Formulario por Ooutlook   Ter Mar 17, 2015 2:45 am

Infelizmente, alexandrevba, não consegui, inseri o código tudo correto, eo executar a macro envia o e-mail, porem não vai o anexo, o corpo do e-mail vai em branco.

Outra coisa é que salvo e fecho a planilha, ao abrir novamente o código que eu inseri não aparece mais.

Muito obrigado por tentar, más desta vez não consegui fazer funcionar com as dicas

Att
Voltar ao Topo Ir em baixo
Ver perfil do usuário
alexandrevba



Mensagens : 1820
Data de inscrição : 13/07/2011
Localização : Serra - ES

MensagemAssunto: Re: Enviar Resumo de Formulario por Ooutlook   Ter Mar 17, 2015 5:10 pm

Bom dia!!

Veja:
http://gurudoexcel.com/forum/t/enviar-formulario-por-e-mail/#post-6084

Att
Voltar ao Topo Ir em baixo
Ver perfil do usuário
Conteúdo patrocinado




MensagemAssunto: Re: Enviar Resumo de Formulario por Ooutlook   Hoje à(s) 10:50 pm

Voltar ao Topo Ir em baixo
 
Enviar Resumo de Formulario por Ooutlook
Ver o tópico anterior Ver o tópico seguinte Voltar ao Topo 
Página 1 de 1
 Tópicos similares
-
» Erro ao enviar mensagem com formulário
» Erro #230 ao enviar mensagem de formulario
» Campo de texto para formulario de enviar PM
» Quero um formulario de postagem para meu pedido de designer.
» Modificar local de cadastro e enviar email a todos membros

Permissão deste fórum:Você não pode responder aos tópicos neste fórum
Fórum Excel Bácico, Avançado e Vba :: Usuários Básico :: Excel Básico-
Ir para: