- 18 Mai 2016 às 13:20
#10755
Bom,
O código está aí abaixo, achei na net, preciso que ele envie uma imagem legível com boa qualidade, essa que ele envia não serve, é ruim. E preciso centralizá-la.
O código está aí abaixo, achei na net, preciso que ele envie uma imagem legível com boa qualidade, essa que ele envia não serve, é ruim. E preciso centralizá-la.
Código: Selecionar todos
Obrigado!Private Sub Gera_Imagem()
Dim tmpSheet As Worksheet
Dim tmpChart As Chart
Dim tmpImg As Object
Dim fjpeg As String
Dim margem As Integer
On Error GoTo erro
'Caso seja uma area fixa a copiar
Range("A1:O15").CopyPicture _
Appearance:=xlScreen, _
Format:=xlBitmap
'Usar a selecção activa
'Selection.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
'impede que se veja a acção acelerando o procedimento de cópia e exportação
Application.ScreenUpdating = False
'uma folha para colocarmos o grafico sem atrapalhar o resto
Set tmpSheet = Worksheets.Add
'colocar um grafico nesta nova folha
Charts.Add
'definições essenciais ao grafico, para que fique numa worksheet
'e não numa folha grafico
ActiveChart.Location Where:=xlLocationAsObject, Name:=tmpSheet.Name
'Colar a zona copiada para dentro da area do grafico
Set tmpChart = ActiveChart
With tmpChart
.Paste
Set tmpImg = Selection
With .ChartArea
'--------->
'(não essencial ao funcionamento da rotina)
'coloca um degrade no fundo do grafico
' .Fill.OneColorGradient _
' Style:=msoGradientHorizontal, _
' Variant:=1, _
' Degree:=0.231372549019608
'<----------
'sem linha de rebordo
.Border.LineStyle = xlNone
End With
'configurar a area do grafico acrescentando
'uma pequena borda ao redor da imagem centrando esta
margem = 1
With .Parent
.Height = tmpImg.Height + margem
.Width = tmpImg.Width + margem
End With
End With
'localização e nome do ficheiro de imagem
'fjpeg = ThisWorkbook.Path & _
"\Teste.jpeg"
'localização e nome do ficheiro de imagem
fjpeg = Environ("temp") & "\Teste.jpeg"
'exportar grafico
tmpChart.Export Filename:=fjpeg, FilterName:="jpeg"
'eliminar a folha temporaria sem avisos
Application.DisplayAlerts = False
tmpSheet.Delete
Application.DisplayAlerts = True
'repor o estado normal
Application.ScreenUpdating = True
'aviso de operação terminada
' MsgBox "Seu Arquivo encontra-se em " & fjpeg, _
' vbInformation, _
' ".:: Exportação"
GoTo fim
erro:
MsgBox "Erro: " & Err.Description, _
vbCritical, _
"Erro: " & Err.Number
fim:
Set tmpSheet = Nothing
Set tmpChart = Nothing
Set tmpImg = Nothing
End Sub
Function GetBoiler(ByVal sFile As String) As String
Dim fso As Object
Dim ts As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
GetBoiler = ts.readall
ts.Close
End Function
Private Sub Email_Imagem()
'Não se esqueça de copiar o GetBoiler função no módulo.
'Trabalhar no Office 2000-2010
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Dim SigString As String
Dim Signature As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
'Envindo para os enderecos abaixos
.To = ""
'Enviando com Copia para o enderecos abaixos
.CC = ""
'Enviando com Copia Oculta para o enderecos abaixos
.BCC = ""
'Titulo do Email
.Subject = Relatorio
'Corpo do Email
.HTMLBody = strbody & "<BR><BR>" & _
"<img src='" & Environ("temp") & "\Teste.jpeg'>" & _
Signature
'Anexar aquivos
'.Attachments.Add (Diretorio1)
.Display 'Exibição do Display
'.Send 'Envio sem Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Sub Email_Com_Imagem()
Call Gera_Imagem
Call Email_Imagem
Kill (Environ("temp") & "\Teste.jpeg")
End Sub
Editado pela última vez por Guilhermefeijo em 18 Mai 2016 às 14:27, em um total de 1 vez.
