Este fórum está sendo desativado

[Ricardomaia]

Pessoal estou procurando uma macro que possa tirar uma print de uma determinada area e que possa colar na area de trabalho , estava tentando uma que vi na internet porem a qualidade sai pessima.

Sub Salva_Range_Como_Imagem()
'http://tech.groups.yahoo.com/group/ms_e ... sage/38865
' =========================================
' Code to save selected Excel Range as Image
' adjusted by Pascal Daulton 15-Sep-2011
'Readaptado em 16-09-2011 por RLM
' =========================================
Dim sRange As Range
Dim oCht As Chart
Dim oImg As Picture
Dim sPath As String, rRange As String


sPath = ThisWorkbook.Path
'Acrescenta a barra invertida "\"; se necessaria
If Right(sPath, 1) <> "\" Then
sPath = sPath & "\"
Else
sPath = sPath
End If

Set sRange = Application.InputBox(prompt:= _
"Selecione o intervalo a ser copiado", _
Title:="Lê Intervalo", Type:=8)
If sRange.Address = "" Then
MsgBox "Sem informação da range"
Exit Sub
End If
With sRange
.CopyPicture xlScreen, xlPicture
Set oCht = ActiveSheet.ChartObjects.Add(50, 50, .Width + 5, .Height + 5).Chart
End With


With oCht
.Paste
.Shapes(1).Left = -.ChartArea.Left
.Shapes(1).Top = -.ChartArea.Top
.Parent.Width = sRange.Width
.Parent.Height = sRange.Height
.Export Filename:=sPath & "AreaSalva.gif", Filtername:="gif"
.Parent.Delete
End With
End Sub

[Jonathaluis]

Ricardomaia, boa tarde!

Dei uma estudada nessa macro aí, e editei um pouco. Antes de mandar para a área de transferência, a macro coloca a imagem em um objeto, aumentei o tamanho (dobrei o tamanho multiplicando por 2) do objeto com print dentro, com isso a imagem aumentou, depois um comando Copy para manter ela na área de transferência, testa aí.

[Ricardomaia]

Ola jhonata , testei aqui e nao esta salvando na area de trabalho , porem eu tambem mandei o codigo errado , o certo e este:

Este salva na area de trabalho porem queria em jpg com qualidade, pus pra jpg aqui mas mesmo assim sai horrivel.

Sub ExportarAreaParaGif()
'
' http://jjoao2k.no.sapo.pt
' Objectivo: exportar uma area para um ficheiro de imagem
' usando o filtro GIF
'
Dim tmpSheet As Worksheet
Dim tmpChart As Chart
Dim tmpImg As Object
Dim fGIF As String
Dim margem As Integer

On Error GoTo erro
'
'caso seja uma area fixa a copiar
'Range([area_a_copiar]).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 = 8
With .Parent
.Height = tmpImg.Height + margem
.Width = tmpImg.Width + margem
End With
End With
'localização e nome do ficheiro de imagem
fGIF = ThisWorkbook.Path & _
"\imagem_" & Format(Now, "yyyymmdd_hhmmss") & ".gif"
'exportar grafico
tmpChart.Export Filename:=fGIF, FilterName:="gif"
'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 "Imagem exportada para o ficheiro:" & fGIF, _
vbInformation, _
"Exportar para GIF"
GoTo fim
erro:
MsgBox "Erro: " & Err.Description, _
vbCritical, _
"Erro: " & Err.Number
fim:
Set tmpSheet = Nothing
Set tmpChart = Nothing
Set tmpImg = Nothing
End Sub

[Ricardomaia]

e ae ninguem consegue me ajudar?

[WeslleyKeif]

Boa tarde.,

manda sua planilha para que eu possa dar um olhada.


Fico no aguardo!

desde já muito obrigado!