Macro to insert, compress then save pictures on Excel workbook

caincha

caincha

New Member
Joined
Feb 16, 2013
Messages
5
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]
 

Excel Facts

Format cells as currency
Select range and press Ctrl+Shift+4 to format cells as currency. (Shift 4 is the $ sign).
Sort by date Sort by votes
You must log in or register to reply here.

Similar threads

P
  • Solved
VBA to open file using Cell for the path
Replies
4
Views
626
Peter Davison
P
M
  • Question
Excel Macro to insert picture into excel from SharePoint or website !
Replies
0
Views
298
MAlhash
M
P
  • Question
Worksheet and cell value matched to range
Replies
1
Views
380
Farscape2020
F
A
  • Question
Help Debugging Custom Data Label Macro
Replies
0
Views
177
arndtea
A
L
  • Question
Lost in Strings-When running macro another Excel workbook is opened
Replies
1
Views
91
Lacampeona
L

Forum statistics

Threads
1,215,523
Messages
6,125,318
Members
449,218
Latest member
Excel Master

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top