Ürün Koduna Göre Açıklama Penceresine Resim Getirme.

[beza]

Merhaba, 2000 satırlı ürün bilgilerini içeren tabloda A sütununda ürün kodları var. C:\Bilgi\Bilgi1\Resim klasörü içerisinde ürün kodlarına göre isimlendirilmiş jpg formatında resimler mevcut. Bir kod ile A sütununda bulunan hücrelere açıklama penceresi ekleyip, içerisinde o hücrede belirtilen ürünün resmi gösterilebilirmi?

 

[Levent Menteşoğlu]

Merhaba, 2000 satırlı ürün bilgilerini içeren tabloda A sütununda ürün kodları var. C:\Bilgi\Bilgi1\Resim klasörü içerisinde ürün kodlarına göre isimlendirilmiş jpg formatında resimler mevcut. Bir kod ile A sütununda bulunan hücrelere açıklama penceresi ekleyip, içerisinde o hücrede belirtilen ürünün resmi gösterilebilirmi?

Aşağıdaki kodu denermisiniz.

Sub resimekle()

On Error Resume Next

Application.ScreenUpdating = False
Set s1 = ActiveSheet

For a = 2 To s1.Cells(Rows.Count, "A").End(3).Row

dt = CreateObject("Scripting.FileSystemObject").FileExists _
("C:\Bilgi\Bilgi1\Resim\" & s1.Cells(a, "A") & ".jpg")

If dt = False Then GoTo 10

If Not Intersect(s1.Cells(a, "A").SpecialCells(xlCellTypeComments), s1.Cells(a, "A")) Is Nothing _
Then s1.Cells(a, "A").ClearComments

s1.Cells(a, "A").AddComment
s1.Cells(a, "A").Comment.Visible = True
s1.Cells(a, "A").Comment.Text Text:=""
s1.Cells(a, "A").Comment.Shape.Select True
Selection.ShapeRange.Fill.UserPicture _
"C:\Bilgi\Bilgi1\Resim\" & s1.Cells(a, "A") & ".jpg"
Selection.ShapeRange.ScaleWidth 2, msoFalse, msoScaleFromTopLeft
Selection.ShapeRange.ScaleHeight 3.5, msoFalse, msoScaleFromTopLeft
s1.Cells(a, "A").Comment.Visible = False

10 Next

End Sub

 

[beza]

Aşağıdaki kodu denermisiniz.

Sub resimekle()

Application.ScreenUpdating = False
Set s1 = ActiveSheet

For a = 2 To s1.Cells(Rows.Count, "A").End(3).Row

dt = CreateObject("Scripting.FileSystemObject").FileExists _
("C:\Bilgi\Bilgi1\Resim\" & s1.Cells(a, "A") & ".jpg")

If dt = False Then GoTo 10

If Not Intersect(s1.Cells(a, "A").SpecialCells(xlCellTypeComments), s1.Cells(a, "A")) Is Nothing _
Then s1.Cells(a, "A").ClearComments

s1.Cells(a, "A").AddComment
s1.Cells(a, "A").Comment.Visible = True
s1.Cells(a, "A").Comment.Text Text:=""
s1.Cells(a, "A").Comment.Shape.Select True
Selection.ShapeRange.Fill.UserPicture _
"C:\Bilgi\Bilgi1\Resim\" & s1.Cells(a, "A") & ".jpg"
Selection.ShapeRange.ScaleWidth 2, msoFalse, msoScaleFromTopLeft
Selection.ShapeRange.ScaleHeight 3.5, msoFalse, msoScaleFromTopLeft
s1.Cells(a, "A").Comment.Visible = False

10 Next

End Sub

Levent Bey Merhaba,
Öncelikle ilginiz için teşekkür ederim.
Tablonun olduğu sayfa1 e ilgili kodları eklediğimde (run time error 1004 - application defined or object defined error) hatası veriyor. çalıştıramadım.

 

[Levent Menteşoğlu]

Kodların en üstüne aşağıdaki satırı ekleyin.

On Error Resume Next

Sub resimekle()

On Error Resume Next

Application.ScreenUpdating = False
Set s1 = ActiveSheet

For a = 2 To s1.Cells(Rows.Count, "A").End(3).Row

dt = CreateObject("Scripting.FileSystemObject").FileExists _
("C:\Bilgi\Bilgi1\Resim\" & s1.Cells(a, "A") & ".jpg")

If dt = False Then GoTo 10

If Not Intersect(s1.Cells(a, "A").SpecialCells(xlCellTypeComments), s1.Cells(a, "A")) Is Nothing _
Then s1.Cells(a, "A").ClearComments

s1.Cells(a, "A").AddComment
s1.Cells(a, "A").Comment.Visible = True
s1.Cells(a, "A").Comment.Text Text:=""
s1.Cells(a, "A").Comment.Shape.Select True
Selection.ShapeRange.Fill.UserPicture _
"C:\Bilgi\Bilgi1\Resim\" & s1.Cells(a, "A") & ".jpg"
Selection.ShapeRange.ScaleWidth 2, msoFalse, msoScaleFromTopLeft
Selection.ShapeRange.ScaleHeight 3.5, msoFalse, msoScaleFromTopLeft
s1.Cells(a, "A").Comment.Visible = False

10 Next

End Sub

 

[beza]

Kodların en üstüne aşağıdaki satırı ekleyin.

On Error Resume Next

Sub resimekle()

On Error Resume Next

Application.ScreenUpdating = False
Set s1 = ActiveSheet

For a = 2 To s1.Cells(Rows.Count, "A").End(3).Row

dt = CreateObject("Scripting.FileSystemObject").FileExists _
("C:\Bilgi\Bilgi1\Resim\" & s1.Cells(a, "A") & ".jpg")

If dt = False Then GoTo 10

If Not Intersect(s1.Cells(a, "A").SpecialCells(xlCellTypeComments), s1.Cells(a, "A")) Is Nothing _
Then s1.Cells(a, "A").ClearComments

s1.Cells(a, "A").AddComment
s1.Cells(a, "A").Comment.Visible = True
s1.Cells(a, "A").Comment.Text Text:=""
s1.Cells(a, "A").Comment.Shape.Select True
Selection.ShapeRange.Fill.UserPicture _
"C:\Bilgi\Bilgi1\Resim\" & s1.Cells(a, "A") & ".jpg"
Selection.ShapeRange.ScaleWidth 2, msoFalse, msoScaleFromTopLeft
Selection.ShapeRange.ScaleHeight 3.5, msoFalse, msoScaleFromTopLeft
s1.Cells(a, "A").Comment.Visible = False

10 Next

End Sub

Tekrar merhaba Levent Bey
Emeğinize sağlık. Mükemmel oldu. Çok teşekkür ederim.