Soru Makro İle Excel'e eklediğim fotoğrafları karşı tarafında görmesi !!

[Bysystemroad]

Merhabalar

Makro kullanarak dosyamdan çektiğim fotoğrafları müşteriye gönderdiğimde müşterinin de fotoğrafları görmesi için ne yapabilirim ?

Müşteri de benim fotoğraflarımın olduğu dosya olmadığı için gönderdiğim excel dosyasında fotoğrafları göremiyor.

Yardımcı olur musunuz ?

Teşekkürler

İyi Forumlar

 

[YUSUF44]

Diğer türlüsünü bilmiyorum ama pdf olarak kaydedilip gönderilince sıkıntı olmaz diye düşünüyorum. Karşı tarafa excel versiyonu lazım değilse böyle çözebilirsiniz.

 

[Bysystemroad]

Yusuf Bey

Cevabınız için teşekkürler. Ama excel versiyonu ile göndermem gerekiyor.

 

[YUSUF44]

Resimleri excel dosyasının olduğu klasöre ya da bir alt klasöre kaydedip kodlarınızı bu klasörden alabilecek şekilde düzenlerseniz olabilir belki.

 

[Bysystemroad]

Teşekkürler
Maalesef fotoğraf dosyasının boyutu oldukça yüksek olduğu için uygun bir çözüm değil.

Excel dosyasını mail olarak karşı tarafa gönderdiğimde fotoğrafları görmesi gerekiyor.

Eğer bunu sağlayabilecek bir çözüm yolunu bilen var ise benim için iyi olur.

 

[cicosz]

Merhaba,

Muhtemelen ActiveSheet.Pictures.Insert ile ekliyorsunuz. O fonksiyonda fotoğraflarınızı link olarak aktarıyor.
Eğer ActiveSheet.Shapes.AddPicture ile eklerseniz fotoğraflarınızın bir kopyası excel dosyanıza eklenir. Excelinize sahip olan herkes eklediğiniz fotoğrafları görebilir.

 

[Bysystemroad]

Merhaba,

Muhtemelen ActiveSheet.Pictures.Insert ile ekliyorsunuz. O fonksiyonda fotoğraflarınızı link olarak aktarıyor.
Eğer ActiveSheet.Shapes.AddPicture ile eklerseniz fotoğraflarınızın bir kopyası excel dosyanıza eklenir. Excelinize sahip olan herkes eklediğiniz fotoğrafları görebilir.

Cevap için teşekkürler
İlgili Makroyu Aşağıda Görebilirsiniz.

Revize etmem gereken yeri söylerseniz sevinirim.

Sub InsertPictures()
  Dim objPic As Picture, i As Long
  Dim sPath As String, sFile As String
 
  sPath = "C:\SS20 FOTOS\"

  If Dir(sPath, vbDirectory) = "" Then
    MsgBox "This directory does not exist"
    Exit Sub
  End If
 
  On Error Resume Next
  For Each objPic In ActiveSheet.Pictures
    If objPic.Name Like "img_*" Then
      objPic.Delete
    End If
  Next
  On Error GoTo 0
 
  For i = 4 To Range("B" & Rows.Count).End(3).Row
    sFile = Range("B" & i).Value & ".jpg"
    If Dir(sPath & sFile) <> "" Then
      Set objPic = ActiveSheet.Pictures.Insert(sPath & sFile)
      With Range("A" & i)
        objPic.ShapeRange.LockAspectRatio = msoFalse
        objPic.Top = .Top
        objPic.Left = .Left
        objPic.Width = .Width
        objPic.Height = .Height
        objPic.Name = "img_" & i
      End With
    End If
  Next
End Sub

 

[Bysystemroad]

Yardım edecek biri yok mu ? sorun devam etmekte

 

[cicosz]

Dosyanızın kopyasını aldıktan sonra dener misiniz?

Sub InsertPictures()
  Dim objPic As Picture, i As Long
  Dim sPath As String, sFile As String
 
  sPath = "C:\SS20 FOTOS\"

  If Dir(sPath, vbDirectory) = "" Then
    MsgBox "This directory does not exist"
    Exit Sub
  End If
 
  On Error Resume Next
  For Each objPic In ActiveSheet.Pictures
    If objPic.Name Like "img_*" Then
      objPic.Delete
    End If
  Next
  On Error GoTo 0
  Application.ScreenUpdating = False
  For i = 4 To Range("B" & Rows.Count).End(3).Row
    sFile = Range("B" & i).Value & ".jpg"
    If Dir(sPath & sFile) <> "" Then
    Dosya = sPath & sFile
    Cells(i, "A").Select
    Set Adres = Range(ActiveWindow.RangeSelection.Address)
    ActiveSheet.Shapes.AddPicture(Filename:=Dosya, linktofile:=msoFalse, _
            savewithdocument:=msoCTrue, Left:=0, Top:=0, Width:=-1, Height:=-1).Select
    Selection.ShapeRange.LockAspectRatio = msoFalse
    Selection.Top = Adres.Top
    Selection.Left = Adres.Left
    Selection.ShapeRange.Height = Adres.Height
    Selection.ShapeRange.Width = Adres.Width
    End If
  Next
  Application.ScreenUpdating = True
  MsgBox "İşlem Tamamlandı."
End Sub

 

[Bysystemroad]

Dosyanızın kopyasını aldıktan sonra dener misiniz?

Sub InsertPictures()
  Dim objPic As Picture, i As Long
  Dim sPath As String, sFile As String

  sPath = "C:\SS20 FOTOS\"

  If Dir(sPath, vbDirectory) = "" Then
    MsgBox "This directory does not exist"
    Exit Sub
  End If

  On Error Resume Next
  For Each objPic In ActiveSheet.Pictures
    If objPic.Name Like "img_*" Then
      objPic.Delete
    End If
  Next
  On Error GoTo 0
  Application.ScreenUpdating = False
  For i = 4 To Range("B" & Rows.Count).End(3).Row
    sFile = Range("B" & i).Value & ".jpg"
    If Dir(sPath & sFile) <> "" Then
    Dosya = sPath & sFile
    Cells(i, "A").Select
    Set Adres = Range(ActiveWindow.RangeSelection.Address)
    ActiveSheet.Shapes.AddPicture(Filename:=Dosya, linktofile:=msoFalse, _
            savewithdocument:=msoCTrue, Left:=0, Top:=0, Width:=-1, Height:=-1).Select
    Selection.ShapeRange.LockAspectRatio = msoFalse
    Selection.Top = Adres.Top
    Selection.Left = Adres.Left
    Selection.ShapeRange.Height = Adres.Height
    Selection.ShapeRange.Width = Adres.Width
    End If
  Next
  Application.ScreenUpdating = True
  MsgBox "İşlem Tamamlandı."
End Sub

Cevap için teşekkürler

Ancak "This directory does not exist" hatasını almaktayım.

Farklı olarak denediğim bir kod için de aynı hatayı almıştım

 

[YUSUF44]

Bilgisayarınızda C sürücüsü altında SS20 FOTOS isimli klasör mevcut mu?

sPath = "C:\SS20 FOTOS\"

O mesaj bu klasörün olmadığını gösteriyor anladığım kadarıyla.

 

[Bysystemroad]

İlgilendiğiniz için teşekkür ederim
Sorunum cözüldü