Klasörden Görsel Çağırma Kodunda Hata Alıyorum

[xtrkax]

Merhabalar, daha önce forumda @Haluk hocamın yazdığı bir kodu kullanıyorum.

Kod şu şekilde:

Sub Test()
    ' Haluk - 15/06/2019
    ' sa4truss@gmail.com
    '
    Dim NoA As Long, i As Long
    Dim PicFile As String, PicTop As Integer, PicLeft As Integer, PicW As Integer, PicH As Integer
    NoA = Range("A" & Rows.Count).End(xlUp).Row

    For i = 2 To 270
        PicFile = ThisWorkbook.Path & "\excel\" & Range("A" & i).Text & ".jpg"
        If Dir(PicFile) = Empty Then
            Range("B" & i) = "Resim bulunamadı..!"
            GoTo ResumeFor:
        End If
        PicTop = Range("B" & i).Top
        PicLeft = Range("B" & i).Left
        PicW = Range("B" & i).Width
        PicH = Range("B" & i).Height
        Set MyPic = ActiveSheet.Shapes.AddPicture(PicFile, True, True, PicLeft, PicTop, PicW, PicH)
ResumeFor:
    Next
End Sub

Aslında kod sorunsuz bir şekilde 185. satıra kadar çalıştı ve istediğim gibi görselleri getirdi:



Fakat her ne yaptıysam 185. satır ve devamını getirmiyor. Klasörde doğru görselleri de mevcut defalarca kontrol ettim görsel anlamında bir problem yok.

For i = 185 To 270 yaparak sadece bu aralıktakileri çalıştırmaya da çalıştım fakat aldığım hata hep şu şekilde:



Bu hatanın sebebi ne olabilir? Neyi gözden kaçırıyorum

185 ve sonrası şu şekilde:



Klasörde bir hata yok, uzantısı da .jpg:

 

[Muzaffer Ali]

Merhaba.

Fotoğraflarınızın bulunduğu klasörün üst kısmında bulunan 'Görünüm' sekmesini açın.
Açılan sekmede 'Dosya Adı Uzantıları' işaretleyin.
'AW00284_1' adlı dosyanızın uzantısının ".jpg" olup olmadığını kontrol edin.
Eğer ".jpg" değilse hata buradan kaynaklanıyor. Dosyayı Paint ile açıp jpg olarak farklı kaydedin.

Bu çözüm sorununuzu çözmezse dosyanızı ve 280 ile 290 arasında bulunan fotoğrafları ekleyin kontrol edelim.

 

[xtrkax]

Muzaffer Bey, ilginize çok teşekkür ederim.
Dosya boyutunun çok kabarık olmaması adına görselleri çekmeyen 185 ve 186. satırların görsellerini ekte gönderdim.
Uzantıları sorunsuz görünüyor.

Kendi dosyamı da linke upload ettim: https://s5.dosya.tc/server5/qxuywa/toptan1.xltm.html

 

[Merhum İdris SERDAR]

.

Böyle bir olay benim başıma da gelmişti. Benzer resim çağırmalarla ilgili bir çalışmada belirli bir sayıdaki resimden sonra yanılmıyorsam aynı hatayı almıştım. Bir kaç resim silip, tekrar resim eklemeye çalıştığımda da olmuyordu. Adeta dosya bozulmuş oluyordu.

Her ne kadar Excel'in sayfada nesne sayısı ile ilgili bir limitinin bulunduğu konusunda da hiçbir yerde bir bilgiye rastlamamıştım. Yine de sanki bir limit varmış gibi geldi bana. Sonuç olarak bir çözüme ulaşamamış ve nedenini anlayamamıştım.

Umarım bir çözüm bulunur.

.

.

 

[halit3]

Merhaba
Belli bir sayıdan sonra bekleme kodu ekliyerek belki bir çözüm olabilir.

bekleme kodunu buraya ekliyorum siz döngünün ya başına yada sonuna ekleyiniz.
kod elli adet resimden sonra beş saniye bekliyor.

sat1 = sat1 + 1
If sat1 = 50 Then
Application.Wait (Now + TimeValue("0:00:05"))
CreateObject("WScript.Shell").Popup "işlem devam ediyor", 1, " UYARI!", vbOKOnly + vbInformation
sat1 = 0
End If

 

[xtrkax]

Merhaba
Belli bir sayıdan sonra bekleme kodu ekliyerek belki bir çözüm olabilir.

bekleme kodunu buraya ekliyorum siz döngünün ya başına yada sonuna ekleyiniz.
kod elli adet resimden sonra beş saniye bekliyor.

sat1 = sat1 + 1
If sat1 = 50 Then
Application.Wait (Now + TimeValue("0:00:05"))
CreateObject("WScript.Shell").Popup "işlem devam ediyor", 1, " UYARI!", vbOKOnly + vbInformation
sat1 = 0
End If

Teşekkür ederim hocam ama ya yanlış yere ekledim ya da çözüm olmadı

 

[halit3]

Resimlerin hepsi olsaydı da deseydik keşke

Bu kodu bir dene

Sub resimlerigetir()

Set klasor = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not klasor Is Nothing Then
Kaynak = klasor.SELF.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla
If Right(Kaynak, 1) <> "\" Then Kaynak = Kaynak & "\"

For r = 2 To Cells(Rows.Count, "A").End(3).Row

isim = Cells(r, "A").Value
Set Adres = Range(Cells(r, 2), Cells(r, 2))
If Cells(r, 10).Value <> "X" Then
Cells(r, 10).Value = "X"

If CreateObject("Scripting.FileSystemObject").FileExists(Kaynak & isim & ".jpg") = True Then
Cells(r, 10).Select
ActiveSheet.Pictures.Insert(Kaynak & isim & ".jpg").Select
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.Top = Adres.Top + 4
Selection.Left = Adres.Left + 2
Selection.ShapeRange.Height = Adres.Height - 6
Selection.ShapeRange.Width = Adres.Width - 6
Selection.ShapeRange.Name = isim
End If

sat1 = sat1 + 1
If sat1 = 50 Then
Application.Wait (Now + TimeValue("0:00:5"))
CreateObject("WScript.Shell").Popup "işlem devam ediyor", 1, " UYARI!", vbOKOnly + vbInformation
sat1 = 0
End If

End If

Next
Range("a1").Select
CreateObject("WScript.Shell").Popup "işlem tamam", 1, " UYARI!", vbOKOnly + vbInformation
Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
End Sub

 

[xtrkax]

Resimlerin hepsi olsaydı da deseydik keşke

Bu kodu bir dene

Sub resimlerigetir()

Set klasor = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not klasor Is Nothing Then
Kaynak = klasor.SELF.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla
If Right(Kaynak, 1) <> "\" Then Kaynak = Kaynak & "\"

For r = 2 To Cells(Rows.Count, "A").End(3).Row

isim = Cells(r, "A").Value
Set Adres = Range(Cells(r, 2), Cells(r, 2))
If Cells(r, 10).Value <> "X" Then
Cells(r, 10).Value = "X"

If CreateObject("Scripting.FileSystemObject").FileExists(Kaynak & isim & ".jpg") = True Then
Cells(r, 10).Select
ActiveSheet.Pictures.Insert(Kaynak & isim & ".jpg").Select
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.Top = Adres.Top + 4
Selection.Left = Adres.Left + 2
Selection.ShapeRange.Height = Adres.Height - 6
Selection.ShapeRange.Width = Adres.Width - 6
Selection.ShapeRange.Name = isim
End If

sat1 = sat1 + 1
If sat1 = 50 Then
Application.Wait (Now + TimeValue("0:00:5"))
CreateObject("WScript.Shell").Popup "işlem devam ediyor", 1, " UYARI!", vbOKOnly + vbInformation
sat1 = 0
End If

End If

Next
Range("a1").Select
CreateObject("WScript.Shell").Popup "işlem tamam", 1, " UYARI!", vbOKOnly + vbInformation
Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
End Sub

Hocam ellerinize sağlık, çok teşekkür ederim bu kod ile tüm resimleri sorunsuz şekilde çekebildim.
Tekrar çok teşekkür ederim.