Excelden klasöre resim alma

[HALILİBRAHIM]

Merhaba,

Hocalar aşağıdaki kodlar "C" nin altına resimleri belirttiğimiz yere kaydediyor fakat ben bu resimleri excel dosyasında belirteceğim kodlarla kaydedebilrmiyim.
Örnek olarak.
"A1" hücresinde resim "A2" hücresinde resimin adı olsun ve böyle kaydetsin mümkün müdür hocalar.

Option Explicit
Sub Resim_Olarak_Aktar()
Dim oRsm As Shape
Dim oGrf As ChartObject
Dim sDzn As String
sDzn = "c:\"
For Each oRsm In ActiveSheet.Shapes
    If oRsm.Type = msoPicture Then
        oRsm.Copy
        Set oGrf = ActiveSheet.ChartObjects.Add(0, 0, oRsm.Width, oRsm.Height)
        With oGrf
            With .Chart
                .Paste
                .Export sDzn & oRsm.Name & ".gif"
            End With
            .Delete
        End With
    End If
Next
End Sub

 

[Muzaffer Ali]

.Export sDzn & oRsm.Name & ".gif"
satırını
.Export sDzn & Range("A2").value & ".gif"
şeklinde değiştirin.

 

[HALILİBRAHIM]

Teşekkür ederim Hocam.
Peki .jpg olarak kaydetmem mümkün mü acaba ?
Ben ".gif" silip ".jpg" olarak kaydettiğimde hata veriyor hocam.

Teşekkür ederim.

 

[Muzaffer Ali]

gif yerine jpg yazarak kaydederseniz sadece dosyanın adını değiştirmiş olursunuz.

gif formatındaki bir dosyayı jpg olarak kaydetmek için encode etmek gerekir ki bence gereksiz bir iş olur.

 

[HALILİBRAHIM]

Hocam yardımlarınız için çok teşekkür ederim,
Fakat dediklerinizi yaptığımda hata veriyor.

Bakabilrseniz çok memnun olurum.(Resimler excel'e jpg. olarak kaydedilmişti hocam doğal olarak bu yüzden .jpg istiyorum)
Dosya içersinde "C" sütununda kodlar "B" sütununda resimler var hocam Resimlerin ismini kodlara göre kaydetmesini isitiyorum

Dosya boyutu 13 Mb. olduğunundan siteye yüklemedim Hocam link gönderiyorum.

http://www.dosya.tc/server6/mvkBza/C_SEZON_KATALOG.rar.html

Saygılarımla

 

[Muzaffer Ali]

Boşver Excel i biraz ticaret yapalım. Dosyada gördüğüm terliklerin toptancılığını mı yapıyosunuz? Eğer öyleyse bu ürünler için fiyat alabilir miyim. Ben de perakendeciğim. Bir de marka nedir bunu da söylerseniz iyi olur.

Sorununuza gelirsek: Resimlerin adlarını istediğiniz gibi kaydedebilmeniz için öncelikle eklenen resimlerin adlarının bir düzen içinde olması gerekir.
Örnek: 1. Resmin adı = Immagini 1 ise 2. sinin Immagini 2, 3. sünün Immagini 3 şeklinde devam etmesi gerekir.
Buna göre düzenli olarak hücrelere girilen değerler resim kaydederken resim adı olarak kullanılabilir. Aksi taktirede bir düzen olmadığı için bu mümkün değil.

 

[HALILİBRAHIM]

Evet hocam ben değil firma yapıyor ben bilgi işlem departmanıyım nasipse olur diyeyim neden olmasın burada marka ismini ifşa etmek uygun olmayabilir özelden tel bırakın ben size özel müşteri diye dönüş yaptırıyım hemen

soruma gelince hocam ben onları tek tek yazarım gerekirse o zamanda olmazmı resimin adını değiştirecek bir makro yokmudur acaba?

 

[halit3]

Alternatif çözüm dosyanızı irdeleyiniz.

 

[halit3]

Eklerin devamı burada dosyaların hepsini indir ve ondan sonra rar dan çıkart


Not: dosyanızın içinde resimler olunca dosyanın boyutu bu kadar büyüyor.

 

[halit3]

Bu dosyanızda kodlar mevcut sadece resimler yok

 

[Muzaffer Ali]

Aşağıdaki kodları dene.

bir resim hangi satırdaysa o satırın numarası ile numaralandırılmalı yada bulunduğu satır no su adının içinde olacak şekilde adlandırılmış olmalı örnek 10. satırdaki resmin adı
10
yada
resim 10
olabilir.

Option Explicit
Sub Resim_Olarak_Aktar()
Dim oRsm As Shape
Dim oGrf As ChartObject
Dim sDzn As String
Dim DosyaAdi As String
sDzn = "c:\"

For Each oRsm In ActiveSheet.Shapes
    If oRsm.Type = msoPicture Then
        oRsm.Copy
        Set oGrf = ActiveSheet.ChartObjects.Add(0, 0, oRsm.Width, oRsm.Height)
        With oGrf
            With .Chart
                .Paste
                '.Export sDzn & oRsm.Name & ".gif"
                DosyaAdi = Range("D" & Satir(oRsm.Name)).Value
                .Export sDzn & Range("c" & Satir(oRsm.Name)).Value & ".jpg"
            End With
            .Delete
        End With
    End If
Next
End Sub

Function Satir(FotoAdi As String) As Integer
    Dim i As Integer
    Dim Sayi
    For i = 1 To Len(FotoAdi)
        Sayi = Mid(FotoAdi, i, 1)
        If IsNumeric(Sayi) = True Then
            Satir = Satir & Sayi
        End If
    Next i
End Function

 

[HALILİBRAHIM]

Merhaba hocalar Allah razı olsun yaptım sayenizde eksik olmayın ne kadar kolaylıklar bunlar üşenmeden bıkmadan yaptığınız yardımlar için çok teşekkür ederim hocam özel mesajınızı bekliyorum

 

[HALILİBRAHIM]

Dalgalıkur Kusura bakmayın, siteden kaynaklı herhalde veya ben size özel mesaj gönderemiyorum, siz isterseniz mail adresinizi gönderin bilgileri veriyim size hocam.

Saygılarımla,