(24/12/2017, 22:52)direnist yazdı: Merhaba sn. donapezil;
Öncelikle rica ederim. Bu hali ile bile işinize yarıyor olmasına ayrıca çok sevindim. 
Açıkçası konunuzu ilk okuduğumda bende yapılamaz diye düşündüm. Çünkü, Excel kitabı içinde hücrenin içine fotoğrafı gömülü şekilde ekleyebilmenin  bayağı bir kod yazımı yada uzun bir algoritma gerektireceğini düşündüm.
Ancak sizin araştırmalarınız sonucunda ulaştığınız sayenizde benim de öğrendiğim (bunun için bende size teşekkür ederim) "xlSheet.Shapes.AddPicture PicLocation, False, True, 125, y, 100, 100" kodunu görünce bunun üzerinden ilerleyerek acemice bişeyler yaptım. Aslında kod tarafı daha dinamik olabilir.
Ve şu hatayı da düzeltebilseydim daha güzel olurdu.
Belirttiğiniz gibi hocalarımız müsait olduğunda bakabilirler ise ki eminim başka bir profesyonel bir yolu da vardır. 
Bende çok merak ediyorum bu konuyu.
İyi çalışmalar.
Saygılar.

Sn direnist;

Yıllardır burada konu açarken, hep altından kalkamayacağım konularla ilgili konu açtım, diğer taraftan da araştırmaya hep devam ettim. Ödev yaptırmak isteyen öğrenciler gibi konuyu ortaya atıp çekilmemişimdir Bu kodu bulmam da bunun sonucu oldu. Başta Ozan hocam olmak üzere, pekçok kişinin emeği vardır öğrendiklerimde. Artık sizin de oldu. Eminim ki üstadlar, konuyu inceleyip, herkesin işine yarayacak hale getirecekledir.

Tekrar çok teşekkür ediyorum.

Saygılar, iyi çalışmalar.

Merhaba,

Butonun tıklandığında olayındaki kodu aşağıdaki ile değiştirerek deneyiniz.

Private Sub Komut14_Click()



On Error GoTo hata



Dim xls As Excel.Application

Dim wb As Excel.Workbook

Dim ws As Excel.Worksheet

Dim rng As Range

Dim PicLocation

Dim i, k, satir, sutun, x, y, alan_adedi As Integer





Dim rs As Object



    Set rs = New ADODB.Recordset

    rs.Open "select * from sorgu1", CurrentProject.Connection, adOpenDynamic, adLockOptimistic



    alan_adedi = rs.Fields.Count



    

 sutun = DCount("*", "sorgu1") + 1

 

Set xls = New Excel.Application

xls.Visible = True



Set wb = xls.Workbooks.Add

Set ws = wb.Sheets(1)

Set rng = ws.Range("A1")



ws.Name = "Ürün Bilgileri"





With rng



satir = 2



    .Range("A1:E" & sutun).EntireColumn.ColumnWidth = 22

    .Rows(CStr(satir) & ":" & CStr(sutun)).RowHeight = 120

        

    .Range("A1:E" & sutun).HorizontalAlignment = xlCenter

    .Range("A1:E" & sutun).VerticalAlignment = xlCenter

    .Range("A1:E" & sutun).WrapText = False

    .Range("A1:E" & sutun).Orientation = 0

    .Range("A1:E" & sutun).AddIndent = False

    .Range("A1:E" & sutun).IndentLevel = 0

    .Range("A1:E" & sutun).ShrinkToFit = False

    .Range("A1:E" & sutun).ReadingOrder = xlContext

    .Range("A1:E" & sutun).MergeCells = False

    

     

     y = 20

     

     rs.MoveFirst

                                

    For i = 1 To alan_adedi

        .Cells(1, i).Value = rs.Fields(i - 1).Name

    Next i

    

    Do While Not rs.EOF

    

        For k = 1 To alan_adedi

            PicLocation = rs.Fields("ÜRÜN FOTO")

            k = 1

            .Cells(satir, k) = rs.Fields("SIRA NO")

            k = k + 1

    

            ws.Shapes.AddPicture PicLocation, False, True, 125, y, 100, 100

            k = k + 1

            .Cells(satir, k) = rs.Fields("ÜRÜN ADI")

            k = k + 1

            .Cells(satir, k) = rs.Fields("ÜRÜN KODU")

            k = k + 1

            .Cells(satir, k) = rs.Fields("ÜRÜN AÇIKLAMA")

            satir = satir + 1

            y = y + 120

        Next k

            rs.MoveNext

    Loop



End With



rs.Close

Set rs = Nothing





wb.SaveAs CurrentProject.Path & "\Urun_Agaci" & Date & ".xlsx"



 

wb.Close False

Set wb = Nothing

xls.Quit

Set xls = Nothing

Set xls = Nothing

Set wb = Nothing

Set ws = Nothing



hata:



If Err.Number = "1004" Then

    

    MsgBox ("Aktarım İptal Edildi")

    wb.Close False

    Set wb = Nothing

    xls.Quit

    Set xls = Nothing

    Set wb = Nothing

    Set ws = Nothing

    Exit Sub

    

ElseIf Err.Number <> 0 Then

    MsgBox (Err.Number & "" & Err.Description)

    Resume Next



End If



    

End Sub

(26/12/2017, 12:29)ozanakkaya yazdı: Merhaba,

Butonun tıklandığında olayındaki kodu aşağıdaki ile değiştirerek deneyiniz.

Private Sub Komut14_Click()



On Error GoTo hata



Dim xls As Excel.Application

Dim wb As Excel.Workbook

Dim ws As Excel.Worksheet

Dim rng As Range

Dim PicLocation

Dim i, k, satir, sutun, x, y, alan_adedi As Integer





Dim rs As Object



    Set rs = New ADODB.Recordset

    rs.Open "select * from sorgu1", CurrentProject.Connection, adOpenDynamic, adLockOptimistic



    alan_adedi = rs.Fields.Count



    

 sutun = DCount("*", "sorgu1") + 1

 

Set xls = New Excel.Application

xls.Visible = True



Set wb = xls.Workbooks.Add

Set ws = wb.Sheets(1)

Set rng = ws.Range("A1")



ws.Name = "Ürün Bilgileri"





With rng



satir = 2



    .Range("A1:E" & sutun).EntireColumn.ColumnWidth = 22

    .Rows(CStr(satir) & ":" & CStr(sutun)).RowHeight = 120

        

    .Range("A1:E" & sutun).HorizontalAlignment = xlCenter

    .Range("A1:E" & sutun).VerticalAlignment = xlCenter

    .Range("A1:E" & sutun).WrapText = False

    .Range("A1:E" & sutun).Orientation = 0

    .Range("A1:E" & sutun).AddIndent = False

    .Range("A1:E" & sutun).IndentLevel = 0

    .Range("A1:E" & sutun).ShrinkToFit = False

    .Range("A1:E" & sutun).ReadingOrder = xlContext

    .Range("A1:E" & sutun).MergeCells = False

    

     

     y = 20

     

     rs.MoveFirst

                                

    For i = 1 To alan_adedi

        .Cells(1, i).Value = rs.Fields(i - 1).Name

    Next i

    

    Do While Not rs.EOF

    

        For k = 1 To alan_adedi

            PicLocation = rs.Fields("ÜRÜN FOTO")

            k = 1

            .Cells(satir, k) = rs.Fields("SIRA NO")

            k = k + 1

    

            ws.Shapes.AddPicture PicLocation, False, True, 125, y, 100, 100

            k = k + 1

            .Cells(satir, k) = rs.Fields("ÜRÜN ADI")

            k = k + 1

            .Cells(satir, k) = rs.Fields("ÜRÜN KODU")

            k = k + 1

            .Cells(satir, k) = rs.Fields("ÜRÜN AÇIKLAMA")

            satir = satir + 1

            y = y + 120

        Next k

            rs.MoveNext

    Loop



End With



rs.Close

Set rs = Nothing





wb.SaveAs CurrentProject.Path & "\Urun_Agaci" & Date & ".xlsx"



 

wb.Close False

Set wb = Nothing

xls.Quit

Set xls = Nothing

Set xls = Nothing

Set wb = Nothing

Set ws = Nothing



hata:



If Err.Number = "1004" Then

    

    MsgBox ("Aktarım İptal Edildi")

    wb.Close False

    Set wb = Nothing

    xls.Quit

    Set xls = Nothing

    Set wb = Nothing

    Set ws = Nothing

    Exit Sub

    

ElseIf Err.Number <> 0 Then

    MsgBox (Err.Number & "" & Err.Description)

    Resume Next



End If



    

End Sub

Ozan hocam, herzamanki gibi hızırlığını gösterdin... Harika olmuş. Bu konuda sıkıntı çeken herkese mükemmel bir örnek oldu bu.
Önce sn direnist'in koduyla işimizi çözdük, şimdi de kusursuz çalışan kodla tüm çalışmalaraıma ve arşive ekliyorum.

Minnacık bir dokunuşta ben yaptım. Arka arkaya alınacak farklı raporlarda kayıt çakışması olmasın diye.
Kayıt yaptırma kodunu
olarak güncelledim.

Güncel kodlu halini de ekliyorum. İsteyen doya doya kullansın. Artık Excel içine gömülü fotoğraf aktarma sıkıntısı bitmiştir.

Emeği geçen sn. direnist'e ve Ozan hocama sonsuz saygılarımla...

Konu taşınabilir. Hatta Access örneklerine taşınabilir

Merhaba, eklediğiniz örnek uygulama Accessden Excele Resim Aktarma bağlantısına yeni konu olarak eklenmiştir.

Bana bunun tersi lazım ama
Accessden Excele Resim Aktarma değil Excelden Access e resim aktarma ?

öğrenci isimleri ve fotoğrafları olan listeyi E-okuldan .htm olarak kaydettim. Şimdi bu htm sayfalarından öğrenci resimlerini accessteki ogrenciler tablosuna aktarmak istiyorum.