Excelde otomatik şekile C sürücüsünden resim eklemek

[xternet]

Merhaba arkadaşlar

Excel sayfasında otomatik şekile "ykoç1" adını verdim ve aşağıdaki makro koduyla resim ekliyorum. Kodu incelediğinizde C sürücüsü üzerinde "ykoc" isimli dosyadan alınıyor resimler. Ben ekleyeceğim resimlere ilgili adı vererek sürekli bu dosyanın içine atıyorum. İsteğim şu arkadaşlar. C üzerindeki adesi excelde bir hücreden girebilirmiyim. Yani;

"C:\ykoç\ykoç (1).JPG"

adresindeki "ykoc" dosya adı belirli bir excel hücresinde yazacağım dosya adı olucak.
Yardımlarınızı bekliyorum.
İyi çalışmalar.

Sub r_ekle1()

ActiveSheet.Shapes("ykoç1").Select
Selection.ShapeRange.Fill.UserPicture "C:\ykoç\ykoç (1).JPG"
End Sub

 

[Ferhat Pazarçevirdi]

Aşağıdaki gibi bir kod kullanabilirsiniz.

Sub ShapeE_Resim_Ekle()
    Dim objShp As Shape
    Dim wks As Worksheet
    Dim rng As Range

[COLOR=green]    'Resmin bulunduğu dizin[/COLOR]
    Const strPth As String = "C:\ykoç\"
    
[COLOR=green]    'Shape'in bulunduğu sheet[/COLOR]
    Set wks = ActiveSheet
    
[COLOR=green]    'Dosya adını belirttiğiniz hücre[/COLOR]
    Set rng = wks.Range("A1")
    
    With wks
                
        On Error Resume Next
        Set objShp = .Shapes("ykoç1")
        On Error GoTo 0
    
[COLOR=green]        'Eğer daha önceki Shape silinmişse yenisini oluştur[/COLOR]
        If objShp Is Nothing Then
            Set objShp = .Shapes.AddShape(msoShapeRectangle, 0, 0, 100, 100)
            objShp.Name = "ykoç1"
        End If
        
[COLOR=green]        'A1 hücresine birşey yazılmamışsa,[/COLOR]
        If Len(rng) = 0 Then GoTo fpc
        
[COLOR=green]        'Belirtilen yolda, resim dosyası yoksa[/COLOR]
        If Len(Dir(strPth & rng & ".jpg")) = 0 Then GoTo fpc
        
[COLOR=green]        'Eğer herşey normalse, resmi shape'e yükle[/COLOR]
        objShp.Fill.UserPicture strPth & rng & ".jpg"
    
    End With
    
    GoTo cikis
    
fpc:
[COLOR=green]    'Shape'de ne varsa temizle[/COLOR]
    objShp.Fill.Solid
cikis:
    Set wks = Nothing
    Set rng = Nothing
    Set objShp = Nothing
End Sub

 

[xternet]

Teşekkür ederim Ferhat bey. Yalnız koddan anladığım kadarıyla sorumu yanlış anlattım.

'Resmin bulunduğu dizin
Const strPth As String = "C:\ykoç\"

Ben dosya adı derken ekleyeceğim resmin değilde, resmin bulunacağı klasörün adını demek istemiştim. Yani C den sonra gelen ykoç. İsteğim sadece bu klasör isminin bir hücreden verilmesi.

 

[Ferhat Pazarçevirdi]

Yani; sizin resminizin adı hep sabit ama resmin bulundupu klasörün adı mı değişken ? Bu şekilde mi anlamalıyım?

 

[xternet]

Evet Ferhat bey. Tam dediğiniz gibi. Resmin adı sabit. Resmin bulunduğu klasörün adı değişken.

 

[Ferhat Pazarçevirdi]

O halde, kodu şu şekilde değiştiriniz.

Sub ShapeE_Resim_Ekle()
    Dim objShp As Shape
    Dim wks As Worksheet
    Dim rng As Range
    Dim strPth As String
    Dim strSpr As String
    
    Const strDosya As String = "ykoç (1).JPG"
    
[COLOR=green]    'Shape'in bulunduğu sheet[/COLOR]
    Set wks = ActiveSheet
    
[COLOR=green]    'Klasör adını belirttiğiniz hücre[/COLOR]
    Set rng = wks.Range("A1")
    
    With wks
                
        On Error Resume Next
        Set objShp = .Shapes("ykoç1")
        On Error GoTo 0
    
[COLOR=green]        'Eğer daha önceki Shape silinmişse (yoksa) yenisini oluştur[/COLOR]
        If objShp Is Nothing Then
            Set objShp = .Shapes.AddShape(msoShapeRectangle, 0, 0, 100, 100)
            objShp.Name = "ykoç1"
        End If
        
[COLOR=green]        'Hücreye birşey yazılmamışsa,[/COLOR]
        If Len(rng) = 0 Then GoTo fpc
        
[COLOR=green]        'Hücrede yazılan  kelimenin sonunda seperator varsa[/COLOR]
        If Right(rng, 1) = Application.PathSeparator Then
            strSpr = Empty
        'Yoksa
        Else
            strSpr = Application.PathSeparator
        End If
            
[COLOR=green]        'Belirtilen yolda, resim dosyası yoksa[/COLOR]
        If Len(Dir(rng & strSpr & strDosya)) = 0 Then GoTo fpc
        
[COLOR=green]        'Eğer herşey normalse, resmi shape'e yükle[/COLOR]
        objShp.Fill.UserPicture rng & strSpr & strDosya
    
    End With
    
    GoTo cikis
    
fpc:
[COLOR=green]    'Shape'de ne varsa temizle[/COLOR]
    objShp.Fill.Solid
cikis:
    Set wks = Nothing
    Set rng = Nothing
    Set objShp = Nothing
End Sub

 

[xternet]

Ferhat bey formülü oldukça ayrıntılı düşünerek karşılaşabileceğim problemlere karşı tedbirlerle donatmışsınız. Teşekkür ederim. Yalnız formülün sadece hücreden klasör adını seçmesi için en sade şekli nasıl olur. Birde bunu yazarsanız memnun olurum.

 

[Ferhat Pazarçevirdi]

Bu şekilde deneyiniz.

Selection.ShapeRange.Fill.UserPicture Range("A1") & "ykoç (1).JPG"

 

[xternet]

Ferhat bey sizide fazlaca uğraştırdım ama son verdiğiniz tek satırı formüle adapte edemedim.

 

[Ferhat Pazarçevirdi]

Şimdi şöyle yapalım ...

Farzedelim ki; siz, kodu çalıştırmadan önce A1 hücresine bir metin yazacak olun. (Dosya adı mı klasör adı mı her neyse ...)

Şimdi; A1 hücresine yazacağınız metinden, bize iki tane örnek verin

 

[xternet]

Bu metin okuldaki sınıfların adı. Yani 9A, 9B, 10A, A11A ... gibi. Ben öğrencilerin resimlerini her sınıf için ayrı ayrı ykoç (1), ykoç (2) ... şeklinde adlandırdım. Bir sınıfın resimlerini çalışmaya ekleyeceğim zaman, sınıfa ait resimleri C sürücüsü üzerindeki "ykoç" klasörüne kopyalıyorum ve kodu çalıştırıyorum. (bu koddan ayrı ayrı 30 tane var. Her öğrenci için).
Bu şekilde olunca her sınıf için resimleri C sürücüsü üzerindeki ykoç klasörüne kopala-yapıştır yapmam gerekiyor.

Ben bu işi biraz daha basitleştirmek için C sürücüsü üzerine bütün sınıfların resim klasörlerini atayım diyorum. Yani C üzerinde 9A, 9B, ...şeklinde sınıfların resim klasörleri olucak. Örneğin 9A sınıfının resimlerini ekleyecek isem belli bir hücreye "9A" yazıcam ve kod C üzerindeki 9A klasöründen ykoç (1), ykoç (2) ... şeklinde adlandırılmış olan resimleri alıcak.

Tabi benim sizden istediğim sadece bir resim için, yada diğer bir ifadeyle bir shape için kodu oluşturmanız. Ben diğerleri için çoğaltıcam.

 

[Ferhat Pazarçevirdi]

Bir de bunu deneyiniz o zaman .. Belki işe yarayabilir...

Selection.ShapeRange.Fill.UserPicture "C:\" & Range("A1") & "\" & "ykoç (1).JPG"

 

[xternet]

Sanırım konu biraz dağıldı. Konuyu yeni inceleyen arkadaşlar için tekrar özetlemek istiyorum.

Sub r_ekle1()

ActiveSheet.Shapes("ykoç1").Select
Selection.ShapeRange.Fill.UserPicture "C:\ykoç\ykoç (1).JPG"
End Sub

Yazmış olduğum bu kod ile excel sayfasındaki "ykoç1" isimli Shapes'e (otomatik şekil), C sürücüsü üzerindeki "ykoç" isimli klasörden, "ykoç (1).jpg" adındaki resmi yüklüyorum.

Burada değiştirmek istediğim; C sürücüsü üzerindeki "ykoç" isimli klasörün yolunu excelde herhangi bir hücreden belirlemek. Örneğin eklemek istediğim resim "9A" adında bir klasörde ise ben yazacağımız kodda beirlenmiş hücreye "9A" yazıp kodu çalıştırdığımda, kod C üzerindeki 9A isimli klasöre gidicek ve oradaki "ykoç (1).jpg" resmini yükleyecek. Eğer eklemek istediğim resim "10A" isimli klasörde ise, ilgili hücreye 10A yazıcam ve kod çalıştığında istediğim resim C üzerindeki 10A klasöründen alınıcak.

 

[xternet]

Ferhat bey işte buydu aradığım.
Sanırım soruyu baştan daha düzgün sorsaydım sizi de bu kadar uğraştırmayacaktım. Teşekkür ederim zaman ayırdığınız için.
İyi çalışmalar.

 

[Ferhat Pazarçevirdi]

Ama bu şekilde kullanırsanız, programınızın zaman zaman çokmesi kaçınızlmaz olur.

Çökme İhtimalleri şunlar;

1. A1 hücresine olmayan bir klasör ismi girdiniz.
2. A1 hücresini boş geçtiniz.
3. A1 hücresine dosya ve klasör isimlerinde kullanılmaması gereken karakterlerden girdiniz..
4. Dosya yolunda belirttiğiniz resim olmayabilir veya farklı bir isimde olabilir.
5. Kullandığınız shape yanlışlıkla silinmiş olabilir
6. Daha aklıma henüz gelmeyenler ...

Bu bir satırlık kodu, yukarıda belirttiğim başlıca kontrolleri tamamlamadan çalıştırısanız, hata mesajı alma ihtimaliniz yüksektir.

Yine de bu haliyle işinize yaradığına sevindim.

 

[xternet]

Uyarılarınız için teşekkür ederim. Bahsettiğiniz konularla ilgili tedbirlerimi aldım.
Kodlarla ilgili bilgim çok zayıf olduğu için fazla detaya girmeden halletmeye çalışıyorum.
İyi çalışmalar.