otomatik resim köprüleme

[xlomba]

açıklama şeklinde resim eklemek (ada göre otomatik resim köprülemek)

arkadaşlar yazılan resim adına comment olarak otomatik resim köprülüyorum ancak kodda sadece jpg mevcut tif eklemem gerekiyor yardımcı olursanız sevinirim

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Columns("AO").ClearComments
If Intersect(Target, [AO1:AO50000]) Is Nothing Then Exit Sub
If Target.Value = "" Then Exit Sub
dosyaadi = ThisWorkbook.Path & "\Resimler\" & Target.Value & ".jpg"
With Cells(Target.Row, "AO")
.AddComment
.Comment.Visible = True
.Comment.Shape.Select True
If CreateObject("Scripting.FileSystemObject").FileExists(dosyaadi) = True Then
Selection.ShapeRange.Fill.UserPicture dosyaadi
Selection.Height = 400 'yukseklik
Selection.Width = 350 'genişlik
Target.Select
Else
.Comment.Visible = False
End If
End With
End Sub

 

[halit3]

Bunu denermisiniz.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim Uzanti(5)
Uzanti(1) = "bmp": Uzanti(2) = "jpg": Uzanti(3) = "gif":
Uzanti(4) = "tif": Uzanti(5) = "AI":
Columns("AO").ClearComments
If Intersect(Target, [AO1:AO50000]) Is Nothing Then Exit Sub
If Target.Value = "" Then Exit Sub
With Cells(Target.Row, "AO")
.AddComment
.Comment.Shape.Select True
.Comment.Visible = False
For i = 1 To 5
dosyaadi = ThisWorkbook.Path & "\Resimler\" & Target.Value & "." & Uzanti(Val(i))
If CreateObject("Scripting.FileSystemObject").FileExists(dosyaadi) = True Then
.Comment.Visible = True
Selection.ShapeRange.Fill.UserPicture dosyaadi
Selection.Height = 400 'yukseklik
Selection.Width = 350 'genişlik
Target.Select
Exit For
End If
Next i
End With
End Sub

 

[xlomba]

.Comment.Shape.Select True bu satırdan kaynaklı hata veriyor

 

[halit3]

.Comment.Shape.Select True bu satırdan kaynaklı hata veriyor

O satırı silin yeniden deneyin

 

[xlomba]

her hata veren satırı sildim silecek kod kalmadı

 

[xlomba]

Belirtilen bir dosyadaki resimlerle aynı adı bir sütuna yazdığımda otomatik köprüleyecek başka bir kod bulamazmıyım?
Resim adı 123. tif örneğin ben exceldeki sütuna 123 yazdığımda o resme otomatik köprü atayacak.

 

[halit3]

Bu kodu denermisiniz.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim Uzanti(5)
Uzanti(1) = "bmp": Uzanti(2) = "jpg": Uzanti(3) = "gif":
Uzanti(4) = "tif": Uzanti(5) = "AI":
Columns("AO").ClearComments
If InStr(Target.Address, ":") > 0 Then Exit Sub
If Target.Value = "" Then Exit Sub
If Intersect(Target, [AO1:AO50000]) Is Nothing Then Exit Sub
For i = 1 To 5
resimyükle = ThisWorkbook.Path & "\Resimler\" & Cells(Target.Row, Target.Column) & "." & Uzanti(Val(i))
If CreateObject("Scripting.FileSystemObject").FileExists(resimyükle) = True Then
With Cells(Target.Row, Target.Column)
.AddComment
.Comment.Visible = True
.Comment.Shape.Select True
End With
Selection.ShapeRange.Fill.UserPicture resimyükle
Selection.Height = 400 'yukseklik
Selection.Width = 350 'genişlik
Target.Select
Exit For
End If
Next i
End Sub

not :dosyanın yanında Resimler klasörü olmalı ve resimlerde bu klasörün içinde olmalı

 

[xlomba]

sağolasın çok güzel olmuş.Çok işime yarayacak.
yalnız aşağıdaki uyarıyı alıyorum;
Gizlilik Uyarısı:Bu belge makrolar,activex denetimleri,xml genişleme paketleri veya web bileşenleri içeriyor.Bunlar, belge denetçisi tarafından kaldırılamayan kişisel bilgiler olabilir.Makroları etkileştirdim ancak yinede devam ediyor.

 

[halit3]

sağolasın çok güzel olmuş.Çok işime yarayacak.
yalnız aşağıdaki uyarıyı alıyorum;
Gizlilik Uyarısı:Bu belge makrolar,activex denetimleri,xml genişleme paketleri veya web bileşenleri içeriyor.Bunlar, belge denetçisi tarafından kaldırılamayan kişisel bilgiler olabilir.Makroları etkileştirdim ancak yinede devam ediyor.

Araçlar/seçenekler/güvenlik bölümünde
kaydederken dosya özelliklerinden kişisel bilgileri kaldır.
seçeneğini kaldırın yani tikin işaretini kaldırın.