Macro to insert, compress then save pictures on Excel workbook

caincha · Mar 8, 2013

I have this macro to save a photo report from work and I can't seem to make it work just right. Everything works fine, but it does not compress the pictures, could anyone point out what I might be doing wrong?

Here it is:

Code:

[COLOR=#808080]Sub BotaoFotos()'Application.ScreenUpdating = False
On Error Resume Next
'MACRO CRIADA POR EM 04/02/2013
'Para: RELATÓRIO FOTOGRÁFICO PROJETO
'Função: Inserir fotos


'INSERINDO O NUMERO IDENTIFICADOR
If Cells(4, 3) <> "" Then
GoTo 3
End If
2 Numero_identificador = InputBox(prompt:="DIGITE O NUMERO IDENTIFICADOR", Default:="")
If Numero_identificador = "" Then
GoTo 69
End If
Cells(4, 3) = Numero_identificador
If Cells(4, 3) = "" Then
    MsgBox "FAVOR DIGITAR O NUMERO IDENTIFICADOR", vbExclamation, "ALERTA"
GoTo 2
End If


'INSERINDO O LOCALIZADOR
3 If Cells(4, 5) <> "" Then
GoTo 5
End If
4 Localizador = InputBox(prompt:="INSIRA O LOCALIZADOR", Default:="")
If Localizador = "" Then
GoTo 69
End If
Cells(4, 5) = Localizador
If Cells(4, 5) = "" Then
MsgBox "FAVOR DIGITAR O LOCALIZADOR", vbExclamation, "ALERTA"
GoTo 4
End If


'INSERINDO O NUMERO DE REVISAO
5 If Cells(4, 7) <> "" Then
GoTo 7
End If
6 Revisao = InputBox(prompt:="INSIRA O NUMERO DA REVISAO", Default:="")
If Revisao = "" Then
GoTo 69
End If
Cells(4, 7) = Revisao
If Cells(4, 7) = "" Then
MsgBox "FAVOR DIGITAR O NUMERO DA REVISÃO", vbExclamation, "ALERTA"
GoTo 6
End If


'INSERINDO A DATA DA REVISAO
7 If Cells(2, 11) <> "" Then
GoTo 9
End If
8 Data_Revisao = InputBox(prompt:="INSIRA A DATA DA REVISAO", Default:="")
If Data_Revisao = "" Then
GoTo 69
End If
Cells(2, 11) = Data_Revisao
If Cells(2, 11) = "" Then
MsgBox "FAVOR DIGITAR A DATA DA REVISAO", vbExclamation, "ALERTA"
GoTo 8
End If


'INSERINDO A DATA DE INSTALACAO
9 If Cells(4, 11) <> "" Then
GoTo 11
End If
10 Data_Instalacao = InputBox(prompt:="INSIRA A DATA DE INSTALACAO", Default:="")
If Data_Instalacao = "" Then
GoTo 69
End If
Cells(4, 11) = Data_Instalacao
If Cells(4, 11) = "" Then
MsgBox "FAVOR DIGITAR A DATA DE INSTALACAO", vbExclamation, "ALERTA"
GoTo 10
End If


'INSERINDO A DATA DE VISTORIA
11 If Cells(6, 6) <> "" Then
GoTo 13
End If
12 Data_Vistoria = InputBox(prompt:="INSIRA A DATA DE VISTORIA DE ACEITACAO", Default:="")
If Data_Vistoria = "" Then
GoTo 69
End If
Cells(6, 6) = Data_Vistoria
If Cells(6, 6) = "" Then
MsgBox "FAVOR DIGITAR A DATA DE VISTORIA DE ACEITACAO", vbExclamation, "ALERTA"
GoTo 12
End If


'INSERINDO A DATA PREVISTA PARA RFI
13 If Cells(6, 8) <> "" Then
GoTo 15
End If
14 Data_Rfi = InputBox(prompt:="INSIRA A DATA PREVISTA PARA RFI", Default:="")
If Data_Rfi = "" Then
GoTo 69
End If
Cells(6, 8) = Data_Rfi
If Cells(6, 8) = "" Then
MsgBox "FAVOR DIGITAR A DATA PREVISTA PARA RFI", vbExclamation, "ALERTA"
GoTo 14
End If


'INSERINDO O PERIODO DA OBRA
15 If Cells(6, 10) <> "" Then
GoTo 17
End If
16 Periodo = InputBox(prompt:="INSIRA O PERIODO DA OBRA", Default:="")
If Periodo = "" Then
GoTo 69
End If
Cells(6, 10) = Periodo
If Cells(6, 10) = "" Then
MsgBox "FAVOR DIGITAR O PERIODO DA OBRA", vbExclamation, "ALERTA"
GoTo 16
End If


'INSERINDO A CONSTRUTORA RESPONSAVEL
17 If Cells(10, 1) <> "" Then
GoTo 19
End If
18 Construtora = InputBox(prompt:="INSIRA A CONSTRUTORA RESPONSAVEL", Default:="")
If Construtora = "" Then
GoTo 69
End If
Cells(10, 1) = Construtora
If Cells(10, 1) = "" Then
MsgBox "FAVOR DIGITAR QUAL A CONSTRUTORA RESPONSAVEL", vbExclamation, "ALERTA"
GoTo 18
End If


'INSERINDO O NOME DO VISTORIADOR
19 If Cells(10, 3) <> "" Then
GoTo 21
End If
20 Vistoriador = InputBox(prompt:="INSIRA O NOME DO VISTORIADOR", Default:="")
If Vistoriador = "" Then
GoTo 69
End If
Cells(10, 3) = Vistoriador
If Cells(10, 3) = "" Then
MsgBox "FAVOR DIGITAR O NOME DO VISTORIADOR", vbExclamation, "ALERTA"
GoTo 20
End If


'INSERINDO O NOME DO APROVADOR
21 If Cells(10, 6) <> "" Then
GoTo 23
End If
22 Nome_Aprovador = InputBox(prompt:="INSIRA O NOME DO APROVADOR", Default:="")
If Nome_Aprovador = "" Then
GoTo 69
End If
Cells(10, 6) = Nome_Aprovador
If Cells(10, 6) = "" Then
MsgBox "FAVOR DIGITAR O NOME DO APROVADOR", vbExclamation, "ALERTA"
GoTo 22
End If


'INSERINDO A ID DO SITE
23 If Cells(10, 11) <> "" Then
GoTo 25
End If
24 Site = InputBox(prompt:="INSIRA A ID DO SITE", Default:="")
If Site = "" Then
GoTo 69
End If
Cells(10, 11) = Site
If Cells(10, 11) = "" Then
MsgBox "FAVOR DIGITAR A ID DO SITE", vbExclamation, "ALERTA"
GoTo 24
End If


'INSERINDO OBSERVACOES
25 If Cells(8, 4) <> "" Then
GoTo 69
End If
26 Site = InputBox(prompt:="INSIRA STATUS DO RFI OU SE A OBRA ESTA EM EXECUCAO", Default:="")
If Site = "" Then
GoTo 69
End If
Cells(8, 4) = Site
If Cells(8, 4) = "" Then
MsgBox "FAVOR DIGITAR SE O RFI ATENDE A DATA PREVISTA OU SE A OBRA AINDA NAO FOI CONCLUIDA", vbExclamation, "ALERTA"
GoTo 26
End If




'INSERINDO O DIRETORIO ONDE ESTÃO AS FOTOS
1 PhotoFolder = InputBox(prompt:=" INSIRA O CAMINHO DO DIRETÓRIO DAS FOTOS", Default:="") & "/"
If PhotoFolder = "" Then
GoTo 69
End If


If PhotoFolder = "" & "/" Then
    MsgBox "NECESSITA DIGITAR O CAMINHO DO DIRETÓRIO DAS FOTOS", vbExclamation, "ALERTA"
GoTo 1
End If[/COLOR]




[B]'GoTo 44
[/B]

[COLOR=#808080]'Inserir FOTOS
    Range("A12").Select
     Call ColeFoto("FOTO01.jpg")
     
    Range("E12").Select
     Call ColeFoto("FOTO02.jpg")
    
    Range("I12").Select
     Call ColeFoto("FOTO03.jpg")
     
    Range("A16").Select
     Call ColeFoto("FOTO04.jpg")
    
    Range("E16").Select
     Call ColeFoto("FOTO05.jpg")
     
    Range("I16").Select
     Call ColeFoto("FOTO06.jpg")
     
    Range("A20").Select
     Call ColeFoto("FOTO07.jpg")
    
    Range("E20").Select
     Call ColeFoto("FOTO08.jpg")
     
    Range("I20").Select
     Call ColeFoto("FOTO09.jpg")
     
    Range("A24").Select
     Call ColeFoto("FOTO10.jpg")
    
    Range("E24").Select
     Call ColeFoto("FOTO11.jpg")
     
    Range("I24").Select
     Call ColeFoto("FOTO12.jpg")
     
    Range("A28").Select
     Call ColeFoto("FOTO13.jpg")
    
    Range("E28").Select
     Call ColeFoto("FOTO14.jpg")
     
    Range("I28").Select
     Call ColeFoto("FOTO15.jpg")
     
    Range("A32").Select
     Call ColeFoto("FOTO16.jpg")
    
    Range("E32").Select
     Call ColeFoto("FOTO17.jpg")
     
    Range("I32").Select
     Call ColeFoto("FOTO18.jpg")
     
    Range("A36").Select
     Call ColeFoto("FOTO19.jpg")
    
    Range("E36").Select
     Call ColeFoto("FOTO20.jpg")
     
    Range("I36").Select
     Call ColeFoto("FOTO21.jpg")
     
    Range("A40").Select
     Call ColeFoto("FOTO22.jpg")
    
    Range("E40").Select
     Call ColeFoto("FOTO23.jpg")
     
    Range("I40").Select
     Call ColeFoto("FOTO24.jpg")
     
    Range("A44").Select
     Call ColeFoto("FOTO25.jpg")
    
    Range("E44").Select
     Call ColeFoto("FOTO26.jpg")
     
    Range("I44").Select
     Call ColeFoto("FOTO27.jpg")
     
    Range("A48").Select
     Call ColeFoto("FOTO28.jpg")
    
    Range("E48").Select
     Call ColeFoto("FOTO29.jpg")
     
    Range("I48").Select
     Call ColeFoto("FOTO30.jpg")
     
    Range("A52").Select
     Call ColeFoto("FOTO31.jpg")
    
    Range("E52").Select
     Call ColeFoto("FOTO32.jpg")
     
    Range("I52").Select
     Call ColeFoto("FOTO33.jpg")
     
    Range("A56").Select
     Call ColeFoto("FOTO34.jpg")
    
    Range("E56").Select
     Call ColeFoto("FOTO35.jpg")
     
    Range("I56").Select
     Call ColeFoto("FOTO36.jpg")
     
    Range("A60").Select
     Call ColeFoto("FOTO37.jpg")
    
    Range("E60").Select
     Call ColeFoto("FOTO38.jpg")
     
    Range("I60").Select
     Call ColeFoto("FOTO39.jpg")
     
    Range("A64").Select
     Call ColeFoto("FOTO40.jpg")
    
    Range("E64").Select
     Call ColeFoto("FOTO41.jpg")
     
    Range("I64").Select
     Call ColeFoto("FOTO42.jpg")
     
    Range("A68").Select
     Call ColeFoto("FOTO43.jpg")
    
    Range("E68").Select
     Call ColeFoto("FOTO44.jpg")
     
    Range("I68").Select
     Call ColeFoto("FOTO45.jpg")
     
    Range("A72").Select
     Call ColeFoto("FOTO46.jpg")
    
    Range("E72").Select
     Call ColeFoto("FOTO47.jpg")
     
    Range("I72").Select
     Call ColeFoto("FOTO48.jpg")
     
    Range("A76").Select
     Call ColeFoto("FOTO49.jpg")
    
    Range("E76").Select
     Call ColeFoto("FOTO50.jpg")
     
    Range("I76").Select
     Call ColeFoto("FOTO51.jpg")
     
    Range("A80").Select
     Call ColeFoto("FOTO52.jpg")
    
    Range("E80").Select
     Call ColeFoto("FOTO53.jpg")
     
    Range("I80").Select
     Call ColeFoto("FOTO54.jpg")
     
    Range("A84").Select
     Call ColeFoto("FOTO55.jpg")
    
    Range("E84").Select
     Call ColeFoto("FOTO56.jpg")
     
    Range("I84").Select
     Call ColeFoto("FOTO57.jpg")
     
    Range("A88").Select
     Call ColeFoto("FOTO58.jpg")
    
    Range("E88").Select
     Call ColeFoto("FOTO59.jpg")
     
    Range("I88").Select
     Call ColeFoto("FOTO60.jpg")
     
    Range("A92").Select
     Call ColeFoto("FOTO61.jpg")
    
    Range("E92").Select
     Call ColeFoto("FOTO62.jpg")
     
    Range("I92").Select
     Call ColeFoto("FOTO63.jpg")
     
    Range("A96").Select
     Call ColeFoto("FOTO64.jpg")
    
    Range("E96").Select
     Call ColeFoto("FOTO65.jpg")
     
    Range("I96").Select
     Call ColeFoto("FOTO66.jpg")[/COLOR]
   


[B]'44
[/B][B] Range("A1").Select
     Call Compress[/B]
     
[COLOR=#808080] Range("A1").Select
     Call SalvaRelatorio[/COLOR]
     
[COLOR=#808080]69


End Sub


Private Sub ColeFoto(foto As String)


     Set tgt = ActiveCell
     
     Set p = ActiveSheet.Pictures.Insert(PhotoFolder & foto)
     'tgt = Left(foto, Len(foto) - 4)


     With p
       .ShapeRange.LockAspectRatio = msoTrue
       .ShapeRange.Height = 180
       .ShapeRange.Left = tgt.Left + tgt.MergeArea.Width / 2 - .ShapeRange.Width / 2
       .ShapeRange.Top = 0.75 + tgt.Top + tgt.MergeArea.Height / 2 - .ShapeRange.Height / 2
    End With
    
    TotalFotos = TotalFotos + 1
End Sub


Private Sub SalvaRelatorio()


ChDir PhotoFolder


FNAME = "Report" & " " & "Fotografico" & " " & "RFI" & " " & Cells(10, 1) & " " & Cells(10, 11) & " " & Cells(10, 9) & " " & Cells(7, 6) & ".xls"
    'SALVAR = Application.GetSaveAsFilename(FNAME)
    'If SALVAR <> "Falso" Then
        ActiveWorkbook.SaveAs Filename:=FNAME
    'End If
    
End Sub
Sub ApagarDados()


    Range("C4:D4").Select
    Selection.ClearContents
    Range("E4:F4").Select
    Selection.ClearContents
    Range("G4:H4").Select
    Selection.ClearContents
    Range("K2:L2").Select
    Selection.ClearContents
    Range("K4:L4").Select
    Selection.ClearContents
    Range("F6:G6").Select
    Selection.ClearContents
    Range("H6:I6").Select
    Selection.ClearContents
    Range("J6:L6").Select
    Selection.ClearContents
    Range("D8:L8").Select
    Selection.ClearContents
    Range("A10:B10").Select
    Selection.ClearContents
    Range("C10:E10").Select
    Selection.ClearContents
    Range("F10:H10").Select
    Selection.ClearContents
    Range("K10:L10").Select
    Selection.ClearContents

End Sub[/COLOR]
[B]

Private Sub Compress()


Dim octl As CommandBarControl


With Selection
    Set octl = Application.CommandBars.FindControl(Id:=6382)
    Application.SendKeys "%e~"
    Application.SendKeys "%a~"
     octl.Execute
End With
     
End Sub[/B]

caincha · Mar 8, 2013

Nops..?

Macro to insert, compress then save pictures on Excel workbook

caincha

New Member

Excel Facts

caincha

New Member

Similar threads

Forum statistics

Share this page

Macro to insert, compress then save pictures on Excel workbook

caincha

New Member

Excel Facts

caincha

New Member

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock