Resimli Stok Listesi

[ercan_bora]

Selamlar Arkadaşlar,

Firma için resimli stok listesi yapmak istiyoruz.
Excel'de dilimleyici kullanarak yaptık , yapmak istediğimiz şey ise: dosya açılınca "res" klasöründeki resimleri stok koduna göre çeksin istiyoruz. ürün resimlerini stok koduna göre yazıyoruz o yüzden stok kodu varsa resimlerde o resmi o stok kodunun yanına getirip göstermesi... 500 tane listede olabilir sadece 4 tane anlaşılması için yaptık.

Açılır açılmaz çalışan bir makro hakkında yardımcı olursanız çok memnun olurum.Örnek çalışma ekte. nasıl olmasını istediğim şeklide.

Dosya.tc : http://s7.dosya.tc/server10/bc7sby/Desktop.rar.html

Yardımcı olan arkadaşlara şimdiden teşekkür eder Allah razı olsun diyorum.

Saygılarımla,

 

[ercan_bora]

hiç çözümü yokmu ?

 

[halit3]

Merhaba yüklemiş olduğunuz dosyaya ait linki tıklayınız dosya iniyormu inmiyormu
bende inmiyor farklı sitelere yönlendirme yapıyor ve virüs uyarısı veriyor.

 

[ercan_bora]

Selamlar,

normalde çalışıyor girdim indirdim.

Yandex e de yükledim. umarım burada problem çıkmaz... çünkü buraya ekleyemiyoruz premium üyelik olmadığı için.
https://yadi.sk/d/3EuHHCQIA9udlA

 

[halit3]

STOK LİSTESİ sayfasındaki kodların hepsini silin ve bu kodları oraya yapıştırın.
dosyanın hemen yanında res klasörü olmalı ve resimlerde onun içinde olmalı

Private Sub Worksheet_Change(ByVal Target As Range)

If Intersect(Target, [e2:e500]) Is Nothing Then Exit Sub

yatay = -1 ' bu kadar hücre sağa kayacak
dikey = 0  ' bu kadar hücre aşağıya kayacak

Dim s1
Set s1 = Sheets(ActiveSheet.Name)

If InStr(Trim(ActiveWindow.RangeSelection.Address), ":") = 0 Then
Set Adres = s1.Cells(Target.Row + dikey, Target.Column + yatay)

Dim Picture As Object
For Each Picture In s1.Shapes
If TypeName(s1.Shapes(Picture.Name).OLEFormat.Object) = "Picture" Then
Set yer = s1.Cells(Picture.TopLeftCell.Row, Picture.TopLeftCell.Column)

If yer.Address = Adres.Address Then

Picture.Delete
Exit For
End If

End If
Next Picture

ReDim uzanti(11)
uzanti(1) = "bmp":        uzanti(2) = "jpg"
uzanti(3) = "gif":        uzanti(4) = "pcx"
uzanti(5) = "tga":        uzanti(6) = "emf"
uzanti(7) = "abm":        uzanti(7) = "avi"
uzanti(8) = "png":        uzanti(9) = "jpeg"
uzanti(10) = "wmf":       uzanti(11) = "TIFF"

For j = 1 To 11

Dosya2 = ThisWorkbook.Path & "\res\" & Target.Value & "." & uzanti(Val(j))
If CreateObject("Scripting.FileSystemObject").FileExists(Dosya2) = True Then
Dosya = Dosya2
Exit For
End If
Next

If CreateObject("Scripting.FileSystemObject").FileExists(Dosya2) = True Then
Dosya = Dosya2
Else
Dosya = ThisWorkbook.Path & "\res\Stok_resmi_yok.jpg"
End If


If CreateObject("Scripting.FileSystemObject").FileExists(Dosya) = True Then

ad = s1.Pictures.Insert(Dosya).Name
s1.Shapes(ad).OLEFormat.Object.ShapeRange.LockAspectRatio = msoFalse
s1.Shapes(ad).OLEFormat.Object.Top = Adres.Top + 1
s1.Shapes(ad).OLEFormat.Object.Left = Adres.Left + 1
s1.Shapes(ad).OLEFormat.Object.ShapeRange.Height = Adres.Height - 2
s1.Shapes(ad).OLEFormat.Object.ShapeRange.Width = Adres.Width - 2

s1.Cells(Target.Row + 1, Target.Column).Select
End If

End If
End Sub

E sutunundaki yazacağınız veriye göre resimler gelecektir.

 

[ercan_bora]

Allah razı olsun hocam....

Peki açılır açılmaz resimli gelmesinin imkanı yokmu ? açılışta makroyu çalıştırsın. çünkü listede 2 binden fazla ürün olacak. hepsini otomatik excel açılınca çekemez mi ?

 

[halit3]

önceki kodları silin
Bir modüle bu kodları kopyalayın ve birer komut düğmesine bağlayın sonrada kodları çalıştırın.
veya dosyayı kayıt edin kapatıp ve sonra yeniden açın

Sub Auto_Open()
On Error Resume Next


Call resimleri_sil
Call resimleri_getir

End Sub
Sub Auto_Close()
On Error Resume Next
Call resimleri_sil

End Sub


Sub resimleri_sil()
Dim Picture As Object
For Each Picture In ActiveSheet.Shapes
If Picture.Type = 13 Then
Picture.Delete
End If
Next Picture
End Sub

Sub resimleri_getir()

Dim s1
Set s1 = Sheets(ActiveSheet.Name)

For i = 7 To s1.Cells(Rows.Count, "E").End(3).Row

Set Adres = s1.Cells(i, 4)
Dim Picture As Object

ReDim uzanti(11)
uzanti(1) = "bmp":        uzanti(2) = "jpg"
uzanti(3) = "gif":        uzanti(4) = "pcx"
uzanti(5) = "tga":        uzanti(6) = "emf"
uzanti(7) = "abm":        uzanti(7) = "avi"
uzanti(8) = "png":        uzanti(9) = "jpeg"
uzanti(10) = "wmf":       uzanti(11) = "TIFF"

For j = 1 To 11
Dosya2 = ThisWorkbook.Path & "\res\" & s1.Cells(i, 5) & "." & uzanti(Val(j))
If CreateObject("Scripting.FileSystemObject").FileExists(Dosya2) = True Then
Dosya = Dosya2
Exit For
End If
Next

If CreateObject("Scripting.FileSystemObject").FileExists(Dosya2) = True Then
Dosya = Dosya2
Else
Dosya = ThisWorkbook.Path & "\res\Stok_resmi_yok.jpg"
End If

If CreateObject("Scripting.FileSystemObject").FileExists(Dosya) = True Then
ad = s1.Pictures.Insert(Dosya).Name
s1.Shapes(ad).OLEFormat.Object.ShapeRange.LockAspectRatio = msoFalse
s1.Shapes(ad).OLEFormat.Object.Top = Adres.Top + 1
s1.Shapes(ad).OLEFormat.Object.Left = Adres.Left + 1
s1.Shapes(ad).OLEFormat.Object.ShapeRange.Height = Adres.Height - 2
s1.Shapes(ad).OLEFormat.Object.ShapeRange.Width = Adres.Width - 2
s1.Cells(i, 4).Select
End If

Next i
MsgBox "işlem tamam"
End Sub

 

[ercan_bora]

Allah razı olsun kardeş...

 

[halit3]

Allah razı olsun kardeş...

Teşekkürler iyi çaışmalar

 

[mustafakayali]

halit bey bu kodunuzu kendime göre çevirip bende yaptım. teşekkür ederim. Lakin exceli başka bir bilgisayara attığımızda fotoğraflar görünmemektedir. Bunun bir çözümü var mı? Dosyayı ne ile kaydedersem kaydedeyim sorun çözülmüyor.

Teşekkürler iyi çaışmalar