Soru Resim adını istenen hücreye yazdırmak.

[xternet]

Merhaba arkadaşlar.

Şunu yapmak mümkün mü? (Gerçi işin uzmanlarına mümkün olmayan bir excel işlemi yok gibi
Çalışma kitabımda kodu çalıştırdığımda dosya seçme yolu açılacak. Ben aradığım klasör içerisindeki resim formatındaki veriyi seçtiğimde, resmin adını belirlediğim hücreye yazacak.
Zaman ayıracak arkadaşlara şimdiden çok teşekkür ediyorum.
İyi çalışmalar herkese.

 

[Korhan Ayhan]

Deneyiniz.

Kodun başındaki varsalıyan klasörleri kendi sisteminize göre revize edersiniz.

Option Explicit

Sub Selected_Image()
    Dim My_File As Variant

    ChDrive "C:\"
    ChDir "C:\Users\Admin\Pictures"

    My_File = Application.GetOpenFilename( _
              Filefilter:="Image Files (*.gif;*.jpg;*.png), *.gif;*.jpg;*.png", _
              Title:="Lütfen bir resim dosyası seçiniz...", MultiSelect:=False)
    
    If My_File <> False Then
        Range("A1") = My_File
    Else
        MsgBox "Resim dosyası seçimi yapmadınız!", vbCritical
    End If
End Sub

 

[xternet]

Sayın Korhan Ayhan;
Yanıtınız için çok teşekkür ederim.
Yalnız ben dosyanın yolunu değil de sadece adını almak istiyorum.
Bu nasıl mümkün olur?

 

[Korhan Ayhan]

Aşağıdaki komutlar ile farklı sonuçlar alabilirsiniz.

Sadece dosyanın adı uzantısı ile birlikte;
Range("A1") = VBA.CreateObject("Scripting.FileSystemObject").GetFileName(My_File)

Sadece dosyanın adı uzantısız;
Range("A1") = VBA.CreateObject("Scripting.FileSystemObject").GetBaseName(My_File)

 

[Haluk]

        Range("A1") = Dir(My_File)

.

 

[xternet]

Sayın Korhan Ayhan ve Sayın Haluk;
Çok teşekkür ediyorum. İkisi de sorunsuz.

(*.gif;*.jpg;*.png)

Buradaki resim dosyası uzantılarına ben bir de "jpeg" ekledim.
Bunun gibi karşılaşabileceğimiz ve eklenebilecek başka resim dosyası uzantısı var mı arkadaşlar.

 

[Korhan Ayhan]

Paint uygulamasında farklı kaydet yaptığımda aşağıdaki dosya formatları görünüyor.

 

[xternet]

Çok akıllıca Sayın Korhan Ayhan
Teşekkürler.

 

[bmutlu966]

Alternatif olsun. Her türlü dosyanın ismini A1 hücresine alabilirsiniz.

Sub dosya_ismi()
    
    DosyaYolu = Application.GetOpenFilename(MultiSelect:=False)
    DosyaIsmi = Dir(DosyaYolu)
    
    If DosyaYolu = Empty Then
        MsgBox "Lütfen önce Dosya seçiniz.", vbExclamation
        Exit Sub
    End If

[A1] = DosyaIsmi
      
End Sub

 

[xternet]

Çok teşekkürler Sayın bmutlu966. Zihninize sağlık.

Konuya ufak bir ekleme daha yapmak istersek;
ismi yazmak istediğimiz hücreyi aktif hücre olarak belirleyebilir miyiz?
Mesela C3'e tıkladıktan sonra kodu çalıştırmış isem ilgili dosya ismini C3 e yazsın.
Ama dalgınlıkla aktif hücreyi belirlemeden kod çalıştırılmamış ise ve çok alakasız bir yer seçilmiş ise de uyarı alabilir miyiz?
Mesela A1 D10 alanı içerisinde seçim yapılmamışsa uyarsın ve işlemi bitirsin.

 

[xternet]

Araştırmaya devam ederken aktif hücre işini çözdüm

ActiveCell = DosyaIsmi

Bu şekilde seçilen dosyayı, aktif hücreye yazdı.
Burada seçili hücrenin istenen alanda olmasını nasıl sınatırız?

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub Selected_Image()
    Dim My_File As Variant, Code_Run_Area As Range

    Set Code_Run_Area = Range("A1:D10")
    
    If Intersect(ActiveCell, Code_Run_Area) Is Nothing Then
        MsgBox "Kodun çalışabilmesi için aşağıdaki alanda bir hücre seçmelisiniz!" & _
               vbCrLf & vbCrLf & Code_Run_Area.Address(0, 0), vbCritical
        Exit Sub
    End If

    ChDrive "C:\"
    ChDir "C:\Users\Admin\Pictures"

    My_File = Application.GetOpenFilename( _
              Filefilter:="Image Files (*.gif;*.jpg;*.jpeg;*.png), *.gif;*.jpg;*.jpeg;*.png", _
              Title:="Lütfen bir resim dosyası seçiniz...", MultiSelect:=False)
    
    If My_File <> False Then
        ActiveCell = VBA.CreateObject("Scripting.FileSystemObject").GetFileName(My_File)
    Else
        MsgBox "Resim dosyası seçimi yapmadınız!", vbCritical
    End If
End Sub

 

[xternet]

Çok teşekkürler Sayın Korhan Ayhan,
elinize, zihninize sağlık..