Macro com execução automática no PowerPoint

Macro com execução automática no PowerPoint

O problema que me foi proposto é o seguinte. Um grupo de usuários utiliza uma máquina em horários diferentes para fazer uma mesma edição em duas imagens da internet de mapas meteorológicos que são atualizados a cada 6 horas, o resultado final é uma única imagem composta pelos mapas.

O meu cliente solicitou a automatização desta tarefa levando em conta que os usuários não dispunham de softwares avançados de edição de imagens, além de serem leigos neste assunto. Propus então uma macro no PowerPoint para automatizar o máximo possível.

Bem, a macro faz o seguinte:

- Inicia automaticamente ao abrir o arquivo PPT;

- Abre um formulário com dois botões;

- O botão “Rede de Meteorologia da Aeronáutica” abre o navegador na página de origem das imagens, por segurança esta etapa o cliente não quis automatizar;

- O botão “Criar imagem” pega as imagens previamente salvas num diretório, redimensiona, posiciona e salva as duas imagens num único arquivo.

Em seguida estão os manuais para instalação da macro, como utilizar e o código fonte.

Para executar uma macro automaticamente no PowerPoint é preciso instalar o suplemento AutoEvents.ppa que posso encaminhar para quem se interessar.

Instalação da macro

Copie a pasta “Cartas Meteorológicas” contendo os arquivos “AutoEvents.ppa” e o arquivo “CriarImagem3.ppt” no diretório raiz da unidade C
Abra o Microsoft Office PowerPoint 2003
Click no menu Ferramentas>>Suplementos

Click no botão “Adicionar novo” da janela de suplementos
Aponte para o arquivo c:\Cartas Meteorológicas\AutoEvents.ppa
Click no botão fechar
Na barra de menu do PowerPoint escolha a opção Ferramentas>>Auto events>>Auto events options

Habilite todas as opções do Auto events

Click no botão ok
No menu do PowerPoint escolha a opção Ferramentas>>Macro>>Segurança>> na aba “Nível de segurança” escolha Médio

Na aba “Fontes confiáveis” habilite as opções “Confiar em todos os suplementos e modelos instalados” e “Confiar no acesso ao projeto do Visual Basic”

Click no botão ok e feche o Powerpoint

Como utilizar

1) Abra o arquivo c:\Cartas Meteorológicas\CriarImagem3.ppt

2) Click no botão “Habilitar macros”

3) Click no botão “Rede de Meteorologia da Aeronáutica” e uma janela do Internet Explorer abrirá apontando para o site www.redemet.aer.mil.br

4) Escolha a opção “Imagem de Satélite”

5) Clique em Data e Hora da linha “América do Sul”

6) Apresentada a imagem, clique com o botão direito sobre a imagem e escolha a opção “Salvar Imagem como...” e no campo Nome do arquivo digite “imagem1” na pasta c:\Cartas Meteorológicas (caso já haja um arquivo com o mesmo nome sobrescreva)

7) Novamente no site da Redemet, escolha a opção “Cartas SIGWX”

> No bloco “S U P / F L 2 5 0”, clique em Data e Horas da linha que lhe interessa

> Apresentada a imagem, clique com o botão direito sobre ela e escolha “Salvar Imagem como...” e no campo Nome do arquivo digite “imagem2” na pasta c:\Cartas Meteorológicas (caso já haja um arquivo com o mesmo nome sobrescreva)

8) Clique no botão “Criar imagem” da Macro criar imagem e ela criará uma imagem na pasta c:\Cartas Meteorológicas\Criar Imagem3\Slide1.JPG

Código fonte da macro

Private Sub BtnCriarImagem_Click()

ActiveWindow.Selection.SlideRange.Shapes.AddPicture(FileName:="c:\Cartas Meteorológicas\imagem1.bmp", LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, Left:=60, Top:=190, Width:=420, Height:=400).Select
With ActiveWindow.Selection.ShapeRange

.IncrementLeft -11.12

.IncrementTop -190.12

End With

ActiveWindow.Selection.Unselect

ActiveWindow.Selection.SlideRange.Shapes.AddPicture(FileName:="c:\Cartas Meteorológicas\imagem2.gif", LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, Left:=-369, Top:=-122, Width:=1281, Height:=1026).Select

ActiveWindow.LargeScroll Down:=-1

ActiveWindow.LargeScroll ToRight:=-1

With ActiveWindow.Selection.ShapeRange

.ScaleWidth 0.5, msoFalse, msoScaleFromBottomRight

.ScaleHeight 0.5, msoFalse, msoScaleFromBottomRight

End With

With ActiveWindow.Selection.ShapeRange

.IncrementLeft -264.38

.IncrementTop -52.25

End With

With ActiveWindow.Selection.ShapeRange

.ScaleWidth 0.86, msoFalse, msoScaleFromBottomRight

.ScaleHeight 0.86, msoFalse, msoScaleFromBottomRight

End With

With ActiveWindow.Selection.ShapeRange

.IncrementLeft -68.12

.IncrementTop -14.25

End With

With ActiveWindow.Selection.ShapeRange

.ScaleWidth 0.84, msoFalse, msoScaleFromBottomRight

.ScaleHeight 0.84, msoFalse, msoScaleFromBottomRight

End With

With ActiveWindow.Selection.ShapeRange

.IncrementLeft -68#

.IncrementTop -56.62

End With

ActiveWindow.Selection.ShapeRange.IncrementTop -4.75

ActiveWindow.Selection.ShapeRange.IncrementLeft -5.75

ActiveWindow.Selection.ShapeRange.IncrementLeft -5.62

ActiveWindow.Selection.ShapeRange.IncrementTop -5.75

ActiveWindow.Selection.ShapeRange.IncrementTop 0.38

ActiveWindow.Selection.ShapeRange.IncrementTop 5.62

ActiveWindow.Selection.ShapeRange.IncrementTop 5.75

ActiveWindow.Selection.ShapeRange.IncrementTop -0.38

ActiveWindow.Selection.ShapeRange.IncrementTop -5.62

ActiveWindow.Selection.ShapeRange.IncrementTop -5.75

ActiveWindow.Selection.Unselect

'Salva arquivo JPG como imagem>>seleciona todo documento>>limpa documento

ActivePresentation.SaveAs FileName:="c:\Cartas Meteorológicas\CriarImagem3.jpg", FileFormat:=ppSaveAsJPG, EmbedTrueTypeFonts:=msoFalse

ActiveWindow.Selection.SlideRange.Shapes.SelectAll

ActiveWindow.Selection.ShapeRange.Delete

ActivePresentation.Save

End Sub

Private Sub CommandButton2_Click()

'Abre Site

Shell ("C:\Arquivos de Programas\Internet Explorer\iexplore.exe http:\\www.redemet.aer.mil.br")

End Sub

' Para executar a macro automaticamente é preciso instalar o suplemento AutoEvents.ppa

' Módulo abrir_auto

Sub auto_open()

UserForm1.Show

End Sub