• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Açıklama Kutusunun içine Resim Ekleme

C

cevatyildiz

Katılım
2 Mayıs 2008
Mesajlar
295
Excel Vers. ve Dili
Office 365
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...
 

Ekli dosyalar

Örnek bir dosya ekledim, inceleyin.
Kod: 
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
 

Ekli dosyalar

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ı?
 
Son düzenleme:
cevatyildiz' Alıntı:
hamitcan eline sağlık çok güzel ama f sütunu haricinde farklı bir hücreye tıklandıgında otomatik kaybolabilir mi?
Genişletmek için tıkla ...

Kod: 
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.
 
cevatyildiz' Alıntı:
Ayrıca birden fazla satır-hücre seçimi yaptıgımda hata veriyor. Bazen bazı satırları beraber kopyalamam gerekebiliyor...
Genişletmek için tıkla ...

Kod: 
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
 
cevatyildiz' Alıntı:
Son olarak resimin boyutunu biraz büyük görmek istiyorum ebatlarını kendi verme şansım var mı?
Genişletmek için tıkla ...

Kod: 
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
 
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.
 
cevatyildiz' Alıntı:
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.
Genişletmek için tıkla ...

Kod: 
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

cevatyildiz' Alıntı:
2. Birden fazla rengi seçme işlemini yapamıyorum. Birden fazla seçim yaptıgımda resim gözükmemesi lazım
Genişletmek için tıkla ...
2.sorunuzu anlamadım.
 
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.
 
Bir de böyle deneyin.
Kod: 
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
 
Kod: 
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
 
Resimin G sütununun ilk satırında değilde 4. satırında çıkmasını sağlamak için ne yapabiliriz?
 
Kod: 
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
 
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
 
Kod: 
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
 

Ekli dosyalar

Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst