Public PhotoFolder As String
Sub BotaoFotos()
'Application.ScreenUpdating = False
On Error Resume Next
'MACRO CRIADA POR JULIANO ERZINGER EM 07/06/2011
'Para: RELATÓRIO FOTOGRÁFICO PROJETO
'Função: Inserir fotos
'INSERINDO O NOME DA OBRA
If Cells(1, 6) <> "" Then
GoTo 3
End If
2 Nome_da_obra = InputBox(prompt:="DIGITE O NOME DA OBRA", Default:="")
If Nome_da_obra = "" Then
GoTo 333
End If
Cells(1, 6) = Nome_da_obra
If Cells(1, 6) = "" Then
MsgBox " FAVOR DIGITAR O NOME DA OBRA", vbExclamation, "ALERTA"
GoTo 2
End If
'INSERINDO O BAIRRO DO BAIRRO
3 If Cells(4, 6) <> "" Then
GoTo 5
End If
4 Bairro = InputBox(prompt:="INSIRA O NOME DO BAIRRO", Default:="")
If Bairro = "" Then
GoTo 333
End If
Cells(4, 6) = Bairro
If Cells(4, 6) = "" Then
MsgBox " FAVOR DIGITAR O NOME DO BAIRRO", vbExclamation, "ALERTA"
GoTo 4
End If
'INSERINDO O NOME DA CIDADE DA OBRA
5 If Cells(5, 6) <> "" Then
GoTo 7
End If
6 cidade = InputBox(prompt:="INSIRA O NOME DA CIDADE", Default:="")
If cidade = "" Then
GoTo 333
End If
Cells(5, 6) = cidade
If Cells(5, 6) = "" Then
MsgBox " FAVOR DIGITAR O NOME DA CIDADE", vbExclamation, "ALERTA"
GoTo 6
End If
'INSERINDO O NOME DO FORNECEDOR
7 If Cells(2, 6) <> "" Then
GoTo 9
End If
8 Fornecedor = InputBox(prompt:="INSIRA O NOME DO FORNECEDOR", Default:="")
If Fornecedor = "" Then
GoTo 333
End If
Cells(2, 6) = Fornecedor
If Cells(2, 6) = "" Then
MsgBox " FAVOR DIGITAR O NOME DO FORNECEDOR", vbExclamation, "ALERTA"
GoTo 8
End If
'INSERINDO A DATA
9 If Cells(3, 11) <> "" Then
GoTo 11
End If
10 Data = InputBox(prompt:="INSIRA A DATA REFERENTE AO RELATÓRIO", Default:="")
If Data = "" Then
GoTo 333
End If
Cells(5, 11) = Data
If Cells(5, 11) = "" Then
MsgBox " FAVOR DIGITAR A DATA", vbExclamation, "ALERTA"
GoTo 10
End If
'INSERINDO O ASSUNTO DO RELATÓRIO
11 assunto = InputBox(prompt:="INSIRA O ASSUNTO DO RELATÓRIO", Default:="")
If assunto = "" Then
GoTo 333
End If
Cells(8, 1) = assunto
If Cells(8, 1) = "" Then
MsgBox " FAVOR DIGITAR O ASSUNTO DO RELATÓRIO", vbExclamation, "ALERTA"
GoTo 10
End If
'DESCRIÇÃO DAS ATIVIDADES
12 descrição = InputBox(prompt:="DESCREVA AS ATIVIDADES", Default:="")
If descrição = "" Then
GoTo 333
End If
Cells(12, 1) = descrição
If Cells(12, 1) = "" Then
MsgBox " FAVOR DESCREVER AS ATIVIDADES", vbExclamation, "ALERTA"
GoTo 11
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 333
End If
If PhotoFolder = "" & "\" Then
MsgBox " NECESSITA DIGITAR O CAMINHO DO DIRETÓRIO DAS FOTOS", vbExclamation, "ALERTA"
GoTo 1
End If
'GoTo 44
'Inserir FOTOS
Range("A15").Select
Call ColeFoto("FOTO1.jpg")
Range("F15").Select
Call ColeFoto("FOTO2.jpg")
Range("A18").Select
Call ColeFoto("FOTO3.jpg")
Range("F18").Select
Call ColeFoto("FOTO4.jpg")
Range("A21").Select
Call ColeFoto("FOTO5.jpg")
Range("F21").Select
Call ColeFoto("FOTO6.jpg")
Range("A26").Select
Call ColeFoto("FOTO7.jpg")
Range("F26").Select
Call ColeFoto("FOTO8.jpg")
Range("A29").Select
Call ColeFoto("FOTO9.jpg")
Range("F29").Select
Call ColeFoto("FOTO10.jpg")
Range("A32").Select
Call ColeFoto("FOTO11.jpg")
Range("F32").Select
Call ColeFoto("FOTO12.jpg")
Range("A37").Select
Call ColeFoto("FOTO13.jpg")
Range("F37").Select
Call ColeFoto("FOTO14.jpg")
Range("A40").Select
Call ColeFoto("FOTO15.jpg")
Range("F40").Select
Call ColeFoto("FOTO16.jpg")
Range("A42").Select
Call ColeFoto("FOTO17.jpg")
Range("F42").Select
Call ColeFoto("FOTO18.jpg")
Range("A44").Select
Call ColeFoto("FOTO19.jpg")
Range("F44").Select
Call ColeFoto("FOTO20.jpg")
Range("A46").Select
Call ColeFoto("FOTO21.jpg")
Range("F46").Select
Call ColeFoto("FOTO22.jpg")
Range("A48").Select
Call ColeFoto("FOTO23.jpg")
Range("F48").Select
Call ColeFoto("FOTO24.jpg")
Range("A50").Select
Call ColeFoto("FOTO25.jpg")
Range("F50").Select
Call ColeFoto("FOTO26.jpg")
Range("A52").Select
Call ColeFoto("FOTO27.jpg")
Range("F52").Select
Call ColeFoto("FOTO28.jpg")
Range("A54").Select
Call ColeFoto("FOTO29.jpg")
Range("F54").Select
Call ColeFoto("FOTO30.jpg")
Range("A56").Select
Call ColeFoto("FOTO31.jpg")
Range("F56").Select
Call ColeFoto("FOTO32.jpg")
Range("A58").Select
Call ColeFoto("FOTO33.jpg")
Range("F58").Select
Call ColeFoto("FOTO34.jpg")
Range("A60").Select
Call ColeFoto("FOTO35.jpg")
Range("F60").Select
Call ColeFoto("FOTO36.jpg")
Range("A62").Select
Call ColeFoto("FOTO37.jpg")
Range("F62").Select
Call ColeFoto("FOTO38.jpg")
Range("A64").Select
Call ColeFoto("FOTO39.jpg")
Range("F64").Select
Call ColeFoto("FOTO40.jpg")
Range("A66").Select
Call ColeFoto("FOTO41.jpg")
Range("F66").Select
Call ColeFoto("FOTO42.jpg")
Range("A68").Select
Call ColeFoto("FOTO43.jpg")
Range("F68").Select
Call ColeFoto("FOTO44.jpg")
Range("A70").Select
Call ColeFoto("FOTO45.jpg")
Range("F70").Select
Call ColeFoto("FOTO46.jpg")
Range("A72").Select
Call ColeFoto("FOTO47.jpg")
Range("F72").Select
Call ColeFoto("FOTO48.jpg")
Range("A74").Select
Call ColeFoto("FOTO49.jpg")
Range("F74").Select
Call ColeFoto("FOTO50.jpg")
Range("A76").Select
Call ColeFoto("FOTO51.jpg")
Range("F76").Select
Call ColeFoto("FOTO52.jpg")
Range("A78").Select
Call ColeFoto("FOTO53.jpg")
Range("F78").Select
Call ColeFoto("FOTO54.jpg")
'44
Range("a1").Select
Call salva_relatorio
333
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 salva_relatorio()
ChDir PhotoFolder
FNAME = "RELATÓRIO" & " " & "FOTOGRÁFICO" & " " & Cells(8, 1) & " " & Cells(1, 6).Value & " " & Cells(2, 6).Value & " " & Cells(3, 6) & ".xls"
'SALVAR = Application.GetSaveAsFilename(FNAME)
'If SALVAR <> "Falso" Then
ActiveWorkbook.SaveAs Filename:=FNAME
'End If
End Sub
Sub APAGAR_FOTOS()
'
'
Range("F2:K2").Select
Selection.ClearContents
Range("F1:K1").Select
Selection.ClearContents
Range("k5").Select
Selection.ClearContents
Range("F4:J4").Select
Selection.ClearContents
Range("F5:I5").Select
Selection.ClearContents
Range("A8:K10").Select
Selection.ClearContents
Range("A12:K13").Select
Selection.ClearContents
End Sub