DOSYADAN RESİM ÇAĞIRMA

[axelis]

Arkadaşlar merhaba , iyi günler.

Ekte forumdan farklı linklerden yararlanarak hazırladığım bir çalışma var. Belirlenen klasörden girilen koda göre resim çağırmakta. Fakat maddelediğim konuları çözemedim desteğinize ihtiyacım var ;

- Listeye girilen kodları tek tek sildiğimde görseller gidiyor fakat toplu şekilde seçip sildiğimde ya da makro ile sildiğimde hata veriyor.
- Listeyi filtrelediğimde resimler üst üste biniyor , sadece ilgili kodun resmi gelmesi mümkün müdür filtre yapıldığında ?
- Hücre genişliğine göre resmi sığdırıyor fakat sürekli sola yanaştırıyor. Resmi yatayda ve dikeyde hücrede merkezlemesi mümkün mü ?

Şimdiden teşekkürler ,

uyguladığım kod aşağıdaki gibidir. Dosyayı ve ilgili resim klasörünü de paylaştım.

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("B3:B20")) Is Nothing Then Exit Sub
Dim PicFile As Variant
Dim MyPic As Object
'hata kontrolü
'On Error GoTo çıkış
Set MyRng = ActiveSheet.Range("C" & Target.Row)
If Target.Value = "" Then
For Each x In ActiveSheet.Shapes
If Val(x.Top) = Val(Range("C" & Target.Row).Top) Then
x.Delete
End If
Next x
Else
PicFile = ActiveWorkbook.Path & "\resimler\" & Target.Value & ".jpg"
If Dir(PicFile) <> "" Then
'Set Resim = ActiveSheet.Pictures.Insert(PicFile)
With MyRng
PicTop = MyRng.Top
PicLeft = MyRng.Left
PicH = -1
PicW = -1

Set MyPic = ActiveSheet.Shapes.AddPicture(PicFile, True, True, PicLeft, PicTop, PicW, PicH)
MyPic.Name = "MyPicture"

MyPic.Width = MyRng.Width

If MyPic.Height > MyRng.Height Then
MyPic.Height = MyRng.Height
End If

Set MyPic = Nothing
Set MyRng = Nothing

End With
Else
MsgBox "Resim Bulunamadı"
End If: End If
çıkış:
End Sub

 

[Muzaffer Ali]

Merhaba.
Sayfadaki kodları silin aşağıdakileri kopyalayın.

Option Explicit

Private Sub CommandButton1_Click()
    Dim tmz As VbMsgBoxResult
    Dim Bak As Range
    Dim Pic As Shape
    tmz = MsgBox("Alanlar temizlensinmi?", vbYesNo)
    If tmz = vbYes Then
        For Each Bak In Range("B3:B20")
            On Error Resume Next
            If Not Bak.Text = "" Then ActiveSheet.Shapes(Bak.Address).Delete
        Next
        Range("B3:B20").ClearContents
    End If
End Sub

Private Sub Worksheet_Calculate()
    Dim Bak As Range
    On Error Resume Next
    For Each Bak In Range("B3:B20")
        If Rows(Bak.Row).EntireRow.Hidden = True Then
            ActiveSheet.Pictures(Bak.Address).Visible = False
        Else
            ActiveSheet.Pictures(Bak.Address).Visible = True
        End If
    Next
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim PicFile As Variant
    Dim MyPic As Object
    Dim MyRng As Range
    Dim x As Shape
    Dim PicTop As Integer, PicLeft As Integer, PicH As Integer, PicW As Integer
    Dim Bak As Range
    
    If Intersect(Target, Range("B3:B20")) Is Nothing Then Exit Sub
    For Each Bak In Target
        Set MyRng = ActiveSheet.Range("C" & Bak.Row)
        If Not Bak.Value = "" Then
            PicFile = ActiveWorkbook.Path & "\resimler\" & Bak.Value & ".jpg"
            If Dir(PicFile) <> "" Then
                With MyRng
                    PicW = MyRng.Width - 10
                    PicH = MyRng.Height - 10
                    PicTop = MyRng.Top + ((MyRng.Height - PicH) / 2)
                    PicLeft = MyRng.Left + ((MyRng.Width - PicW) / 2)
                    
                    Set MyPic = ActiveSheet.Shapes.AddPicture(PicFile, True, True, PicLeft, PicTop, PicW, PicH)
                    MyPic.Name = Bak.Address
                    Set MyPic = Nothing
                    Set MyRng = Nothing
                End With
            Else
                MsgBox "Resim Bulunamadı"
            End If
        End If
    Next Bak
End Sub

 

[Haluk]

ͼ( ͡~ ͜ʖ ͡°)ͽ

.

 

[Muzaffer Ali]

Şunu unutmuşum 2. isteğinizin gerçekleşmesi için herhangi bir hücreye örneğin A1 hücresine şu formülü kopyalayın.

=EĞERSAY(B:B;"")

Formül sonucunun görünmesini istemezseniz metin rengini beyaz yapabilirsiniz.

 

[axelis]

Şunu unutmuşum 2. isteğinizin gerçekleşmesi için herhangi bir hücreye örneğin A1 hücresine şu formülü kopyalayın.

=EĞERSAY(B:B;"")

Formül sonucunun görünmesini istemezseniz metin rengini beyaz yapabilirsiniz.

Merhaba, öncelikler teşekkürler cevaplarını için tam istediğim gibi olmuş ancak birkaç ufak detay var ,

-Resimlerin en x boy oranının bozmadan sığdırması mümkün mü ? Bendeki formül aynı ölçekte küçültüyordu sadece bir köşeye sabitliyordu resmi. (ek olarak resim ekledim)
- Bir de makro ile silme dışında ilgili veri hücrelerini seçip delete ile sildiğim zaman da resimler silinsin istiyorum mümkün müdür ?

teşekkürler.

 

[Muzaffer Ali]

O zaman aşağıdaki kodları deneyin.

Option Explicit

Private Sub CommandButton1_Click()
    Dim tmz As VbMsgBoxResult
    tmz = MsgBox("Alanlar temizlensinmi?", vbYesNo)
    If tmz = vbYes Then
        Temizle
        Range("B3:B20").ClearContents
    End If
End Sub

Sub Temizle()
    Dim Bak As Range
    For Each Bak In Range("B3:B20")
        On Error Resume Next
        If Bak.Text = "" Then ActiveSheet.Shapes(Bak.Address).Delete
    Next
End Sub

Private Sub Worksheet_Calculate()
    Dim Bak As Range
    On Error Resume Next
    For Each Bak In Range("B3:B20")
        If Rows(Bak.Row).EntireRow.Hidden = True Then
            ActiveSheet.Pictures(Bak.Address).Visible = False
        Else
            ActiveSheet.Pictures(Bak.Address).Visible = True
        End If
    Next
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim PicFile As Variant
    Dim MyPic As Object
    Dim MyRng As Range
    Dim x As Shape
    Dim PicTop As Integer, PicLeft As Integer, PicH As Integer, PicW As Integer
    Dim Bak As Range
    If Intersect(Target, Range("B3:B20")) Is Nothing Then Exit Sub
    For Each Bak In Target
        If Bak.Value = "" Then
            Temizle
        Else
            Set MyRng = ActiveSheet.Range("C" & Bak.Row)
            PicFile = ActiveWorkbook.Path & "\resimler\" & Bak.Value & ".jpg"
            If Dir(PicFile) <> "" Then
                With MyRng
                    Set MyPic = ActiveSheet.Shapes.AddPicture(PicFile, True, True, -1, -1, -1, -1)
                    MyPic.Name = Bak.Address
                    MyPic.LockAspectRatio = msoTrue
                    PicH = MyRng.Height - 4
                    MyPic.Height = PicH
                    PicW = MyPic.Width
                    PicTop = MyRng.Top + ((MyRng.Height - PicH) / 2)
                    PicLeft = MyRng.Left + ((MyRng.Width - PicW) / 2)
                    MyPic.Left = PicLeft
                    MyPic.Top = PicTop
                    Set MyPic = Nothing
                    Set MyRng = Nothing
                End With
            Else
                MsgBox "Resim Bulunamadı"
            End If
        End If
    Next Bak
End Sub

 

[axelis]

Çok güzel oldu elinize sağlık çok teşekkürler

 

[Muzaffer Ali]

Rica ederim iyi çalışmalar.

 

[mars2]

İyi Günler;
Yukarıdaki kodu, B3 hücresindeki isme göre gelmekte ancak, C3 hücresini, C3 ile D10 aralğında birleştirip tek hücre yaptığımda (C3 olarak gözükmekte) birleşen hücrelerin tammamında değil B3 hücresinin boyutunda gelmektedir.
Bu konuda yardımlarınızı beklemeketeyim.