Excel Forum

Excel Forum (http://www.excel.web.tr/index.php)
-   Makro-VBA (http://www.excel.web.tr/forumdisplay.php?f=48)
-   -   Otomatik Resim Ekleme (http://www.excel.web.tr/showthread.php?t=170421)

anemis 09-02-2018 09:38

Otomatik Resim Ekleme
 
1 Eklenti(ler)
Merhabalar,

Ekli dosyada detaylıca anlatmaya çalıştım. İnşallah yeterli açıklamam olmuştur.

Özet olarak;
Bilgisayarımdaki herhangi bir klasördeki çokça resimi belirli bir düzende excel içine atmak istiyorum. (her bir resimi ekleneceği hücre pattern i aynı. Örneğin 01.jpg resmi B52:Y98 hücreleri arasında strechlenecek ise (bu hücreler birleştirilerek tek bir hücre de olabilir) 02.jpg resmi B52 den 50 satır sonra yani B102 ve Y98 den yine 50 satır sonra Y148 e yani B102:Y148 e gelmeli.
Aynı şekilde 03.jpg resmi yine 50 satır sonrasına B152:Y198 e gelmeli vs.

Onlarca resmi tek tek ekleyip çıktıya hazır hale getirmek inanılmaz yorucu olmaya başladı. Yardımcı olabilicek, fikir verebilecek herkese sonsuz teşekkürler.

askm 09-02-2018 09:56

Resimleri sırası ile alması için sizin resimlerin isimlerini farklı bir sheete sırası ile alt alta yazmanız gerekir. Ya da öncelikle resim isimlerini başka bir sayfaya çektirip sıralam yaptırıp ona göre ekleme yapmak gerekir. (Bu şekilde belki istediğiniz sonucu tam olarak vermez.) Sonrasında belirttiğiniz gibi hücre birleştirip resim eklenebilir.

anemis 09-02-2018 09:58

Değerli katkınız için teşekkür ederim sayın askm, resimlerin isimlerinin de bir şablonu var aslında, gerçi çok önemli de değil. gerekli ise isimleri bir sayfaya yada belli bir yere elle girebilirim. yada listeleme makrosu da bu işimi çöze diye düşünüyorum.

askm 09-02-2018 10:01

Belirttiğiniz gibi isimleri girerek tekrar dosyanızı ekleyebilir misiniz?

anemis 09-02-2018 10:11

1 Eklenti(ler)
Alıntı:

askm tarafından gönderildi (Mesaj 929603)
Belirttiğiniz gibi isimleri girerek tekrar dosyanızı ekleyebilir misiniz?

Tabii ki,

Belirli bir formülasyonla excel dosyasının içine ekledim. Oradan zaten şablonu algılayabilirsiniz.

Zamanınız ve yardımınız için teşekkürler.

askm 09-02-2018 10:25

Aşağıdaki kodları bir modüle yapıştırıp deneyin. Belirttiğiniz formatta değil de resim isimleri 01-02 şeklinde gittiğiniz varsayarak kod yazdım.
Kod:

Sub askm()
Call Belirli_Bir_Alandaki_Resimleri_Sil
Klasor = ThisWorkbook.Path & "\"
On Error Resume Next
Satir = 52
For i = 1 To 6
    If i < 10 Then
        dosya = Klasor & "0" & i & ".jpg"
    Else
        dosya = Klasor & i & ".jpg"
    End If
    Range(Cells(Satir, 2), Cells(Satir + 46, "Y")).Select
    Range(Cells(Satir, 2), Cells(Satir + 46, "Y")).Merge
    ActiveSheet.Pictures.Insert(dosya).Select
    With Selection
            .ShapeRange.LockAspectRatio = msoFalse
            .Top = Range(Cells(Satir, 2), Cells(Satir + 46, "Y")).Top
            .Left = Range(Cells(Satir, 2), Cells(Satir + 46, "Y")).Left
            .Width = Range(Cells(Satir, 2), Cells(Satir + 46, "Y")).Width
            .Height = Range(Cells(Satir, 2), Cells(Satir + 46, "Y")).Height
    End With
    Satir = Satir + 50
Next i
End Sub


Sub Belirli_Bir_Alandaki_Resimleri_Sil()
    Dim Resim As Picture, Alan As Range
    Set Alan = Range("B52:Y65536")
    For Each Resim In ActiveSheet.Pictures
        If Not Intersect(Resim.TopLeftCell, Alan) Is Nothing Then
            Resim.Delete
        End If
    Next
    Set Alan = Nothing
End Sub


anemis 09-02-2018 10:35

Emeklerinize sağlık üstadım, ancak ne yazık ki modüle ekleyip çalıştır diyorum kodları, bir sonuç alamıyorum.

askm 09-02-2018 10:41

1 Eklenti(ler)
Dosyanız ektedir.

anemis 09-02-2018 10:45

Sayın askm üstadım çok teşekkür ederim. Harikasınız. Aslında bu benim işimi oldukça kolaylaştıracak. Emeklerinize sağlık.

Artık bir miktar daha şımararak biraz kodu geliştirebilir miyiz acaba diye sormak istiyorum?

1) Resimlerin ekleneceği klasörü ben seçemez miyim? excel ile resimler aynı klasörde olmuyor her zaman.
2) Resim ekleme gibi bir button olsa dosyanın içerisinde. ona tıklayınca resimleri seçtirse ve otomatik eklese olur mu?

askm 09-02-2018 14:04

Dosyadaki kodları aşağıdaki kodlar ile değiştirin. Sayfanıza AA sütunundan sonra olmak üzere bir şekil ekleyin. Şekli istediğiniz gibi biçimlendirin. Sağ tıklayın.Makro ata deyin ve makro olarak "ASKM_RESİM_GETİR" seçin.

Kod:

Sub ASKM_RESİM_GETİR()
Dim Kaynak As String
Dim askm As FileDialog

    Set askm = Application.FileDialog(msoFileDialogFolderPicker)
    askm.AllowMultiSelect = False
    askm.Show
    Kaynak = askm.SelectedItems(1)
    If Kaynak = Empty Or InStr(1, Kaynak, "{") > 0 Then GoTo Atla


Call Belirli_Bir_Alandaki_Resimleri_Sil

On Error Resume Next
Satir = 52
For i = 1 To 6
    If i < 10 Then
        Dosya = Kaynak & "\" & "0" & i & ".jpg"
    Else
        Dosya = Kaynak & "\" & i & ".jpg"
    End If
    Range(Cells(Satir, 2), Cells(Satir + 46, "Y")).Select
    Range(Cells(Satir, 2), Cells(Satir + 46, "Y")).Merge
    ActiveSheet.Pictures.Insert(Dosya).Select
    With Selection
            .ShapeRange.LockAspectRatio = msoFalse
            .Top = Range(Cells(Satir, 2), Cells(Satir + 46, "Y")).Top
            .Left = Range(Cells(Satir, 2), Cells(Satir + 46, "Y")).Left
            .Width = Range(Cells(Satir, 2), Cells(Satir + 46, "Y")).Width
            .Height = Range(Cells(Satir, 2), Cells(Satir + 46, "Y")).Height
    End With
    Satir = Satir + 50
Next i
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız!", vbInformation, "ASKM"
End Sub


Sub Belirli_Bir_Alandaki_Resimleri_Sil()
    Dim Resim As Picture, Alan As Range
   
    Set Alan = Range("B52:Y65536")
   
    For Each Resim In ActiveSheet.Pictures
        If Not Intersect(Resim.TopLeftCell, Alan) Is Nothing Then
            Resim.Delete
        End If
    Next
   
    Set Alan = Nothing
   
End Sub



Saat 18:15

Powered by vBulletin Version 3.7.2
Copyright ©2000 - 2018, Jelsoft Enterprises Ltd.