Klasörden resim çağırma...

[halit3]

Halit bey teşekkür ederim yardımlarınız için. Şimdi excel dosyamda ilgili resimleri ekledikten sonra resimler geliyor. Ancak dosyayı kaydedip kapattıktan sonra yeniden açtığımda aynı hatayı tekrar veriyor. Bir diğer problemde resimler benim istediğim ölçülerde gelmiyor. Yani bir çanta cocuk resmi getirmek istediğimi düşünün, çocukğun ayak kısmı görünüyor. Anlayacağınız resmi orantılı bir şekilde küçüktüp ortalamıyor. Yaa üstünü ya altını görebiliyorsunuz...

Emeğiniz için çok teşekkür ederim..

kodun kırmızı renkli yerleri siz 1 veya 2 veya 3 yapıp deneyin

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [a2]) Is Nothing Then Exit Sub
Sheets("emir").Image1.Picture = LoadPicture(None)
Sheets("emir").Image2.Picture = LoadPicture(None)
Sheets("emir").Image3.Picture = LoadPicture(None)
On Error GoTo 10
yol = "[URL="file://\\Satis\LOBİ"]\\Satis\LOBİ[/URL] C\Inetpub\wwwroot\resimler\"
Sheets("emir").Image1.Picture = LoadPicture(yol & [a5] & ".jpg")
Sheets("emir").Image2.Picture = LoadPicture(yol & [a5] & ".jpg")
Sheets("emir").Image3.Picture = LoadPicture(yol & [a5] & ".jpg")
Sheets("emir").Image1.PictureSizeMode = [COLOR=red]1[/COLOR]
Sheets("emir").Image2.PictureSizeMode = [COLOR=red]1
[/COLOR]Sheets("emir").Image3.PictureSizeMode = [COLOR=red]1[/COLOR]
10 End Sub

 

[serkan_sdl]

Kapatıp yeniden açılınca hata veriyor...

Halit bey ellerinize sağlık. Resim boyurları çok güzel olmuş. Makro yu uyguladım, kusursuz bir şekilde çalıştı. Ancak kapatıp dosyayı yeniden açınca yeniden "debug" hatası veriyor. Acama resimleri aldığı konumda bir problem olabilir mi?


Saygılarımla,

 

[merthannizam]

Değerli arkadaşlar, sizlere bir sorum olacak, aşağıdaki kodu yazınca hangi işlemi yaparsam yapayımhep D99 hücresine geliyor imleç, bunu nasıl iptal edebiliriz?

kod şu:

Private Sub Worksheet_Change(ByVal Target As Range)


Range("M99").Select
resimadi = LoadPicture("")
resimadi = Range("D99").Text & ".jpg"
On Error Resume Next
ActiveSheet.Pictures.Insert("C:\Users\" & resimadi).Select
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.ShapeRange.Height = 200
Selection.ShapeRange.Width = 400
Selection.ShapeRange.Rotation = 0#
Range("D99").Select
End Sub

 

[ZorBey_]

Sayın merthannizam
en altta Range("D99").Select
silerek veya
'Range("D99").Select
denermisiniz.

 

[merthannizam]

Sayın Zorbey , denedim ama olmadı , size örnek dosyası gönderiyorum denemeniz açısından.Kod çalışıyor ama sorun başka hücrede işlem yaparken hep M99 a atlıyor imleç.

tşkler.​

 

[ZorBey_]

Merhaba Sayın merthannizam
İyi Çalışmalar
Ekli dosyayı denermisiniz.

 

[merthannizam]

hala aynı resmi çağırdıktan sonra mesela B1 hücresine 1 yazıp enter diyorum oraya resmi koyuyor, ne kadar çok hücreye veri girersem hepsinin altına o kadar çok resim koyuyor?

 

[halit3]

Alternatif olarak bu kodu denermisiniz.

Private Sub Worksheet_Change(ByVal Target As Range)

If Intersect(Target, Range("D99")) Is Nothing Then Exit Sub
resimadi = Range("D99").Text & ".jpg"
Dosya = "C:\Users\" & resimadi

If Dosya = False Then
MsgBox "Veri alınacak dosyayı seçmediniz.", vbInformation, "DİKKAT"
Exit Sub
Else
End If


Set Adres = Range("m99")

Dim Picture As Object
For Each Picture In ActiveSheet.Shapes
If TypeName(ActiveSheet.Shapes(Picture.Name).OLEFormat.Object) = "Picture" Then
If Not Intersect(Range(Picture.TopLeftCell.Address & ":" & Picture.BottomRightCell.Address), Adres) Is Nothing Then
Picture.Delete
Exit For
End If
End If
Next Picture

If CreateObject("Scripting.FileSystemObject").FileExists(Dosya) = True Then
ActiveSheet.Pictures.Insert(Dosya).Select
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.Top = Adres.Top + 2
Selection.Left = Adres.Left + 2
Selection.ShapeRange.Height = Adres.Height - 3
Selection.ShapeRange.Width = Adres.Width - 3

End If


End Sub

 

[merthannizam]

Sayın Halit3 bu şekilde çalıştı çok teşekkür ederim Allah razı olsun....
Bir sorum daha olacak size resim çok küçük çıkıyor 2mmx2mm gibi ben bunun daha buyük olmasını istiyorum en az 5cmx5cm gibi, bunu nasıl ayarlayabilirim?
tşkler,

 

[halit3]

Sayın Halit3 bu şekilde çalıştı çok teşekkür ederim Allah razı olsun....
Bir sorum daha olacak size resim çok küçük çıkıyor 2mmx2mm gibi ben bunun daha buyük olmasını istiyorum en az 5cmx5cm gibi, bunu nasıl ayarlayabilirim?
tşkler,

Sizin istediğiniz gibi resim M99 hücresine geliyor.

Eğer resimi büyütmek istiyorsanız ya M99 hücresini büyütün yada aşağıdaki kodu

Set Adres = Range("m99")

böyle yapabilirsiniz.

Set Adres = Range("M99[COLOR="Red"]:N100[/COLOR]")

veya

Set Adres = Range("M99[COLOR="red"]:N101[/COLOR]")

veya

Set Adres = Range("M99:O102")

Vs.

 

[cengizank]

http://www.excel.web.tr/f50/fotoorafly-personel-listesi-ayny-sayfada-t126099/sayfa2.html

linki inceleyiniz

 

[merthannizam]

Sayın Halit3 çok teşekkür ederim çok güzel çalıştı vallahi , emeğinize sağlık...
iyi çalışmalar, iyi günler...çok saolun...

 

[merthannizam]

size de teşekkür ederim cengizank bey...

 

[halit3]

Sayın Halit3 çok teşekkür ederim çok güzel çalıştı vallahi , emeğinize sağlık...
iyi çalışmalar, iyi günler...çok saolun...

Teşekkürler İyi çalışmalar