Não consigo salvar arquivos com fotos

[JULIANO ERZINGER]

Senhores,

Estou rodando uma macro para poder inserir fotos em um arquivo. Após isso peço para que ele salve o arquivo de acordo com alguns critérios de nome e data. Porém, ao abrir o arquivo percebo que as fotos nao ficaram vinculadas ao arquivo e as pessoas que eu mando nao conseguem visualizar as fotos.
Verifico também que o arquivo ao ser salvo fica com um tamanho que é incompatível com o que deveria ser por causa das fotos. O Arquivo fica com 70kb enquanto deveria ter ao menos 1Mb, o que pode estar acontecendo? Segue o scrip que estou utilizando.


Public PhotoFolder As String

Sub BotaoFotos()
'Application.ScreenUpdating = False
On Error Resume Next
'MARCRO CRIADA POR JULIANO ERZINGER EM 07/06/2011
'Para: RELATÓRIO FOTOGRÁFICO PROJETO NEXTEL
'Função: Inserir fotos

'INSERINDO O NOME DA OBRA
If Cells(1, 6) <> "" Then
GoTo 3
End If
2 Nome_da_obra = InputBox(prompt:="INSIRA O NOME DA OBRA", Default:="")
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:="")
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:="")
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:="")
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 Data = InputBox(prompt:="INSIRA A DATA REFERENTE AO RELATÓRIO", Default:="")
Cells(5, 11) = Data
If Cells(5, 11) = "" Then
MsgBox " FAVOR DIGITAR A DATA", vbExclamation, "ALERTA"
GoTo 9
End If

'INSERINDO O ASSUNTO DO RELATÓRIO
10 Assunto = InputBox(prompt:="INSIRA O ASSUNTO DO RELATÓRIO", Default:="")
Cells(8, 1) = Assunto
If Cells(8, 1) = "" Then
MsgBox " FAVOR DIGITAR O ASSUNTO DO RELATÓRIO", vbExclamation, "ALERTA"
GoTo 10
End If

11 Descrição = InputBox(prompt:="DESCREVA AS ATIVIDADES", Default:="")
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
MsgBox " NECESSITA DIGITAR O CAMINHO DO DIRETÓRIO DAS FOTOS", vbExclamation, "ALERTA"
GoTo 1
End If
'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("F52").Select
Call ColeFoto("FOTO26.jpg")

Range("A54").Select
Call ColeFoto("FOTO27.jpg")

Range("F54").Select
Call ColeFoto("FOTO28.jpg")

Range("A56").Select
Call ColeFoto("FOTO29.jpg")

Range("F56").Select
Call ColeFoto("FOTO30.jpg")

Range("A58").Select
Call ColeFoto("FOTO31.jpg")

Range("F58").Select
Call ColeFoto("FOTO32.jpg")

Range("A60").Select
Call ColeFoto("FOTO33.jpg")

Range("F60").Select
Call ColeFoto("FOTO34.jpg")

Range("A62").Select
Call ColeFoto("FOTO35.jpg")

Range("F62").Select
Call ColeFoto("FOTO36.jpg")

Range("A64").Select
Call ColeFoto("FOTO37.jpg")

Range("F64").Select
Call ColeFoto("FOTO38.jpg")

Range("A66").Select
Call ColeFoto("FOTO39.jpg")

Range("F66").Select
Call ColeFoto("FOTO40.jpg")

Range("A68").Select
Call ColeFoto("FOTO41.jpg")

Range("F68").Select
Call ColeFoto("FOTO42.jpg")

Range("A70").Select
Call ColeFoto("FOTO43.jpg")

Range("F70").Select
Call ColeFoto("FOTO44.jpg")

Range("A72").Select
Call ColeFoto("FOTO45.jpg")

Range("F72").Select
Call ColeFoto("FOTO46.jpg")

Range("A74").Select
Call ColeFoto("FOTO47.jpg")

Range("F74").Select
Call ColeFoto("FOTO48.jpg")

Range("A76").Select
Call ColeFoto("FOTO49.jpg")

Range("F76").Select
Call ColeFoto("FOTO50.jpg")

Range("A78").Select
Call ColeFoto("FOTO51.jpg")

Range("F78").Select
Call ColeFoto("FOTO52.jpg")



Call salva_relatorio

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()

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.SaveCopyAs 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