Exportar area de uma worksheet para um Imagem - JJoão (10/2006)
Dúvida: "Em uma planilha tenho alguns lançamentos que abrangem da celula B2 até J20, então seleciono os dados, copio e com o Shift pressionado clico em Editar e tem a opção Colar Figura, e é inserido uma cópia como uma figura, agora o que eu gostaria de saber é se tem como salvar essa figura no diretório armazenando para poder visualiza-la como se fosse uma imagem.A intenção com isso é que nessa planilha são feitos pedidos e em vez de gerar uma cópia como arquivo do excel, gostaria que fossem como uma imagem que se possa abri-la para imprimir."
Solução: Macro que copia a selecção activa, ou uma area predefinida, como imagem para um area de grafico, e executa a exportação usando o filtro gif.
Area selecionada para copiar como imagem |
|
Resultado já em ficheiro gif |
|
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
|