VBA Resim çekme ve düzeltme

[mrtklc]

Herkese merhaba.

Excel VBA konusunda çok yeniyim. Aşağıda yazılan VBA kodlarını kendimce düzelttim.
Açılır liste oluşturdum. Açılır listede ilgili metini seçtiğimde logo geliyor, açılır listesinde farklı bir metni seçtiğimde logo gelmekte fakat önceki logonun üstünde oluyor. Bir öncekini silip yeni seçtiğim logonun gelmesi için hangi kodu yazmak lazım.

Diğer sorunum ise yine açılır listede yer alan fakat logosu olmayan metnin yanına sabit bir logo ekleyebilirmiyiz.
Ayrıca Logo sil kodu logosu olmayan metni seçtiğimde sonraki satırdakileri siliyor.

Çok teşekkür ederim.

Private Sub Worksheet_Change(ByVal Target As Range)

If Intersect(Target, [D:D]) Is Nothing Then Exit Sub

'Hata
On Error GoTo hata

'Logo Sil
ActiveSheet.DrawingObjects.Delete

   
'Logo yolunun bulunması

Dim Logoyolu As Variant
Dim Logo As Object

For satır = 4 To 50

Logoyolu = ActiveWorkbook.Path & "\logolar\" & Range("D" & satır) & ".png"

'Logo oluştur

Set Logo = ActiveSheet.Pictures.Insert(Logoyolu)

'Logoyu boyutlandır

With Range("C" & satır)
Logo.Top = .Top + 3
Logo.Left = .Left + 8
Logo.Height = .Height - 5
'Logo.Width = .Width

End With

Next satır

hata:
End Sub

 

[Ömer]

Merhaba,

Örnek dosya ekleyerek açıklar mısınız.

Dosya Yükle - Dosya Upload

Dosyalarınızı ücretsiz yükleyebilir ve paylaşabilirsiniz. Dosya yükleme, Dosya Upload ücretsiz.

dosya.co

.

 

[Korhan Ayhan]

Deneyiniz.

DIR komutu ile logonun varlığı test edilebilir.

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Logo_Yolu As String, Logo As Object, X As Long
   
    If Intersect(Target, Range("D:D")) Is Nothing Then Exit Sub
   
    On Error GoTo Hata
   
    If ActiveSheet.DrawingObjects.Count > 0 Then ActiveSheet.DrawingObjects.Delete
   
    For X = 4 To 50
        Logo_Yolu = ActiveWorkbook.Path & "\logolar\" & Range("D" & X) & ".png"
   
        If Dir(Logo_Yolu) <> "" Then
            Set Logo = ActiveSheet.Pictures.Insert(Logo_Yolu)
           
            With Range("C" & X)
                Logo.Top = .Top + 3
                Logo.Left = .Left + 8
                Logo.Height = .Height - 5
                Logo.Width = .Width
            End With
        End If
    Next
   
Hata:
End Sub

 

[mrtklc]

Deneyiniz.

DIR komutu ile logonun varlığı test edilebilir.

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Logo_Yolu As String, Logo As Object, X As Long
 
    If Intersect(Target, Range("D:D")) Is Nothing Then Exit Sub
 
    On Error GoTo Hata
 
    If ActiveSheet.DrawingObjects.Count > 0 Then ActiveSheet.DrawingObjects.Delete
 
    For X = 4 To 50
        Logo_Yolu = ActiveWorkbook.Path & "\logolar\" & Range("D" & X) & ".png"
 
        If Dir(Logo_Yolu) <> "" Then
            Set Logo = ActiveSheet.Pictures.Insert(Logo_Yolu)
         
            With Range("C" & X)
                Logo.Top = .Top + 3
                Logo.Left = .Left + 8
                Logo.Height = .Height - 5
                Logo.Width = .Width
            End With
        End If
    Next
 
Hata:
End Sub

Hocam çok teşekkür ederim.
Logosu olmayan bir metni seçtiğimde varsayılan bir imaj atayabilirmiyiz. logoyok.png gibi. Ayrıca logoları bulunduğu hücrede kilitleyebilir miyiz. Şimdiden çok teşekkür ederim.

 

[silvereye06]

Sayın hocalar,
merak ettiğim resimlerin excel dosyası ile aynı klasörde olması gerekmekte, fakat çok farklı resim adeti olunca dosya karışabilmekte, klasörden çağırılan bir resim paketi bu yöntem sonrası excel dosyası içine gömülü olarak kayıt edilebilecek bir yöntem bulunuyor mu?

 

[Korhan Ayhan]

Merhaba,

Linkten faydalanabilirsiniz.

Bağlantılı resim görüntülenemiyor, Dosya taşımış hatası

Aynı sorunu ben de yaşıyorum. Insert komutu ile resim ekliyorum. Ama resimleri klasörden silince Excel'de görünmüyor. Bu resimleri Excel'e gömmek mümkün mü?

www.excel.web.tr

 

[nzmsmz]

Merhaba,

Linkten faydalanabilirsiniz.

Bağlantılı resim görüntülenemiyor, Dosya taşımış hatası

Aynı sorunu ben de yaşıyorum. Insert komutu ile resim ekliyorum. Ama resimleri klasörden silince Excel'de görünmüyor. Bu resimleri Excel'e gömmek mümkün mü?

www.excel.web.tr

Korhan Bey merhaba,

ilgili kodu, ekte eklediğim test örneğine göre nasıl revize edebiliriz ?, klasorden değil de farklı bir sayfadan çekmesini
Resmi çektikten sonrada genişlik 4,77 yükseklik 6,50 olmalı. Bunlara ek olarak eğer olabiliyorsa stili vesaydamlık derecesini belirttiğim şekilde otomatik dönüştürebilirmi ?

resimtest_.xlsm dosyasını indir - download

resimtest_.xlsm dosyasını indir, download. Dosya.tc .Dosya Upload. Dosya Paylaş. Dosya Yükle

s2.dosya.tc

 

[silvereye06]

Korhan bey teşekkür ederim cevap için ama ilgili çalışmamı aşağıdaki link üzerine yükledim.

çalışma dosyası

burada

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, [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 = 2 To 450
    'aktif sayfanın path bilgisini alıp, seçilen ürün idyi sonuna ekliyoruz ve dosyayı alıyoruz
    ResimDosyaYolu = ActiveWorkbook.Path & "\" & Range("h" & i) & ".jpg"

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

Next i

Çıkış:

End Sub

yukarıdaki kod dizilimine göre excell dosyası ile resimler aynı klasörde olmak zorunda yoksa resimler görülmüyor. Talebim resimleri bu kodla yükledikten sonra resimleri excell içine gömülü hale getirmek.