Proforma'ya Resim Çekme

[ibrhmblc]

Merhabalar, çalıştığım iş yerinin proformasına otomatik resim çekmesi için bir vba kodu buldum ve uyguladım. Gayet düzgün çalışıyor ancak proformanın üstünde yer alan şirket logosunu siliyor. Nasıl düzeltebilirim?

 

[Muzaffer Ali]

Merhaba.

Muhtemelen kodlar resimleri eklemeden önce sayfada bulunan diğer resimler siliyor.
Kodlarda ".delete" ile biten satır varsa silin.

Eğer olmazsa-yapamazsanız dosyanızı ekleyin kontrol edelim.

 

[ibrhmblc]

Merhaba.

Muhtemelen kodlar resimleri eklemeden önce sayfada bulunan diğer resimler siliyor.
Kodlarda ".delete" ile biten satır varsa silin.

Eğer olmazsa-yapamazsanız dosyanızı ekleyin kontrol edelim.

Hocam allah razı olsun, işe yaradı

 

[ibrhmblc]

Merhaba.

Muhtemelen kodlar resimleri eklemeden önce sayfada bulunan diğer resimler siliyor.
Kodlarda ".delete" ile biten satır varsa silin.

Eğer olmazsa-yapamazsanız dosyanızı ekleyin kontrol edelim.

Muzaffer hocam, bir sorum daha olacak. Proformanın yukarısında iki logo bulunuyor. .delete kodunu sildiğim için kodları değiştirirken veya eklerken eski resimler arkada kalıyor. B1:B20 arasını pas geçmesini sağlayabilir miyim .delete kodunun.

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)
If Intersect(Target, [b:b]) Is Nothing Then Exit Sub

On Error GoTo Çıkış:
ActiveSheet.DrawingObjects.Delete

Dim ResimDosyaYolu As String
Dim Resim As Object
For i = 20 To 31
   
    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("j" & i)
     Resim.Top = .Top
     Resim.Left = .Left
     Resim.Height = .Height
     Resim.Width = .Width
     End With

Next i

Çıkış:

End Sub

 

[Muzaffer Ali]

Hücre adresine göre değil, resim adına göre yapılabilir.
Dosyanızı paylaşırsanız yapabiliriz.

Dosyanızda özel şeyler varsa onları silin.
Sadece Logolar kalsın. Yani sürekli sabit kalacak olan resimler kalsın.

Eğer dosyanız özel değilse tamamını paylaşın..

 

[ibrhmblc]

Hücre adresine göre değil, resim adına göre yapılabilir.
Dosyanızı paylaşırsanız yapabiliriz.

Dosyanızda özel şeyler varsa onları silin.
Sadece Logolar kalsın. Yani sürekli sabit kalacak olan resimler kalsın.

Eğer dosyanız özel değilse tamamını paylaşın..

hocam altın üye olmadığım için dosya ekleyemiyorum sanırım. Ekran Alıntısı.PNG olarak geçiyor resimler

 

[Muzaffer Ali]

dosya.tc gibi bir paylaşım sitesine ekleyip linkini buraya kopyalayın.

 

[ibrhmblc]

dosya.tc gibi bir paylaşım sitesine ekleyip linkini buraya kopyalayın.

Proforma.xlsm dosyasını indir - download

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

s7.dosya.tc

 

[Muzaffer Ali]

Yukarıda eklediğiniz kod ile dosyanızdaki aynı değil.

Ayrıca dosyadaki kodları silerken yanlışlıkla sildiğiniz yerler var.

Dosyanızın kod kısmında hiçbir şey silmeden gönderirseniz çözmeye çalışabilirim.

 

[ibrhmblc]

Pardon hocam denediğim haliyle kalmış. https://s7.dosya.tc/server20/0434d5/Proforma.xlsm.html şöyle buyurun

 

[Muzaffer Ali]

Private Sub Worksheet_Change kodlarını aşağıdaki ile değiştirin.

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [b:b]) Is Nothing Then Exit Sub
On Error GoTo Çıkış:
Dim Bak As Integer
    For Bak = DrawingObjects.Count To 1 Step -1
        MsgBox Sayfa1.DrawingObjects.Count
        If Not DrawingObjects(Bak).Name = "1 Resim" And Not DrawingObjects(Bak).Name = "2 Resim" Then
            DrawingObjects(Bak).Delete
        End If
    Next
Dim ResimDosyaYolu As String
Dim Resim As Object
For i = 20 To 31
    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("j" & i)
     Resim.Top = .Top
     Resim.Left = .Left
     Resim.Height = .Height
     Resim.Width = .Width
     End With
Next i
Çıkış:
End Sub

 

[ibrhmblc]

Private Sub Worksheet_Change kodlarını aşağıdaki ile değiştirin.

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [b:b]) Is Nothing Then Exit Sub
On Error GoTo Çıkış:
Dim Bak As Integer
    For Bak = DrawingObjects.Count To 1 Step -1
        MsgBox Sayfa1.DrawingObjects.Count
        If Not DrawingObjects(Bak).Name = "1 Resim" And Not DrawingObjects(Bak).Name = "2 Resim" Then
            DrawingObjects(Bak).Delete
        End If
    Next
Dim ResimDosyaYolu As String
Dim Resim As Object
For i = 20 To 31
    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("j" & i)
     Resim.Top = .Top
     Resim.Left = .Left
     Resim.Height = .Height
     Resim.Width = .Width
     End With
Next i
Çıkış:
End Sub

hocam teşekkürler fakat logolar silindi bende. Bende mi bir sorun var acaba

 

[Muzaffer Ali]

Ben Resimlerin isimlerini değiştirmiştim ondan kaynaklanıyor.
Kodlarda bulunan1 Resim ve 2 Resim yerine 4 Resim, 17 Resim yazın.

 

[ibrhmblc]

Ben Resimlerin isimlerini değiştirmiştim ondan kaynaklanıyor.
Kodlarda bulunan1 Resim ve 2 Resim yerine 4 Resim, 17 Resim yazın.

hocam çok teşekkür ederim, ellerinize sağlık