Açıklama Kutusunun içine Resim Ekleme

[cevatyildiz]

Merhaba,

Ekte açıklama ekleme ile ilgili internette buldugum bir örnek var. Ben bu örneği biraz değiştirerek uygulamak istiyorum. Ekte yapmak istediğim ufak değişikliği bulabilirsiniz...

 

[hamitcan]

Örnek bir dosya ekledim, inceleyin.

Option Explicit

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Intersect(Target, [f13:f17]) Is Nothing Then Exit Sub
    With [L19]
    .ClearComments
    .AddComment
    .Comment.Visible = True
    .Comment.Shape.Select True
         Selection.ShapeRange.Fill.UserPicture _
     ThisWorkbook.Path & "\" & Cells(Target.Row, "c") & Target.Text & ".jpg"
    End With
End Sub

 

[cevatyildiz]

hamitcan eline sağlık çok güzel ama f sütunu haricinde farklı bir hücreye tıklandıgında otomatik kaybolabilir mi? Ayrıca birden fazla satır-hücre seçimi yaptıgımda hata veriyor. Bazen bazı satırları beraber kopyalamam gerekebiliyor...

Son olarak resimin boyutunu biraz büyük görmek istiyorum ebatlarını kendi verme şansım var mı?

 

[cevatyildiz]

Arkadaslar yardımcı olabilecek olan varmı?

 

[hamitcan]

hamitcan eline sağlık çok güzel ama f sütunu haricinde farklı bir hücreye tıklandıgında otomatik kaybolabilir mi?

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Not Intersect(Target, [f13:f17]) Is Nothing Then
    With [L19]
    .ClearComments
    .AddComment
    .Comment.Visible = True
    .Comment.Shape.Select True
         Selection.ShapeRange.Fill.UserPicture _
     ThisWorkbook.Path & "\" & Cells(Target.Row, "c") & Target.Text & ".jpg"
    End With
    Else
    [L19].ClearComments
    End If
End Sub

Diğer sorularınızı sırayla cevaplamaya çalışacağım.

 

[hamitcan]

Ayrıca birden fazla satır-hücre seçimi yaptıgımda hata veriyor. Bazen bazı satırları beraber kopyalamam gerekebiliyor...

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim hcr As Range
    Dim c As Integer
    [g1:g5].ClearComments
    If Not Intersect(Target, [f13:f17]) Is Nothing Then
            For Each hcr In Selection
                c = c + 1
                With Cells(c, "g")
                    .AddComment
                    .Comment.Visible = True
                    .Comment.Shape.Select True
                     Selection.ShapeRange.Fill.UserPicture _
                     ThisWorkbook.Path & "\" & Cells(hcr.Row, "c") & Cells(hcr.Row, "f") & ".jpg"
                End With
            Next
    Else
        [g1:g5].ClearComments
    End If
End Sub

 

[hamitcan]

Son olarak resimin boyutunu biraz büyük görmek istiyorum ebatlarını kendi verme şansım var mı?

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim hcr As Range
    Dim c As Integer
    Dim yuk As Double, gen As Double
    If Not Intersect(Target, [f13:f17]) Is Nothing Then
    [g1:g5].ClearComments
    yuk = InputBox("Yüksekliği Girin")
    gen = InputBox("Genişliği Girin")

            For Each hcr In Selection
                c = c + 1
                With Cells(c, "g")
                    .AddComment
                    .Comment.Visible = True
                    .Comment.Shape.Select True
                     Selection.ShapeRange.Fill.UserPicture _
                     ThisWorkbook.Path & "\" & Cells(hcr.Row, "c") & Cells(hcr.Row, "f") & ".jpg"
                     Selection.Height = yuk
                     Selection.Width = gen
                     .Comment.Visible = False
                End With
            Next
    Else
        [g1:g5].ClearComments
    End If
End Sub

 

[cevatyildiz]

hamitcan yardımlarınız için teşekkür ederim. Sorunlarım :

1. Dışarıdan bir değer girilmesini istemiyorum, yukseklik ve genişliği kodlardan vermemiz yeterli olur.
2. Birden fazla rengi seçme işlemini yapamıyorum. Birden fazla seçim yaptıgımda resim gözükmemesi lazım.

 

[hamitcan]

hamitcan yardımlarınız için teşekkür ederim. Sorunlarım :

1. Dışarıdan bir değer girilmesini istemiyorum, yukseklik ve genişliği kodlardan vermemiz yeterli olur.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim hcr As Range
    Dim c As Integer
    Dim yuk As Double, gen As Double
    If Not Intersect(Target, [f13:f17]) Is Nothing Then
    [g1:g5].ClearComments
'    yuk = InputBox("Yüksekliği Girin")
 '   gen = InputBox("Genişliği Girin")

            For Each hcr In Selection
                c = c + 1
                With Cells(c, "g")
                    .AddComment
                    .Comment.Visible = True
                    .Comment.Shape.Select True
                     Selection.ShapeRange.Fill.UserPicture _
                     ThisWorkbook.Path & "\" & Cells(hcr.Row, "c") & Cells(hcr.Row, "f") & ".jpg"
                     Selection.Height = 100
                     Selection.Width = 200
                     .Comment.Visible = False
                End With
            Next
    Else
        [g1:g5].ClearComments
    End If
End Sub

2. Birden fazla rengi seçme işlemini yapamıyorum. Birden fazla seçim yaptıgımda resim gözükmemesi lazım

2.sorunuzu anlamadım.

 

[cevatyildiz]

Mesela C13 den F17 ye kadar olan tablomu seçip kopyalayarak mail programı ile gondermek istiyorum. Seçimi yaptıgımda bir sürü resim çıkıyor ekrana. Üstelik resimler çıktıgı için sol tıklayıp kopyala yapacagim seçim alanım da kayboluyor.

 

[hamitcan]

Bir de böyle deneyin.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim hcr As Range
    Dim c As Integer
    Dim yuk As Double, gen As Double
        [g1:g5].ClearComments

    If Intersect(Target, [f13:f17]) Is Nothing Then Exit Sub
    If Target.Count > 5 Then Exit Sub

    
'    yuk = InputBox("Yüksekliği Girin")
'    gen = InputBox("Genişliği Girin")

            For Each hcr In Selection
                c = c + 1
                With Cells(c, "g")
                    .AddComment
                    .Comment.Visible = True
                    .Comment.Shape.Select True
                     Selection.ShapeRange.Fill.UserPicture _
                     ThisWorkbook.Path & "\" & Cells(hcr.Row, "c") & Cells(hcr.Row, "f") & ".jpg"
                     Selection.Height = 100 'yuk
                     Selection.Width = 100 'gen
                     .Comment.Visible = False
                End With
            Next
End Sub

 

[cevatyildiz]

Harika oldu elinize sağlık

 

[cevatyildiz]

Denk gelen bir resim var olmadıgında hata vermesini engelleyebilir miyiz?

 

[hamitcan]

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim hcr As Range
    Dim c As Integer
    Dim yuk As Double, gen As Double
        
    If Intersect(Target, [g1:g5]) Is Nothing Then [g1:g5].ClearComments
    If Intersect(Target, [f13:f17]) Is Nothing Then Exit Sub
    
    If Target.Count > 5 Then Exit Sub

    
'    yuk = InputBox("Yüksekliği Girin")
'    gen = InputBox("Genişliği Girin")

            For Each hcr In Selection
                c = c + 1
                With Cells(c, "g")
                    .AddComment
                    .Comment.Visible = True
                    .Comment.Shape.Select True
                    On Error Resume Next
                     Selection.ShapeRange.Fill.UserPicture _
                     ThisWorkbook.Path & "\" & Cells(hcr.Row, "c") & Cells(hcr.Row, "f") & ".jpg"
                     Selection.Height = 100 'yuk
                     Selection.Width = 100 'gen
                     .Comment.Visible = False
                End With
            Next
End Sub

 

[cevatyildiz]

çok teşekkür ederim, çok zamanınızı aldım.

 

[cevatyildiz]

Resimin G sütununun ilk satırında değilde 4. satırında çıkmasını sağlamak için ne yapabiliriz?

 

[hamitcan]

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim hcr As Range
    Dim c As Integer
    Dim yuk As Double, gen As Double
    [color=red] c=3   [/color]
    If Intersect(Target, [g1:g5]) Is Nothing Then [g1:g5].ClearComments
    If Intersect(Target, [f13:f17]) Is Nothing Then Exit Sub
    
    If Target.Count > 5 Then Exit Sub

    
'    yuk = InputBox("Yüksekliği Girin")
'    gen = InputBox("Genişliği Girin")

            For Each hcr In Selection
                c = c + 1
                With Cells(c, "g")
                    .AddComment
                    .Comment.Visible = True
                    .Comment.Shape.Select True
                    On Error Resume Next
                     Selection.ShapeRange.Fill.UserPicture _
                     ThisWorkbook.Path & "\" & Cells(hcr.Row, "c") & Cells(hcr.Row, "f") & ".jpg"
                     Selection.Height = 100 'yuk
                     Selection.Width = 100 'gen
                     .Comment.Visible = False
                End With
            Next
End Sub

 

[cevatyildiz]

uzun bir süre sonra farkettimki auto filter kullanınca resim göstermede problem yaşıyorum. Acaba ilgili alan tıklandıgında hangi satırdaysa; o satırın G sütununda çıkmasını salayabilir misiniz?

Tesekkurler

 

[hamitcan]

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim hcr As Range
    Dim c As Integer
    Dim yuk As Double, gen As Double
    Columns("g").ClearComments
    If Intersect(Target, [f13:f17]) Is Nothing Then Exit Sub
    If Target.Count > 5 Then Exit Sub

                With Cells(Target.Row, "G")
                    .AddComment
                    .Comment.Visible = True
                    .Comment.Shape.Select True
                End With
                    On Error Resume Next
                     Selection.ShapeRange.Fill.UserPicture _
                     ThisWorkbook.Path & "\" & Cells(Target.Row, "c") & Cells(Target.Row, "f") & ".jpg"
                     Selection.Height = 100 'yuk
                     Selection.Width = 100 'gen
'                     .Comment.Visible = False
                
End Sub

 

[cevatyildiz]

Teşekkürler