(Çözüldü) Klasörden otomatik resim alma

teknisyen7777 · 16 Ekim 2017

Aşağıda verilen kodlarda "B" sütununa girilen id ye göre belirlenen klasörden resim alarak "F" sütununda aynı satıra yerleştiriyor.
Şöyle bir şey mümkün mü?
"B" sütununa id girince "F" sütununa, "H" sütununa id girince ise "L" sütununa resim almak mümkün olabilir mi?

Kod:

Public Function DosyaVarmi(dosyayolu As String) As Boolean
    On Error GoTo Çıkış
    If Not Dir(dosyayolu, vbDirectory) = vbNullString Then DosyaVarmi = True
    
Çıkış:
    On Error GoTo 0
End Function

'worksheette bir değişiklik oldugunda bu kısım çalışıyor
Private Sub Worksheet_Change(ByVal Target As Range)

'değişiklik b sutunundamı olmuş diye kontrol et, değilse direk olarak fonksiyondan çık
If Intersect(Target, [b:b]) Is Nothing Then Exit Sub

'herhangi bir hata oluşursa Çıkış labelına git
On Error GoTo Çıkış:

' ilk olarak yüklü olan Resimleri silelim
ActiveSheet.DrawingObjects.Delete

Dim ResimDosyaYolu As String
Dim Resim As Object

'b deki 5 ile 12 arasındaki satırları kontrol edip resim ataması yapıyoruz, siz burayı isteğinize göre artırabilirsiniz
For i = 5 To 12
    'aktif sayfanın path bilgisini alıp, seçilen ürün idyi sonuna ekliyoruz ve dosyayı alıyoruz
    ResimDosyaYolu = ActiveWorkbook.Path & "\" & Range("b" & i) & ".jpg"

    'dosya yok ise hataya düşmemek için aşağıdaki kontrolü yapıyoruz.
    If DosyaVarmi(ResimDosyaYolu) Then
         ResimDosyaYolu = ActiveWorkbook.Path & "\" & Range("b" & i) & ".jpg"
        Else
           ResimDosyaYolu = ActiveWorkbook.Path & "\yok.jpg"
        End If
        
    'resmi oluşturuyoruz.
     Set Resim = ActiveSheet.Pictures.Insert(ResimDosyaYolu)
     'Resmi boyutlandırıyoruz
     With Range("f" & i)
     Resim.Top = .Top
     Resim.Left = .Left
     Resim.Height = .Height
     Resim.Width = .Width
     End With

Next i

Çıkış:

End Sub

askm · 16 Ekim 2017

Kod:

Public Function DosyaVarmi(dosyayolu As String) As Boolean
    On Error GoTo Çıkış
    If Not Dir(dosyayolu, vbDirectory) = vbNullString Then DosyaVarmi = True
    
Çıkış:
    On Error GoTo 0
End Function

'worksheette bir değişiklik oldugunda bu kısım çalışıyor
Private Sub Worksheet_Change(ByVal Target As Range)
'değişiklik b sutunundamı olmuş diye kontrol et, değilse direk olarak fonksiyondan çık
If Intersect(Target, [b:b,H:H]) Is Nothing Then Exit Sub

'herhangi bir hata oluşursa Çıkış labelına git
On Error GoTo Çıkış:

' ilk olarak yüklü olan Resimleri silelim
ActiveSheet.DrawingObjects.Delete

Dim ResimDosyaYolu As String
Dim Resim As Object

'b deki 5 ile 12 arasındaki satırları kontrol edip resim ataması yapıyoruz, siz burayı isteğinize göre artırabilirsiniz
For i = 5 To 12
    'aktif sayfanın path bilgisini alıp, seçilen ürün idyi sonuna ekliyoruz ve dosyayı alıyoruz
    ResimDosyaYolu = ActiveWorkbook.Path & "\" & Range("b" & i) & ".jpg"

    'dosya yok ise hataya düşmemek için aşağıdaki kontrolü yapıyoruz.
    If DosyaVarmi(ResimDosyaYolu) Then
         ResimDosyaYolu = ActiveWorkbook.Path & "\" & Range("b" & i) & ".jpg"
        Else
           ResimDosyaYolu = ActiveWorkbook.Path & "\yok.jpg"
        End If
        
    'resmi oluşturuyoruz.
     Set Resim = ActiveSheet.Pictures.Insert(ResimDosyaYolu)
     'Resmi boyutlandırıyoruz
     With Cells(i, Target.Column + 4)
     Resim.Top = .Top
     Resim.Left = .Left
     Resim.Height = .Height
     Resim.Width = .Width
     End With

Next i

Çıkış:

End Sub

halit3 · 16 Ekim 2017

Alternatif kod

Kod:

Public Function DosyaVarmi(dosyayolu As String) As Boolean
On Error GoTo Çıkış
If Not Dir(dosyayolu, vbDirectory) = vbNullString Then DosyaVarmi = True

Çıkış:
On Error GoTo 0
End Function

Kod:

Private Sub Worksheet_Change(ByVal Target As Range)

If Intersect(Target, [b:b[COLOR="red"],H:H[/COLOR]]) Is Nothing Then Exit Sub

On Error GoTo Çıkış:

ActiveSheet.DrawingObjects.Delete

Exit Sub
Dim ResimDosyaYolu As String
Dim Resim As Object

For i = 5 To 12

ResimDosyaYolu = ActiveWorkbook.Path & "\" & [COLOR="red"]Cells(i, Target.Column)[/COLOR] & ".jpg"

If DosyaVarmi(ResimDosyaYolu) Then
ResimDosyaYolu = ActiveWorkbook.Path & "\" & [COLOR="red"]Cells(i, Target.Column)[/COLOR] & ".jpg"
Else
ResimDosyaYolu = ActiveWorkbook.Path & "\yok.jpg"
End If

Set Resim = ActiveSheet.Pictures.Insert(ResimDosyaYolu)
With [COLOR="Red"]Cells(i, Target.Column + 4)[/COLOR]
Resim.Top = .Top
Resim.Left = .Left
Resim.Height = .Height
Resim.Width = .Width
End With

Next i

Çıkış:

End Sub

hakankilic · 16 Ekim 2017

Excel dosyası ile örnek oluşturursanız bizler içinde daha iyi olur kanaatindeyim. Saygılarımla.

halit3 · 16 Ekim 2017

hakankilic' Alıntı:
Excel dosyası ile örnek oluşturursanız bizler içinde daha iyi olur kanaatindeyim. Saygılarımla.

1 nolu mesajda ilgili mesajda örnek bir dosya yok onun için kodda düzenleme yapıldı ve dosya eklenmedi

teknisyen7777 · 17 Ekim 2017

Yardımcı olan tüm arkadaşlara teşekkür ederim.
PC başına geçtiğimde verilen kodlarlı örnek bir çalışma dosyasında deneyerek ekleyeceğim.

teknisyen7777 · 19 Ekim 2017

http://www.dosya.tc/server10/m7700k/excel_resim.rar.html

Arkadaşlar maalesef verdiğiniz kodlar olmadı. Çünkü ilk mesajımda istediğimi tam ifade edememişim.
Yukarıda örnek dosya linki var.
Askm rumuzlu arkadasın verdiği kodda resimler sadece tek sütünda çıkıyor. Ben her iki sütunda da resim id sine göre resimlerin aynı anda çıkmasını istiyorum. Halit3 arkadaşın verdiği kodu ise hiç çalıştıramadım.

halit3 · 19 Ekim 2017

Birde bunu dene

Kod:

Public Function DosyaVarmi(dosyayolu As String) As Boolean
On Error GoTo Çıkış
If Not Dir(dosyayolu, vbDirectory) = vbNullString Then DosyaVarmi = True

Çıkış:
On Error GoTo 0
End Function


Private Sub Worksheet_Change(ByVal Target As Range)

On Error GoTo Çıkış:
ActiveSheet.DrawingObjects.Delete
Dim ResimDosyaYolu As String
Dim Resim As Object


If Not Intersect(Target, [b:b]) Is Nothing Then

For i = 5 To 12
ResimDosyaYolu = ActiveWorkbook.Path & "\" & Range("b" & i) & ".jpg"
If DosyaVarmi(ResimDosyaYolu) Then
ResimDosyaYolu = ActiveWorkbook.Path & "\" & Range("b" & i) & ".jpg"
Else
ResimDosyaYolu = ActiveWorkbook.Path & "\yok.jpg"
End If

Set Resim = ActiveSheet.Pictures.Insert(ResimDosyaYolu)
With Range("f" & i)
Resim.Top = .Top
Resim.Left = .Left
Resim.Height = .Height
Resim.Width = .Width
End With
Next i

End If

If Not Intersect(Target, [h:h]) Is Nothing Then

For i = 5 To 12
ResimDosyaYolu = ActiveWorkbook.Path & "\" & Range("b" & i) & ".jpg"
If DosyaVarmi(ResimDosyaYolu) Then
ResimDosyaYolu = ActiveWorkbook.Path & "\" & Range("b" & i) & ".jpg"
Else
ResimDosyaYolu = ActiveWorkbook.Path & "\yok.jpg"
End If

Set Resim = ActiveSheet.Pictures.Insert(ResimDosyaYolu)
With Range("l" & i)
Resim.Top = .Top
Resim.Left = .Left
Resim.Height = .Height
Resim.Width = .Width
End With
Next i

End If
Çıkış:


End Sub

teknisyen7777 · 19 Ekim 2017

Alaka için teşekkürler Halit3
Ancak son yazdığınız kodda da sadece tek bir sütunda resim gösteriyor.
En son hangi sütuna id girişi yaptıysam ona bağlı sütunda resimleri gösteriyor, diğer sütundaki resimleri ise siliyor.

askm · 20 Ekim 2017

ikinci fordaki b leri h yaparak dener misiniz.

halit3 · 20 Ekim 2017

Ne dediğinizi anlamak için yazıyorum

Mevcut kodlarınızda B7 hücresine sayı yazınca B5-B12 Hücrelerine bakarak F5-F12 hücrelerine resimleri getiriyor.

Örnek B7 hücresine 3 rakamını yazınca hangi satır ve sutünlara resimlerin gelmesi gerekiyor.

Asri · 20 Ekim 2017

Alternatif;

B kolonuna yada H kolonuna sayı girildiğinde 4 kolon sonraki resimi siler.
Girilen sayı adında resim var ise 4 kolon sonrasına ekler yok ise yok.jpg yi ekler.
Hücredeki sayı silinir ise hücre boş ise 4 kolon sonraki hücrede resim var ise siler.

Sayfanın kod bölümüne yapıştırınız.

Kod:

Dim resimyolu, resimyokyolu As String

Function dosyavarmi(dosya)
    Dim ds, a
    Set ds = CreateObject("Scripting.FileSystemObject")
    a = ds.FileExists(dosya)
    If a = True Then
    dosyavarmi = True
    Else
    dosyavarmi = False
    End If
End Function

Sub resimsil(curcell As Range)  'curcell=ActiveWindow.ActiveCell
    Dim sh As Shape
    On Error Resume Next
    For Each sh In ActiveSheet.Shapes
        If sh.TopLeftCell.Address = curcell.Address Then sh.Delete
    Next
End Sub


'worksheette bir değişiklik oldugunda bu kısım çalışıyor
Private Sub Worksheet_Change(ByVal Target As Range)
    'If Target.Cells.Count > 1 Then Exit Sub
    If Intersect(Target, Range("B5:B100000", "H5:H100000")) Is Nothing Then Exit Sub

    For Each hucre In Selection
      If hucre.Value = "" Then
         resimsil (Cells(hucre.Row, hucre.Column + 4))
         GoTo son
      End If
    
         yol = ActiveWorkbook.Path & "\"
         resimyolu = yol & hucre.Value & ".jpg"
         resimyokyolu = yol & "yok.jpg"
         resimsil (Cells(hucre.Row, hucre.Column + 4))
         If dosyavarmi(resimyolu) Then
           Set Rng = Cells(hucre.Row, hucre.Column + 4)
           Rng.Select
           Set sShape = ActiveSheet.Shapes.AddPicture(resimyolu, msoFalse, msoCTrue, Selection.Left, Selection.Top, Selection.Width, Selection.Height)
         Else
           Set Rng = Cells(hucre.Row, hucre.Column + 4)
           Rng.Select
           Set sShape = ActiveSheet.Shapes.AddPicture(resimyokyolu, msoFalse, msoCTrue, Selection.Left, Selection.Top, Selection.Width, Selection.Height)
        
         End If
son:
    Next
End Sub

teknisyen7777 · 20 Ekim 2017

asri' Alıntı:

Alternatif;

B kolonuna yada H kolonuna sayı girildiğinde 4 kolon sonraki resimi siler.
Girilen sayı adında resim var ise 4 kolon sonrasına ekler yok ise yok.jpg yi ekler.
Hücredeki sayı silinir ise hücre boş ise 4 kolon sonraki hücrede resim var ise siler.

Sayfanın kod bölümüne yapıştırınız.

Kod:

Dim resimyolu, resimyokyolu As String

Function dosyavarmi(dosya)
    Dim ds, a
    Set ds = CreateObject("Scripting.FileSystemObject")
    a = ds.FileExists(dosya)
    If a = True Then
    dosyavarmi = True
    Else
    dosyavarmi = False
    End If
End Function

Sub resimsil(curcell As Range)  'curcell=ActiveWindow.ActiveCell
    Dim sh As Shape
    On Error Resume Next
    For Each sh In ActiveSheet.Shapes
        If sh.TopLeftCell.Address = curcell.Address Then sh.Delete
    Next
End Sub


'worksheette bir değişiklik oldugunda bu kısım çalışıyor
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Cells.Count > 1 Then Exit Sub
    If Intersect(Target, Range("B5:B100000", "H5:H100000")) Is Nothing Then Exit Sub
    satir = Target.Row
    sutun = Target.Column
    If Target.Value = "" Then
       resimsil (Cells(satir, sutun + 4))
       Exit Sub
    End If
    
    yol = ActiveWorkbook.Path & "\"
    resimyolu = yol & Target.Value & ".jpg"
    resimyokyolu = yol & "yok.jpg"
    resimsil (Cells(satir, sutun + 4))
    If dosyavarmi(resimyolu) Then
      Set Rng = Cells(satir, sutun + 4)
      Rng.Select
      Set sShape = ActiveSheet.Shapes.AddPicture(resimyolu, msoFalse, msoCTrue, Selection.Left, Selection.Top, Selection.Width, Selection.Height)
    Else
      Set Rng = Cells(satir, sutun + 4)
      Rng.Select
      Set sShape = ActiveSheet.Shapes.AddPicture(resimyokyolu, msoFalse, msoCTrue, Selection.Left, Selection.Top, Selection.Width, Selection.Height)
   
    End If

End Sub

Asri arkadaşın verdiği bu kod tam aradığım kod. Teşekkürler.

teknisyen7777 · 20 Ekim 2017

Çok özür dileyerek bir ekleme yapmak istiyorum.
B ve H sütunlarına tek tek veri girişi yaptığımızda sorun yok ama kopyala yapıştır yaparak toplu giriş yaptığımızda maalesef resimleri getirmiyor.

Asri · 20 Ekim 2017

teknisyen7777' Alıntı:
Çok özür dileyerek bir ekleme yapmak istiyorum.
B ve H sütunlarına tek tek veri girişi yaptığımızda sorun yok ama kopyala yapıştır yaparak toplu giriş yaptığımızda maalesef resimleri getirmiyor.

Kod güncellendi. Kontrol ediniz.

teknisyen7777 · 20 Ekim 2017

asri' Alıntı:
Kod güncellendi. Kontrol ediniz.

Evet tamamdır. Teşekkürler.

halit3 · 21 Ekim 2017

Alternatif kod 6 farklı resim uzantısından resimleri getiriyor.
ayrıca yok.jpg resim nesnesini de kontrol ediyor.

Kod:

Private Sub Worksheet_Change(ByVal Target As Range)

If Intersect(Target, [b2:b1000,h2:h1000]) Is Nothing Then Exit Sub
If InStr(Trim(ActiveWindow.RangeSelection.Address), ":") > 0 Then Exit Sub

Dim s1, Adres, yatay, dikey, j, Dosya, ad
Set s1 = Sheets(ActiveSheet.Name)

yatay = 4 ' bu kadar hücre sağa kayacak
dikey = 0  ' bu kadar hücre aşağıya kayacak

Set Adres = s1.Cells(Target.Row + dikey, Target.Column + yatay)

Dim Picture As Object
For Each Picture In s1.Shapes
If TypeName(s1.Shapes(Picture.Name).OLEFormat.Object) = "Picture" Then
If s1.Cells(Picture.TopLeftCell.Row, Picture.TopLeftCell.Column).Address = Adres.Address Then
Picture.Delete
Exit For
End If
End If
Next Picture

ReDim uzanti(6)
uzanti(1) = "jpg": uzanti(2) = "JPG": uzanti(3) = "gif": uzanti(4) = "GİF": uzanti(5) = "bmp":   uzanti(6) = "BMP"

For j = 1 To 6
Dosya = ThisWorkbook.Path & "\" & Target.Value & "." & uzanti(Val(j))
If CreateObject("Scripting.FileSystemObject").FileExists(Dosya) = True Then
GoTo atla
End If
Next

Dosya = ThisWorkbook.Path & "\yok.jpg"

If CreateObject("Scripting.FileSystemObject").FileExists(Dosya) = False Then
GoTo atla2
End If

atla:

s1.Shapes.AddPicture Dosya, msoFalse, msoCTrue, Adres.Left + 1, Adres.Top + 1, Adres.Width - 2, Adres.Height - 2
atla2:

End Sub

(Çözüldü) Klasörden otomatik resim alma

teknisyen7777

askm

Destek Ekibi

halit3

Uzman

hakankilic

halit3

Uzman

teknisyen7777

teknisyen7777

halit3

Uzman

teknisyen7777

askm

Destek Ekibi

halit3

Uzman

Asri

teknisyen7777

teknisyen7777

Asri

teknisyen7777

halit3

Uzman