• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Hücrelere resimler ekleme

M

mrwarrior

Katılım
26 Ocak 2013
Mesajlar
232
Excel Vers. ve Dili
Excel 2016 Türkçe
Benim istediğim makro çalıştığında bulunduğu klasördeki tüm resimleri a2 a8 a14 gibi 6şar artarak a sütununa yapıştıracak.

Resim ebatı ise eklendiği hücre ebatı kadar olacak. acaba böyle bir makro yapılabilir mi?
 
Son düzenleme:
kod:

Kod: 
Dim sat
Sub mevcut_dosyaları_bul()

Set Klasor = CreateObject("shell.application").browseforfolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.SELF.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo atla

If Right(Kaynak, 1) <> "\" Then Kaynak = Kaynak & "\"
sat = 2
Liste4 (Kaynak)
Set Klasor = Nothing
MsgBox "işlem tamam"
Else
atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
End Sub


Private Sub Liste4(yol As String)
Dim fL As Object, f As Object, j As Long, n As Long
Set fL = CreateObject("Scripting.FileSystemObject")

'On Error Resume Next
For Each Dosya In fL.GetFolder(yol).Files
uzanti = fL.GetExtensionName(Dosya.Name) ' uzantı buluyor

If uzanti = "JPG" Or uzanti = "jpg" Or uzanti = "GİF" Or uzanti = "gif" Then


Set Adres = Range(Cells(sat, 1), Cells(sat, 1))

ActiveSheet.Pictures.Insert(Dosya).Select
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.Top = Adres.Top + 2
Selection.Left = Adres.Left + 2
Selection.ShapeRange.Height = Adres.Height - 4
Selection.ShapeRange.Width = Adres.Width - 4
sat = sat + 6


sat1 = sat1 + 1
If sat1 = 50 Then
Application.Wait (Now + TimeValue("0:00:05"))
MsgBox "devam et"
'Exit Sub
sat1 = 0
End If

End If

Next

On Error GoTo sonraki
For Each f In fL.GetFolder(yol).SubFolders
Liste4 (f.Path)
sonraki:
Next

Set fL = Nothing
End Sub
 
halit3' Alıntı:
kod:

Kod: 
Dim sat
Sub mevcut_dosyaları_bul()

Set Klasor = CreateObject("shell.application").browseforfolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.SELF.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo atla

If Right(Kaynak, 1) <> "\" Then Kaynak = Kaynak & "\"
sat = 2
Liste4 (Kaynak)
Set Klasor = Nothing
MsgBox "işlem tamam"
Else
atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
End Sub


Private Sub Liste4(yol As String)
Dim fL As Object, f As Object, j As Long, n As Long
Set fL = CreateObject("Scripting.FileSystemObject")

'On Error Resume Next
For Each Dosya In fL.GetFolder(yol).Files
uzanti = fL.GetExtensionName(Dosya.Name) ' uzantı buluyor

If uzanti = "JPG" Or uzanti = "jpg" Or uzanti = "GİF" Or uzanti = "gif" Then


Set Adres = Range(Cells(sat, 1), Cells(sat, 1))

[COLOR="Red"]ActiveSheet.Pictures.Insert(Dosya).Select[/COLOR]
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.Top = Adres.Top + 2
Selection.Left = Adres.Left + 2
Selection.ShapeRange.Height = Adres.Height - 4
Selection.ShapeRange.Width = Adres.Width - 4
sat = sat + 6


sat1 = sat1 + 1
If sat1 = 50 Then
Application.Wait (Now + TimeValue("0:00:05"))
MsgBox "devam et"
'Exit Sub
sat1 = 0
End If

End If

Next

On Error GoTo sonraki
For Each f In fL.GetFolder(yol).SubFolders
Liste4 (f.Path)
sonraki:
Next

Set fL = Nothing
End Sub
Genişletmek için tıkla ...

işaretlediğim satırda hata veriyor. ve hiç bişey yapmadan excel i kapatıyor. gene de yardımınız için teşekkür ederim.

sadece belli bir klasördeki tek resimi a2 hücresine tam oturacak şekilde nasıl resim eklerim?

bu daha kolaysa bunu cevaplarsanız memnun olurum.
 
Aşağıdaki kodu deneyiniz.

Kod: 
Sub Test()
    Dim Dosya As String, Resim As Object
    Dosya = ThisWorkbook.Path & "\Resim.jpg"
    On Error Resume Next
    Set Resim = ActiveSheet.Pictures.Insert(Dosya)
    On Error GoTo 0
    If Not Resim Is Nothing Then
        Set Hucre = ActiveCell
        With Resim
            .Height = Hucre.Height
            .Width = Hucre.Width
            .Left = Hucre.Left
            .Top = Hucre.Top
        End With
    End If
End Sub
 
Birde bu kodu denermisiniz.

Kod: 
Sub resimleri_getir()

Set Klasor = CreateObject("shell.application").browseforfolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.SELF.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo atla
If Right(Kaynak, 1) <> "\" Then Kaynak = Kaynak & "\"
Liste (Kaynak)
Set Klasor = Nothing
MsgBox "işlem tamam"
Else
atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
End Sub

Private Sub Liste(yol As String)
Dim fL As Object, f As Object
Set fL = CreateObject("Scripting.FileSystemObject")

'On Error Resume Next
For Each Dosya In fL.GetFolder(yol).Files
uzanti = fL.GetExtensionName(Dosya.Name) ' uzantı buluyor
If uzanti = "JPG" Or uzanti = "jpg" Or uzanti = "GİF" Or uzanti = "gif" Then

If sat <= 2 Then
sat = 2
Else
sat = sat
End If
Adres = Range(Cells(sat, 1), Cells(sat, 1)).Address
ActiveSheet.Shapes.AddPicture Dosya, msoFalse, msoCTrue, Range(Adres).Left + 2, Range(Adres).Top + 2, Range(Adres).Width - 4, Range(Adres).Height - 4
sat = sat + 6
sat1 = sat1 + 1
If sat1 = 50 Then
Application.Wait (Now + TimeValue("0:00:05"))
MsgBox "devam et"
'Exit Sub
sat1 = 0
End If

End If

Next

On Error GoTo sonraki
For Each f In fL.GetFolder(yol).SubFolders
Liste (f.Path)
sonraki:
Next

Set fL = Nothing
End Sub
Sub resimleri_sil()
Dim Picture As Object
For Each Picture In ActiveSheet.Shapes
If TypeName(ActiveSheet.Shapes(Picture.Name).OLEFormat.Object) = "Picture" Then
Picture.Delete
End If
Next Picture
End Sub
 
Halit3 Teşekkür ederim. Tam istediğim gibi olmuş. Hatta istediğimden de iyi :)
 
halit3' Alıntı:
Birde bu kodu denermisiniz.

Kod: 
Sub resimleri_getir()

Set Klasor = CreateObject("shell.application").browseforfolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.SELF.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo atla
If Right(Kaynak, 1) <> "\" Then Kaynak = Kaynak & "\"
Liste (Kaynak)
Set Klasor = Nothing
MsgBox "işlem tamam"
Else
atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
End Sub

Private Sub Liste(yol As String)
Dim fL As Object, f As Object
Set fL = CreateObject("Scripting.FileSystemObject")

'On Error Resume Next
For Each Dosya In fL.GetFolder(yol).Files
uzanti = fL.GetExtensionName(Dosya.Name) ' uzantı buluyor
If uzanti = "JPG" Or uzanti = "jpg" Or uzanti = "GİF" Or uzanti = "gif" Then

If sat <= 2 Then
sat = 2
Else
sat = sat
End If
Adres = Range(Cells(sat, 1), Cells(sat, 1)).Address
ActiveSheet.Shapes.AddPicture Dosya, msoFalse, msoCTrue, Range(Adres).Left + 2, Range(Adres).Top + 2, Range(Adres).Width - 4, Range(Adres).Height - 4
sat = sat + [COLOR="Red"]2[/COLOR]
sat1 = sat1 + 1
If sat1 = 50 Then
Application.Wait (Now + TimeValue("0:00:05"))
MsgBox "devam et"
'Exit Sub
sat1 = 0
End If

End If

Next

On Error GoTo sonraki
For Each f In fL.GetFolder(yol).SubFolders
Liste (f.Path)
sonraki:
Next

Set fL = Nothing
End Sub
Sub resimleri_sil()
Dim Picture As Object
For Each Picture In ActiveSheet.Shapes
If TypeName(ActiveSheet.Shapes(Picture.Name).OLEFormat.Object) = "Picture" Then
Picture.Delete
End If
Next Picture
End Sub
Genişletmek için tıkla ...

Sizin code larda sadece kırmızı ile belirttiğim yeri 6 iken 2 yaptım. böylece 2 satırda bir resim ekliyor.

Şimdi biraz fazla şey istemişim. onu fark ettim. acaba

Resim eklediğinde resim genişliği hücre genişliği olsun.

ancak orantılı şekilde küçülterek satır genişliğini resme göre ayarlasın.

Umarım anlatabilmişimdir.

Ayrıca Resmi yazının arkasına ekleme durumu olurmu. yani hücreye bir yazı yazdığımda resmin önünde kalmasını sağlayabilir misiniz :)

Şimdiden Allah razı olsun.
 
Sayın Halit3 Hocam,
Ekli dosyada sınıflarda kullandığımız bir çalışma var. İsim yazılı yerlerin üzerine o isimdeki resimleri getirtiyoruz. Ders programı değiştiğinde, sınıf ve öğretmen sayısına bağlı olarak oldukça uzun sürüyor.
Zahmetiniz için şimdiden teşekkür ederim.
Saygılarımla
 

Ekli dosyalar

Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst